From 105c3177000865ad953317e0d63f7398d4138529 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 18 Feb 2009 03:14:31 +0900 Subject: [PATCH 001/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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/535] 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 From b1c0ea895bbf6ee8c6223d84cc5340a67b2e3005 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 7 Jul 2009 19:16:23 +0900 Subject: [PATCH 155/535] committing initial bignum support, still needs more thorough testing. can disable with USE_BIGNUMS=0 - the interactions between this and USE_FLONUMS are messy, so they will likely be merged into a single option in the near future (i.e. you either have only fixnums, or a full range of numeric types). adding rationals based on this would be easy and is a likely future feature. adding native support for complex numbers is unlikely. --- .hgignore | 20 + Makefile | 118 ++ README | 52 + VERSION | 1 + debug.c | 75 + eval.c | 2329 ++++++++++++++++++++++++ gc.c | 237 +++ include/chibi/bignum.h | 33 + include/chibi/config.h | 127 ++ include/chibi/eval.h | 140 ++ include/chibi/sexp.h | 617 +++++++ init.scm | 713 ++++++++ main.c | 152 ++ mkfile | 36 + opcodes.c | 129 ++ opt/bignum.c | 713 ++++++++ opt/sexp-huff.c | 128 ++ opt/sexp-hufftabs.c | 92 + opt/sexp-unhuff.c | 71 + sexp.c | 1385 ++++++++++++++ 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 ++++ 43 files changed, 7824 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/bignum.h 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/bignum.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..429e9f41 --- /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 -g3 $(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 opt/bignum.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 at %ld", top); +#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) +#if USE_BIGNUMS + || sexp_bignump(_ARG1) +#endif +#if USE_FLONUMS + || (sexp_flonump(_ARG1) + && (sexp_flonum_value(_ARG1) + == trunc(sexp_flonum_value(_ARG1)))) +#endif + ); + 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 USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + if (sexp_integerp(tmp1) && sexp_integerp(tmp2)) { + j = sexp_unbox_integer(tmp1) + sexp_unbox_integer(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_integer(j); + } + else + _ARG2 = sexp_add(ctx, tmp1, tmp2); +#else + 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)); +#endif + top--; + break; + case OP_SUB: +#if USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + if (sexp_integerp(tmp1) && sexp_integerp(tmp2)) { + j = sexp_unbox_integer(tmp1) - sexp_unbox_integer(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_integer(j); + } + else + _ARG2 = sexp_sub(ctx, tmp1, tmp2); +#else + 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)); +#endif + top--; + break; + case OP_MUL: +#if USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + if (sexp_integerp(tmp1) && sexp_integerp(tmp2)) { + prod = sexp_unbox_integer(tmp1) * sexp_unbox_integer(tmp2); + if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_integer(prod); + } + else + _ARG2 = sexp_mul(ctx, tmp1, tmp2); +#else + 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)); +#endif + 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_BIGNUMS + else + _ARG2 = sexp_div(ctx, _ARG1, _ARG2); +#else +#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)); +#endif + 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--; + } +#if USE_BIGNUMS + else { + _ARG2 = sexp_quotient(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + 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; + } +#if USE_BIGNUMS + else { + _ARG2 = sexp_remainder(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case OP_NEGATIVE: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_make_integer(-sexp_unbox_integer(_ARG1)); +#if USE_BIGNUMS + else if (sexp_bignump(_ARG1)) { + _ARG1 = sexp_copy_bignum(ctx, NULL, _ARG1, 0); + sexp_bignum_sign(_ARG1) = -sexp_bignum_sign(_ARG1); + } +#endif +#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_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_integerp(tmp1) + ? sexp_make_boolean(sexp_unbox_integer(tmp1) < 0) : tmp1; + } +#else +#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); +#endif + top--; + break; + case OP_LE: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; +#if USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_integerp(tmp1) + ? sexp_make_boolean(sexp_unbox_integer(tmp1) <= 0) : tmp1; + } +#else +#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); +#endif + top--; + break; + case OP_EQN: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + i = _ARG1 == _ARG2; +#if USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_integerp(tmp1) + ? sexp_make_boolean(sexp_unbox_integer(tmp1) == 0) : tmp1; + } +#else +#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); +#endif + 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); +#if USE_BIGNUMS + else if (sexp_bignump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); +#endif + else if (! sexp_flonump(_ARG1)) + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case OP_FLO2FIX: + if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_integer((sexp_sint_t)sexp_flonum_value(_ARG1)); + else 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 + +#if USE_BIGNUMS +#define maybe_convert_bignum(z) \ + else if (sexp_bignump(z)) d = sexp_bignum_to_double(z); +#else +#define maybe_convert_bignum(z) +#endif + +#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); \ + maybe_convert_bignum(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 f, x1, e1; + sexp res; +#if USE_BIGNUMS + if (sexp_bignump(e)) { + if ((x == sexp_make_integer(0)) || (x == sexp_make_integer(-1))) + res = sexp_make_flonum(ctx, pow(0, 0)); + else if (x == sexp_make_integer(1)) + res = sexp_make_flonum(ctx, sexp_unbox_integer(x)); + else if (sexp_flonump(x)) + res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); + else + res = sexp_make_flonum(ctx, pow(10.0, 1e100)); + } else if (sexp_bignump(x)) { + res = sexp_bignum_expt(ctx, x, e); + } else { +#endif + 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); + f = pow(x1, e1); +#if USE_FLONUMS + if ((f > SEXP_MAX_FIXNUM) || sexp_flonump(x) || sexp_flonump(e)) { + if (sexp_flonump(x) || sexp_flonump(e)) + res = sexp_make_flonum(ctx, f); + else + res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); + } else +#endif + res = sexp_make_integer((sexp_sint_t)round(f)); +#if USE_BIGNUMS + } +#endif + 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)) + 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/bignum.h b/include/chibi/bignum.h new file mode 100644 index 00000000..4f362e8a --- /dev/null +++ b/include/chibi/bignum.h @@ -0,0 +1,33 @@ +/* bignum.h -- header for bignum utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_BIGNUM_H +#define SEXP_BIGNUM_H + +typedef unsigned long long sexp_luint_t; +typedef long long sexp_lsint_t; + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b); +sexp sexp_compare (sexp ctx, sexp a, sexp b); +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len); +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len); +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a); +double sexp_bignum_to_double (sexp a); +sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b); +sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset); +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset); +sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_div (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_expt (sexp ctx, sexp n, sexp e); +sexp sexp_add (sexp ctx, sexp a, sexp b); +sexp sexp_sub (sexp ctx, sexp a, sexp b); +sexp sexp_mul (sexp ctx, sexp a, sexp b); +sexp sexp_div (sexp ctx, sexp a, sexp b); +sexp sexp_quotient (sexp ctx, sexp a, sexp b); +sexp sexp_remainder (sexp ctx, sexp a, sexp b); + +#endif /* ! SEXP_BIGNUM_H */ + diff --git a/include/chibi/config.h b/include/chibi/config.h new file mode 100644 index 00000000..a1ba09fb --- /dev/null +++ b/include/chibi/config.h @@ -0,0 +1,127 @@ +/* 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 want bignum support */ +/* #define USE_BIGNUMS 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 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_BIGNUMS +#define USE_BIGNUMS 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_CHECK_STACK +#define USE_CHECK_STACK 1 +#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..f54473ca --- /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 8192 + +#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..d68717f1 --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,617 @@ +/* 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 + +#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; + +#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2)) +#define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type)) +#define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type)) + +#define SEXP_UINT_T_MAX ((sexp_uint_t)-1) +#define SEXP_UINT_T_MIN (0) +#define SEXP_SINT_T_MAX __MAX_SIGNED(sexp_sint_t) +#define SEXP_SINT_T_MIN __MIN_SIGNED(sexp_sint_t) + +#define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1) +#define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1) + +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) + +#if USE_BIGNUMS +#include "chibi/bignum.h" +#endif + +/***************************** 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_object_type(x) (&(sexp_type_specs[(x)->tag])) +#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x))) + +#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_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) +#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)) + +#define sexp_integer_to_double(x) ((double)sexp_unbox_integer(x)) + +#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) (+1 | (((sexp_sint_t)(a)) >> (sizeof(int)*8 - 1))) +#define sexp_fx_abs(a) (((sexp_sint_t)a) < 0 ? -((sexp_sint_t)a) : ((sexp_sint_t)a)) +#define sexp_fx_neg(a) (sexp_make_integer(-(sexp_unbox_integer(a)))) + +#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(ctx, (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_write_to_string(sexp ctx, sexp obj); +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..fac7cae9 --- /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))) + +(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..8538f7ee --- /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=SEXP_VOID, 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..e2a9476a --- /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), +_FN5(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/bignum.c b/opt/bignum.c new file mode 100644 index 00000000..da5bbcbd --- /dev/null +++ b/opt/bignum.c @@ -0,0 +1,713 @@ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_INIT_BIGNUM_SIZE 2 + +#define sexp_negate(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_integerp(x)) \ + x = sexp_fx_neg(x); \ + + +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { + sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + sexp_bignum_length(res) = len; + sexp_bignum_sign(res) = 1; + return res; +} + +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { + sexp res = sexp_make_bignum(ctx, 1); + sexp_bignum_data(res)[0] = sexp_unbox_integer(sexp_fx_abs(a)); + sexp_bignum_sign(res) = sexp_fx_sign(a); + return res; +} + +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { + sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size; + size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + if (! dst || sexp_bignum_length(dst) < len) { + dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + memcpy(dst, a, size); + sexp_bignum_length(dst) = len; + } else { + memset(dst->value.bignum.data, 0, + sexp_bignum_length(dst)*sizeof(sexp_uint_t)); + memcpy(dst->value.bignum.data, a->value.bignum.data, + sexp_bignum_length(a)*sizeof(sexp_uint_t)); + } + return dst; +} + +int sexp_bignum_zerop (sexp a) { + int i; + sexp_uint_t *data = sexp_bignum_data(a); + for (i=sexp_bignum_length(a)-1; i>=0; i--) + if (data[i]) + return 0; + return 1; +} + +static sexp_uint_t sexp_bignum_hi (sexp a) { + sexp_uint_t i=sexp_bignum_length(a)-1; + while ((i>0) && ! sexp_bignum_data(a)[i]) + i--; + return i+1; +} + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { + int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b); + sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b); + if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) + return sexp_bignum_sign(a); + if (ai != bi) + return ai - bi; + for (--ai; ai >= 0; ai--) { + if (adata[ai] > bdata[ai]) + return 1; + else if (adata[ai] < bdata[ai]) + return -1; + } + return 0; +} + +sexp sexp_bignum_normalize (sexp a) { + sexp_uint_t *data; + if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) + return a; + data = sexp_bignum_data(a); + if ((data[0] > SEXP_MAX_FIXNUM) + && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1))) + return a; + return sexp_make_integer((sexp_sint_t)data[0] * sexp_bignum_sign(a)); +} + +double sexp_bignum_to_double (sexp a) { + double res = 0; + sexp_uint_t i, *data=sexp_bignum_data(a); + for (i=0; i (SEXP_UINT_T_MAX - carry)) { + carry = 1; + } else { + carry = 0; + break; + } + } + if (carry) { + a = sexp_copy_bignum(ctx, NULL, a, len+1); + sexp_bignum_data(a)[len] = 1; + } + return a; +} + +sexp sexp_bignum_fxsub (sexp ctx, sexp a, sexp_uint_t b) { + sexp_uint_t *data=sexp_bignum_data(a), borrow=b, i=0, n; + for (borrow=b; borrow; i++) { + n = data[i]; + data[i] -= borrow; + borrow = ((n < borrow) ? 1 : 0); + } + return a; +} + +sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset) { + sexp_uint_t len=sexp_bignum_length(a), *data, *adata=sexp_bignum_data(a), + carry=0, i; + sexp_luint_t n; + if ((! d) || (sexp_bignum_length(d)+offset < len)) + d = sexp_make_bignum(ctx, len); + data = sexp_bignum_data(d); + for (i=0; i> (sizeof(sexp_uint_t)*8); + } + if (carry) { + if (sexp_bignum_length(d)+offset <= len) + d = sexp_copy_bignum(ctx, NULL, d, len+offset+1); + sexp_bignum_data(d)[len+offset] = carry; + } + return d; +} + +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r; + int i; + sexp_luint_t n = 0; + for (i=len-1; i>=offset; i--) { + n = (n << sizeof(sexp_uint_t)*8) + data[i]; + q = n / b; + r = n - (sexp_luint_t)q * b; + data[i] = q; + n = r; + } + return r; +} + +sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, + char sign, sexp_uint_t base) { + int c, digit; + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE); + sexp_bignum_sign(res) = sign; + sexp_bignum_data(res)[0] = init; + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + res = sexp_bignum_fxmul(ctx, res, res, base, 0); + res = sexp_bignum_fxadd(ctx, res, digit); + } + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); + } else if ((c!=EOF) && ! is_separator(c)) { + res = sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + } + sexp_push_char(ctx, c, in); + sexp_gc_release(ctx, res, s_res); + return sexp_bignum_normalize(res); +} + +sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { + int i, str_len, lg_base = trunc(log2(base)); + char *data; + sexp_gc_var(ctx, b, s_b); + sexp_gc_var(ctx, str, s_str); + sexp_gc_preserve(ctx, b, s_b); + sexp_gc_preserve(ctx, str, s_str); + b = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(b) = 1; + i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) + / lg_base + 1; + str = sexp_make_string(ctx, sexp_make_integer(str_len), + sexp_make_character(' ')); + data = sexp_string_data(str); + while (! sexp_bignum_zerop(b)) + data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0)); + if (i == str_len) + data[--i] = '0'; + else if (sexp_bignum_sign(a) == -1) + data[--i] = '-'; + sexp_write_string(ctx, data + i, out); + sexp_gc_release(ctx, b, s_b); + return SEXP_VOID; +} + +/****************** bignum arithmetic *************************/ + +sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { + if (sexp_bignum_sign(a) == sexp_fx_sign(b)) + return sexp_bignum_fxadd(ctx, a, sexp_unbox_integer(sexp_fx_abs(b))); + else + return sexp_bignum_fxsub(ctx, a, sexp_unbox_integer(sexp_fx_abs(b))); +} + +sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), + borrow=0, i, *adata, *bdata, *cdata; + sexp_gc_var(ctx, c, s_c); + if (alen < blen) + return sexp_bignum_sub_digits(ctx, dst, b, a); + sexp_gc_preserve(ctx, c, s_c); + c = ((dst && sexp_bignum_hi(dst) >= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0); + } + for ( ; carry && (i= 0 ? a : b); + } + return res; +} + +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { + sexp res; + if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { + res = sexp_bignum_sub_digits(ctx, dst, a, b); + sexp_bignum_sign(res) + = sexp_bignum_sign(sexp_bignum_compare(a, b) >= 0 ? a : b); + } else { + res = sexp_bignum_add_digits(ctx, dst, a, b); + sexp_bignum_sign(res) = sexp_bignum_sign(a); + } + return res; +} + +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, + *bdata=sexp_bignum_data(b), *ddata; + sexp_gc_var(ctx, c, s_c); + sexp_gc_var(ctx, d, s_d); + if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); + sexp_gc_preserve(ctx, c, s_c); + sexp_gc_preserve(ctx, d, s_d); + c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); + d = sexp_make_bignum(ctx, alen+blen); + ddata = sexp_bignum_data(d); + for (i=0; i 0) { + *rem = a; + return sexp_fixnum_to_bignum(ctx, sexp_make_integer(0)); + } + sexp_gc_preserve(ctx, x, s_x); + sexp_gc_preserve(ctx, prod, s_prod); + sexp_gc_preserve(ctx, diff, s_diff); + sexp_gc_preserve(ctx, k2, s_k2); + sexp_gc_preserve(ctx, i2, s_i2); + k2 = sexp_bignum_double(ctx, k); + i2 = sexp_bignum_double(ctx, i); + x = quot_step(ctx, rem, a, b, k2, i2); + prod = sexp_bignum_mul(ctx, NULL, x, b); + diff = sexp_bignum_sub_digits(ctx, NULL, a, prod); + if (sexp_bignum_compare(diff, k) >= 0) { + *rem = sexp_bignum_sub_digits(ctx, NULL, diff, k); + res = sexp_bignum_add_digits(ctx, NULL, x, i); + } else { + *rem = diff; + res = x; + } + sexp_gc_release(ctx, x, s_x); + return res; +} + +#undef _str + +sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { + int cmp; + sexp res; + sexp_gc_var(ctx, k, s_k); + sexp_gc_var(ctx, i, s_i); + cmp = sexp_bignum_compare(a, b); + if (cmp == 0) { /* a == b, return 1, no rem */ + *rem = sexp_make_integer(0); + return sexp_make_integer(1); + } else if (cmp < 0) { /* a < b, return 0, rem = a */ + *rem = a; + return sexp_make_integer(0); + } + sexp_gc_preserve(ctx, k, s_k); + sexp_gc_preserve(ctx, i, s_i); + k = sexp_copy_bignum(ctx, NULL, b, 0); + i = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); + res = quot_step(ctx, rem, a, b, k, i); + sexp_gc_release(ctx, k, s_k); + return res; +} + +sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { + sexp res; + sexp_gc_var(ctx, rem, s_rem); + sexp_gc_preserve(ctx, rem, s_rem); + res = sexp_bignum_quot_rem(ctx, &rem, a, b); + sexp_gc_release(ctx, rem, s_rem); + return res; +} + +sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { + sexp rem; + sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */ + return rem; +} + +sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { + sexp_sint_t e = sexp_unbox_integer(sexp_fx_abs(b)); + sexp_gc_var(ctx, res, s_res); + sexp_gc_var(ctx, acc, s_acc); + sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve(ctx, acc, s_acc); + res = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); + acc = sexp_copy_bignum(ctx, NULL, a, 0); + for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) + if (e & 1) + res = sexp_bignum_mul(ctx, NULL, res, acc); + sexp_gc_release(ctx, res, s_res); + return res; +} + +/****************** generic arithmetic ************************/ + +enum sexp_number_types { + SEXP_NUM_NOT = 0, + SEXP_NUM_FIX, + SEXP_NUM_FLO, + SEXP_NUM_BIG, +}; + +enum sexp_number_combs { + SEXP_NUM_NOT_NOT = 0, + SEXP_NUM_NOT_FIX, + SEXP_NUM_NOT_FLO, + SEXP_NUM_NOT_BIG, + SEXP_NUM_FIX_NOT, + SEXP_NUM_FIX_FIX, + SEXP_NUM_FIX_FLO, + SEXP_NUM_FIX_BIG, + SEXP_NUM_FLO_NOT, + SEXP_NUM_FLO_FIX, + SEXP_NUM_FLO_FLO, + SEXP_NUM_FLO_BIG, + SEXP_NUM_BIG_NOT, + SEXP_NUM_BIG_FIX, + SEXP_NUM_BIG_FLO, + SEXP_NUM_BIG_BIG, +}; + +int sexp_number_type_lookup[SEXP_NUM_TYPES] = + {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, }; + +int sexp_number_type (sexp a) { + if (sexp_integerp(a)) { + return 1; + } else if (! sexp_pointerp(a)) { + return 0; + } else { + return sexp_number_type_lookup[sexp_pointer_tag(a)]; + } +} + +sexp sexp_add (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "+: not a number", a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_add(a, b); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_integer_to_double(a)+sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_add(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_add(ctx, NULL, b, a)); + break; + } + return r; +} + +sexp sexp_sub (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "-: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "-: not a number", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_sub(a, b); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_integer_to_double(a)+sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a))); + sexp_negate(r); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_integer_to_double(b)+sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_sub(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, sexp_fixnum_to_bignum(ctx, b))); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_flonum_value(b) + sexp_bignum_to_double(a)); + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); + break; + } + return r; +} + +sexp sexp_mul (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "*: not a number", a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_mul(a, b); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_integer_to_double(a)+sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_integer(sexp_fx_abs(a)), 0); + sexp_bignum_sign(r) *= sexp_fx_sign(a); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_mul(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_mul(ctx, NULL, a, b); + break; + } + return r; +} + +sexp sexp_div (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + double f; + sexp r, rem; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "/: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "/: not a number", b); + break; + case SEXP_NUM_FIX_FIX: + f = sexp_integer_to_double(a) / sexp_integer_to_double(b); + r = ((f == trunc(f)) ? sexp_make_integer((sexp_sint_t)f) + : sexp_make_flonum(ctx, f)); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_integer_to_double(a)/sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_flonum(ctx, sexp_integer_to_double(a)/sexp_bignum_to_double(b)); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_integer_to_double(b)/sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_div(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_quot_rem(ctx, &rem, a, b); + if (sexp_bignum_normalize(rem) != sexp_make_integer(0)) + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) + / sexp_integer_to_double(b)); + else + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b)); + break; + } + return r; +} + +sexp sexp_quotient (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "quotient: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "quotient: not a number", b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_div(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_integer(0); + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b)); + break; + } + return r; +} + +sexp sexp_remainder (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "remainder: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "remainder: not a number", b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_rem(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = a; + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b)); + break; + } + return r; +} + +sexp sexp_compare (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r; + double f; + if (at > bt) { + r = sexp_compare(ctx, b, a); + sexp_negate(r); + } else { + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "compare: not a number", a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_make_integer(sexp_unbox_integer(a) - sexp_unbox_integer(b)); + break; + case SEXP_NUM_FIX_FLO: + f = sexp_integer_to_double(a) - sexp_flonum_value(b); + r = sexp_make_integer(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_integer(-1); + break; + case SEXP_NUM_FLO_FLO: + f = sexp_flonum_value(a) - sexp_flonum_value(b); + r = sexp_make_integer(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FLO_BIG: + f = sexp_flonum_value(a) - sexp_bignum_to_double(b); + r = sexp_make_integer(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_make_integer(sexp_bignum_compare(a, b)); + break; + } + } + return r; +} + 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..9be46d26 --- /dev/null +++ b/sexp.c @@ -0,0 +1,1385 @@ +/* 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; + +sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp); + +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(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(sexp_exception_message(exn))) + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); + else + sexp_write(ctx, 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_preserve(ctx, name, s_name); + sexp_gc_preserve(ctx, str, s_str); + sexp_gc_preserve(ctx, irr, s_irr); + 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 (! sexp_integerp(len)) return sexp_type_exception(ctx, "bad length", len); + 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; +#if USE_BIGNUMS + case SEXP_BIGNUM: + sexp_write_bignum(ctx, obj, out, 10); + break; +#endif + 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_uint_t whole, int negp) { + sexp exponent=SEXP_VOID; + 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); + res = ((double)whole + res) * pow(10, e); + if (negp) res *= -1; + if ((scale == 0.1) && (exponent != SEXP_VOID) && (res == round(res))) + return sexp_make_integer(res); + else + return sexp_make_flonum(ctx, res); +} + +sexp sexp_read_number(sexp ctx, sexp in, int base) { + sexp den; + sexp_uint_t res = 0, tmp; + int c, digit, negativep = 0; + + c = sexp_read_char(ctx, in); + if (c == '-') + negativep = 1; + else if (isdigit(c)) + res = digit_value(c); + + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + tmp = res * base + digit; +#if USE_BIGNUMS + if ((tmp < res) || (tmp > SEXP_MAX_FIXNUM)) { + sexp_push_char(ctx, c, in); + return sexp_read_bignum(ctx, in, res, (negativep ? -1 : 1), base); + } +#endif + res = tmp; + } + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + return sexp_read_float_tail(ctx, in, res, negativep); + } 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, 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 +#if USE_BIGNUMS + if (sexp_bignump(res)) + sexp_bignum_sign(res) = -sexp_bignum_sign(res); + else +#endif + res = sexp_fx_mul(res, sexp_make_integer(-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; +} + +sexp sexp_write_to_string(sexp ctx, sexp obj) { + sexp str; + sexp_gc_var(ctx, out, s_out); + sexp_gc_preserve(ctx, out, s_out); + out = sexp_make_output_string_port(ctx); + sexp_write(ctx, obj, out); + str = sexp_get_output_string(ctx, out); + sexp_gc_release(ctx, out, s_out); + return str; +} + +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 e8985cd84c787f3b44404bd1d69f4d016c7befbe Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 7 Jul 2009 19:36:59 +0900 Subject: [PATCH 156/535] Reporting a more sensible error when the initialization file isn't found, per issue #2: http://code.google.com/p/chibi-scheme/issues/detail?id=2 --- main.c | 46 +++++++++++++++++++++++++++++++++++----------- 1 file changed, 35 insertions(+), 11 deletions(-) diff --git a/main.c b/main.c index 8538f7ee..9197f996 100644 --- a/main.c +++ b/main.c @@ -48,6 +48,29 @@ sexp find_module_file (sexp ctx, char *file) { return res; } +sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { + sexp res = SEXP_VOID; + sexp_gc_var(ctx, path, s_path); + sexp_gc_var(ctx, irr, s_irr); + sexp_gc_preserve(ctx, path, s_path); + sexp_gc_preserve(ctx, irr, s_irr); + path = find_module_file(ctx, file); + if (! sexp_stringp(path)) { + path = sexp_c_string(ctx, chibi_module_dir, -1); + irr = sexp_cons(ctx, path, SEXP_NULL); + path = sexp_c_string(ctx, file, -1); + irr = sexp_cons(ctx, path, irr); + res = sexp_user_exception(ctx, + SEXP_FALSE, + "couldn't find file to load in ./ or module dir", + irr); + } else { + res = sexp_load(ctx, path, env); + } + sexp_gc_release(ctx, path, s_path); + return res; +} + void repl (sexp ctx) { sexp tmp, res, env, in, out, err; sexp_gc_var(ctx, obj, s_obj); @@ -98,7 +121,7 @@ void run_main (int argc, char **argv) { case 'e': case 'p': if (! init_loaded++) - sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); + sexp_load_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); @@ -115,8 +138,8 @@ void run_main (int argc, char **argv) { 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); + sexp_load_module_file(ctx, sexp_init_file, env); + sexp_load_module_file(ctx, argv[++i], env); break; case 'q': init_loaded = 1; @@ -131,14 +154,15 @@ void run_main (int argc, char **argv) { 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); - } + res = sexp_load_module_file(ctx, sexp_init_file, env); + if (res && sexp_exceptionp(res)) + sexp_print_exception(ctx, res, + sexp_eval_string(ctx, "(current-error-port)")); + if (i < argc) + for ( ; i < argc; i++) + res = sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env); + else + repl(ctx); } sexp_gc_release(ctx, str, s_str); From 41f54a7f41eb990697ce8bb5a08ad9bbd1117d99 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 7 Jul 2009 19:58:28 +0900 Subject: [PATCH 157/535] initial windows mingw support patch from felix winkelmann --- Makefile | 39 +++++++++++-------- include/chibi/config.h | 10 +++++ include/chibi/eval.h | 14 +++---- include/chibi/sexp.h | 86 +++++++++++++++++++++--------------------- 4 files changed, 84 insertions(+), 65 deletions(-) diff --git a/Makefile b/Makefile index 429e9f41..ef014868 100644 --- a/Makefile +++ b/Makefile @@ -2,14 +2,13 @@ .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 +CC ?= cc +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +SOLIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi DESTDIR ?= @@ -17,9 +16,14 @@ ifndef PLATFORM ifeq ($(shell uname),Darwin) PLATFORM=macosx else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +SOLIBDIR = $(BINDIR) +else PLATFORM=unix endif endif +endif ifeq ($(PLATFORM),macosx) SO = .dylib @@ -30,7 +34,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 = @@ -39,6 +46,8 @@ STATICFLAGS = -static endif endif +all: chibi-scheme$(EXE) + ifdef USE_BOEHM GCLDFLAGS := -lgc XCPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1 @@ -77,12 +86,12 @@ 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; \ + ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ if diff -q $${f%.scm}.out $${f%.scm}.res; then \ echo "[PASS] $${f%.scm}"; \ else \ @@ -90,10 +99,10 @@ test-basic: chibi-scheme fi; \ done -test: chibi-scheme - ./chibi-scheme tests/r5rs-tests.scm +test: chibi-scheme$(EXE) + ./chibi-scheme$(EXE) tests/r5rs-tests.scm -install: chibi-scheme +install: chibi-scheme$(EXE) mkdir -p $(DESTDIR)$(BINDIR) cp chibi-scheme $(DESTDIR)$(BINDIR)/ mkdir -p $(DESTDIR)$(MODDIR) diff --git a/include/chibi/config.h b/include/chibi/config.h index a1ba09fb..bd4007cb 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -125,3 +125,13 @@ #endif #endif + +#ifdef __MINGW32__ +#ifdef BUILDING_DLL +#define SEXP_API __declspec(dllexport) +#else +#define SEXP_API __declspec(dllimport) +#endif +#else +#define SEXP_API +#endif diff --git a/include/chibi/eval.h b/include/chibi/eval.h index f54473ca..7a696998 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); +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 ctx, sexp from, sexp to, sexp out); #endif /* ! SEXP_EVAL_H */ diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index d68717f1..a889732d 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -564,54 +564,54 @@ 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); +SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); +SEXP_API sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p); +SEXP_API sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p); +SEXP_API 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_write_to_string(sexp ctx, sexp obj); -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(); +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_string_concatenate (sexp ctx, sexp str_ls); +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 void sexp_write(sexp ctx, 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_write_to_string(sexp ctx, sexp obj); +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 source); +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 */ From 821546244ab6a51ca4c564f7bbac41d50b93c229 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 12 Jul 2009 18:36:37 +0900 Subject: [PATCH 158/535] plan9 fixes - can't use #if preprocessor statements inside macros. also, no log2() by default, defining it in terms of log(). --- eval.c | 12 ++++++------ mkfile | 3 +++ opt/bignum.c | 4 ++++ 3 files changed, 13 insertions(+), 6 deletions(-) diff --git a/eval.c b/eval.c index 429fee63..61d2a2b7 100644 --- a/eval.c +++ b/eval.c @@ -1543,16 +1543,16 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_NULLP: _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; case OP_INTEGERP: - _ARG1 = sexp_make_boolean(sexp_integerp(_ARG1) + j = sexp_integerp(_ARG1); #if USE_BIGNUMS - || sexp_bignump(_ARG1) + if (! j) j = sexp_bignump(_ARG1); #endif #if USE_FLONUMS - || (sexp_flonump(_ARG1) - && (sexp_flonum_value(_ARG1) - == trunc(sexp_flonum_value(_ARG1)))) + if (! j) + j = (sexp_flonump(_ARG1) + && (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1)))); #endif - ); + _ARG1 = sexp_make_boolean(j); break; case OP_SYMBOLP: _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; diff --git a/mkfile b/mkfile index 3caba3f9..1c6fb068 100644 --- a/mkfile +++ b/mkfile @@ -34,3 +34,6 @@ clean:V: install:V: $BIN/$TARG mkdir -p $MODDIR cp init.scm $MODDIR/ + +test:V: + ./chibi-scheme tests/r5rs-tests.scm diff --git a/opt/bignum.c b/opt/bignum.c index da5bbcbd..35cfec49 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -186,6 +186,10 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, return sexp_bignum_normalize(res); } +#ifdef PLAN9 +#define log2(n) (log(n)/log(2)) +#endif + sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { int i, str_len, lg_base = trunc(log2(base)); char *data; From f2e79c3028f5ce3a597c369ce7ffed6ac58febad Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 12 Jul 2009 19:06:38 +0900 Subject: [PATCH 159/535] off by one error in sexp_bignum_mul need an extra digit to fit carries --- opt/bignum.c | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/opt/bignum.c b/opt/bignum.c index 35cfec49..fe13f45a 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -304,19 +304,18 @@ sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, - *bdata=sexp_bignum_data(b), *ddata; + *bdata=sexp_bignum_data(b); sexp_gc_var(ctx, c, s_c); sexp_gc_var(ctx, d, s_d); if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); sexp_gc_preserve(ctx, c, s_c); sexp_gc_preserve(ctx, d, s_d); c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); - d = sexp_make_bignum(ctx, alen+blen); - ddata = sexp_bignum_data(d); + d = sexp_make_bignum(ctx, alen+blen+1); for (i=0; i Date: Sun, 12 Jul 2009 20:40:00 +0900 Subject: [PATCH 160/535] Reverting order of close and free for closing Linux memstreams. Freeing first causes a segfault when closing a string port. This closes issue 3: http://code.google.com/p/chibi-scheme/issues/detail?id=3 --- eval.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/eval.c b/eval.c index 61d2a2b7..644ee22b 100644 --- a/eval.c +++ b/eval.c @@ -1969,10 +1969,10 @@ static sexp sexp_close_port (sexp ctx, sexp 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_stream(port)) + fclose(sexp_port_stream(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; } From 6d709264bd878a68fecdbd6a3e68a6927e5ba3b7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 12 Jul 2009 23:46:27 +0900 Subject: [PATCH 161/535] Cleanup for more pedantic C. Notably no longer converting from function pointers <-> void*. Remaining --pedantic warnings: * ISO C90 does not support 'long long' * ISO C90 does not support the 'z' printf length modifier * ISO C90 does not support flexible array members * ISO C90 forbids mixed declarations and code * ISO C90 forbids specifying subobject to initialize * anonymous variadic macros were introduced in C99 * invalid use of structure with flexible array member The first one is only used when optional bignums are enabled, and I have no intention of supporting bignums on systems w/o long long (although it's not guaranteed two words fit in a long long - I need to fix this). The 'z' modifier is necessary for long types (you'd get warnings the other way without it). The next 4 are intentional - they make the code cleaner, and all of these extensions are supported by Plan 9. The last one is tricky. I think it refers to the fact that not only am I using flexible array members, but I'm using them as non-final alternates in a union. I'll have to double check the semantics of this. --- eval.c | 37 +++++++++++++++++++------------------ gc.c | 1 + include/chibi/eval.h | 16 +++------------- include/chibi/sexp.h | 17 ++++++++++++++--- opcodes.c | 34 +++++++++++++++++----------------- opt/bignum.c | 4 ++-- sexp.c | 2 +- 7 files changed, 57 insertions(+), 54 deletions(-) diff --git a/eval.c b/eval.c index 644ee22b..b91623e5 100644 --- a/eval.c +++ b/eval.c @@ -899,9 +899,9 @@ static void generate_opcode_app (sexp ctx, sexp app) { /* 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_data(op) && (sexp_opcode_class(op) != OPC_PARAMETER)) { - emit_push(ctx, sexp_opcode_default(op)); + emit_push(ctx, sexp_opcode_data(op)); if (sexp_opcode_opt_param_p(op)) emit(ctx, OP_CDR); sexp_context_depth(ctx)++; @@ -945,14 +945,16 @@ static void generate_opcode_app (sexp ctx, sexp app) { emit(ctx, sexp_opcode_code(op)); break; case OPC_FOREIGN: + emit(ctx, sexp_opcode_code(op)); + emit_word(ctx, (sexp_uint_t)op); + break; 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_push(ctx, sexp_opcode_data(op)); emit(ctx, ((num_args == 0) ? OP_CDR : OP_SET_CDR)); break; default: @@ -1396,47 +1398,47 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case OP_FCALL0: sexp_context_top(ctx) = top; - _PUSH(((sexp_proc1)_UWORD0)(ctx)); + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx)); ip += sizeof(sexp); sexp_check_exception(); break; case OP_FCALL1: sexp_context_top(ctx) = top; - _ARG1 = ((sexp_proc2)_UWORD0)(ctx, _ARG1); + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx, _ARG1); ip += sizeof(sexp); sexp_check_exception(); break; case OP_FCALL2: sexp_context_top(ctx) = top; - _ARG2 = ((sexp_proc3)_UWORD0)(ctx, _ARG1, _ARG2); + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(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); + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(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); + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(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); + _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(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); + _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); top -= 5; ip += sizeof(sexp); sexp_check_exception(); @@ -1516,7 +1518,6 @@ sexp sexp_vm (sexp ctx, sexp proc) { 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; @@ -1560,8 +1561,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; case OP_TYPEP: _ARG1 = sexp_make_boolean(sexp_pointerp(_ARG1) - && (sexp_pointer_tag(_ARG1) - == _UWORD0)); + && (sexp_make_integer(sexp_pointer_tag(_ARG1)) + == _WORD0)); ip += sizeof(sexp); break; case OP_CAR: @@ -2185,10 +2186,10 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { e = sexp_make_null_env(ctx, version); for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { op = sexp_copy_opcode(ctx, &opcodes[i]); - if (sexp_opcode_opt_param_p(op) && sexp_opcode_default(op)) { - sym = sexp_intern(ctx, (char*)sexp_opcode_default(op)); + if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op)); cell = env_cell_create(ctx, e, sym, SEXP_VOID); - sexp_opcode_default(op) = cell; + sexp_opcode_data(op) = cell; } env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); } @@ -2211,7 +2212,7 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { 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_word(ctx2, (sexp_uint_t)sexp_cdr(perr_cell)); } emit_push(ctx2, SEXP_VOID); emit(ctx2, OP_DONE); diff --git a/gc.c b/gc.c index 8f9f718a..7b4262de 100644 --- a/gc.c +++ b/gc.c @@ -151,6 +151,7 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { sexp sexp_gc (sexp ctx, size_t *sum_freed) { sexp res; int i; + fprintf(stderr, "*********************** gc **********************\n"); sexp_mark(continuation_resumer); sexp_mark(final_resumer); for (i=0; ivalue.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_func(x) ((x)->value.opcode.func) #define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) #define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2) diff --git a/opcodes.c b/opcodes.c index e2a9476a..68f1627d 100644 --- a/opcodes.c +++ b/opcodes.c @@ -1,8 +1,8 @@ -#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 _OP(c,o,n,m,t,u,i,s,d,f) \ + {.tag=SEXP_OPCODE, \ + .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, f}}} +#define _FN(o,n,m,t,u,s,f,p) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp_proc0)p) #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) @@ -45,19 +45,19 @@ _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_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), +_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), +_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0), +_OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_integer(SEXP_PAIR), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_integer(SEXP_STRING), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_integer(SEXP_VECTOR), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_integer(SEXP_FLONUM), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_integer(SEXP_PROCEDURE), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_integer(SEXP_OPCODE), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_integer(SEXP_IPORT), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_integer(SEXP_OPORT), 0), _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), diff --git a/opt/bignum.c b/opt/bignum.c index fe13f45a..245c15e5 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -418,7 +418,7 @@ enum sexp_number_types { SEXP_NUM_NOT = 0, SEXP_NUM_FIX, SEXP_NUM_FLO, - SEXP_NUM_BIG, + SEXP_NUM_BIG }; enum sexp_number_combs { @@ -437,7 +437,7 @@ enum sexp_number_combs { SEXP_NUM_BIG_NOT, SEXP_NUM_BIG_FIX, SEXP_NUM_BIG_FLO, - SEXP_NUM_BIG_BIG, + SEXP_NUM_BIG_BIG }; int sexp_number_type_lookup[SEXP_NUM_TYPES] = diff --git a/sexp.c b/sexp.c index 9be46d26..4c4342a4 100644 --- a/sexp.c +++ b/sexp.c @@ -84,7 +84,7 @@ static struct sexp_struct sexp_type_specs[] = { _DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"), _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"), _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"), - _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, dflt), 2, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"), + _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 2, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"), _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"), _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditoinal"), _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"), From 5d94079e4aa9a0b132f46fd79f30b42588514635 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 14 Jul 2009 00:34:23 +0900 Subject: [PATCH 162/535] more cleanup and portability fixes Using and for plan9, no need for separate .i file construction. Also mkfile now simplified and using /sys/src/cmd/mkone (thanks to Charles Forsyth). --- eval.c | 2 +- gc.c | 2 +- include/chibi/eval.h | 2 +- include/chibi/sexp.h | 8 +++++--- mkfile | 26 ++++++-------------------- opt/bignum.c | 12 ++++++++---- sexp.c | 8 ++++---- 7 files changed, 26 insertions(+), 34 deletions(-) diff --git a/eval.c b/eval.c index b91623e5..2b8510f9 100644 --- a/eval.c +++ b/eval.c @@ -2298,7 +2298,7 @@ sexp sexp_eval_string (sexp ctx, char *str) { return res; } -void sexp_scheme_init () { +void sexp_scheme_init (void) { sexp ctx; if (! scheme_initialized_p) { scheme_initialized_p = 1; diff --git a/gc.c b/gc.c index 7b4262de..c7e2e955 100644 --- a/gc.c +++ b/gc.c @@ -227,7 +227,7 @@ void* sexp_alloc (sexp ctx, size_t size) { return res; } -void sexp_gc_init () { +void sexp_gc_init (void) { sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); heap = sexp_make_heap(size); #if USE_DEBUG_GC diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 5dbc89d2..4184dd61 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -118,7 +118,7 @@ enum opcode_names { /**************************** prototypes ******************************/ -SEXP_API void sexp_scheme_init(); +SEXP_API void sexp_scheme_init(void); 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); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 265e17d2..446671ea 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -10,9 +10,11 @@ #include #include + #ifdef PLAN9 +#include +#include typedef unsigned long size_t; -#define offsetof(st, m) ((size_t) ((char*)&((st*)(0))->m - (char*)0)) #else #include #include @@ -103,7 +105,7 @@ typedef struct sexp_struct *sexp; #define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1) /* procedure types */ -typedef sexp (*sexp_proc0) (); +typedef sexp (*sexp_proc0) (void); typedef sexp (*sexp_proc1) (sexp); typedef sexp (*sexp_proc2) (sexp, sexp); typedef sexp (*sexp_proc3) (sexp, sexp, sexp); @@ -622,7 +624,7 @@ 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_API void sexp_init(void); #endif /* ! SEXP_H */ diff --git a/mkfile b/mkfile index 1c6fb068..3aff84cd 100644 --- a/mkfile +++ b/mkfile @@ -4,36 +4,22 @@ BIN=/$objtype/bin TARG=chibi-scheme MODDIR=/sys/lib/chibi-scheme -CPPFLAGS= -Iinclude -DPLAN9 -DUSE_STRING_STREAMS=0 -DUSE_DEBUG=0 -CFLAGS= -c -B $CPPFLAGS +CPPFLAGS= -Iinclude -DPLAN9 '-DUSE_STRING_STREAMS=0' '-DUSE_DEBUG=0' +CFLAGS= -p $CPPFLAGS OFILES=sexp.$O eval.$O main.$O -IFILES=${OFILES:%.$O=%.i} HFILES=include/chibi/sexp.h include/chibi/eval.h include/chibi/config.h include/chibi/install.h -%.i: %.c $HFILES - cpp $CPPFLAGS $stem.c > $target - -%.$O: %.i - $CC $CFLAGS -c -o $target $prereq - -all:V: $TARG + 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 + test -d $MODDIR || mkdir -p $MODDIR cp init.scm $MODDIR/ test:V: ./chibi-scheme tests/r5rs-tests.scm + +sexp.c:N: gc.c opt/bignum.c diff --git a/opt/bignum.c b/opt/bignum.c index 245c15e5..e7f9a2f9 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -186,12 +186,16 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, return sexp_bignum_normalize(res); } -#ifdef PLAN9 -#define log2(n) (log(n)/log(2)) -#endif +static int log2i(int v) { + int i; + for (i = 0; i < sizeof(v)*8; i++) + if ((1<<(i+1)) > v) + break; + return i; +} sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { - int i, str_len, lg_base = trunc(log2(base)); + int i, str_len, lg_base = log2i(base); char *data; sexp_gc_var(ctx, b, s_b); sexp_gc_var(ctx, str, s_str); diff --git a/sexp.c b/sexp.c index 4c4342a4..093c2d33 100644 --- a/sexp.c +++ b/sexp.c @@ -40,11 +40,11 @@ static char sexp_separators[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x5_ */ }; -static int digit_value (c) { +static int digit_value (int c) { return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); } -static int hex_digit (n) { +static int hex_digit (int n) { return ((n<=9) ? ('0' + n) : ('A' + n - 10)); } @@ -86,7 +86,7 @@ static struct sexp_struct sexp_type_specs[] = { _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"), _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 2, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"), _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"), - _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditoinal"), + _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional"), _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"), _DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"), _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"), @@ -1357,7 +1357,7 @@ sexp sexp_write_to_string(sexp ctx, sexp obj) { return str; } -void sexp_init() { +void sexp_init(void) { int i; sexp ctx; if (! sexp_initialized_p) { From e8b2cb872be0acab6606d7caf636a55a379ee6c0 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 14 Jul 2009 00:42:36 +0900 Subject: [PATCH 163/535] don't free() manually buffered input ports since they point to gc managed memory. --- eval.c | 6 ++++-- gc.c | 1 - 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/eval.c b/eval.c index 2b8510f9..a8592aeb 100644 --- a/eval.c +++ b/eval.c @@ -1971,9 +1971,11 @@ static sexp sexp_close_port (sexp ctx, sexp port) { if (! sexp_port_openp(port)) return sexp_user_exception(ctx, SEXP_FALSE, "port already closed", port); if (sexp_port_stream(port)) - fclose(sexp_port_stream(port)); - if (sexp_port_buf(port)) + fclose(sexp_port_stream(port)); +#if ! USE_STRING_STREAMS + if (sexp_port_buf(port) && sexp_oportp(port)) free(sexp_port_buf(port)); +#endif sexp_port_openp(port) = 0; return SEXP_VOID; } diff --git a/gc.c b/gc.c index c7e2e955..ca6d0136 100644 --- a/gc.c +++ b/gc.c @@ -151,7 +151,6 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { sexp sexp_gc (sexp ctx, size_t *sum_freed) { sexp res; int i; - fprintf(stderr, "*********************** gc **********************\n"); sexp_mark(continuation_resumer); sexp_mark(final_resumer); for (i=0; i Date: Tue, 14 Jul 2009 01:09:59 +0900 Subject: [PATCH 164/535] fixing the mk test target to test with $O.out --- mkfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mkfile b/mkfile index 3aff84cd..3996a381 100644 --- a/mkfile +++ b/mkfile @@ -20,6 +20,6 @@ install:V: $BIN/$TARG cp init.scm $MODDIR/ test:V: - ./chibi-scheme tests/r5rs-tests.scm + ./$O.out tests/r5rs-tests.scm sexp.c:N: gc.c opt/bignum.c From e780c122c0e26fccdd2aaa0fcc86ede989ffaed5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 14 Jul 2009 01:36:37 +0900 Subject: [PATCH 165/535] fixing definition of trunc for plan9 --- include/chibi/config.h | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/include/chibi/config.h b/include/chibi/config.h index bd4007cb..b070397b 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -110,9 +110,8 @@ #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) +#define round(x) floor((x)+0.5) +#define trunc(x) ((x)-((x)-round(x))) #else From 4ba0705f05109328c94327e9ef83c183895b6f43 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 14 Jul 2009 01:45:16 +0900 Subject: [PATCH 166/535] fixing trunc for real now (hopefully... getting sleepy) --- include/chibi/config.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/include/chibi/config.h b/include/chibi/config.h index b070397b..a79c7b17 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -111,7 +111,7 @@ #define strcasecmp cistrcmp #define strncasecmp cistrncmp #define round(x) floor((x)+0.5) -#define trunc(x) ((x)-((x)-round(x))) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) #else From 9951c8e9218f25bec48fcae37507e0a902eb17ea Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 15 Jul 2009 23:56:51 +0900 Subject: [PATCH 167/535] adding extended numeric tests and fixes for the bignum bugs it turned up --- Makefile | 3 + include/chibi/sexp.h | 2 +- opt/bignum.c | 75 ++++++++++++---------- sexp.c | 6 +- tests/numeric-tests.scm | 138 ++++++++++++++++++++++++++++++++++++++++ tests/r5rs-tests.scm | 20 ++++-- 6 files changed, 206 insertions(+), 38 deletions(-) create mode 100644 tests/numeric-tests.scm diff --git a/Makefile b/Makefile index ef014868..df83a51a 100644 --- a/Makefile +++ b/Makefile @@ -99,6 +99,9 @@ test-basic: chibi-scheme$(EXE) fi; \ done +test-numbers: chibi-scheme$(EXE) + ./chibi-scheme$(EXE) tests/numeric-tests.scm + test: chibi-scheme$(EXE) ./chibi-scheme$(EXE) tests/r5rs-tests.scm diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 446671ea..973535a9 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -523,8 +523,8 @@ sexp sexp_make_flonum(sexp ctx, double f); #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) (+1 | (((sexp_sint_t)(a)) >> (sizeof(int)*8 - 1))) -#define sexp_fx_abs(a) (((sexp_sint_t)a) < 0 ? -((sexp_sint_t)a) : ((sexp_sint_t)a)) #define sexp_fx_neg(a) (sexp_make_integer(-(sexp_unbox_integer(a)))) +#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) #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))) diff --git a/opt/bignum.c b/opt/bignum.c index e7f9a2f9..0ddd7c3e 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -4,12 +4,11 @@ #define SEXP_INIT_BIGNUM_SIZE 2 -#define sexp_negate(x) \ - if (sexp_bignump(x)) \ - sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ - else if (sexp_integerp(x)) \ - x = sexp_fx_neg(x); \ - +#define sexp_negate(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_integerp(x)) \ + x = sexp_fx_neg(x); sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); @@ -58,11 +57,9 @@ static sexp_uint_t sexp_bignum_hi (sexp a) { return i+1; } -sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { +sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) { int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b); sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b); - if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) - return sexp_bignum_sign(a); if (ai != bi) return ai - bi; for (--ai; ai >= 0; ai--) { @@ -74,6 +71,12 @@ sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { return 0; } +sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { + if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) + return sexp_bignum_sign(a); + return sexp_bignum_compare_abs(a, b); +} + sexp sexp_bignum_normalize (sexp a) { sexp_uint_t *data; if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) @@ -222,17 +225,22 @@ sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { /****************** bignum arithmetic *************************/ sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { - if (sexp_bignum_sign(a) == sexp_fx_sign(b)) - return sexp_bignum_fxadd(ctx, a, sexp_unbox_integer(sexp_fx_abs(b))); + sexp_gc_var(ctx, c, s_c); + sexp_gc_preserve(ctx, c, s_c); + c = sexp_copy_bignum(ctx, NULL, a, 0); + if (sexp_bignum_sign(c) == sexp_fx_sign(b)) + c = sexp_bignum_fxadd(ctx, c, sexp_unbox_integer(sexp_fx_abs(b))); else - return sexp_bignum_fxsub(ctx, a, sexp_unbox_integer(sexp_fx_abs(b))); + c = sexp_bignum_fxsub(ctx, c, sexp_unbox_integer(sexp_fx_abs(b))); + sexp_gc_release(ctx, c, s_c); + return c; } sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), borrow=0, i, *adata, *bdata, *cdata; sexp_gc_var(ctx, c, s_c); - if (alen < blen) + if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) return sexp_bignum_sub_digits(ctx, dst, b, a); sexp_gc_preserve(ctx, c, s_c); c = ((dst && sexp_bignum_hi(dst) >= alen) @@ -288,7 +296,7 @@ sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b) { } else { res = sexp_bignum_sub_digits(ctx, dst, a, b); sexp_bignum_sign(res) - = sexp_bignum_sign(sexp_bignum_compare(a, b) >= 0 ? a : b); + = sexp_bignum_sign(sexp_bignum_compare_abs(a, b) >= 0 ? a : b); } return res; } @@ -298,7 +306,8 @@ sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { res = sexp_bignum_sub_digits(ctx, dst, a, b); sexp_bignum_sign(res) - = sexp_bignum_sign(sexp_bignum_compare(a, b) >= 0 ? a : b); + = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a) + : -sexp_bignum_sign(a)); } else { res = sexp_bignum_add_digits(ctx, dst, a, b); sexp_bignum_sign(res) = sexp_bignum_sign(a); @@ -362,26 +371,27 @@ static sexp quot_step (sexp ctx, sexp *rem, sexp a, sexp b, sexp k, sexp i) { return res; } -#undef _str - sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { - int cmp; sexp res; sexp_gc_var(ctx, k, s_k); sexp_gc_var(ctx, i, s_i); - cmp = sexp_bignum_compare(a, b); - if (cmp == 0) { /* a == b, return 1, no rem */ - *rem = sexp_make_integer(0); - return sexp_make_integer(1); - } else if (cmp < 0) { /* a < b, return 0, rem = a */ - *rem = a; - return sexp_make_integer(0); - } + sexp_gc_var(ctx, a1, s_a1); + sexp_gc_var(ctx, b1, s_b1); sexp_gc_preserve(ctx, k, s_k); sexp_gc_preserve(ctx, i, s_i); - k = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_gc_preserve(ctx, a1, s_a1); + sexp_gc_preserve(ctx, b1, s_b1); + a1 = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(a1) = 1; + b1 = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_bignum_sign(b1) = 1; + k = sexp_copy_bignum(ctx, NULL, b1, 0); i = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); - res = quot_step(ctx, rem, a, b, k, i); + res = quot_step(ctx, rem, a1, b1, k, i); + sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); + if (sexp_bignum_sign(a) < 0) { + sexp_negate(*rem); + } sexp_gc_release(ctx, k, s_k); return res; } @@ -468,7 +478,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) { r = sexp_type_exception(ctx, "+: not a number", a); break; case SEXP_NUM_FIX_FIX: - r = sexp_fx_add(a, b); + r = sexp_fx_add(a, b); /* XXXX check overflow */ break; case SEXP_NUM_FIX_FLO: r = sexp_make_flonum(ctx, sexp_integer_to_double(a)+sexp_flonum_value(b)); @@ -501,14 +511,15 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { r = sexp_type_exception(ctx, "-: not a number", b); break; case SEXP_NUM_FIX_FIX: - r = sexp_fx_sub(a, b); + r = sexp_fx_sub(a, b); /* XXXX check overflow */ break; case SEXP_NUM_FIX_FLO: r = sexp_make_flonum(ctx, sexp_integer_to_double(a)+sexp_flonum_value(b)); break; case SEXP_NUM_FIX_BIG: - r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a))); + r = sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a)); sexp_negate(r); + r = sexp_bignum_normalize(r); break; case SEXP_NUM_FLO_FIX: r = sexp_make_flonum(ctx, sexp_integer_to_double(b)+sexp_flonum_value(a)); @@ -548,7 +559,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) { break; case SEXP_NUM_FIX_BIG: r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_integer(sexp_fx_abs(a)), 0); - sexp_bignum_sign(r) *= sexp_fx_sign(a); + sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b); break; case SEXP_NUM_FLO_FLO: r = sexp_fp_mul(ctx, a, b); diff --git a/sexp.c b/sexp.c index 093c2d33..dfaca5a1 100644 --- a/sexp.c +++ b/sexp.c @@ -307,7 +307,7 @@ sexp sexp_nreverse (sexp ctx, sexp ls) { if (ls == SEXP_NULL) { return ls; } else if (! sexp_pairp(ls)) { - return SEXP_NULL; /* XXXX return an exception */ + return sexp_type_exception(ctx, "not a list", ls); } else { b = ls; a = sexp_cdr(ls); @@ -387,6 +387,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_BIGNUMS + case SEXP_BIGNUM: + return sexp_make_boolean(!sexp_bignum_compare(a, b)); +#endif #if ! USE_IMMEDIATE_FLONUMS case SEXP_FLONUM: return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm new file mode 100644 index 00000000..a5d17b2f --- /dev/null +++ b/tests/numeric-tests.scm @@ -0,0 +1,138 @@ + +;; these tests are only valid if chibi-scheme is compiled with full +;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-neighborhoods x) + (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) + +(test '(536870912 536870913 536870911 -536870912 -536870911 -536870913) + (integer-neighborhoods (expt 2 29))) + +(test '(1073741824 1073741825 1073741823 -1073741824 -1073741823 -1073741825) + (integer-neighborhoods (expt 2 30))) + +(test '(2147483648 2147483649 2147483647 -2147483648 -2147483647 -2147483649) + (integer-neighborhoods (expt 2 31))) + +(test '(4294967296 4294967297 4294967295 -4294967296 -4294967295 -4294967297) + (integer-neighborhoods (expt 2 32))) + +(test '(4611686018427387904 4611686018427387905 4611686018427387903 + -4611686018427387904 -4611686018427387903 -4611686018427387905) + (integer-neighborhoods (expt 2 62))) + +(test '(9223372036854775808 9223372036854775809 9223372036854775807 + -9223372036854775808 -9223372036854775807 -9223372036854775809) + (integer-neighborhoods (expt 2 63))) + +(test '(18446744073709551616 18446744073709551617 18446744073709551615 + -18446744073709551616 -18446744073709551615 -18446744073709551617) + (integer-neighborhoods (expt 2 64))) + +(test '(85070591730234615865843651857942052864 + 85070591730234615865843651857942052865 + 85070591730234615865843651857942052863 + -85070591730234615865843651857942052864 + -85070591730234615865843651857942052863 + -85070591730234615865843651857942052865) + (integer-neighborhoods (expt 2 126))) + +(test '(170141183460469231731687303715884105728 + 170141183460469231731687303715884105729 + 170141183460469231731687303715884105727 + -170141183460469231731687303715884105728 + -170141183460469231731687303715884105727 + -170141183460469231731687303715884105729) + (integer-neighborhoods (expt 2 127))) + +(test '(340282366920938463463374607431768211456 + 340282366920938463463374607431768211457 + 340282366920938463463374607431768211455 + -340282366920938463463374607431768211456 + -340282366920938463463374607431768211455 + -340282366920938463463374607431768211457) + (integer-neighborhoods (expt 2 128))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-arithmetic-combinations a b) + (list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b))) + +(define (sign-combinations a b) + (list (integer-arithmetic-combinations a b) + (integer-arithmetic-combinations (- a) b) + (integer-arithmetic-combinations a (- b)) + (integer-arithmetic-combinations (- a) (- b)))) + +;; fix x fix +(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0)) + (sign-combinations 0 1)) +(test '((2 0 1 1 0) (0 -2 -1 -1 0) (0 2 -1 -1 0) (-2 0 1 1 0)) + (sign-combinations 1 1)) +(test '((59 25 714 2 8) (-25 -59 -714 -2 -8) + (25 59 -714 -2 8) (-59 -25 714 2 -8)) + (sign-combinations 42 17)) + +;; fix x big +(test '((4294967338 -4294967254 180388626432 0 42) + (4294967254 -4294967338 -180388626432 0 -42) + (-4294967254 4294967338 -180388626432 0 42) + (-4294967338 4294967254 180388626432 0 -42)) + (sign-combinations 42 (expt 2 32))) + +;; big x fix +(test '((4294967338 4294967254 180388626432 102261126 4) + (-4294967254 -4294967338 -180388626432 -102261126 -4) + (4294967254 4294967338 -180388626432 -102261126 4) + (-4294967338 -4294967254 180388626432 102261126 -4)) + (sign-combinations (expt 2 32) 42)) + +;; big x bigger +(test '((12884901889 -4294967297 36893488151714070528 0 4294967296) + (4294967297 -12884901889 -36893488151714070528 0 -4294967296) + (-4294967297 12884901889 -36893488151714070528 0 4294967296) + (-12884901889 4294967297 36893488151714070528 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) + +;; bigger x big +(test '((12884901889 4294967297 36893488151714070528 2 1) + (-4294967297 -12884901889 -36893488151714070528 -2 -1) + (4294967297 12884901889 -36893488151714070528 -2 1) + (-12884901889 -4294967297 36893488151714070528 2 -1)) + (sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) + +(test-report) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 8fc0606e..9e06318d 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -219,8 +219,20 @@ (test 256 (string->number "100" 16)) +(test 127 (string->number "177" 8)) + +(test 5 (string->number "101" 2)) + (test 100 (string->number "1e2")) +(test "100" (number->string 100)) + +(test "100" (number->string 256 16)) + +(test "177" (number->string 127 8)) + +(test "101" (number->string 5 2)) + (test #f (not 3)) (test #f (not (list 3))) @@ -349,6 +361,10 @@ (test #t (call-with-current-continuation procedure?)) +(test 7 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + (test 7 (apply + (list 3 4))) (test '(b e h) (map cadr '((a b) (d e) (g h)))) @@ -368,10 +384,6 @@ (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 1de49b46ce44de36843383a07194e2e9cad9cafa Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 17 Jul 2009 01:58:04 +0900 Subject: [PATCH 168/535] initial plan9 extensions --- eval.c | 4 ++ opcodes.c | 19 ++++++++ opt/plan9.c | 122 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 145 insertions(+) create mode 100644 opt/plan9.c diff --git a/eval.c b/eval.c index a8592aeb..6351ad33 100644 --- a/eval.c +++ b/eval.c @@ -2134,6 +2134,10 @@ static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { return sexp_make_integer(diff); } +#ifdef PLAN9 +#include "opt/plan9.c" +#endif + /*********************** standard environment *************************/ static struct sexp_struct core_forms[] = { diff --git a/opcodes.c b/opcodes.c index 68f1627d..492ebc6b 100644 --- a/opcodes.c +++ b/opcodes.c @@ -125,5 +125,24 @@ _FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), #if USE_DEBUG _FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), #endif +#if PLAN9 +_FN0("random-integer", 0, sexp_rand), +_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), +_FN0("current-directory", 0, sexp_getwd), +_FN0("current-user", 0, sexp_getuser), +_FN0("system-name", 0, sexp_sysname), +_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), +_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), +_FN0("fork", 0, sexp_fork), +_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), +_FN1(SEXP_STRING, "exits", 0, sexp_exits), +_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), +_FN0("pipe", 0, sexp_pipe), +_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), +_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), +_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), +_FN0("wait", 0, sexp_wait), +_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), +#endif }; diff --git a/opt/plan9.c b/opt/plan9.c new file mode 100644 index 00000000..3cc51097 --- /dev/null +++ b/opt/plan9.c @@ -0,0 +1,122 @@ +/* plan9.c -- extended Plan 9 system utils */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +sexp sexp_rand (sexp ctx) { + return sexp_make_integer(rand()); +} + +sexp sexp_srand (sexp ctx, sexp seed) { + srand(sexp_unbox_integer(seed)); + return SEXP_VOID; +} + +sexp sexp_fdopen (sexp ctx, sexp fd, sexp mode) { + FILE *f; + if (! sexp_integerp(fd)) + return sexp_type_exception(ctx, "fdopen: not an integer", fd); + if (! sexp_stringp(mode)) + return sexp_type_exception(ctx, "fdopen: not a mode string", mode); + f = fdopen(sexp_unbox_integer(fd), sexp_string_data(mode)); + if (! f) + return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd); + /* maybe use fd2path to get the name of the fd */ + if (sexp_string_data(mode)[0] == 'w') + return sexp_make_output_port(ctx, f, SEXP_FALSE); + else + return sexp_make_input_port(ctx, f, SEXP_FALSE); +} + +sexp sexp_fileno (sexp ctx, sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "fileno: not a port", port); + return sexp_make_integer(fileno(sexp_port_stream(port))); +} + +sexp sexp_fork (sexp ctx) { + return sexp_make_integer(fork()); +} + +sexp sexp_exec (sexp ctx, sexp name, sexp args) { + int i, len = sexp_unbox_integer(sexp_length(ctx, args)); + char **argv = malloc((len+1)*sizeof(char*)); + for (i=0; imsg, -1); + res = sexp_list2(ctx, sexp_make_integer(wmsg->pid), msg); + sexp_gc_release(ctx, msg, s_msg); + return res; +} + +sexp sexp_postnote (sexp ctx, sexp pid, sexp note) { + if (! sexp_integerp(pid)) + return sexp_type_exception(ctx, "postnote: not an integer", pid); + if (! sexp_stringp(note)) + return sexp_type_exception(ctx, "postnote: not a string", note); + postnote(PNPROC, sexp_unbox_integer(pid), sexp_string_data(note)); + return SEXP_VOID; +} + From c6499c8b625c9d79682688cd4218eff2c30f797e Mon Sep 17 00:00:00 2001 From: felix Date: Sun, 19 Jul 2009 16:18:30 +0200 Subject: [PATCH 169/535] diff should get -b on windows to ignore line-terminator differences; SEXP_API is redundantly redefined in sexp.c --- Makefile | 3 ++- sexp.c | 1 - 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index ed2744c2..a98fd165 100644 --- a/Makefile +++ b/Makefile @@ -19,6 +19,7 @@ else ifeq ($(shell uname -o),Msys) PLATFORM=mingw SOLIBDIR = $(BINDIR) +DIFFOPTS = -b else PLATFORM=unix endif @@ -92,7 +93,7 @@ cleaner: clean test-basic: chibi-scheme$(EXE) @for f in tests/basic/*.scm; do \ ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ - if diff -q $${f%.scm}.out $${f%.scm}.res; then \ + if diff -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \ echo "[PASS] $${f%.scm}"; \ else \ echo "[FAIL] $${f%.scm}"; \ diff --git a/sexp.c b/sexp.c index dfaca5a1..d5a63443 100644 --- a/sexp.c +++ b/sexp.c @@ -2,7 +2,6 @@ /* 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 */ From 8ba102c5c42648f986c19006d87a898ae9f08894 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 11 Aug 2009 01:14:39 +0900 Subject: [PATCH 170/535] adding initial untyped "cpointer" data type --- include/chibi/sexp.h | 11 +++++++++++ sexp.c | 7 +++++++ 2 files changed, 18 insertions(+) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 973535a9..45e74da0 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -14,6 +14,9 @@ #ifdef PLAN9 #include #include +#include +#include +#include <9p.h> typedef unsigned long size_t; #else #include @@ -66,6 +69,7 @@ enum sexp_types { SEXP_VECTOR, SEXP_FLONUM, SEXP_BIGNUM, + SEXP_CPOINTER, SEXP_IPORT, SEXP_OPORT, SEXP_EXCEPTION, @@ -163,6 +167,9 @@ struct sexp_struct { sexp_uint_t length; sexp_uint_t data[]; } bignum; + struct { + void *value; + } cpointer; /* runtime types */ struct { char flags; @@ -341,6 +348,7 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT)) #define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) #define sexp_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) +#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER)) #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)) @@ -420,6 +428,8 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_exception_procedure(p) ((p)->value.exception.procedure) #define sexp_exception_source(p) ((p)->value.exception.source) +#define sexp_cpointer_value(p) ((p)->value.cpointer.value) + #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) @@ -606,6 +616,7 @@ 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_make_cpointer(sexp ctx, void* value); SEXP_API void sexp_write(sexp ctx, 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); diff --git a/sexp.c b/sexp.c index d5a63443..74cf8376 100644 --- a/sexp.c +++ b/sexp.c @@ -74,6 +74,7 @@ static struct sexp_struct sexp_type_specs[] = { _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_CPOINTER, 0, 0, 0, 0, sexp_sizeof(cpointer), 0, 0, "cpointer"), _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"), @@ -554,6 +555,12 @@ sexp sexp_list_to_vector(sexp ctx, sexp ls) { return vec; } +sexp sexp_make_cpointer (sexp ctx, void *value) { + sexp ptr = sexp_alloc_type(ctx, port, SEXP_CPOINTER); + sexp_cpointer_value(ptr) = value; + return ptr; +} + /************************ reading and writing *************************/ #if USE_BIGNUMS From df5b9166405f23c1c25006b16e86a25c527395c8 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 11 Aug 2009 01:15:29 +0900 Subject: [PATCH 171/535] adding initial 9p interface --- opcodes.c | 1 + opt/plan9.c | 187 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 188 insertions(+) diff --git a/opcodes.c b/opcodes.c index 492ebc6b..56aa6563 100644 --- a/opcodes.c +++ b/opcodes.c @@ -143,6 +143,7 @@ _FN1(SEXP_STRING, "getenv", 0, sexp_getenv), _FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), _FN0("wait", 0, sexp_wait), _FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), +_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), #endif }; diff --git a/opt/plan9.c b/opt/plan9.c index 3cc51097..b386a3a0 100644 --- a/opt/plan9.c +++ b/opt/plan9.c @@ -120,3 +120,190 @@ sexp sexp_postnote (sexp ctx, sexp pid, sexp note) { return SEXP_VOID; } +/**********************************************************************/ +/* 9p interface */ + +typedef struct sexp_plan9_srv { + sexp context, auth, attach, walk, walk1, clone, open, create, remove, + read, write, stat, wstat, flush, destroyfid, destroyreq, end; +} *sexp_plan9_srv; + +void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) { + s->context = ctx; + s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open + = s->create = s->remove = s->read = s->write = s->stat = s->wstat + = s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE; + for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) { + if (sexp_car(ls) == sexp_intern(ctx, "auth:")) { + s->auth = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "attach:")) { + s->attach = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk:")) { + s->walk = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:")) { + s->walk1 = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "clone:")) { + s->clone = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "open:")) { + s->open = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "create:")) { + s->create = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "remove:")) { + s->remove = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "read:")) { + s->read = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "write:")) { + s->write = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "stat:")) { + s->stat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:")) { + s->wstat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "flush:")) { + s->flush = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:")) { + s->destroyfid = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:")) { + s->destroyreq = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "end:")) { + s->end = sexp_cadr(ls); + } + } +} + +void sexp_run_9p_handler (Req *r, sexp handler) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, r); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, handler, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +#define sexp_def_9p_handler(name, field) \ + void name (Req *r) { \ + sexp_run_9p_handler(r, ((sexp_plan9_srv)r->srv->aux)->field); \ + } + +sexp_def_9p_handler(sexp_9p_auth, auth) +sexp_def_9p_handler(sexp_9p_attach, attach) +sexp_def_9p_handler(sexp_9p_walk, walk) +sexp_def_9p_handler(sexp_9p_open, open) +sexp_def_9p_handler(sexp_9p_create, create) +sexp_def_9p_handler(sexp_9p_remove, remove) +sexp_def_9p_handler(sexp_9p_read, read) +sexp_def_9p_handler(sexp_9p_write, write) +sexp_def_9p_handler(sexp_9p_stat, stat) +sexp_def_9p_handler(sexp_9p_wstat, wstat) +sexp_def_9p_handler(sexp_9p_flush, flush) + +char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, qid); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_c_string(ctx, name, -1); + args = sexp_cons(ctx, ptr, args); + ptr = sexp_make_cpointer(ctx, fid); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->walk1, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +char* sexp_9p_clone (Fid *oldfid, Fid *newfid) { + sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, oldfid); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_make_cpointer(ctx, newfid); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->clone, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +void sexp_9p_destroyfid (Fid *fid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, fid); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyfid, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_destroyreq (Req *r) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, r); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyreq, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_end (Srv *srv) { + sexp_plan9_srv s = (sexp_plan9_srv)srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, srv); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->end, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +sexp sexp_postmountsrv (sexp ctx, sexp ls, sexp name, sexp mtpt, sexp flags) { + Srv s; + struct sexp_plan9_srv p9s; + if (! sexp_listp(ctx, ls)) + return sexp_type_exception(ctx, "postmountsrv: not an list", ls); + if (! sexp_stringp(name)) + return sexp_type_exception(ctx, "postmountsrv: not a string", name); + if (! sexp_stringp(mtpt)) + return sexp_type_exception(ctx, "postmountsrv: not a string", mtpt); + if (! sexp_integerp(flags)) + return sexp_type_exception(ctx, "postmountsrv: not an integer", flags); + sexp_build_srv(ctx, &p9s, ls); + s.aux = &p9s; + s.auth = &sexp_9p_auth; + s.attach = &sexp_9p_attach; + s.walk = &sexp_9p_walk; + s.walk1 = &sexp_9p_walk1; + s.clone = &sexp_9p_clone; + s.open = &sexp_9p_open; + s.create = &sexp_9p_create; + s.remove = &sexp_9p_remove; + s.read = &sexp_9p_read; + s.write = &sexp_9p_write; + s.stat = &sexp_9p_stat; + s.wstat = &sexp_9p_wstat; + s.flush = &sexp_9p_flush; + s.destroyfid = &sexp_9p_destroyfid; + s.destroyreq = &sexp_9p_destroyreq; + s.end = &sexp_9p_end; + postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt), + sexp_unbox_integer(flags)); + return SEXP_UNDEF; +} + From d36e70f6bf587d5d7ffb4215ea2d3e1ca2f7e6ba Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 24 Aug 2009 22:41:33 +0900 Subject: [PATCH 172/535] fixing various numeric operations --- eval.c | 27 +++++++++++++++++++++------ init.scm | 7 +++++++ opcodes.c | 19 +------------------ opt/bignum.c | 34 +++++++++++++++++++++++++++++----- sexp.c | 28 ++++++++++++++++++++-------- 5 files changed, 78 insertions(+), 37 deletions(-) diff --git a/eval.c b/eval.c index 6351ad33..eace6762 100644 --- a/eval.c +++ b/eval.c @@ -1678,13 +1678,20 @@ sexp sexp_vm (sexp ctx, sexp proc) { 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 (_ARG2 == sexp_make_integer(0)) { +#if USE_FLONUMS + if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) + _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else 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); + if (sexp_flonum_value(_ARG2) == trunc(sexp_flonum_value(_ARG2))) + _ARG2 = sexp_make_integer(sexp_flonum_value(_ARG2)); #else _ARG2 = sexp_fx_div(_ARG1, _ARG2); #endif @@ -1849,10 +1856,18 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); break; case OP_FLO2FIX: - if (sexp_flonump(_ARG1)) - _ARG1 = sexp_make_integer((sexp_sint_t)sexp_flonum_value(_ARG1)); - else if (! sexp_integerp(_ARG1)) + if (sexp_flonump(_ARG1)) { + if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { + sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); + } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { + _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); + } else { + _ARG1 = sexp_make_integer((sexp_sint_t)sexp_flonum_value(_ARG1)); + } + } else if (! sexp_integerp(_ARG1) && ! sexp_bignump(_ARG1)) { sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + } break; case OP_CHAR2INT: _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); diff --git a/init.scm b/init.scm index fac7cae9..61413eda 100644 --- a/init.scm +++ b/init.scm @@ -391,6 +391,13 @@ (define (abs x) (if (< x 0) (- x) x)) +(define (numerator x) + (if (integer? x) x (numerator (* x 10)))) +(define (denominator x) + (if (exact? x) + 1 + (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10)))))) + (define (modulo a b) (let ((res (remainder a b))) (if (< b 0) diff --git a/opcodes.c b/opcodes.c index 56aa6563..e765c22b 100644 --- a/opcodes.c +++ b/opcodes.c @@ -126,24 +126,7 @@ _FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), _FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), #endif #if PLAN9 -_FN0("random-integer", 0, sexp_rand), -_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), -_FN0("current-directory", 0, sexp_getwd), -_FN0("current-user", 0, sexp_getuser), -_FN0("system-name", 0, sexp_sysname), -_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), -_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), -_FN0("fork", 0, sexp_fork), -_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), -_FN1(SEXP_STRING, "exits", 0, sexp_exits), -_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), -_FN0("pipe", 0, sexp_pipe), -_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), -_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), -_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), -_FN0("wait", 0, sexp_wait), -_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), -_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), +#include "opt/plan9-opcodes.c" #endif }; diff --git a/opt/bignum.c b/opt/bignum.c index 0ddd7c3e..1a7112bd 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -25,6 +25,30 @@ sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { return res; } +#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) +#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) + +sexp sexp_double_to_bignum (sexp ctx, double f) { + int sign; + sexp_gc_var(ctx, res, s_res); + sexp_gc_var(ctx, scale, s_scale); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve(ctx, scale, s_scale); + sexp_gc_preserve(ctx, tmp, s_tmp); + res = sexp_fixnum_to_bignum(ctx, sexp_make_integer(0)); + scale = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); + sign = (f < 0 ? -1 : 1); + for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { + tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); + res = sexp_bignum_add(ctx, res, res, tmp); + scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); + } + sexp_bignum_sign(res) = sign; + sexp_gc_release(ctx, res, s_res); + return res; +} + sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size; size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); @@ -514,7 +538,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { r = sexp_fx_sub(a, b); /* XXXX check overflow */ break; case SEXP_NUM_FIX_FLO: - r = sexp_make_flonum(ctx, sexp_integer_to_double(a)+sexp_flonum_value(b)); + r = sexp_make_flonum(ctx, sexp_integer_to_double(a)-sexp_flonum_value(b)); break; case SEXP_NUM_FIX_BIG: r = sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a)); @@ -528,13 +552,13 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { r = sexp_fp_sub(ctx, a, b); break; case SEXP_NUM_FLO_BIG: - r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b)); break; case SEXP_NUM_BIG_FIX: r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, sexp_fixnum_to_bignum(ctx, b))); break; case SEXP_NUM_BIG_FLO: - r = sexp_make_flonum(ctx, sexp_flonum_value(b) + sexp_bignum_to_double(a)); + r = sexp_make_flonum(ctx, sexp_flonum_value(b) - sexp_bignum_to_double(a)); case SEXP_NUM_BIG_BIG: r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); break; @@ -555,7 +579,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) { r = sexp_fx_mul(a, b); break; case SEXP_NUM_FIX_FLO: - r = sexp_make_flonum(ctx, sexp_integer_to_double(a)+sexp_flonum_value(b)); + r = sexp_make_flonum(ctx, sexp_integer_to_double(a)*sexp_flonum_value(b)); break; case SEXP_NUM_FIX_BIG: r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_integer(sexp_fx_abs(a)), 0); @@ -565,7 +589,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) { r = sexp_fp_mul(ctx, a, b); break; case SEXP_NUM_FLO_BIG: - r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b)); break; case SEXP_NUM_BIG_BIG: r = sexp_bignum_mul(ctx, NULL, a, b); diff --git a/sexp.c b/sexp.c index 74cf8376..e27c42aa 100644 --- a/sexp.c +++ b/sexp.c @@ -844,9 +844,14 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { #if ! USE_IMMEDIATE_FLONUMS case SEXP_FLONUM: f = sexp_flonum_value(obj); - i = sprintf(numbuf, "%.15g", f); - if (f == trunc(f)) { - numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else { + i = sprintf(numbuf, "%.15g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + } } sexp_write_string(ctx, numbuf, out); break; @@ -902,9 +907,14 @@ void sexp_write (sexp ctx, sexp obj, sexp 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'; + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else { + i = sprintf(numbuf, "%.15g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + } } sexp_write_string(ctx, numbuf, out); #endif @@ -1029,15 +1039,17 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp) { 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)) + } else if ((c!=EOF) && ! is_separator(c)) { return sexp_read_error(ctx, "invalid numeric syntax", sexp_make_character(c), in); + } else { + sexp_push_char(ctx, c, in); + } res = ((double)whole + res) * pow(10, e); if (negp) res *= -1; if ((scale == 0.1) && (exponent != SEXP_VOID) && (res == round(res))) From 386a1cdb0ac64a80bb5f086ed522b8715f405be2 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 24 Aug 2009 22:41:54 +0900 Subject: [PATCH 173/535] working on 9p support --- opt/plan9-opcodes.c | 18 ++++++++++++++++++ opt/plan9.c | 33 ++++++++++++++++++++++++++++++++- 2 files changed, 50 insertions(+), 1 deletion(-) create mode 100644 opt/plan9-opcodes.c diff --git a/opt/plan9-opcodes.c b/opt/plan9-opcodes.c new file mode 100644 index 00000000..e64dd8a8 --- /dev/null +++ b/opt/plan9-opcodes.c @@ -0,0 +1,18 @@ +_FN0("random-integer", 0, sexp_rand), +_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), +_FN0("current-directory", 0, sexp_getwd), +_FN0("current-user", 0, sexp_getuser), +_FN0("system-name", 0, sexp_sysname), +_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), +_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), +_FN0("fork", 0, sexp_fork), +_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), +_FN1(SEXP_STRING, "exits", 0, sexp_exits), +_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), +_FN0("pipe", 0, sexp_pipe), +_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), +_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), +_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), +_FN0("wait", 0, sexp_wait), +_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), +_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), diff --git a/opt/plan9.c b/opt/plan9.c index b386a3a0..024e37d0 100644 --- a/opt/plan9.c +++ b/opt/plan9.c @@ -277,7 +277,7 @@ sexp sexp_postmountsrv (sexp ctx, sexp ls, sexp name, sexp mtpt, sexp flags) { Srv s; struct sexp_plan9_srv p9s; if (! sexp_listp(ctx, ls)) - return sexp_type_exception(ctx, "postmountsrv: not an list", ls); + return sexp_type_exception(ctx, "postmountsrv: not a list", ls); if (! sexp_stringp(name)) return sexp_type_exception(ctx, "postmountsrv: not a string", name); if (! sexp_stringp(mtpt)) @@ -307,3 +307,34 @@ sexp sexp_postmountsrv (sexp ctx, sexp ls, sexp name, sexp mtpt, sexp flags) { return SEXP_UNDEF; } +sexp sexp_9p_req_offset (sexp ctx, sexp req) { + return sexp_make_integer(ctx, (Req*)sexp_cpointer_value(req)->ifcall.offset); +} + +sexp sexp_9p_req_count (sexp ctx, sexp req) { + return sexp_make_integer(ctx, (Req*)sexp_cpointer_value(req)->ifcall.count); +} + +sexp sexp_9p_req_path (sexp ctx, sexp req) { + return sexp_c_string(ctx, (Req*)sexp_cpointer_value(req)->fid.qid.path, -1); +} + +sexp sexp_9p_req_fid (sexp ctx, sexp req) { + return sexp_make_cpointer(ctx, (Req*)sexp_cpointer_value(req)->fid); +} + +sexp sexp_9p_req_newfid (sexp ctx, sexp req) { + return sexp_make_cpointer(ctx, (Req*)sexp_cpointer_value(req)->newfid); +} + +sexp sexp_9p_respond (sexp ctx, sexp req, sexp err) { + char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil; + respond(sexp_cpointer_value(req), cerr); + return SEXP_VOID; +} + +sexp sexp_9p_responderror (sexp ctx, sexp req) { + responderror(sexp_cpointer_value(req)); + return SEXP_VOID; +} + From 34a9b1564565a88675bc232b740844fd25d5db2b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 24 Aug 2009 22:48:33 +0900 Subject: [PATCH 174/535] adding reader support for infinities --- sexp.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/sexp.c b/sexp.c index e27c42aa..ca8db254 100644 --- a/sexp.c +++ b/sexp.c @@ -1328,6 +1328,14 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } else { sexp_push_char(ctx, c2, in); res = sexp_read_symbol(ctx, in, c1, 1); +#if USE_FLONUMS + if (res == sexp_intern(ctx, "+inf.0")) + res = sexp_make_flonum(ctx, 1.0/0.0); + else if (res == sexp_intern(ctx, "-inf.0")) + res = sexp_make_flonum(ctx, -1.0/0.0); + else if (res == sexp_intern(ctx, "+nan.0")) + res = sexp_make_flonum(ctx, 0.0/0.0); +#endif } break; case '0': case '1': case '2': case '3': case '4': From 6376198e92d1657c72948a09a4e139184ddf7c65 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 11 Oct 2009 18:45:32 +0900 Subject: [PATCH 175/535] additions in preparation for module system --- eval.c | 126 +++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 82 insertions(+), 44 deletions(-) diff --git a/eval.c b/eval.c index eace6762..881425e3 100644 --- a/eval.c +++ b/eval.c @@ -26,8 +26,25 @@ static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; static sexp analyze (sexp ctx, sexp x); static void generate (sexp ctx, sexp x); +static sexp sexp_make_env (sexp ctx); static sexp sexp_make_null_env (sexp ctx, sexp version); static sexp sexp_make_standard_env (sexp ctx, sexp version); +static sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls); + +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); + msg = sexp_c_string(ctx, message, -1); + exn = sexp_make_exception(ctx, the_compile_error_symbol, msg, irritants, + SEXP_FALSE, (sexp_pairp(obj) ? + sexp_pair_source(obj) : SEXP_FALSE)); + sexp_gc_release(ctx, irritants, s_irr); + return exn; +} /********************** environment utilities ***************************/ @@ -68,15 +85,19 @@ 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 (sexp_truep(cell)) - sexp_cdr(cell) = value; - else { - tmp = sexp_cons(ctx, key, value); - sexp_push(ctx, sexp_env_bindings(e), tmp); + if (sexp_immutablep(e)) { + fprintf(stderr, "ERROR: immutable environment\n"); + } else { + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, tmp, s_tmp); + if (sexp_truep(cell)) + sexp_cdr(cell) = value; + else { + tmp = sexp_cons(ctx, key, value); + sexp_push(ctx, sexp_env_bindings(e), tmp); + } + sexp_gc_release(ctx, tmp, s_tmp); } - sexp_gc_release(ctx, tmp, s_tmp); } static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { @@ -213,7 +234,7 @@ static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) { static sexp sexp_make_synclo (sexp ctx, sexp env, sexp fv, sexp expr) { sexp res; - if (sexp_synclop(expr)) + if (! (sexp_symbolp(expr) || sexp_pairp(expr))) return expr; res = sexp_alloc_type(ctx, synclo, SEXP_SYNCLO); sexp_synclo_env(res) = env; @@ -360,21 +381,6 @@ 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) { - 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); - msg = sexp_c_string(ctx, message, -1); - exn = sexp_make_exception(ctx, the_compile_error_symbol, msg, irritants, - SEXP_FALSE, (sexp_pairp(obj) ? - sexp_pair_source(obj) : SEXP_FALSE)); - sexp_gc_release(ctx, irritants, s_irr); - return exn; -} - static sexp analyze_app (sexp ctx, sexp x) { sexp_gc_var(ctx, res, s_res); sexp_gc_var(ctx, tmp, s_tmp); @@ -570,6 +576,7 @@ static sexp analyze_define (sexp ctx, sexp x) { sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x); res = SEXP_VOID; } else { + if (sexp_synclop(name)) name = sexp_synclo_expr(name); env_cell_create(ctx, env, name, SEXP_VOID); if (sexp_pairp(sexp_cadr(x))) { tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); @@ -591,7 +598,7 @@ static sexp analyze_define (sexp ctx, sexp x) { } static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { - sexp res = SEXP_VOID; + sexp res = SEXP_VOID, name; sexp_gc_var(eval_ctx, proc, s_proc); sexp_gc_var(eval_ctx, mac, s_mac); sexp_gc_var(eval_ctx, tmp, s_tmp); @@ -605,8 +612,11 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { } else { proc = sexp_eval(eval_ctx, sexp_cadar(ls)); if (sexp_procedurep(proc)) { + name = sexp_caar(ls); + if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) + name = sexp_synclo_expr(name); mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(bind_ctx)); - tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac); + tmp = sexp_cons(eval_ctx, name, mac); sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp); } else { res = (sexp_exceptionp(proc) ? proc @@ -753,13 +763,13 @@ static sexp analyze (sexp ctx, sexp object) { } 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, + tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(tmp) = sexp_synclo_env(x); + sexp_context_fv(tmp) = sexp_append2(tmp, sexp_synclo_free_vars(x), - sexp_context_fv(ctx)); + sexp_context_fv(tmp)); x = sexp_synclo_expr(x); - goto loop; + res = analyze(tmp, x); } else { res = x; } @@ -1263,9 +1273,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { loop: #ifdef DEBUG_VM if (sexp_context_tracep(ctx)) { - sexp_print_stack(stack, top, fp, + sexp_print_stack(ctx, stack, top, fp, env_global_ref(env, the_cur_err_symbol, SEXP_FALSE)); - fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); + fprintf(stderr, "%s\n", (*ip<=OP_NUM_OPCODES) ? + reverse_opcode_names[*ip] : "UNKNOWN"); } #endif switch (*ip++) { @@ -1995,6 +2006,13 @@ static sexp sexp_close_port (sexp ctx, sexp port) { return SEXP_VOID; } +static sexp sexp_file_exists_p (sexp ctx, sexp path) { + struct stat buf; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "not a string", path); + return (stat(sexp_string_data(path), &buf) ? SEXP_FALSE : SEXP_TRUE); +} + 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)) @@ -2181,12 +2199,17 @@ static sexp sexp_copy_opcode (sexp ctx, sexp op) { return res; } -static sexp sexp_make_null_env (sexp ctx, sexp version) { - sexp_uint_t i; +static sexp sexp_make_env (sexp ctx) { 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; + return e; +} + +static sexp sexp_make_null_env (sexp ctx, sexp version) { + sexp_uint_t i; + sexp e = sexp_make_env(ctx); 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])), sexp_copy_core(ctx, &core_forms[i])); @@ -2222,6 +2245,8 @@ 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); + env_define(ctx, e, sexp_intern(ctx, "*module-directory*"), + sexp_c_string(ctx, sexp_module_dir, -1)); /* add default exception handler */ err_cell = env_cell(e, the_cur_err_symbol); perr_cell = env_cell(e, sexp_intern(ctx, "print-exception")); @@ -2248,6 +2273,17 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { return e; } +static sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) { + if (! sexp_envp(to)) to = sexp_context_env(ctx); + if (! sexp_envp(from)) from = sexp_context_env(ctx); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (sexp_pairp(sexp_car(ls))) + env_define(ctx, to, sexp_caar(ls), env_global_ref(from, sexp_cdar(ls), SEXP_FALSE)); + else + env_define(ctx, to, sexp_car(ls), env_global_ref(from, sexp_car(ls), SEXP_FALSE)); + return SEXP_UNDEF; +} + /************************** eval interface ****************************/ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { @@ -2279,10 +2315,8 @@ sexp sexp_compile (sexp ctx, sexp x) { 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); + generate(ctx, ast); + res = finalize_bytecode(ctx); vec = sexp_make_vector(ctx, 0, SEXP_VOID); res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0), res, vec); @@ -2292,18 +2326,20 @@ sexp sexp_compile (sexp ctx, sexp x) { } sexp sexp_eval (sexp ctx, sexp obj) { - sexp res; + sexp res, ctx2; sexp_gc_var(ctx, thunk, s_thunk); sexp_gc_preserve(ctx, thunk, s_thunk); - thunk = sexp_compile(ctx, obj); + ctx2 = sexp_make_context(ctx, NULL, sexp_context_env(ctx)); + sexp_context_parent(ctx2) = ctx; + thunk = sexp_compile(ctx2, obj); if (sexp_exceptionp(thunk)) { - sexp_print_exception(ctx, thunk, - env_global_ref(sexp_context_env(ctx), + sexp_print_exception(ctx2, thunk, + env_global_ref(sexp_context_env(ctx2), the_cur_err_symbol, SEXP_FALSE)); res = thunk; } else { - res = sexp_apply(ctx, thunk, SEXP_NULL); + res = sexp_apply(ctx2, thunk, SEXP_NULL); } sexp_gc_release(ctx, thunk, s_thunk); return res; @@ -2347,5 +2383,7 @@ void sexp_scheme_init (void) { sexp_make_integer(0), finalize_bytecode(ctx), sexp_make_vector(ctx, 0, SEXP_VOID)); + sexp_bytecode_name(sexp_procedure_code(final_resumer)) + = sexp_intern(ctx, "final-resumer"); } } From 62c390d68e1aaac5b55ddb035c59157c9081f06d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 13 Oct 2009 18:29:18 +0900 Subject: [PATCH 176/535] initial module system --- Makefile | 6 +- debug.c | 2 +- eval.c | 48 ++++++++++------ include/chibi/bignum.h | 1 + include/chibi/config.h | 7 +++ include/chibi/eval.h | 11 +++- include/chibi/sexp.h | 1 + init.scm | 29 +++++++--- lib/srfi/1.module | 31 ++++++++++ lib/srfi/1/alists.scm | 10 ++++ lib/srfi/1/constructors.scm | 33 +++++++++++ lib/srfi/1/deletion.scm | 22 +++++++ lib/srfi/1/fold.scm | 112 ++++++++++++++++++++++++++++++++++++ lib/srfi/1/lset.scm | 48 ++++++++++++++++ lib/srfi/1/misc.scm | 58 +++++++++++++++++++ lib/srfi/1/predicates.scm | 31 ++++++++++ lib/srfi/1/search.scm | 50 ++++++++++++++++ lib/srfi/1/selectors.scm | 56 ++++++++++++++++++ main.c | 40 +++++++++---- opcodes.c | 3 + opt/bignum.c | 13 ++--- sexp.c | 17 ++++-- 22 files changed, 572 insertions(+), 57 deletions(-) create mode 100644 lib/srfi/1.module create mode 100644 lib/srfi/1/alists.scm create mode 100644 lib/srfi/1/constructors.scm create mode 100644 lib/srfi/1/deletion.scm create mode 100644 lib/srfi/1/fold.scm create mode 100644 lib/srfi/1/lset.scm create mode 100644 lib/srfi/1/misc.scm create mode 100644 lib/srfi/1/predicates.scm create mode 100644 lib/srfi/1/search.scm create mode 100644 lib/srfi/1/selectors.scm diff --git a/Makefile b/Makefile index a98fd165..001e90c5 100644 --- a/Makefile +++ b/Makefile @@ -68,10 +68,10 @@ include/chibi/install.h: Makefile sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< -eval.o: eval.c debug.c opcodes.c include/chibi/eval.h $(INCLUDES) Makefile +eval.o: eval.c debug.c opcodes.c $(INCLUDES) include/chibi/eval.h Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< -main.o: main.c $(INCLUDES) Makefile +main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< libchibi-scheme$(SO): eval.o sexp.o @@ -84,7 +84,7 @@ chibi-scheme-static$(EXE): main.o eval.o sexp.o $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) clean: - rm -f *.o *.i *.s + rm -f *.o *.i *.s *.8 cleaner: clean rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) *$(SO) *.a diff --git a/debug.c b/debug.c index d8a51689..74c4774e 100644 --- a/debug.c +++ b/debug.c @@ -63,7 +63,7 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { } #ifdef DEBUG_VM -static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) { +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { int i; for (i=0; i #include #include +#include #include #endif diff --git a/init.scm b/init.scm index 61413eda..a3b0030e 100644 --- a/init.scm +++ b/init.scm @@ -79,7 +79,9 @@ (map1 proc ls '()) (mapn proc (cons ls lol) '()))) -(define for-each map) +(define (for-each f ls . lol) + (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls))))) + (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f)))) (define (any pred ls) (if (pair? ls) (if (pred (car ls)) #t (any pred (cdr ls))) #f)) @@ -355,12 +357,10 @@ (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 (member obj ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (and (pair? ls) (if (eq obj (car ls)) ls (lp (cdr ls))))))) (define memv member) @@ -542,6 +542,7 @@ (apply consumer (cdr res)) (consumer res)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; syntax-rules (define-syntax syntax-rules @@ -718,3 +719,17 @@ (lambda (clause) (expand-pattern (car clause) (cadr clause))) forms) (list (list 'error "no expansion")))))))))) + +(define *config-env* #f) + +(define-syntax import + (er-macro-transformer + (lambda (expr rename compare) + (let ((mod (eval `(load-module ',(cadr expr)) *config-env*))) + (if (vector? mod) + `(%env-copy! #f + (vector-ref + (eval '(load-module ',(cadr expr)) *config-env*) + 1) + ',(vector-ref mod 0)) + `(error "couldn't find module" ',(cadr expr))))))) diff --git a/lib/srfi/1.module b/lib/srfi/1.module new file mode 100644 index 00000000..1d76a116 --- /dev/null +++ b/lib/srfi/1.module @@ -0,0 +1,31 @@ + +(define-module (srfi 1) + (export + xcons cons* make-list list-tabulate list-copy circular-list iota + proper-list? circular-list? dotted-list? not-pair? null-list? list= + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr take drop take-right drop-right take! drop-right! split-at split-at! + last last-pair length+ concatenate append! concatenate! reverse! + append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 count + fold unfold pair-fold reduce fold-right unfold-right + pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter partition remove filter! partition! remove! find find-tail any every + list-index take-while drop-while take-while! span break span! break! + delete delete-duplicates delete! delete-duplicates! + alist-cons alist-copy alist-delete alist-delete! + lset<= lset= lset-adjoin lset-union lset-union! lset-intersection + lset-intersection! lset-difference lset-difference! lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection!) + (import (scheme)) + (include "srfi/1/constructors.scm" + "srfi/1/predicates.scm" + "srfi/1/selectors.scm" + "srfi/1/misc.scm" + "srfi/1/search.scm" + "srfi/1/fold.scm" + "srfi/1/deletion.scm" + "srfi/1/alists.scm" + "srfi/1/lset.scm")) + diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm new file mode 100644 index 00000000..ffea4bd8 --- /dev/null +++ b/lib/srfi/1/alists.scm @@ -0,0 +1,10 @@ + +(define (alist-cons key value ls) (cons (cons key value) ls)) + +(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls)) + +(define (alist-delete key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (remove (lambda (x) (eq (car x) key)) ls))) + +(define alist-delete! alist-delete) \ No newline at end of file diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm new file mode 100644 index 00000000..836f48b5 --- /dev/null +++ b/lib/srfi/1/constructors.scm @@ -0,0 +1,33 @@ + +(define (xcons a b) (cons b a)) + +(define (cons* x . args) + (let lp ((rev '()) (x x) (ls args)) + (if (null? ls) + (append-reverse rev x) + (lp (cons x rev) (car ls) (cdr ls))))) + +(define (make-list n . o) + (let ((default (if (pair? o) (car o)))) + (let lp ((n n) (res '())) + (if (<= n 0) res (lp (- n 1) (cons default res)))))) + +(define (list-tabulate n proc) + (let lp ((n n) (res '())) + (if (< n 0) res (lp (- n 1) (cons (proc n) res))))) + +(define (list-copy ls) (reverse! (reverse ls))) + +(define (circular-list x . args) + (let ((res (cons x args))) + (set-cdr! (last-pair res) res) + res)) + +(define (iota count . o) + (let ((start (if (pair? o) (car o) count)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) + (let lp ((i count) (n (- start step)) (res '())) + (if (<= i 0) + res + (lp (- i 1) (- n step) (cons n res)))))) + diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm new file mode 100644 index 00000000..721ae8c3 --- /dev/null +++ b/lib/srfi/1/deletion.scm @@ -0,0 +1,22 @@ + +(define (delete x ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (if (eq? eq eq?) + (let lp ((ls ls) (rev '())) ;; fast path for delq + (let ((tail (memq x ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls)))) + (filter (lambda (y) (eq x y)) ls)))) + +(define delete! delete) + +(define (delete-duplicates ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res))) + (reverse! res))))) + +(define delete-duplicates! delete-duplicates) + diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm new file mode 100644 index 00000000..8bb25b4a --- /dev/null +++ b/lib/srfi/1/fold.scm @@ -0,0 +1,112 @@ + +(define (fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (map-onto car lists (list acc)))) + acc)))) + +(define (fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (map-onto car lists (lp (map cdr lists)))) + knil)))) + +(define (pair-fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (append lists (list acc)))) + acc)))) + +(define (pair-fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (append lists (lp (map cdr lists)))) + knil)))) + +(define (reduce f identity ls) + (if (null? ls) identity (fold f (car ls) (cdr ls)))) + +(define (reduce-right f identity ls) + (if (null? ls) identity (fold-right f (car ls) (cdr ls)))) + +(define (unfold p f g seed . o) + (let lp ((seed seed)) + (if (p seed) + (if (pair? o) ((car o) seed) '()) + (cons (f seed) (lp (g seed)))))) + +(define (unfold-right p f g seed . o) + (let lp ((seed seed) (res (if (pair? o) (car o) '()))) + (if (p seed) res (lp (g seed) (cons (f seed) res))))) + +(define (append-map-helper append f ls lists) + (if (null? lists) + (if (null? ls) + '() + (let ((rev-ls (reverse ls))) + (let lp ((ls (cdr rev-ls)) (res (car rev-ls))) + (if (null? ls) res (lp (cdr ls) (append (f (car ls) res)))) + ))) + (if (and (pair? ls) (every pair lists)) + (let lp ((lists (cons ls lists))) + (let ((vals (apply f (map car lists))) + (cdrs (map cdr lists))) + (if (every pair? cdrs) (append vals (lp cdrs)) vals))) + '()))) + +(define (append-map f ls . lists) + (append-map-helper append f ls lists)) + +(define (append-map! f ls . lists) + (append-map-helper append! f ls lists)) + +(define map! map) +(define map-in-order map) + +(define (pair-for-each f ls . lists) + (apply pair-fold (lambda (x _) (f x)) ls lists)) + +(define (filter-map f ls . lists) + (if (null? lists) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res))) + (reverse! res))) + (filter (lambda (x) x) (apply map f ls lists)))) + +(define (take-up-to-reverse from to init) + (if (eq? from to) + init + (take-up-to-reverse (cdr from) to (cons (car from) init)))) + +(define (filter pred ls) + (let lp ((ls ls) (rev '())) + (let ((tail (find-tail pred ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls))))) + +(define (remove pred ls) (filter (lambda (x) (not (pred x))) ls)) + +(define (partition pred ls) + (let lp ((ls ls) (good '()) (bad '())) + (cond ((null? ls) (values (reverse! good) (reverse! bad))) + ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad)) + (else (lp (cdr ls) good (cons (car ls) bad)))))) + +(define filter! filter) +(define remove! remove) +(define partition! partition) + diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm new file mode 100644 index 00000000..dd1a0964 --- /dev/null +++ b/lib/srfi/1/lset.scm @@ -0,0 +1,48 @@ + +(define (lset<= eq . sets) + (if (null? sets) + #t + (let lp1 ((set1 (car sets)) (sets (cdr sets))) + (if (null? sets) + #t + (let ((set2 (car sets))) + (let lp2 ((ls set1)) + (if (pair? ls) + (and (member (car set1) set2 eq) (lp2 (cdr ls))) + (lp1 set2 (cdr sets))))))))) + +(define (lset= eq . sets) + (and (apply lset<= eq sets) (apply lset<= eq (reverse sets)))) + +(define (lset-adjoin eq set . elts) + (lset-union2 eq elts set)) + +(define (lset-union2 eq a b) + (if (null? b) + a + (lset-union2 (cdr b) (if (member (car b) a eq) a (cons (car b) a))))) + +(define (lset-union eq . sets) + (reduce (lambda (a b) (lset-union2 eq a b)) '() sets)) + +(define (lset-intersection eq . sets) + (reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-difference eq . sets) + (reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-xor eq . sets) + (reduce (lambda (a b) + (append (filter (lambda (x) (member x b eq)) a) + (filter (lambda (x) (member x a eq)) b))) + '() + sets)) + +(define (lset-diff+intersection eq . sets) + (values (apply lset-difference eq sets) (apply lset-intersection eq sets))) + +(define lset-diff+intersection! lset-diff+intersection) +(define lset-xor! lset-xor) +(define lset-difference! lset-difference) +(define lset-intersection! lset-intersection) +(define lset-union! lset-union) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm new file mode 100644 index 00000000..20011c44 --- /dev/null +++ b/lib/srfi/1/misc.scm @@ -0,0 +1,58 @@ + +(define (map-onto proc ls init) + (let lp ((ls ls) (res init)) + (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res))))) + +(define (length+ x) + (if (not (pair? x)) + 0 + (let lp ((hare (cdr x)) (tortoise x) (res 0)) + (and (not (eq? hare tortoise)) + (if (pair? hare) + (lp (cddr hare) (cdr tortoise) (+ res 1)) + res))))) + +(define (append! . lists) (concatenate! lists)) + +(define (concatenate lists) (reduce-right append '() lists)) + +(define (concatenate! lists) + (if (null? lists) + '() + (let lp ((ls lists)) + (cond ((not (pair? (cdr ls))) + lists) + (else + (set-cdr! (last-pair (car ls)) (cadr ls)) + (lp (cdr ls))))))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define (append-reverse! rev tail) + (if (null? rev) + tail + (let ((head (reverse! rev))) + (set-cdr! rev tail) + head))) + +(define (zip . lists) (apply map list lists)) + +(define (unzip1 ls) (map car ls)) +(define (unzip2 ls) (values (map car ls) (map cadr ls))) +(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls))) +(define (unzip4 ls) + (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) +(define (unzip5 ls) + (values (map car ls) (map cadr ls) (map caddr ls) + (map cadddr ls) (map fifth ls))) + +(define (count pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (res 0)) + (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res)) + (let lp ((lists (cons ls lists)) (res 0)) + (if (every pair? lists) + (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res)) + res)))) + diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm new file mode 100644 index 00000000..fe1dc77b --- /dev/null +++ b/lib/srfi/1/predicates.scm @@ -0,0 +1,31 @@ + +(define (proper-list? x) + (cond ((null? x) #t) + ((pair? x) (proper-list? (cdr x))) + (else #f))) + +(define (circular-list? x) + (and (pair? x) (pair? (cdr x)) + (let race ((hare (cdr x)) (tortoise x)) + (or (eq? hare tortoise) + (and (pair? hare) (pair? (cdr hare)) + (race (cddr hare) (cdr tortoise))))))) + +(define (dotted-list? x) + (not (proper-list? x))) + +(define (not-pair? x) (not (pair? x))) + +(define (null-list? x) (null? x)) ; no error + +(define (list= eq . lists) + (let lp1 ((lists lists)) + (or (null? lists) + (null? (cdr lists)) + (let lp2 ((ls1 (car lists)) (ls2 (cadr lists))) + (if (null? ls1) + (and (null? ls2) + (lp1 (cdr lists))) + (and (eq (car ls1) (car ls2)) + (lp2 (cdr ls1) (cdr ls2)))))))) + diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm new file mode 100644 index 00000000..335faf4c --- /dev/null +++ b/lib/srfi/1/search.scm @@ -0,0 +1,50 @@ + +(define (find pred ls) + (cond ((find-tail pred ls) => car) (else #f))) + +(define (find-tail pred ls) + (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls))))) + +(define (take-while pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (reverse! res)))) + +(define take-while! take-while) + +(define (drop-while pred ls) + (or (find-tail (lambda (x) (not (pred x))) ls) '())) + +(define (span pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (values (reverse! res) ls)))) + +(define span! span) + +(define (break pred ls) (span (lambda (x) (not (pred x))) ls)) + +(define break! break) + +(define (any pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) #t (lp (cdr ls))))) + (let lp ((lists (cons ls lists))) + (and (every pair? lists) + (if (apply pred (map car lists)) #t (lp (map cdr lists))))))) + +(define (every pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t)) + (not (apply any (lambda (x) (not (pred x))) ls lists)))) + +(define (list-index pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (n 0)) + (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1))))) + (let lp ((lists (cons ls lists)) (n 0)) + (and (every pair? lists) + (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1))) + )))) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm new file mode 100644 index 00000000..c6608d50 --- /dev/null +++ b/lib/srfi/1/selectors.scm @@ -0,0 +1,56 @@ + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth ls) (car (cdr (cdr (cdr (cdr ls)))))) +(define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls))))))) +(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (eighth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (ninth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))) +(define (tenth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))) + +(define (car+cdr x) (values (car x) (cdr x))) + +(define (take ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (reverse! res) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (take! ls i) + (if (<= i 0) + '() + (let ((tail (list-tail ls (- i 1)))) + (set-cdr! tail '()) + ls))) + +(define (drop ls i) + (if (<= i 0) ls (drop (cdr ls) (- i 1)))) + +(define (take-right ls i) + (drop ls (- (length+ ls) i))) + +(define (drop-right ls i) + (take ls (- (length+ ls) i))) + +(define (drop-right! ls i) + (take! ls (- (length+ ls) i))) + +(define (split-at ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (values (reverse! res) ls) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (split-at! ls i) + (if (<= i 0) + (values '() ls) + (let* ((tail (list-tail ls (- i 1))) + (right (cdr tail))) + (set-cdr! tail '()) + (values ls right)))) + +(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls)))) +(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls)))) + diff --git a/main.c b/main.c index 9197f996..7f05c55e 100644 --- a/main.c +++ b/main.c @@ -71,15 +71,33 @@ sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { return res; } +sexp sexp_init_environments (sexp ctx) { + sexp res, env; + sexp_gc_var(ctx, confenv, s_confenv); + env = sexp_context_env(ctx); + res = sexp_load_module_file(ctx, sexp_init_file, env); + if (! sexp_exceptionp(res)) { + res = SEXP_UNDEF; + sexp_gc_preserve(ctx, confenv, s_confenv); + confenv = sexp_make_env(ctx); + sexp_env_copy(ctx, confenv, env, SEXP_FALSE); + sexp_load_module_file(ctx, sexp_config_file, confenv); + env_define(ctx, env, sexp_intern(ctx, "*config-env*"), confenv); + env_define(ctx, confenv, sexp_intern(ctx, "*config-env*"), confenv); + sexp_gc_release(ctx, confenv, s_confenv); + } + 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)"); + in = sexp_eval_string(ctx, "(current-input-port)", env); + out = sexp_eval_string(ctx, "(current-output-port)", env); + err = sexp_eval_string(ctx, "(current-error-port)", env); sexp_port_sourcep(in) = 1; while (1) { sexp_write_string(ctx, "> ", out); @@ -92,7 +110,7 @@ void repl (sexp ctx) { } else { tmp = sexp_env_bindings(env); sexp_context_top(ctx) = 0; - res = sexp_eval(ctx, obj); + res = sexp_eval(ctx, obj, env); #if USE_WARN_UNDEFS sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, err); #endif @@ -109,11 +127,13 @@ void run_main (int argc, char **argv) { sexp env, out=NULL, res=SEXP_VOID, ctx; sexp_uint_t i, quit=0, init_loaded=0; sexp_gc_var(ctx, str, s_str); + sexp_gc_var(ctx, confenv, s_confenv); ctx = sexp_make_context(NULL, NULL, NULL); sexp_gc_preserve(ctx, str, s_str); + sexp_gc_preserve(ctx, confenv, s_confenv); env = sexp_context_env(ctx); - out = sexp_eval_string(ctx, "(current-output-port)"); + out = sexp_eval_string(ctx, "(current-output-port)", env); /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { @@ -121,10 +141,10 @@ void run_main (int argc, char **argv) { case 'e': case 'p': if (! init_loaded++) - sexp_load_module_file(ctx, sexp_init_file, env); + sexp_init_environments(ctx); res = sexp_read_from_string(ctx, argv[i+1]); if (! sexp_exceptionp(res)) - res = sexp_eval(ctx, res); + res = sexp_eval(ctx, res, env); if (sexp_exceptionp(res)) { sexp_print_exception(ctx, res, out); quit = 1; @@ -138,7 +158,7 @@ void run_main (int argc, char **argv) { break; case 'l': if (! init_loaded++) - sexp_load_module_file(ctx, sexp_init_file, env); + sexp_init_environments(ctx); sexp_load_module_file(ctx, argv[++i], env); break; case 'q': @@ -154,10 +174,10 @@ void run_main (int argc, char **argv) { if (! quit) { if (! init_loaded) - res = sexp_load_module_file(ctx, sexp_init_file, env); + res = sexp_init_environments(ctx); if (res && sexp_exceptionp(res)) sexp_print_exception(ctx, res, - sexp_eval_string(ctx, "(current-error-port)")); + sexp_eval_string(ctx, "(current-error-port)", env)); if (i < argc) for ( ; i < argc; i++) res = sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env); diff --git a/opcodes.c b/opcodes.c index e765c22b..fc2277b4 100644 --- a/opcodes.c +++ b/opcodes.c @@ -84,9 +84,12 @@ _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_STRING, "file-exists?", 0, sexp_file_exists_p), +_FN0("make-environment", 0, sexp_make_env), _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), +_FN3(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), _FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), _FN5(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception), diff --git a/opt/bignum.c b/opt/bignum.c index 1a7112bd..aacdcf19 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -478,18 +478,13 @@ enum sexp_number_combs { SEXP_NUM_BIG_BIG }; -int sexp_number_type_lookup[SEXP_NUM_TYPES] = +static int sexp_number_types[SEXP_NUM_TYPES] = {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, }; -int sexp_number_type (sexp a) { - if (sexp_integerp(a)) { - return 1; - } else if (! sexp_pointerp(a)) { - return 0; - } else { - return sexp_number_type_lookup[sexp_pointer_tag(a)]; - } +static int sexp_number_type (sexp a) { + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)] + : sexp_integerp(a); } sexp sexp_add (sexp ctx, sexp a, sexp b) { diff --git a/sexp.c b/sexp.c index ca8db254..3b057044 100644 --- a/sexp.c +++ b/sexp.c @@ -1133,20 +1133,24 @@ sexp sexp_read_raw (sexp ctx, sexp in) { goto scan_loop; case '\'': res = sexp_read(ctx, in); - res = sexp_list2(ctx, the_quote_symbol, res); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, the_quote_symbol, res); break; case '`': res = sexp_read(ctx, in); - res = sexp_list2(ctx, the_quasiquote_symbol, res); + if (! sexp_exceptionp(res)) + 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); + if (! sexp_exceptionp(res)) + 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); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, the_unquote_symbol, res); } break; case '"': @@ -1157,12 +1161,12 @@ sexp sexp_read_raw (sexp ctx, sexp in) { 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; } + res = sexp_cons(ctx, tmp, res); + tmp = sexp_read_raw(ctx, in); } if (! sexp_exceptionp(res)) { if (tmp == SEXP_RAWDOT) { /* dotted list */ @@ -1238,6 +1242,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = tmp; else goto scan_loop; + break; case '\\': c1 = sexp_read_char(ctx, in); res = sexp_read_symbol(ctx, in, c1, 0); From e50950316f3922fa631d2f48518f0bda79a9f538 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 14 Oct 2009 10:42:10 +0900 Subject: [PATCH 177/535] commenting out name used for debugging stack references into the heap --- include/chibi/sexp.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 6d580e99..103d11db 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -121,7 +121,7 @@ typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp); struct sexp_gc_var_t { sexp *var; - char *name; + /* char *name; */ struct sexp_gc_var_t *next; }; @@ -269,7 +269,7 @@ struct sexp_struct { #define sexp_gc_preserve(ctx, x, y) \ do { \ (y).var = &(x); \ - (y).name = #x; \ + /* (y).name = #x; */ \ (y).next = sexp_context_saves(ctx); \ sexp_context_saves(ctx) = &(y); \ } while (0) From 91efc04852a9f575ad431347382ee12d45c34fbd Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Nov 2009 17:17:06 +0900 Subject: [PATCH 178/535] fixes for 64-bit machines --- gc.c | 4 ++++ include/chibi/config.h | 8 ++++++++ sexp.c | 6 +++--- 3 files changed, 15 insertions(+), 3 deletions(-) diff --git a/gc.c b/gc.c index ca6d0136..bb50dd39 100644 --- a/gc.c +++ b/gc.c @@ -9,7 +9,11 @@ #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair)) #define SEXP_GROW_HEAP_RATIO 0.7 +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else #define sexp_heap_align(n) sexp_align(n, 4) +#endif typedef struct sexp_free_list *sexp_free_list; struct sexp_free_list { diff --git a/include/chibi/config.h b/include/chibi/config.h index 96d64a58..834c3ea2 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -48,6 +48,14 @@ /* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ /************************************************************************/ +#ifndef SEXP_64_BIT +#if defined(__amd64) || defined(__x86_64) +#define SEXP_64_BIT 1 +#else +#define SEXP_64_BIT 0 +#endif +#endif + #if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) #define SEXP_BSD 1 #else diff --git a/sexp.c b/sexp.c index 3b057044..d0a4a3ae 100644 --- a/sexp.c +++ b/sexp.c @@ -71,9 +71,9 @@ static struct sexp_struct sexp_type_specs[] = { _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"), + _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "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_BIGNUM, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum"), _DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, sexp_sizeof(cpointer), 0, 0, "cpointer"), _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"), @@ -91,7 +91,7 @@ static struct sexp_struct sexp_type_specs[] = { _DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"), _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"), _DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"), - _DEF_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"), + _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack"), _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"), }; From 445f8e9fa43502d403a11e57944c7388d815731c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Nov 2009 18:53:32 +0900 Subject: [PATCH 179/535] adding bignum support for 64-bit machines using gcc 128-bit register extensions to hold the result of multpliying two 64-bit integers. --- include/chibi/bignum.h | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/include/chibi/bignum.h b/include/chibi/bignum.h index 3d889d82..8a160c52 100644 --- a/include/chibi/bignum.h +++ b/include/chibi/bignum.h @@ -5,8 +5,15 @@ #ifndef SEXP_BIGNUM_H #define SEXP_BIGNUM_H +#if (SEXP_64_BIT) +typedef unsigned int uint128_t __attribute__((mode(TI))); +typedef int sint128_t __attribute__((mode(TI))); +typedef uint128_t sexp_luint_t; +typedef sint128_t sexp_lsint_t; +#else typedef unsigned long long sexp_luint_t; typedef long long sexp_lsint_t; +#endif sexp_sint_t sexp_bignum_compare (sexp a, sexp b); sexp sexp_compare (sexp ctx, sexp a, sexp b); From 576a20b3bc2a744ca66ccd628f1f4764a9946c87 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Nov 2009 19:48:30 +0900 Subject: [PATCH 180/535] simplifying gc variable preservation Adding sexp_gc_var1..6 and corresponding _preserve/release1..6 referring to fixed preservation variable names, to substantially reduce the boilerplate on C functions which produce temporary sexp values. The fixed variable names are safe because we never nest them within the same C function. The original macros are still available for manual naming, block local variables and cases of more than 6 gc vars. Consider combining var+preserve into a single macro, since splitting them is rare. --- eval.c | 284 ++++++++++++++++--------------------------- include/chibi/sexp.h | 21 ++++ opt/bignum.c | 90 +++++--------- sexp.c | 112 +++++++---------- 4 files changed, 201 insertions(+), 306 deletions(-) diff --git a/eval.c b/eval.c index bc9fe415..e93f8edc 100644 --- a/eval.c +++ b/eval.c @@ -31,16 +31,14 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version); 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); + sexp_gc_var2(irritants, msg); + sexp_gc_preserve2(ctx, irritants, msg); 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_pairp(obj) ? sexp_pair_source(obj) : SEXP_FALSE)); - sexp_gc_release(ctx, irritants, s_irr); + sexp_gc_release2(ctx); return exn; } @@ -60,15 +58,15 @@ static sexp env_cell(sexp e, sexp key) { } static sexp env_cell_create(sexp ctx, sexp e, sexp key, sexp value) { - sexp_gc_var(ctx, cell, s_cell); + sexp_gc_var1(cell); cell = env_cell(e, key); if (! cell) { - sexp_gc_preserve(ctx, cell, s_cell); + sexp_gc_preserve1(ctx, 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); + sexp_gc_release1(ctx); } return cell; } @@ -83,26 +81,24 @@ static sexp env_global_ref(sexp e, sexp key, sexp dflt) { void env_define(sexp ctx, sexp e, sexp key, sexp value) { sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e)); + sexp_gc_var1(tmp); if (sexp_immutablep(e)) { fprintf(stderr, "ERROR: immutable environment\n"); } else { - sexp_gc_var(ctx, tmp, s_tmp); - sexp_gc_preserve(ctx, tmp, s_tmp); + sexp_gc_preserve1(ctx, tmp); if (sexp_truep(cell)) sexp_cdr(cell) = value; else { tmp = sexp_cons(ctx, key, value); sexp_push(ctx, sexp_env_bindings(e), tmp); } - sexp_gc_release(ctx, tmp, s_tmp); + sexp_gc_release1(ctx); } } static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { - 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); + sexp_gc_var2(e, tmp); + sexp_gc_preserve2(ctx, e, tmp); e = sexp_alloc_type(ctx, env, SEXP_ENV); sexp_env_parent(e) = env; sexp_env_bindings(e) = SEXP_NULL; @@ -110,13 +106,13 @@ static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { 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_release2(ctx); 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); + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); res = env2; if (env1 && sexp_envp(env1)) { res = sexp_alloc_type(ctx, env, SEXP_ENV); @@ -124,16 +120,16 @@ static sexp sexp_chain_env (sexp ctx, sexp env1, sexp env2) { sexp_env_bindings(res) = sexp_env_bindings(env1); sexp_env_lambda(res) = sexp_env_lambda(env1); } - sexp_gc_release(ctx, res, s_res); + sexp_gc_release1(ctx); 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); + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, 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); + sexp_gc_release1(ctx); return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res)); } @@ -285,8 +281,8 @@ static sexp sexp_make_lit(sexp ctx, sexp value) { #define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE) 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); + sexp_gc_var1(res); + if (ctx) sexp_gc_preserve1(ctx, res); res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); if ((! stack) || (stack == SEXP_FALSE)) { stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK); @@ -311,7 +307,7 @@ sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { sexp_context_top(res) = 0; sexp_context_tailp(res) = 1; sexp_context_tracep(res) = 0; - if (ctx) sexp_gc_release(ctx, res, save_res); + if (ctx) sexp_gc_release1(ctx); return res; } @@ -338,10 +334,8 @@ 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); + sexp_gc_var2(kar, kdr); + sexp_gc_preserve2(ctx, kar, kdr); loop: if (sexp_synclop(x)) { x = sexp_synclo_expr(x); @@ -354,7 +348,7 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) { } else { res = x; } - sexp_gc_release(ctx, kar, s_kar); + sexp_gc_release2(ctx); return res; } @@ -380,10 +374,8 @@ static sexp sexp_identifier_eq(sexp ctx, sexp e1, sexp id1, sexp e2, sexp id2) { /************************* the compiler ***************************/ static sexp analyze_app (sexp ctx, sexp x) { - 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); + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) { sexp_push(ctx, res, SEXP_FALSE); tmp = analyze(ctx, sexp_car(x)); @@ -394,15 +386,13 @@ static sexp analyze_app (sexp ctx, sexp x) { sexp_car(res) = tmp; } } - sexp_gc_release(ctx, res, s_res); + sexp_gc_release2(ctx); return (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); } static sexp analyze_seq (sexp ctx, sexp ls) { - 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); + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); if (sexp_nullp(ls)) res = SEXP_VOID; else if (sexp_nullp(sexp_cdr(ls))) @@ -415,14 +405,14 @@ static sexp analyze_seq (sexp ctx, sexp ls) { else sexp_seq_ls(res) = tmp; } - sexp_gc_release(ctx, res, s_res); + sexp_gc_release2(ctx); return res; } 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); + sexp_gc_var1(cell); + sexp_gc_preserve1(ctx, cell); cell = env_cell(env, x); if (! cell) { if (sexp_synclop(x)) { @@ -436,16 +426,14 @@ static sexp analyze_var_ref (sexp ctx, sexp x) { 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); + sexp_gc_release1(ctx); return res; } 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); + sexp_gc_var2(ref, value); + sexp_gc_preserve2(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); @@ -461,7 +449,7 @@ 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_release2(ctx); return res; } @@ -469,18 +457,8 @@ static sexp analyze_set (sexp ctx, sexp x) { static sexp analyze_lambda (sexp ctx, sexp x) { 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_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); + sexp_gc_var6(res, body, tmp, value, defs, ctx2); + sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2); /* verify syntax */ if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x)); @@ -523,18 +501,14 @@ static sexp analyze_lambda (sexp ctx, sexp x) { } sexp_lambda_body(res) = body; cleanup: - sexp_gc_release(ctx, res, s_res); + sexp_gc_release1(ctx); return res; } static sexp analyze_if (sexp ctx, sexp x) { 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); + sexp_gc_var3(test, pass, fail); + sexp_gc_preserve3(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 { @@ -545,20 +519,14 @@ static sexp analyze_if (sexp ctx, sexp x) { 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); + sexp_gc_release3(ctx); return res; } static sexp analyze_define (sexp ctx, sexp x) { 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); + sexp_gc_var4(ref, value, tmp, env); + sexp_gc_preserve4(ctx, ref, value, tmp, env); env = sexp_context_env(ctx); if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { res = sexp_compile_error(ctx, "bad define syntax", x); @@ -591,18 +559,14 @@ static sexp analyze_define (sexp ctx, sexp x) { res = sexp_make_set(ctx, ref, value); } } - sexp_gc_release(ctx, ref, s_ref); + sexp_gc_release4(ctx); return res; } static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { sexp res = SEXP_VOID, name; - 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); + sexp_gc_var3(proc, mac, tmp); + sexp_gc_preserve3(eval_ctx, proc, mac, tmp); for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls)) && sexp_nullp(sexp_cddar(ls)))) { @@ -623,28 +587,24 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { } } } - sexp_gc_release(eval_ctx, proc, s_proc); + sexp_gc_release3(eval_ctx); return res; } static sexp analyze_define_syntax (sexp ctx, sexp x) { sexp res; - sexp_gc_var(ctx, tmp, s_tmp); - sexp_gc_preserve(ctx, tmp, s_tmp); + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); tmp = sexp_list1(ctx, sexp_cdr(x)); res = analyze_bind_syntax(tmp, ctx, ctx); - sexp_gc_release(ctx, tmp, s_tmp); + sexp_gc_release1(ctx); return res; } static sexp analyze_let_syntax (sexp ctx, sexp x) { 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); + sexp_gc_var3(env, ctx2, tmp); + sexp_gc_preserve3(ctx, env, ctx2, tmp); if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { res = sexp_compile_error(ctx, "bad let-syntax", x); } else { @@ -656,34 +616,28 @@ static sexp analyze_let_syntax (sexp ctx, sexp x) { 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); + sexp_gc_release3(ctx); return res; } 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); + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); 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); + sexp_gc_release1(ctx); return res; } static sexp analyze (sexp ctx, sexp object) { 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); + sexp_gc_var4(res, tmp, x, cell); + sexp_gc_preserve4(ctx, res, tmp, x, cell); x = object; loop: if (sexp_pairp(x)) { @@ -771,7 +725,7 @@ static sexp analyze (sexp ctx, sexp object) { } else { res = x; } - sexp_gc_release(ctx, res, s_res); + sexp_gc_release4(ctx); return res; } @@ -898,8 +852,8 @@ static void generate_set (sexp ctx, sexp set) { 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); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); num_args = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))); sexp_context_tailp(ctx) = 0; @@ -977,14 +931,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); + sexp_gc_release1(ctx); } 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); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); /* push the arguments onto the stack */ sexp_context_tailp(ctx) = 0; @@ -999,7 +953,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); + sexp_gc_release1(ctx); } static void generate_app (sexp ctx, sexp app) { @@ -1012,10 +966,8 @@ static void generate_app (sexp ctx, sexp 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); + sexp_gc_var2(tmp, bc); + sexp_gc_preserve2(ctx, tmp, 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); @@ -1073,7 +1025,7 @@ static void generate_lambda (sexp ctx, sexp lambda) { emit_push(ctx, flags); emit(ctx, OP_MAKE_PROCEDURE); } - sexp_gc_release(ctx, tmp, s_tmp); + sexp_gc_release2(ctx); } static void generate (sexp ctx, sexp x) { @@ -1103,34 +1055,32 @@ 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_var1(res); if (sexp_nullp(fv2)) return fv1; - sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve1(ctx, 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); + sexp_gc_release1(ctx); 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); + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, 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); + sexp_gc_release1(ctx); 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); + sexp_gc_var2(fv1, fv2); + sexp_gc_preserve2(ctx, fv1, fv2); fv1 = fv; if (sexp_lambdap(x)) { fv1 = free_vars(ctx, sexp_lambda_body(x), SEXP_NULL); @@ -1157,34 +1107,26 @@ static sexp free_vars (sexp ctx, sexp x, sexp fv) { } else if (sexp_synclop(x)) { fv1 = free_vars(ctx, sexp_synclo_expr(x), fv); } - sexp_gc_release(ctx, fv1, s_fv1); + sexp_gc_release2(ctx); 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); + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); res = SEXP_NULL; for ( ; i>0; i--) res = sexp_cons(ctx, sexp_make_integer(i), res); - sexp_gc_release(ctx, res, s_res); + sexp_gc_release1(ctx); 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); + sexp_gc_var5(params, ref, refs, lambda, 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); + sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); params = make_param_list(ctx, i); lambda = sexp_make_lambda(ctx, params); ctx2 = sexp_make_child_context(ctx, lambda); @@ -1203,7 +1145,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t 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_release5(ctx); return res; } @@ -1259,13 +1201,9 @@ sexp sexp_vm (sexp ctx, sexp proc) { #if USE_BIGNUMS sexp_lsint_t prod; #endif + sexp_gc_var3(self, tmp1, tmp2); + sexp_gc_preserve3(ctx, self, tmp1, tmp2); 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: @@ -1954,7 +1892,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { goto loop; end_loop: - sexp_gc_release(ctx, self, s_self); + sexp_gc_release3(ctx); sexp_context_top(ctx) = top; return _ARG1; } @@ -2024,14 +1962,8 @@ void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp 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); + sexp_gc_var4(ctx2, x, in, res); + sexp_gc_preserve4(ctx, ctx2, x, in, res); res = SEXP_VOID; in = sexp_open_input_file(ctx, source); out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); @@ -2061,7 +1993,7 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out); #endif } - sexp_gc_release(ctx, ctx2, s_ctx2); + sexp_gc_release4(ctx); return res; } @@ -2222,14 +2154,8 @@ 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 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); + sexp_gc_var4(e, op, tmp, err_handler); + sexp_gc_preserve4(ctx, e, op, tmp, err_handler); e = sexp_make_null_env(ctx, version); for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { op = sexp_copy_opcode(ctx, &opcodes[i]); @@ -2272,7 +2198,7 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { finalize_bytecode(ctx2), tmp); env_define(ctx2, e, the_err_handler_symbol, err_handler); - sexp_gc_release(ctx, e, s_e); + sexp_gc_release4(ctx); return e; } @@ -2314,14 +2240,8 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { } 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); - 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); + sexp_gc_var4(ast, ctx2, vec, res); + sexp_gc_preserve4(ctx, ast, ctx2, vec, res); ast = analyze(ctx, x); if (sexp_exceptionp(ast)) { res = ast; @@ -2333,14 +2253,14 @@ sexp sexp_compile (sexp ctx, sexp x) { res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0), res, vec); } - sexp_gc_release(ctx, ast, s_ast); + sexp_gc_release4(ctx); return res; } sexp sexp_eval (sexp ctx, sexp obj, sexp env) { sexp res, ctx2; - sexp_gc_var(ctx, thunk, s_thunk); - sexp_gc_preserve(ctx, thunk, s_thunk); + sexp_gc_var1(thunk); + sexp_gc_preserve1(ctx, thunk); ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); sexp_context_parent(ctx2) = ctx; thunk = sexp_compile(ctx2, obj); @@ -2353,17 +2273,17 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) { } else { res = sexp_apply(ctx2, thunk, SEXP_NULL); } - sexp_gc_release(ctx, thunk, s_thunk); + sexp_gc_release1(ctx); return res; } sexp sexp_eval_string (sexp ctx, char *str, sexp env) { sexp res; - sexp_gc_var(ctx, obj, s_obj); - sexp_gc_preserve(ctx, obj, s_obj); + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); obj = sexp_read_from_string(ctx, str); res = sexp_eval(ctx, obj, env); - sexp_gc_release(ctx, obj, s_obj); + sexp_gc_release1(ctx); return res; } diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 103d11db..a3a00dcb 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -293,6 +293,27 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #endif #endif +#define sexp_gc_var1(x) sexp_gc_var(ctx, x, __sexp_gc_preserver1) +#define sexp_gc_var2(x, y) sexp_gc_var1(x); sexp_gc_var(ctx, y, __sexp_gc_preserver2) +#define sexp_gc_var3(x, y, z) sexp_gc_var2(x, y); sexp_gc_var(ctx, z, __sexp_gc_preserver3) +#define sexp_gc_var4(x, y, z, w) sexp_gc_var3(x, y, z); sexp_gc_var(ctx, w, __sexp_gc_preserver4) +#define sexp_gc_var5(x, y, z, w, v) sexp_gc_var4(x, y, z, w); sexp_gc_var(ctx, v, __sexp_gc_preserver5) +#define sexp_gc_var6(x, y, z, w, v, u) sexp_gc_var5(x, y, z, w, v); sexp_gc_var(ctx, u, __sexp_gc_preserver6) + +#define sexp_gc_preserve1(ctx, x) sexp_gc_preserve(ctx, x, __sexp_gc_preserver1) +#define sexp_gc_preserve2(ctx, x, y) sexp_gc_preserve1(ctx, x); sexp_gc_preserve(ctx, y, __sexp_gc_preserver2) +#define sexp_gc_preserve3(ctx, x, y, z) sexp_gc_preserve2(ctx, x, y); sexp_gc_preserve(ctx, z, __sexp_gc_preserver3) +#define sexp_gc_preserve4(ctx, x, y, z, w) sexp_gc_preserve3(ctx, x, y, z); sexp_gc_preserve(ctx, w, __sexp_gc_preserver4) +#define sexp_gc_preserve5(ctx, x, y, z, w, v) sexp_gc_preserve4(ctx, x, y, z, w); sexp_gc_preserve(ctx, v, __sexp_gc_preserver5) +#define sexp_gc_preserve6(ctx, x, y, z, w, v, u) sexp_gc_preserve5(ctx, x, y, z, w, v); sexp_gc_preserve(ctx, u, __sexp_gc_preserver6) + +#define sexp_gc_release1(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1) +#define sexp_gc_release2(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1) +#define sexp_gc_release3(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1) +#define sexp_gc_release4(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1) +#define sexp_gc_release5(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1) +#define sexp_gc_release6(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1) + #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) \ diff --git a/opt/bignum.c b/opt/bignum.c index aacdcf19..e4e4f8ea 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -30,12 +30,8 @@ sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { sexp sexp_double_to_bignum (sexp ctx, double f) { int sign; - sexp_gc_var(ctx, res, s_res); - sexp_gc_var(ctx, scale, s_scale); - sexp_gc_var(ctx, tmp, s_tmp); - sexp_gc_preserve(ctx, res, s_res); - sexp_gc_preserve(ctx, scale, s_scale); - sexp_gc_preserve(ctx, tmp, s_tmp); + sexp_gc_var3(res, scale, tmp); + sexp_gc_preserve3(ctx, res, scale, tmp); res = sexp_fixnum_to_bignum(ctx, sexp_make_integer(0)); scale = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); sign = (f < 0 ? -1 : 1); @@ -45,7 +41,7 @@ sexp sexp_double_to_bignum (sexp ctx, double f) { scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); } sexp_bignum_sign(res) = sign; - sexp_gc_release(ctx, res, s_res); + sexp_gc_release3(ctx); return res; } @@ -187,8 +183,8 @@ sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, char sign, sexp_uint_t base) { int c, digit; - sexp_gc_var(ctx, res, s_res); - sexp_gc_preserve(ctx, res, s_res); + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE); sexp_bignum_sign(res) = sign; sexp_bignum_data(res)[0] = init; @@ -209,7 +205,7 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, sexp_make_character(c), in); } sexp_push_char(ctx, c, in); - sexp_gc_release(ctx, res, s_res); + sexp_gc_release1(ctx); return sexp_bignum_normalize(res); } @@ -224,10 +220,8 @@ static int log2i(int v) { sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { int i, str_len, lg_base = log2i(base); char *data; - sexp_gc_var(ctx, b, s_b); - sexp_gc_var(ctx, str, s_str); - sexp_gc_preserve(ctx, b, s_b); - sexp_gc_preserve(ctx, str, s_str); + sexp_gc_var2(b, str); + sexp_gc_preserve2(ctx, b, str); b = sexp_copy_bignum(ctx, NULL, a, 0); sexp_bignum_sign(b) = 1; i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) @@ -242,31 +236,31 @@ sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { else if (sexp_bignum_sign(a) == -1) data[--i] = '-'; sexp_write_string(ctx, data + i, out); - sexp_gc_release(ctx, b, s_b); + sexp_gc_release2(ctx); return SEXP_VOID; } /****************** bignum arithmetic *************************/ sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { - sexp_gc_var(ctx, c, s_c); - sexp_gc_preserve(ctx, c, s_c); + sexp_gc_var1(c); + sexp_gc_preserve1(ctx, c); c = sexp_copy_bignum(ctx, NULL, a, 0); if (sexp_bignum_sign(c) == sexp_fx_sign(b)) c = sexp_bignum_fxadd(ctx, c, sexp_unbox_integer(sexp_fx_abs(b))); else c = sexp_bignum_fxsub(ctx, c, sexp_unbox_integer(sexp_fx_abs(b))); - sexp_gc_release(ctx, c, s_c); + sexp_gc_release1(ctx); return c; } sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), borrow=0, i, *adata, *bdata, *cdata; - sexp_gc_var(ctx, c, s_c); + sexp_gc_var1(c); if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) return sexp_bignum_sub_digits(ctx, dst, b, a); - sexp_gc_preserve(ctx, c, s_c); + sexp_gc_preserve1(ctx, c); c = ((dst && sexp_bignum_hi(dst) >= alen) ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); adata = sexp_bignum_data(a); @@ -280,16 +274,16 @@ sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { borrow = (cdata[i] == 0 ? 1 : 0); cdata[i]--; } - sexp_gc_release(ctx, c, s_c); + sexp_gc_release1(ctx); return c; } sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) { sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), carry=0, i, n, *adata, *bdata, *cdata; - sexp_gc_var(ctx, c, s_c); + sexp_gc_var1(c); if (alen < blen) return sexp_bignum_add_digits(ctx, dst, b, a); - sexp_gc_preserve(ctx, c, s_c); + sexp_gc_preserve1(ctx, c); c = ((dst && sexp_bignum_hi(dst) >= alen) ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); adata = sexp_bignum_data(a); @@ -308,7 +302,7 @@ sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) { c = sexp_copy_bignum(ctx, NULL, c, alen+1); sexp_bignum_data(c)[alen] = 1; } - sexp_gc_release(ctx, c, s_c); + sexp_gc_release1(ctx); return c; } @@ -342,11 +336,9 @@ sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, *bdata=sexp_bignum_data(b); - sexp_gc_var(ctx, c, s_c); - sexp_gc_var(ctx, d, s_d); + sexp_gc_var2(c, d); if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); - sexp_gc_preserve(ctx, c, s_c); - sexp_gc_preserve(ctx, d, s_d); + sexp_gc_preserve2(ctx, c, d); c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); d = sexp_make_bignum(ctx, alen+blen+1); for (i=0; i 0) { *rem = a; return sexp_fixnum_to_bignum(ctx, sexp_make_integer(0)); } - sexp_gc_preserve(ctx, x, s_x); - sexp_gc_preserve(ctx, prod, s_prod); - sexp_gc_preserve(ctx, diff, s_diff); - sexp_gc_preserve(ctx, k2, s_k2); - sexp_gc_preserve(ctx, i2, s_i2); + sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); k2 = sexp_bignum_double(ctx, k); i2 = sexp_bignum_double(ctx, i); x = quot_step(ctx, rem, a, b, k2, i2); @@ -391,20 +375,14 @@ static sexp quot_step (sexp ctx, sexp *rem, sexp a, sexp b, sexp k, sexp i) { *rem = diff; res = x; } - sexp_gc_release(ctx, x, s_x); + sexp_gc_release5(ctx); return res; } sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { sexp res; - sexp_gc_var(ctx, k, s_k); - sexp_gc_var(ctx, i, s_i); - sexp_gc_var(ctx, a1, s_a1); - sexp_gc_var(ctx, b1, s_b1); - sexp_gc_preserve(ctx, k, s_k); - sexp_gc_preserve(ctx, i, s_i); - sexp_gc_preserve(ctx, a1, s_a1); - sexp_gc_preserve(ctx, b1, s_b1); + sexp_gc_var4(k, i, a1, b1); + sexp_gc_preserve4(ctx, k, i, a1, b1); a1 = sexp_copy_bignum(ctx, NULL, a, 0); sexp_bignum_sign(a1) = 1; b1 = sexp_copy_bignum(ctx, NULL, b, 0); @@ -416,16 +394,16 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { if (sexp_bignum_sign(a) < 0) { sexp_negate(*rem); } - sexp_gc_release(ctx, k, s_k); + sexp_gc_release4(ctx); return res; } sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { sexp res; - sexp_gc_var(ctx, rem, s_rem); - sexp_gc_preserve(ctx, rem, s_rem); + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); res = sexp_bignum_quot_rem(ctx, &rem, a, b); - sexp_gc_release(ctx, rem, s_rem); + sexp_gc_release1(ctx); return res; } @@ -437,16 +415,14 @@ sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { sexp_sint_t e = sexp_unbox_integer(sexp_fx_abs(b)); - sexp_gc_var(ctx, res, s_res); - sexp_gc_var(ctx, acc, s_acc); - sexp_gc_preserve(ctx, res, s_res); - sexp_gc_preserve(ctx, acc, s_acc); + sexp_gc_var2(res, acc); + sexp_gc_preserve2(ctx, res, acc); res = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); acc = sexp_copy_bignum(ctx, NULL, a, 0); for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) if (e & 1) res = sexp_bignum_mul(ctx, NULL, res, acc); - sexp_gc_release(ctx, res, s_res); + sexp_gc_release2(ctx); return res; } diff --git a/sexp.c b/sexp.c index d0a4a3ae..e1f9c233 100644 --- a/sexp.c +++ b/sexp.c @@ -120,48 +120,38 @@ sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp irritants) { sexp res; - sexp_gc_var(ctx, sym, s_sym); - sexp_gc_var(ctx, str, s_str); - sexp_gc_var(ctx, irr, s_irr); - sexp_gc_preserve(ctx, sym, s_sym); - sexp_gc_preserve(ctx, str, s_str); - sexp_gc_preserve(ctx, irr, s_irr); + sexp_gc_var3(sym, str, irr); + sexp_gc_preserve3(ctx, sym, str, irr); res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user"), str = sexp_c_string(ctx, message, -1), ((sexp_pairp(irritants) || sexp_nullp(irritants)) ? irritants : (irr = sexp_list1(ctx, irritants))), self, SEXP_FALSE); - sexp_gc_release(ctx, sym, s_sym); + sexp_gc_release3(ctx); return res; } sexp sexp_type_exception (sexp ctx, char *message, sexp obj) { sexp res; - sexp_gc_var(ctx, sym, s_sym); - sexp_gc_var(ctx, str, s_str); - sexp_gc_var(ctx, irr, s_irr); - sexp_gc_preserve(ctx, sym, s_sym); - sexp_gc_preserve(ctx, str, s_str); - sexp_gc_preserve(ctx, irr, s_irr); + sexp_gc_var3(sym, str, irr); + sexp_gc_preserve3(ctx, sym, str, irr); 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_gc_release(ctx, sym, s_sym); + sexp_gc_release3(ctx); return res; } sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { - 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); + sexp_gc_var2(res, msg); + sexp_gc_preserve2(ctx, res, 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_gc_release(ctx, res, s_res); + sexp_gc_release2(ctx); return res; } @@ -225,12 +215,8 @@ sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { 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_preserve(ctx, name, s_name); - sexp_gc_preserve(ctx, str, s_str); - sexp_gc_preserve(ctx, irr, s_irr); + sexp_gc_var3(name, str, irr); + sexp_gc_preserve3(ctx, name, str, irr); 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); @@ -238,7 +224,7 @@ static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) { ? 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); + sexp_gc_release3(ctx); return res; } @@ -253,11 +239,11 @@ sexp sexp_cons (sexp ctx, sexp head, sexp tail) { } sexp sexp_list2 (sexp ctx, sexp a, sexp b) { - sexp_gc_var(ctx, res, s_res); - sexp_gc_preserve(ctx, res, s_res); + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); res = sexp_cons(ctx, b, SEXP_NULL); res = sexp_cons(ctx, a, res); - sexp_gc_release(ctx, res, s_res); + sexp_gc_release1(ctx); return res; } @@ -294,11 +280,11 @@ sexp sexp_assq (sexp ctx, sexp x, sexp ls) { } sexp sexp_reverse (sexp ctx, sexp ls) { - sexp_gc_var(ctx, res, s_res); - sexp_gc_preserve(ctx, res, s_res); + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, 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); + sexp_gc_release1(ctx); return res; } @@ -321,14 +307,12 @@ sexp sexp_nreverse (sexp ctx, sexp ls) { } 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); + sexp_gc_var2(a1, b1); + sexp_gc_preserve2(ctx, a1, 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); + sexp_gc_release2(ctx); return b1; } @@ -493,7 +477,7 @@ sexp sexp_intern(sexp ctx, char *str) { 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); + sexp_gc_var1(sym); #if USE_HUFF_SYMS res = 0; @@ -521,11 +505,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); + sexp_gc_preserve1(ctx, 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); + sexp_gc_release1(ctx); return sym; } @@ -625,8 +609,8 @@ 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; - sexp_gc_var(ctx, cookie, s_cookie); - sexp_gc_preserve(ctx, cookie, s_cookie); + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID); sexp_stream_ctx(cookie) = ctx; sexp_stream_buf(cookie) = str; @@ -635,15 +619,15 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) { 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); + sexp_gc_release1(ctx); 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); + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, 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; @@ -653,7 +637,7 @@ sexp sexp_make_output_string_port (sexp ctx) { 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); + sexp_gc_release1(ctx); return res; } @@ -727,7 +711,7 @@ sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p) { } sexp sexp_buffered_flush (sexp ctx, sexp p) { - sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_var1(tmp); if (! sexp_oportp(p)) return sexp_type_exception(ctx, "not an output-port", p); else if (! sexp_port_openp(p)) @@ -737,10 +721,10 @@ sexp sexp_buffered_flush (sexp ctx, sexp 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); + sexp_gc_preserve1(ctx, 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_gc_release1(ctx); } sexp_port_offset(p) = 0; return SEXP_VOID; @@ -767,10 +751,8 @@ 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); + sexp_gc_var2(ls, tmp); + sexp_gc_preserve2(ctx, ls, 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)); @@ -778,7 +760,7 @@ sexp sexp_get_output_string (sexp ctx, sexp out) { ls = sexp_port_cookie(out); } res = sexp_string_concatenate(ctx, ls); - sexp_gc_release(ctx, ls, s_ls); + sexp_gc_release2(ctx); return res; } @@ -1109,10 +1091,8 @@ 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); + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); scan_loop: switch (c1 = sexp_read_char(ctx, in)) { @@ -1355,7 +1335,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { if (sexp_port_sourcep(in) && sexp_pointerp(res)) sexp_immutablep(res) = 1; - sexp_gc_release(ctx, res, s_res); + sexp_gc_release2(ctx); return res; } @@ -1370,25 +1350,23 @@ sexp sexp_read (sexp ctx, sexp in) { 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); + sexp_gc_var2(s, in); + sexp_gc_preserve2(ctx, 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); + sexp_gc_release2(ctx); return res; } sexp sexp_write_to_string(sexp ctx, sexp obj) { sexp str; - sexp_gc_var(ctx, out, s_out); - sexp_gc_preserve(ctx, out, s_out); + sexp_gc_var1(out); + sexp_gc_preserve1(ctx, out); out = sexp_make_output_string_port(ctx); sexp_write(ctx, obj, out); str = sexp_get_output_string(ctx, out); - sexp_gc_release(ctx, out, s_out); + sexp_gc_release1(ctx); return str; } From 5b14a3a19d11ec29d30cdbe2ad4681013d562f6a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 2 Nov 2009 01:31:23 +0900 Subject: [PATCH 181/535] adding todo list --- TODO | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) create mode 100644 TODO diff --git a/TODO b/TODO new file mode 100644 index 00000000..790de726 --- /dev/null +++ b/TODO @@ -0,0 +1,49 @@ +* -*- outline -*- + +*+ precise gc rewrite +**+ fix heap growing +**- separate gc heaps +**- finalizers +**- weak references +*+ ast rewrite +*+ full r5rs +*+ closures +*+ string-ports +*+ argument validation +*+ variadic procedures +*+ call/cc +*+ exceptions +*+ tail-call elimination +*+ internal defines +*+ 1st class primitives +*+ macros +*+ hygiene +**- nested +**- compiler macros +*+ bignums +*= modules +**+ scheme48-like config language +**- only/except/rename modifiers +**- scheme-complete.el support +*= ffi +**- libdl interface +**- opcode generation interface +**- stub generator +*= cleanup +*- user documentation +*- unicode +*- condition-case +*- native x86 compilation +*+ plan 9 port +*= 9p support +*- optimization passes +**- constant folding +**- simplification pass, dead-code elimination +**- lambda lift +**- inlining +**- unsafe operations +**- plugin infrastructure +*- type inference with warnings +*- SRFI-0 cond-expand +*- SRFI-9 define-record-type +*- code repository with install tools From c4625e1c869fcd30e47e898c7f5d74b7bed743f0 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 2 Nov 2009 23:39:42 +0900 Subject: [PATCH 182/535] fixnum/integer naming cleanup Replacing sexp_make_integer, sexp_integerp, etc. with sexp_make_fixnum, sexp_fixnump, etc. Defining the old names as variants handling either fixnums or bignums, or just as aliases for the new terms when compiled without bignum support. sexp_make_integer needs to take a context now in case it generates a bignum. --- eval.c | 267 +++++++++++++++++++++---------------------- gc.c | 4 +- include/chibi/sexp.h | 36 +++--- opcodes.c | 20 ++-- opt/bignum.c | 78 +++++++------ sexp.c | 114 +++++++++--------- 6 files changed, 268 insertions(+), 251 deletions(-) diff --git a/eval.c b/eval.c index e93f8edc..f2575de9 100644 --- a/eval.c +++ b/eval.c @@ -291,7 +291,7 @@ sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { } sexp_context_stack(res) = stack; sexp_context_env(res) - = (env ? env : sexp_make_standard_env(res, sexp_make_integer(5))); + = (env ? env : sexp_make_standard_env(res, sexp_make_fixnum(5))); sexp_context_bc(res) = sexp_alloc_tagged(ctx, sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); @@ -690,9 +690,9 @@ static sexp analyze (sexp ctx, sexp object) { /* 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)) { + if (sexp_unbox_fixnum(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)) + } else if ((sexp_unbox_fixnum(res) > sexp_opcode_num_args(op)) && (! sexp_opcode_variadic_p(op))) { res = sexp_compile_error(ctx, "too many args for opcode", x); } else { @@ -855,7 +855,7 @@ static void generate_opcode_app (sexp ctx, sexp app) { sexp_gc_var1(ls); sexp_gc_preserve1(ctx, ls); - num_args = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))); + num_args = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))); sexp_context_tailp(ctx) = 0; /* maybe push the default for an optional argument */ @@ -935,7 +935,7 @@ static void generate_opcode_app (sexp ctx, sexp app) { } static void generate_general_app (sexp ctx, sexp app) { - sexp_uint_t len = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))), + sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), tailp = sexp_context_tailp(ctx); sexp_gc_var1(ls); sexp_gc_preserve1(ctx, ls); @@ -950,7 +950,7 @@ static void generate_general_app (sexp ctx, sexp app) { /* maybe overwrite the current frame */ emit(ctx, (tailp ? OP_TAIL_CALL : OP_CALL)); - emit_word(ctx, (sexp_uint_t)sexp_make_integer(len)); + emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); sexp_context_depth(ctx) -= len; sexp_gc_release1(ctx); @@ -991,14 +991,14 @@ 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(ctx2, sexp_lambda_params(lambda)) + flags = sexp_make_fixnum((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_vector(ctx2, sexp_make_fixnum(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); @@ -1012,7 +1012,7 @@ static void generate_lambda (sexp ctx, sexp lambda) { 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_push(ctx, sexp_make_fixnum(k)); emit(ctx, OP_STACK_REF); emit_word(ctx, 3); emit(ctx, OP_VECTOR_SET); @@ -1116,7 +1116,7 @@ static sexp make_param_list(sexp ctx, sexp_uint_t i) { sexp_gc_preserve1(ctx, res); res = SEXP_NULL; for ( ; i>0; i--) - res = sexp_cons(ctx, sexp_make_integer(i), res); + res = sexp_cons(ctx, sexp_make_fixnum(i), res); sexp_gc_release1(ctx); return res; } @@ -1141,7 +1141,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { 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), + res = sexp_make_procedure(ctx2, sexp_make_fixnum(0), sexp_make_fixnum(i), bc, SEXP_VOID); if (i == sexp_opcode_num_args(op)) sexp_opcode_proc(op) = res; @@ -1154,7 +1154,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { 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); + res = sexp_make_vector(ctx, sexp_make_fixnum(to), SEXP_VOID); data = sexp_vector_data(res); for (i=0; i= INIT_STACK_SIZE) errx(70, "out of stack space at %ld", top); #endif - i = sexp_unbox_integer(_WORD0); + i = sexp_unbox_fixnum(_WORD0); tmp1 = _ARG1; make_call: if (sexp_opcodep(tmp1)) { @@ -1307,10 +1307,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { } if (! sexp_procedurep(tmp1)) sexp_raise("non procedure application", sexp_list1(ctx, tmp1)); - j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); + j = i - sexp_unbox_fixnum(sexp_procedure_num_args(tmp1)); if (j < 0) sexp_raise("not enough args", - sexp_list2(ctx, tmp1, sexp_make_integer(i))); + sexp_list2(ctx, tmp1, sexp_make_fixnum(i))); if (j > 0) { if (sexp_procedure_variadic_p(tmp1)) { stack[top-i-1] = sexp_cons(ctx, stack[top-i-1], SEXP_NULL); @@ -1322,7 +1322,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { i -= (j-1); } else { sexp_raise("too many args", - sexp_list2(ctx, tmp1, sexp_make_integer(i))); + sexp_list2(ctx, tmp1, sexp_make_fixnum(i))); } } else if (sexp_procedure_variadic_p(tmp1)) { /* shift stack, set extra arg to null */ @@ -1332,10 +1332,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { top++; i++; } - _ARG1 = sexp_make_integer(i); - stack[top] = sexp_make_integer(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + _ARG1 = sexp_make_fixnum(i); + stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc)); stack[top+1] = self; - stack[top+2] = sexp_make_integer(fp); + stack[top+2] = sexp_make_fixnum(fp); top += 3; self = tmp1; bc = sexp_procedure_code(self); @@ -1436,7 +1436,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { ip += sizeof(sexp); break; case OP_CLOSURE_REF: - _PUSH(sexp_vector_ref(cp, sexp_make_integer(_WORD0))); + _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); ip += sizeof(sexp); break; case OP_VECTOR_REF: @@ -1455,7 +1455,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { top-=2; break; case OP_VECTOR_LENGTH: - _ARG1 = sexp_make_integer(sexp_vector_length(_ARG1)); + _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); break; case OP_STRING_REF: _ARG2 = sexp_string_ref(_ARG1, _ARG2); @@ -1471,7 +1471,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { top-=2; break; case OP_STRING_LENGTH: - _ARG1 = sexp_make_integer(sexp_string_length(_ARG1)); + _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); break; case OP_MAKE_PROCEDURE: sexp_context_top(ctx) = top; @@ -1493,9 +1493,6 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; case OP_INTEGERP: j = sexp_integerp(_ARG1); -#if USE_BIGNUMS - if (! j) j = sexp_bignump(_ARG1); -#endif #if USE_FLONUMS if (! j) j = (sexp_flonump(_ARG1) @@ -1509,7 +1506,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; case OP_TYPEP: _ARG1 = sexp_make_boolean(sexp_pointerp(_ARG1) - && (sexp_make_integer(sexp_pointer_tag(_ARG1)) + && (sexp_make_fixnum(sexp_pointer_tag(_ARG1)) == _WORD0)); ip += sizeof(sexp); break; @@ -1547,25 +1544,25 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_ADD: #if USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; - if (sexp_integerp(tmp1) && sexp_integerp(tmp2)) { - j = sexp_unbox_integer(tmp1) + sexp_unbox_integer(tmp2); + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) _ARG2 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); else - _ARG2 = sexp_make_integer(j); + _ARG2 = sexp_make_fixnum(j); } else _ARG2 = sexp_add(ctx, tmp1, tmp2); #else - if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + if (sexp_fixnump(_ARG1) && sexp_fixnump(_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)); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) + sexp_flonum_value(_ARG2)); #endif else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2)); #endif @@ -1574,25 +1571,25 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_SUB: #if USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; - if (sexp_integerp(tmp1) && sexp_integerp(tmp2)) { - j = sexp_unbox_integer(tmp1) - sexp_unbox_integer(tmp2); + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) _ARG2 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); else - _ARG2 = sexp_make_integer(j); + _ARG2 = sexp_make_fixnum(j); } else _ARG2 = sexp_sub(ctx, tmp1, tmp2); #else - if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + if (sexp_fixnump(_ARG1) && sexp_fixnump(_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)); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) - sexp_flonum_value(_ARG2)); #endif else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2)); #endif @@ -1601,45 +1598,45 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_MUL: #if USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; - if (sexp_integerp(tmp1) && sexp_integerp(tmp2)) { - prod = sexp_unbox_integer(tmp1) * sexp_unbox_integer(tmp2); + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + prod = sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) _ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); else - _ARG2 = sexp_make_integer(prod); + _ARG2 = sexp_make_fixnum(prod); } else _ARG2 = sexp_mul(ctx, tmp1, tmp2); #else - if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + if (sexp_fixnump(_ARG1) && sexp_fixnump(_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)); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) * sexp_flonum_value(_ARG2)); #endif else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2)); #endif top--; break; case OP_DIV: - if (_ARG2 == sexp_make_integer(0)) { + if (_ARG2 == sexp_make_fixnum(0)) { #if USE_FLONUMS if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); else #endif sexp_raise("divide by zero", SEXP_NULL); - } else if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + } else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { #if USE_FLONUMS - _ARG1 = sexp_integer_to_flonum(ctx, _ARG1); - _ARG2 = sexp_integer_to_flonum(ctx, _ARG2); + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); + _ARG2 = sexp_fixnum_to_flonum(ctx, _ARG2); _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); if (sexp_flonum_value(_ARG2) == trunc(sexp_flonum_value(_ARG2))) - _ARG2 = sexp_make_integer(sexp_flonum_value(_ARG2)); + _ARG2 = sexp_make_fixnum(sexp_flonum_value(_ARG2)); #else _ARG2 = sexp_fx_div(_ARG1, _ARG2); #endif @@ -1651,18 +1648,18 @@ sexp sexp_vm (sexp ctx, sexp proc) { #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)); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) / sexp_flonum_value(_ARG2)); #endif else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2)); #endif top--; break; case OP_QUOTIENT: - if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { - if (_ARG2 == sexp_make_integer(0)) + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == sexp_make_fixnum(0)) sexp_raise("divide by zero", SEXP_NULL); _ARG2 = sexp_fx_div(_ARG1, _ARG2); top--; @@ -1677,8 +1674,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { #endif break; case OP_REMAINDER: - if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { - if (_ARG2 == sexp_make_integer(0)) + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == sexp_make_fixnum(0)) sexp_raise("divide by zero", SEXP_NULL); tmp1 = sexp_fx_rem(_ARG1, _ARG2); top--; @@ -1694,8 +1691,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { #endif break; case OP_NEGATIVE: - if (sexp_integerp(_ARG1)) - _ARG1 = sexp_make_integer(-sexp_unbox_integer(_ARG1)); + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_make_fixnum(-sexp_unbox_fixnum(_ARG1)); #if USE_BIGNUMS else if (sexp_bignump(_ARG1)) { _ARG1 = sexp_copy_bignum(ctx, NULL, _ARG1, 0); @@ -1709,8 +1706,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { 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 (sexp_fixnump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, 1/(double)sexp_unbox_fixnum(_ARG1)); #if USE_FLONUMS else if (sexp_flonump(_ARG1)) _ARG1 = sexp_make_flonum(ctx, 1/sexp_flonum_value(_ARG1)); @@ -1718,23 +1715,23 @@ sexp sexp_vm (sexp ctx, sexp proc) { else sexp_raise("/: not a number", sexp_list1(ctx, _ARG1)); break; case OP_LT: - if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; #if USE_BIGNUMS _ARG2 = sexp_make_boolean(i); } else { tmp1 = sexp_compare(ctx, _ARG1, _ARG2); - _ARG2 = sexp_integerp(tmp1) - ? sexp_make_boolean(sexp_unbox_integer(tmp1) < 0) : tmp1; + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) < 0) : tmp1; } #else #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); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_fixnum(_ARG2); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_fixnum(_ARG1) < sexp_flonum_value(_ARG2); #endif else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); _ARG2 = sexp_make_boolean(i); @@ -1742,23 +1739,23 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case OP_LE: - if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; #if USE_BIGNUMS _ARG2 = sexp_make_boolean(i); } else { tmp1 = sexp_compare(ctx, _ARG1, _ARG2); - _ARG2 = sexp_integerp(tmp1) - ? sexp_make_boolean(sexp_unbox_integer(tmp1) <= 0) : tmp1; + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) <= 0) : tmp1; } #else #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); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_fixnum(_ARG2); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_fixnum(_ARG1) <= sexp_flonum_value(_ARG2); #endif else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); _ARG2 = sexp_make_boolean(i); @@ -1766,23 +1763,23 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case OP_EQN: - if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { i = _ARG1 == _ARG2; #if USE_BIGNUMS _ARG2 = sexp_make_boolean(i); } else { tmp1 = sexp_compare(ctx, _ARG1, _ARG2); - _ARG2 = sexp_integerp(tmp1) - ? sexp_make_boolean(sexp_unbox_integer(tmp1) == 0) : tmp1; + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) == 0) : tmp1; } #else #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); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_fixnum(_ARG2); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_fixnum(_ARG1) == sexp_flonum_value(_ARG2); #endif else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); _ARG2 = sexp_make_boolean(i); @@ -1794,8 +1791,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case OP_FIX2FLO: - if (sexp_integerp(_ARG1)) - _ARG1 = sexp_integer_to_flonum(ctx, _ARG1); + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); #if USE_BIGNUMS else if (sexp_bignump(_ARG1)) _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); @@ -1811,17 +1808,17 @@ sexp sexp_vm (sexp ctx, sexp proc) { || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); } else { - _ARG1 = sexp_make_integer((sexp_sint_t)sexp_flonum_value(_ARG1)); + _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); } - } else if (! sexp_integerp(_ARG1) && ! sexp_bignump(_ARG1)) { + } else if (! sexp_fixnump(_ARG1) && ! sexp_bignump(_ARG1)) { sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); } break; case OP_CHAR2INT: - _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); + _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); break; case OP_INT2CHAR: - _ARG1 = sexp_make_character(sexp_unbox_integer(_ARG1)); + _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); break; case OP_CHAR_UPCASE: _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); @@ -1875,19 +1872,19 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case OP_RET: - i = sexp_unbox_integer(stack[fp]); + i = sexp_unbox_fixnum(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]); + ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(stack[fp+1]); cp = sexp_procedure_vars(self); - fp = sexp_unbox_integer(stack[fp+3]); + fp = sexp_unbox_fixnum(stack[fp+3]); break; case OP_DONE: goto end_loop; default: - sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_integer(*(ip-1)))); + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); } goto loop; @@ -2011,8 +2008,8 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { double d; \ if (sexp_flonump(z)) \ d = sexp_flonum_value(z); \ - else if (sexp_integerp(z)) \ - d = (double)sexp_unbox_integer(z); \ + else if (sexp_fixnump(z)) \ + d = (double)sexp_unbox_fixnum(z); \ maybe_convert_bignum(z) \ else \ return sexp_type_exception(ctx, "not a number", z); \ @@ -2040,10 +2037,10 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { sexp res; #if USE_BIGNUMS if (sexp_bignump(e)) { - if ((x == sexp_make_integer(0)) || (x == sexp_make_integer(-1))) + if ((x == sexp_make_fixnum(0)) || (x == sexp_make_fixnum(-1))) res = sexp_make_flonum(ctx, pow(0, 0)); - else if (x == sexp_make_integer(1)) - res = sexp_make_flonum(ctx, sexp_unbox_integer(x)); + else if (x == sexp_make_fixnum(1)) + res = sexp_make_flonum(ctx, sexp_unbox_fixnum(x)); else if (sexp_flonump(x)) res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); else @@ -2052,16 +2049,16 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { res = sexp_bignum_expt(ctx, x, e); } else { #endif - if (sexp_integerp(x)) - x1 = (double)sexp_unbox_integer(x); + if (sexp_fixnump(x)) + x1 = (double)sexp_unbox_fixnum(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 (sexp_fixnump(e)) + e1 = (double)sexp_unbox_fixnum(e); #if USE_FLONUMS else if (sexp_flonump(e)) e1 = sexp_flonum_value(e); @@ -2077,7 +2074,7 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); } else #endif - res = sexp_make_integer((sexp_sint_t)round(f)); + res = sexp_make_fixnum((sexp_sint_t)round(f)); #if USE_BIGNUMS } #endif @@ -2099,7 +2096,7 @@ static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { diff = strncasecmp(sexp_string_data(str1), sexp_string_data(str2), len); if (! diff) diff = len1 - len2; - return sexp_make_integer(diff); + return sexp_make_fixnum(diff); } #ifdef PLAN9 @@ -2193,8 +2190,8 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { 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), + sexp_make_fixnum(0), + sexp_make_fixnum(0), finalize_bytecode(ctx2), tmp); env_define(ctx2, e, the_err_handler_symbol, err_handler); @@ -2227,15 +2224,15 @@ sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) { 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)); + offset = top + sexp_unbox_fixnum(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); + stack[top] = sexp_make_fixnum(top); top++; sexp_context_top(ctx) = top + 3; - stack[top++] = sexp_make_integer(0); + stack[top++] = sexp_make_fixnum(0); stack[top++] = final_resumer; - stack[top++] = sexp_make_integer(0); + stack[top++] = sexp_make_fixnum(0); return sexp_vm(ctx, proc); } @@ -2250,7 +2247,7 @@ sexp sexp_compile (sexp ctx, sexp x) { generate(ctx, ast); res = finalize_bytecode(ctx); vec = sexp_make_vector(ctx, 0, SEXP_VOID); - res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0), + res = sexp_make_procedure(ctx, sexp_make_fixnum(0), sexp_make_fixnum(0), res, vec); } sexp_gc_release4(ctx); @@ -2311,8 +2308,8 @@ void sexp_scheme_init (void) { ctx = sexp_make_child_context(ctx, NULL); emit(ctx, OP_DONE); final_resumer = sexp_make_procedure(ctx, - sexp_make_integer(0), - sexp_make_integer(0), + sexp_make_fixnum(0), + sexp_make_fixnum(0), finalize_bytecode(ctx), sexp_make_vector(ctx, 0, SEXP_VOID)); sexp_bytecode_name(sexp_procedure_code(final_resumer)) diff --git a/gc.c b/gc.c index bb50dd39..e9d5577e 100644 --- a/gc.c +++ b/gc.c @@ -149,7 +149,7 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { } } sum_freed_ptr[0] = sum_freed; - return sexp_make_integer(max_freed); + return sexp_make_fixnum(max_freed); } sexp sexp_gc (sexp ctx, size_t *sum_freed) { @@ -217,7 +217,7 @@ void* sexp_alloc (sexp ctx, size_t size) { size = sexp_heap_align(size); res = sexp_try_alloc(ctx, size); if (! res) { - max_freed = sexp_unbox_integer(sexp_gc(ctx, &sum_freed)); + max_freed = sexp_unbox_fixnum(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)))) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index a3a00dcb..3b0c9183 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -334,7 +334,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #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_fixnump(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)) @@ -398,18 +398,26 @@ sexp sexp_make_flonum(sexp ctx, double f); #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_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) #define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) -#define sexp_integer_to_double(x) ((double)sexp_unbox_integer(x)) +#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) + +#if USE_BIGNUMS +SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); +#define sexp_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) +#else +#define sexp_make_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_integerp sexp_fixnump +#endif #if USE_FLONUMS -#define sexp_integer_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_integer(x))) +#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) #else -#define sexp_integer_to_flonum(ctx, x) (x) +#define sexp_fixnum_to_flonum(ctx, x) (x) #endif /*************************** field accessors **************************/ @@ -417,20 +425,20 @@ sexp sexp_make_flonum(sexp ctx, double f); #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_fixnum(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_fixnum(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_variadic_p(x) (sexp_unbox_fixnum(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_string_ref(x, i) (sexp_make_character(sexp_string_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_character(v)) #define sexp_symbol_string(x) ((x)->value.symbol.string) @@ -552,10 +560,10 @@ sexp sexp_make_flonum(sexp ctx, double f); #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_div(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b))) +#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b))) #define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(int)*8 - 1))) -#define sexp_fx_neg(a) (sexp_make_integer(-(sexp_unbox_integer(a)))) +#define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a)))) #define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) #define sexp_fp_add(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) + sexp_flonum_value(b))) diff --git a/opcodes.c b/opcodes.c index fc2277b4..8f29fca7 100644 --- a/opcodes.c +++ b/opcodes.c @@ -30,8 +30,8 @@ _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, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_fixnum(0), NULL), +_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_fixnum(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), @@ -50,14 +50,14 @@ _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), _OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), _OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0), _OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_integer(SEXP_PAIR), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_integer(SEXP_STRING), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_integer(SEXP_VECTOR), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_integer(SEXP_FLONUM), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_integer(SEXP_PROCEDURE), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_integer(SEXP_OPCODE), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_integer(SEXP_IPORT), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_integer(SEXP_OPORT), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0), _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), diff --git a/opt/bignum.c b/opt/bignum.c index e4e4f8ea..4ffafa1e 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -7,7 +7,7 @@ #define sexp_negate(x) \ if (sexp_bignump(x)) \ sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ - else if (sexp_integerp(x)) \ + else if (sexp_fixnump(x)) \ x = sexp_fx_neg(x); sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { @@ -20,11 +20,23 @@ sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { sexp res = sexp_make_bignum(ctx, 1); - sexp_bignum_data(res)[0] = sexp_unbox_integer(sexp_fx_abs(a)); + sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a)); sexp_bignum_sign(res) = sexp_fx_sign(a); return res; } +sexp sexp_make_integer (sexp ctx, sexp_sint_t x) { + sexp res; + if ((SEXP_MIN_FIXNUM < x) && (x < SEXP_MAX_FIXNUM)) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + sexp_bignum_sign(res) = (x < 0 ? -1 : 1); + sexp_bignum_data(res)[0] = x * sexp_bignum_sign(res); + } + return res; +} + #define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) #define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) @@ -32,8 +44,8 @@ sexp sexp_double_to_bignum (sexp ctx, double f) { int sign; sexp_gc_var3(res, scale, tmp); sexp_gc_preserve3(ctx, res, scale, tmp); - res = sexp_fixnum_to_bignum(ctx, sexp_make_integer(0)); - scale = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); + res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0)); + scale = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); sign = (f < 0 ? -1 : 1); for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); @@ -105,7 +117,7 @@ sexp sexp_bignum_normalize (sexp a) { if ((data[0] > SEXP_MAX_FIXNUM) && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1))) return a; - return sexp_make_integer((sexp_sint_t)data[0] * sexp_bignum_sign(a)); + return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a)); } double sexp_bignum_to_double (sexp a) { @@ -226,7 +238,7 @@ sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { sexp_bignum_sign(b) = 1; i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) / lg_base + 1; - str = sexp_make_string(ctx, sexp_make_integer(str_len), + str = sexp_make_string(ctx, sexp_make_fixnum(str_len), sexp_make_character(' ')); data = sexp_string_data(str); while (! sexp_bignum_zerop(b)) @@ -247,9 +259,9 @@ sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { sexp_gc_preserve1(ctx, c); c = sexp_copy_bignum(ctx, NULL, a, 0); if (sexp_bignum_sign(c) == sexp_fx_sign(b)) - c = sexp_bignum_fxadd(ctx, c, sexp_unbox_integer(sexp_fx_abs(b))); + c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); else - c = sexp_bignum_fxsub(ctx, c, sexp_unbox_integer(sexp_fx_abs(b))); + c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); sexp_gc_release1(ctx); return c; } @@ -360,7 +372,7 @@ static sexp quot_step (sexp ctx, sexp *rem, sexp a, sexp b, sexp k, sexp i) { sexp_gc_var5(x, prod, diff, k2, i2); if (sexp_bignum_compare(k, a) > 0) { *rem = a; - return sexp_fixnum_to_bignum(ctx, sexp_make_integer(0)); + return sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0)); } sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); k2 = sexp_bignum_double(ctx, k); @@ -388,7 +400,7 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { b1 = sexp_copy_bignum(ctx, NULL, b, 0); sexp_bignum_sign(b1) = 1; k = sexp_copy_bignum(ctx, NULL, b1, 0); - i = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); + i = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); res = quot_step(ctx, rem, a1, b1, k, i); sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); if (sexp_bignum_sign(a) < 0) { @@ -414,10 +426,10 @@ sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { } sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { - sexp_sint_t e = sexp_unbox_integer(sexp_fx_abs(b)); + sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b)); sexp_gc_var2(res, acc); sexp_gc_preserve2(ctx, res, acc); - res = sexp_fixnum_to_bignum(ctx, sexp_make_integer(1)); + res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); acc = sexp_copy_bignum(ctx, NULL, a, 0); for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) if (e & 1) @@ -460,7 +472,7 @@ static int sexp_number_types[SEXP_NUM_TYPES] = static int sexp_number_type (sexp a) { return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)] - : sexp_integerp(a); + : sexp_fixnump(a); } sexp sexp_add (sexp ctx, sexp a, sexp b) { @@ -476,7 +488,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) { r = sexp_fx_add(a, b); /* XXXX check overflow */ break; case SEXP_NUM_FIX_FLO: - r = sexp_make_flonum(ctx, sexp_integer_to_double(a)+sexp_flonum_value(b)); + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b)); break; case SEXP_NUM_FIX_BIG: r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a)); @@ -509,7 +521,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { r = sexp_fx_sub(a, b); /* XXXX check overflow */ break; case SEXP_NUM_FIX_FLO: - r = sexp_make_flonum(ctx, sexp_integer_to_double(a)-sexp_flonum_value(b)); + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b)); break; case SEXP_NUM_FIX_BIG: r = sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a)); @@ -517,7 +529,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { r = sexp_bignum_normalize(r); break; case SEXP_NUM_FLO_FIX: - r = sexp_make_flonum(ctx, sexp_integer_to_double(b)+sexp_flonum_value(a)); + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)+sexp_flonum_value(a)); break; case SEXP_NUM_FLO_FLO: r = sexp_fp_sub(ctx, a, b); @@ -550,10 +562,10 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) { r = sexp_fx_mul(a, b); break; case SEXP_NUM_FIX_FLO: - r = sexp_make_flonum(ctx, sexp_integer_to_double(a)*sexp_flonum_value(b)); + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)); break; case SEXP_NUM_FIX_BIG: - r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_integer(sexp_fx_abs(a)), 0); + r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0); sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b); break; case SEXP_NUM_FLO_FLO: @@ -582,18 +594,18 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) { r = sexp_type_exception(ctx, "/: not a number", b); break; case SEXP_NUM_FIX_FIX: - f = sexp_integer_to_double(a) / sexp_integer_to_double(b); - r = ((f == trunc(f)) ? sexp_make_integer((sexp_sint_t)f) + f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b); + r = ((f == trunc(f)) ? sexp_make_fixnum((sexp_sint_t)f) : sexp_make_flonum(ctx, f)); break; case SEXP_NUM_FIX_FLO: - r = sexp_make_flonum(ctx, sexp_integer_to_double(a)/sexp_flonum_value(b)); + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_flonum_value(b)); break; case SEXP_NUM_FIX_BIG: - r = sexp_make_flonum(ctx, sexp_integer_to_double(a)/sexp_bignum_to_double(b)); + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); break; case SEXP_NUM_FLO_FIX: - r = sexp_make_flonum(ctx, sexp_integer_to_double(b)/sexp_flonum_value(a)); + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)/sexp_flonum_value(a)); break; case SEXP_NUM_FLO_FLO: r = sexp_fp_div(ctx, a, b); @@ -606,9 +618,9 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) { /* ... FALLTHROUGH ... */ case SEXP_NUM_BIG_BIG: r = sexp_bignum_quot_rem(ctx, &rem, a, b); - if (sexp_bignum_normalize(rem) != sexp_make_integer(0)) + if (sexp_bignum_normalize(rem) != sexp_make_fixnum(0)) r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) - / sexp_integer_to_double(b)); + / sexp_fixnum_to_double(b)); else r = sexp_bignum_normalize(r); break; @@ -640,7 +652,7 @@ sexp sexp_quotient (sexp ctx, sexp a, sexp b) { r = sexp_fx_div(a, b); break; case SEXP_NUM_FIX_BIG: - r = sexp_make_integer(0); + r = sexp_make_fixnum(0); break; case SEXP_NUM_BIG_FIX: b = sexp_fixnum_to_bignum(ctx, b); @@ -699,25 +711,25 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) { r = sexp_type_exception(ctx, "compare: not a number", a); break; case SEXP_NUM_FIX_FIX: - r = sexp_make_integer(sexp_unbox_integer(a) - sexp_unbox_integer(b)); + r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); break; case SEXP_NUM_FIX_FLO: - f = sexp_integer_to_double(a) - sexp_flonum_value(b); - r = sexp_make_integer(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + f = sexp_fixnum_to_double(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); break; case SEXP_NUM_FIX_BIG: - r = sexp_make_integer(-1); + r = sexp_make_fixnum(-1); break; case SEXP_NUM_FLO_FLO: f = sexp_flonum_value(a) - sexp_flonum_value(b); - r = sexp_make_integer(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); break; case SEXP_NUM_FLO_BIG: f = sexp_flonum_value(a) - sexp_bignum_to_double(b); - r = sexp_make_integer(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); break; case SEXP_NUM_BIG_BIG: - r = sexp_make_integer(sexp_bignum_compare(a, b)); + r = sexp_make_fixnum(sexp_bignum_compare(a, b)); break; } } diff --git a/sexp.c b/sexp.c index e1f9c233..946a1319 100644 --- a/sexp.c +++ b/sexp.c @@ -169,8 +169,8 @@ sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { } if (sexp_pairp(sexp_exception_source(exn))) { ls = sexp_exception_source(exn); - if (sexp_integerp(sexp_cdr(ls)) - && (sexp_cdr(ls) >= sexp_make_integer(0))) { + if (sexp_fixnump(sexp_cdr(ls)) + && (sexp_cdr(ls) >= sexp_make_fixnum(0))) { sexp_write_string(ctx, " on line ", out); sexp_write(ctx, sexp_cdr(ls), out); } @@ -218,7 +218,7 @@ static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) { sexp_gc_var3(name, str, irr); sexp_gc_preserve3(ctx, name, str, irr); name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); - name = sexp_cons(ctx, name, sexp_make_integer(sexp_port_line(port))); + name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port))); str = sexp_c_string(ctx, msg, -1); irr = ((sexp_pairp(irritants) || sexp_nullp(irritants)) ? irritants : sexp_list1(ctx, irritants)); @@ -320,7 +320,7 @@ 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); + return sexp_make_fixnum(res); } sexp sexp_equalp (sexp ctx, sexp a, sexp b) { @@ -334,17 +334,17 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) { return sexp_make_boolean((a == b) || (sexp_flonump(a) - && sexp_make_integer(sexp_flonum_value(a)) == b) + && sexp_make_fixnum(sexp_flonum_value(a)) == b) || (sexp_flonump(b) - && sexp_make_integer(sexp_flonum_value(b)) == a)); + && sexp_make_fixnum(sexp_flonum_value(b)) == a)); #else if (! sexp_pointerp(a)) - return sexp_make_boolean(sexp_integerp(a) && sexp_pointerp(b) - && (sexp_unbox_integer(a) + return sexp_make_boolean(sexp_fixnump(a) && sexp_pointerp(b) + && (sexp_unbox_fixnum(a) == sexp_flonum_value(b))); else if (! sexp_pointerp(b)) - return sexp_make_boolean(sexp_integerp(b) && sexp_pointerp(a) - && (sexp_unbox_integer(b) + return sexp_make_boolean(sexp_fixnump(b) && sexp_pointerp(a) + && (sexp_unbox_fixnum(b) == sexp_flonum_value(a))); #endif if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) @@ -395,9 +395,9 @@ sexp sexp_make_flonum(sexp ctx, double f) { #endif sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { - sexp_sint_t clen = sexp_unbox_integer(len); + sexp_sint_t clen = sexp_unbox_fixnum(len); sexp s; - if (! sexp_integerp(len)) return sexp_type_exception(ctx, "bad length", len); + if (! sexp_fixnump(len)) return sexp_type_exception(ctx, "bad length", len); 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; @@ -410,7 +410,7 @@ 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); + sexp s = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID); memcpy(sexp_string_data(s), str, len); sexp_string_data(s)[len] = '\0'; return s; @@ -420,21 +420,21 @@ 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)) + if (! sexp_fixnump(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)) + end = sexp_make_fixnum(sexp_string_length(str)); + if (! sexp_fixnump(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)) + if ((sexp_unbox_fixnum(start) < 0) + || (sexp_unbox_fixnum(start) > sexp_string_length(str)) + || (sexp_unbox_fixnum(end) < 0) + || (sexp_unbox_fixnum(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_data(str)+sexp_unbox_fixnum(start), sexp_string_length(res)); sexp_string_data(res)[sexp_string_length(res)] = '\0'; return res; @@ -449,7 +449,7 @@ sexp sexp_string_concatenate (sexp ctx, sexp str_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); + res = sexp_make_string(ctx, sexp_make_fixnum(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)); @@ -519,7 +519,7 @@ sexp sexp_string_to_symbol (sexp ctx, sexp str) { sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { sexp v, *x; - int i, clen = sexp_unbox_integer(len); + int i, clen = sexp_unbox_fixnum(len); if (! clen) return the_empty_vector; v = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), SEXP_VECTOR); @@ -557,39 +557,39 @@ sexp sexp_make_cpointer (sexp ctx, void *value) { #if SEXP_BSD -#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)) +#define sexp_stream_ctx(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(0)) +#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(1)) +#define sexp_stream_size(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(2)) +#define sexp_stream_pos(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(3)) int sstream_read (void *vec, char *dst, int n) { - sexp_uint_t len = sexp_unbox_integer(sexp_stream_size(vec)); - sexp_uint_t pos = sexp_unbox_integer(sexp_stream_pos(vec)); + sexp_uint_t len = sexp_unbox_fixnum(sexp_stream_size(vec)); + sexp_uint_t pos = sexp_unbox_fixnum(sexp_stream_pos(vec)); if (pos >= 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); + sexp_stream_pos(vec) = sexp_make_fixnum(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)); + len = sexp_unbox_fixnum(sexp_stream_size(vec)); + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)); newpos = pos+n; if (newpos >= len) { newbuf = sexp_make_string(sexp_stream_ctx(vec), - sexp_make_integer(newpos*2), + sexp_make_fixnum(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); + sexp_stream_size(vec) = sexp_make_fixnum(newpos*2); } memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); - sexp_stream_pos(vec) = sexp_make_integer(newpos); + sexp_stream_pos(vec) = sexp_make_fixnum(newpos); return n; } @@ -598,11 +598,11 @@ off_t sstream_seek (void *vec, off_t offset, int whence) { if (whence == SEEK_SET) { pos = offset; } else if (whence == SEEK_CUR) { - pos = sexp_unbox_integer(sexp_stream_pos(vec)) + offset; + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)) + offset; } else { /* SEEK_END */ - pos = sexp_unbox_integer(sexp_stream_size(vec)) + offset; + pos = sexp_unbox_fixnum(sexp_stream_size(vec)) + offset; } - sexp_stream_pos(vec) = sexp_make_integer(pos); + sexp_stream_pos(vec) = sexp_make_fixnum(pos); return pos; } @@ -611,11 +611,11 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) { sexp res; sexp_gc_var1(cookie); sexp_gc_preserve1(ctx, cookie); - cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(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); + sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str)); + sexp_stream_pos(cookie) = sexp_make_fixnum(0); in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); res = sexp_make_input_port(ctx, in, SEXP_FALSE); sexp_port_cookie(res) = cookie; @@ -628,12 +628,12 @@ sexp sexp_make_output_string_port (sexp ctx) { sexp res, size; sexp_gc_var1(cookie); sexp_gc_preserve1(ctx, cookie); - size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); - cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID); + size = sexp_make_fixnum(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(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); + sexp_stream_pos(cookie) = sexp_make_fixnum(0); out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); res = sexp_make_output_port(ctx, out, SEXP_FALSE); sexp_port_cookie(res) = cookie; @@ -646,7 +646,7 @@ sexp sexp_get_output_string (sexp ctx, sexp port) { fflush(sexp_port_stream(port)); return sexp_substring(ctx, sexp_stream_buf(cookie), - sexp_make_integer(0), + sexp_make_fixnum(0), sexp_stream_pos(cookie)); } @@ -883,8 +883,8 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { sexp_write_char(ctx, '>', out); break; } - } else if (sexp_integerp(obj)) { - sprintf(numbuf, "%ld", sexp_unbox_integer(obj)); + } else if (sexp_fixnump(obj)) { + sprintf(numbuf, "%ld", sexp_unbox_fixnum(obj)); sexp_write_string(ctx, numbuf, out); #if USE_IMMEDIATE_FLONUMS } else if (sexp_flonump(obj)) { @@ -1024,7 +1024,7 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp) { 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) + e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(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", @@ -1035,7 +1035,7 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp) { res = ((double)whole + res) * pow(10, e); if (negp) res *= -1; if ((scale == 0.1) && (exponent != SEXP_VOID) && (res == round(res))) - return sexp_make_integer(res); + return sexp_make_fixnum(res); else return sexp_make_flonum(ctx, res); } @@ -1072,11 +1072,11 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { return sexp_read_float_tail(ctx, in, res, negativep); } else if (c=='/') { den = sexp_read_number(ctx, in, base); - if (! sexp_integerp(den)) + if (! sexp_fixnump(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)); + / (double)sexp_unbox_fixnum(den)); } else { if ((c!=EOF) && ! is_separator(c)) return sexp_read_error(ctx, "invalid numeric syntax", @@ -1084,7 +1084,7 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { sexp_push_char(ctx, c, in); } - return sexp_make_integer(negativep ? -res : res); + return sexp_make_fixnum(negativep ? -res : res); } sexp sexp_read_raw (sexp ctx, sexp in) { @@ -1177,7 +1177,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } if ((line >= 0) && sexp_pairp(res)) { sexp_pair_source(res) - = sexp_cons(ctx, sexp_port_name(in), sexp_make_integer(line)); + = sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line)); } if (sexp_port_sourcep(in)) for (tmp=res; sexp_pairp(tmp); tmp=sexp_cdr(tmp)) @@ -1196,12 +1196,12 @@ sexp sexp_read_raw (sexp ctx, sexp in) { case 'e': res = sexp_read(ctx, in); if (sexp_flonump(res)) - res = sexp_make_integer((sexp_sint_t)sexp_flonum_value(res)); + res = sexp_make_fixnum((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)); + if (sexp_fixnump(res)) + res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res)); break; case 'f': case 't': @@ -1308,7 +1308,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { sexp_bignum_sign(res) = -sexp_bignum_sign(res); else #endif - res = sexp_fx_mul(res, sexp_make_integer(-1)); + res = sexp_fx_mul(res, sexp_make_fixnum(-1)); } } else { sexp_push_char(ctx, c2, in); From 44d0156c80c87d2cd5a2438d10f05b318a72a28d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 2 Nov 2009 23:52:19 +0900 Subject: [PATCH 183/535] better type checking in the VM Fixes http://code.google.com/p/chibi-scheme/issues/detail?id=5 Some non-opcode primitive functions may still need type checking. --- eval.c | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/eval.c b/eval.c index f2575de9..78a67b82 100644 --- a/eval.c +++ b/eval.c @@ -1442,6 +1442,11 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_VECTOR_REF: if (! sexp_vectorp(_ARG1)) sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); _ARG2 = sexp_vector_ref(_ARG1, _ARG2); top--; break; @@ -1450,14 +1455,30 @@ sexp sexp_vm (sexp ctx, sexp proc) { 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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); sexp_vector_set(_ARG1, _ARG2, _ARG3); _ARG3 = SEXP_VOID; top-=2; break; case OP_VECTOR_LENGTH: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); break; case OP_STRING_REF: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("string-ref: immutable string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); _ARG2 = sexp_string_ref(_ARG1, _ARG2); top--; break; @@ -1466,11 +1487,20 @@ sexp sexp_vm (sexp ctx, sexp proc) { 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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2)); + else if (! sexp_charp(_ARG3)) + sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); sexp_string_set(_ARG1, _ARG2, _ARG3); _ARG3 = SEXP_VOID; top-=2; break; case OP_STRING_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); break; case OP_MAKE_PROCEDURE: @@ -1480,6 +1510,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case OP_MAKE_VECTOR: sexp_context_top(ctx) = top; + if (! sexp_fixnump(_ARG1)) + sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); top--; break; @@ -1815,15 +1847,23 @@ sexp sexp_vm (sexp ctx, sexp proc) { } break; case OP_CHAR2INT: + if (! sexp_charp(_ARG1)) + sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); break; case OP_INT2CHAR: + if (! sexp_fixnump(_ARG1)) + sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); break; case OP_CHAR_UPCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); break; case OP_CHAR_DOWNCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); break; case OP_DISPLAY: @@ -1845,6 +1885,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case OP_WRITE_CHAR: + if (! sexp_charp(_ARG1)) + sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); _ARG2 = SEXP_VOID; top--; From c1e8606c01f03ffc1fb8e00dfceff8c00ed9d5cd Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 3 Nov 2009 01:04:53 +0900 Subject: [PATCH 184/535] forgot to push config file --- config.scm | 139 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 139 insertions(+) create mode 100644 config.scm diff --git a/config.scm b/config.scm new file mode 100644 index 00000000..a62e3e4e --- /dev/null +++ b/config.scm @@ -0,0 +1,139 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *modules* '()) +(define *this-module* '()) +(define *load-path* (list "./lib" *module-directory*)) + +(define (make-module exports env meta) (vector exports env meta)) +(define (module-exports mod) (vector-ref mod 0)) +(define (module-env mod) (vector-ref mod 1)) +(define (module-meta-data mod) (vector-ref mod 2)) +(define (module-env-set! mod env) (vector-set! mod 1 env)) + +(define (find-module-file name file) + (let lp ((ls *load-path*)) + (and (pair? ls) + (let ((path (string-append (car ls) "/" file))) + (if (file-exists? path) path (lp (cdr ls))))))) + +(define (module-name->strings ls res) + (if (null? ls) + res + (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls))) + ((number? (car ls)) (number->string (car ls))) + ((string? (car ls)) (car ls)) + (else (error "invalid module name" (car ls)))))) + (module-name->strings (cdr ls) (cons "/" (cons str res)))))) + +(define (module-name->file name) + (string-concatenate + (reverse (cons ".module" (cdr (module-name->strings name '())))))) + +(define (load-module-definition name) + (let* ((file (module-name->file name)) + (path (find-module-file name file))) + (if path (%load path *config-env*)))) + +(define (find-module name) + (cond + ((assoc name *modules*) => cdr) + (else + (load-module-definition name) + (cond ((assoc name *modules*) => cdr) + (else #f))))) + +(define (eval-module name mod) + (let ((env (make-environment))) + (for-each + (lambda (x) + (case (and (pair? x) (car x)) + ((import) + (let ((mod2 (load-module (cadr x)))) + (%env-copy! env (module-env mod2) (module-exports mod2)))) + ((include) + (for-each (lambda (f) (%load (find-module-file name f) env)) (cdr x))) + ((body) + (for-each (lambda (expr) (eval expr env)) (cdr x))))) + (module-meta-data mod)) + env)) + +(define (load-module name) + (let ((mod (find-module name))) + (if (and mod (not (module-env mod))) + (module-env-set! mod (eval-module name mod))) + mod)) + +(define-syntax define-module + (rsc-macro-transformer + (lambda (expr env) + (let ((name (cadr expr)) + (body (cddr expr))) + `(let ((tmp *this-module*)) + (set! *this-module* '()) + ,@body + (set! *this-module* (reverse *this-module*)) + (let ((exports + (cond ((assq 'export *this-module*) => cdr) + (else '())))) + (set! *modules* + (cons (cons ',name (make-module exports #f *this-module*)) + *modules*))) + (set! *this-module* tmp)))))) + +(define-syntax define-config-primitive + (rsc-macro-transformer + (lambda (expr env) + `(define-syntax ,(cadr expr) + (er-macro-transformer + (lambda (expr rename compare) + `(set! *this-module* (cons ',expr *this-module*)))))))) + +(define-config-primitive import) +(define-config-primitive export) +(define-config-primitive include) +(define-config-primitive body) + +(let ((exports + '(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 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 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 + error file-exists? string-concatenate + open-input-string open-output-string get-output-string + sc-macro-transformer rsc-macro-transformer er-macro-transformer + identifier? identifier=? identifier->symbol make-syntactic-closure + ))) + (set! *modules* + (list (cons '(scheme) (make-module exports + (interaction-environment) + (list (cons 'export exports))))))) + From 99dd2b98e1a362a1b12695f85e1ea9dfc58d479e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 3 Nov 2009 01:05:22 +0900 Subject: [PATCH 185/535] reporting better error for unmatched syntax-rules patterns --- init.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/init.scm b/init.scm index a3b0030e..f286a48f 100644 --- a/init.scm +++ b/init.scm @@ -564,6 +564,7 @@ (_append (rename 'append)) (_map (rename 'map)) (_vector? (rename 'vector?)) (_list? (rename 'list?)) (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_error (rename 'error)) (_vector->list (rename 'vector->list)) (_list->vector (rename 'list->vector))) (define (next-v) @@ -718,7 +719,7 @@ (map (lambda (clause) (expand-pattern (car clause) (cadr clause))) forms) - (list (list 'error "no expansion")))))))))) + (list (list _error "no expansion for" _expr)))))))))) (define *config-env* #f) From eafd40c193cfbb27686a721a088fb681813c4de1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 3 Nov 2009 01:44:36 +0900 Subject: [PATCH 186/535] adding some handy syntax modules --- lib/srfi/11.module | 28 ++++++++++++++++++++++++++++ lib/srfi/16.module | 24 ++++++++++++++++++++++++ lib/srfi/2.module | 16 ++++++++++++++++ lib/srfi/26.module | 24 ++++++++++++++++++++++++ lib/srfi/6.module | 5 +++++ lib/srfi/8.module | 10 ++++++++++ 6 files changed, 107 insertions(+) create mode 100644 lib/srfi/11.module create mode 100644 lib/srfi/16.module create mode 100644 lib/srfi/2.module create mode 100644 lib/srfi/26.module create mode 100644 lib/srfi/6.module create mode 100644 lib/srfi/8.module diff --git a/lib/srfi/11.module b/lib/srfi/11.module new file mode 100644 index 00000000..386443a2 --- /dev/null +++ b/lib/srfi/11.module @@ -0,0 +1,28 @@ + +(define-module (srfi 11) + (export let-values let*-values) + (import (scheme)) + (body + (define-syntax let*-values + (syntax-rules () + ((let*-values () . body) + (begin . body)) + ((let*-values (((a) expr) . rest) . body) + (let ((a expr)) (let*-values rest . body))) + ((let*-values ((params expr) . rest) . body) + (call-with-values (lambda () expr) + (lambda params (let*-values rest . body)))))) + (define-syntax let-values + (syntax-rules () + ((let-values ("step") (binds ...) bind expr maps () () . body) + (let*-values (binds ... (bind expr)) (let maps . body))) + ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body) + (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body) + (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body) + (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body)) + ((let-values ((params expr) . rest) . body) + (let-values ("step") () () expr () params rest . body)) + )))) + diff --git a/lib/srfi/16.module b/lib/srfi/16.module new file mode 100644 index 00000000..61837146 --- /dev/null +++ b/lib/srfi/16.module @@ -0,0 +1,24 @@ + +(define-module (srfi 16) + (export case-lambda) + (import (scheme)) + (body + (define-syntax %case + (syntax-rules () + ((%case args len n p ((params ...) . body) . rest) + (if (= len (length '(params ...))) + (apply (lambda (params ...) . body) args) + (%case args len 0 () . rest))) + ((%case args len n (p ...) ((x . y) . body) . rest) + (%case args len (+ n 1) (p ... x) (y . body) . rest)) + ((%case args len n (p ...) (y . body) . rest) + (if (>= len n) + (apply (lambda (p ... y) . body) args) + (%case args len 0 () . rest))) + ((%case args len n p) + (error "case-lambda: no cases matched")))) + (define-syntax case-lambda + (syntax-rules () + ((case-lambda . clauses) + (lambda args (let ((len (length args))) (%case args len 0 () . clauses)))))))) + diff --git a/lib/srfi/2.module b/lib/srfi/2.module new file mode 100644 index 00000000..b7addf06 --- /dev/null +++ b/lib/srfi/2.module @@ -0,0 +1,16 @@ + +(define-module (srfi 2) + (export and-let*) + (import (scheme)) + (body + (define-syntax and-let* + (syntax-rules () + ((and-let* () . body) + (begin . body)) + ((and-let* ((var expr) . rest) . body) + (let ((var expr)) + (and var (and-let* rest . body)))) + ((and-let* ((expr) . rest) . body) + (let ((tmp expr)) + (and tmp (and-let* rest . body)))))))) + diff --git a/lib/srfi/26.module b/lib/srfi/26.module new file mode 100644 index 00000000..9ed9aeee --- /dev/null +++ b/lib/srfi/26.module @@ -0,0 +1,24 @@ + +(define-module (srfi 26) + (export cut cute) + (import (scheme)) + (body + (define-syntax %cut + (syntax-rules (<> <...>) + ((%cut e? params args) + (lambda params args)) + ((%cut e? (params ...) (args ...) <> . rest) + (%cut e? (params ... tmp) (args ... tmp) . rest)) + ((%cut e? (params ...) (args ...) <...>) + (%cut e? (params ... . tmp) (apply args ... tmp))) + ((%cut e? (params ...) (args ...) <...> . rest) + (error "cut: non-terminal <...>")) + ((%cut #t (params ...) (args ...) x . rest) + (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest))) + ((%cut #f (params ...) (args ...) x . rest) + (%cut #t (params ...) (args ... x) . rest)))) + (define-syntax cut + (syntax-rules () ((cut args ...) (%cut #f () () args ...)))) + (define-syntax cute + (syntax-rules () ((cute args ...) (%cut #t () () args ...)))))) + diff --git a/lib/srfi/6.module b/lib/srfi/6.module new file mode 100644 index 00000000..bbabf209 --- /dev/null +++ b/lib/srfi/6.module @@ -0,0 +1,5 @@ + +(define-module (srfi 6) + (export open-input-string open-output-string get-output-string) + (import (scheme))) + diff --git a/lib/srfi/8.module b/lib/srfi/8.module new file mode 100644 index 00000000..ebe02df7 --- /dev/null +++ b/lib/srfi/8.module @@ -0,0 +1,10 @@ + +(define-module (srfi 8) + (export receive) + (import (scheme)) + (body + (define-syntax receive + (syntax-rules () + ((receive params expr . body) + (call-with-values (lambda () expr) (lambda params . body))))))) + From 520c6603472b888390212238b732972495e9695d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 3 Nov 2009 12:54:06 +0900 Subject: [PATCH 187/535] installing config file, fixing installed module search path --- Makefile | 7 ++++--- config.scm | 2 +- eval.c | 2 ++ 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 001e90c5..ffbd1fa7 100644 --- a/Makefile +++ b/Makefile @@ -110,12 +110,13 @@ install: chibi-scheme$(EXE) mkdir -p $(DESTDIR)$(BINDIR) cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ mkdir -p $(DESTDIR)$(MODDIR) - cp init.scm $(DESTDIR)$(MODDIR)/ + cp init.scm config.scm $(DESTDIR)$(MODDIR)/ + cp -r lib/ $(DESTDIR)$(MODDIR)/ mkdir -p $(DESTDIR)$(INCDIR) cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ mkdir -p $(DESTDIR)$(LIBDIR) cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ - -cp libchibi-scheme$(SO).a $(DESTDIR)$(LIBDIR)/ + -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi uninstall: @@ -123,7 +124,7 @@ uninstall: 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 + rm -rf $(MODDIR) dist: cleaner rm -f chibi-scheme-`cat VERSION`.tgz diff --git a/config.scm b/config.scm index a62e3e4e..8bd17f2f 100644 --- a/config.scm +++ b/config.scm @@ -4,7 +4,7 @@ (define *modules* '()) (define *this-module* '()) -(define *load-path* (list "./lib" *module-directory*)) +(define *load-path* (list "./lib" (string-append *module-directory* "/lib"))) (define (make-module exports env meta) (vector exports env meta)) (define (module-exports mod) (vector-ref mod 0)) diff --git a/eval.c b/eval.c index 78a67b82..86ab276f 100644 --- a/eval.c +++ b/eval.c @@ -110,6 +110,7 @@ static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { return e; } +#if 0 static sexp sexp_chain_env (sexp ctx, sexp env1, sexp env2) { sexp_gc_var1(res); sexp_gc_preserve1(ctx, res); @@ -123,6 +124,7 @@ static sexp sexp_chain_env (sexp ctx, sexp env1, sexp env2) { sexp_gc_release1(ctx); return res; } +#endif static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { sexp_gc_var1(res); From 6afc9f964d7e87a0c3636241fcc5bbd03e5f7b13 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 3 Nov 2009 12:57:38 +0900 Subject: [PATCH 188/535] stripping syntactic-closures in syntax-rules error messages --- init.scm | 3 ++- opcodes.c | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/init.scm b/init.scm index f286a48f..4e971d9f 100644 --- a/init.scm +++ b/init.scm @@ -719,7 +719,8 @@ (map (lambda (clause) (expand-pattern (car clause) (cadr clause))) forms) - (list (list _error "no expansion for" _expr)))))))))) + (list (list _error "no expansion for" + (list (rename 'strip-syntactic-closures) _expr))))))))))) (define *config-env* #f) diff --git a/opcodes.c b/opcodes.c index 8f29fca7..55c859bd 100644 --- a/opcodes.c +++ b/opcodes.c @@ -101,6 +101,7 @@ _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), +_FN1(0, "strip-syntactic-closures", 0, sexp_strip_synclos), _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), From 9c128c49fa91998fc0b650c9c5904a3cd3be22f0 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 5 Nov 2009 06:54:52 +0900 Subject: [PATCH 189/535] removing unintended immutability check from OP_STRING_REF --- eval.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/eval.c b/eval.c index 86ab276f..04124004 100644 --- a/eval.c +++ b/eval.c @@ -1474,8 +1474,6 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_STRING_REF: if (! sexp_stringp(_ARG1)) sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); - else if (sexp_immutablep(_ARG1)) - sexp_raise("string-ref: immutable string", sexp_list1(ctx, _ARG1)); else if (! sexp_fixnump(_ARG2)) sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); i = sexp_unbox_fixnum(_ARG2); From 58a6724deab0c2d010e7a37031dde2b671e96e0a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 5 Nov 2009 18:54:25 +0900 Subject: [PATCH 190/535] setting correct top in sexp_apply --- eval.c | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/eval.c b/eval.c index 04124004..463b2cde 100644 --- a/eval.c +++ b/eval.c @@ -2264,18 +2264,20 @@ sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) { /************************** eval interface ****************************/ 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_fixnum(sexp_length(ctx, args)); + sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx), len, offset; + len = sexp_unbox_fixnum(sexp_length(ctx, args)); + offset = top + len; for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) stack[--offset] = sexp_car(ls); - stack[top] = sexp_make_fixnum(top); + stack[top] = sexp_make_fixnum(len); top++; sexp_context_top(ctx) = top + 3; stack[top++] = sexp_make_fixnum(0); stack[top++] = final_resumer; stack[top++] = sexp_make_fixnum(0); - return sexp_vm(ctx, proc); + res = sexp_vm(ctx, proc); + return res; } sexp sexp_compile (sexp ctx, sexp x) { From 1cdd7edfa5caddf7cbff09db8be4310bd714131b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 5 Nov 2009 20:41:01 +0900 Subject: [PATCH 191/535] adding support for dynamic loading shared libraries load now recognizes ".so" files and loads them with dlopen, then calls sexp_init_library(ctx, env) from that library. --- Makefile | 11 +++++++++-- eval.c | 41 +++++++++++++++++++++++++++++++++-------- include/chibi/config.h | 11 +++++++++++ include/chibi/sexp.h | 7 +++++++ main.c | 28 ++++++++++++---------------- 5 files changed, 72 insertions(+), 26 deletions(-) diff --git a/Makefile b/Makefile index ffbd1fa7..05579c84 100644 --- a/Makefile +++ b/Makefile @@ -9,6 +9,7 @@ LIBDIR ?= $(PREFIX)/lib SOLIBDIR ?= $(PREFIX)/lib INCDIR ?= $(PREFIX)/include/chibi MODDIR ?= $(PREFIX)/share/chibi +LIBDIR ?= $(PREFIX)/lib/chibi DESTDIR ?= @@ -49,7 +50,7 @@ endif all: chibi-scheme$(EXE) -ifdef USE_BOEHM +ifeq ($(USE_BOEHM),1) GCLDFLAGS := -lgc XCPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1 else @@ -57,13 +58,19 @@ GCLDFLAGS := XCPPFLAGS := $(CPPFLAGS) -Iinclude endif +ifeq ($(USE_DL),0) XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -DUSE_DL=0 -g3 $(CFLAGS) +else +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -ldl -lm XCFLAGS := -Wall -g3 $(CFLAGS) +endif INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h include/chibi/install.h: Makefile - echo '#define sexp_module_dir "'$(MODDIR)'"' > $@ + echo '#define sexp_so_extension "'$(SO)'"' > $@ + echo '#define sexp_module_dir "'$(MODDIR)'"' >> $@ sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< diff --git a/eval.c b/eval.c index 463b2cde..98f44e26 100644 --- a/eval.c +++ b/eval.c @@ -1999,9 +1999,31 @@ void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) { } } +#if USE_DL +sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); + if (! handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = dlsym(handle, "sexp_init_library"); + if (! init) { + dlclose(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx, env); +} +#endif + sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp tmp, out; sexp_gc_var4(ctx2, x, in, res); +#if USE_DL + char *suffix = sexp_string_data(source) + + sexp_string_length(source) - strlen(sexp_so_extension); + if (strcmp(suffix, sexp_so_extension) == 0) { + res = sexp_load_dl(ctx, source, env); + } else { +#endif sexp_gc_preserve4(ctx, ctx2, x, in, res); res = SEXP_VOID; in = sexp_open_input_file(ctx, source); @@ -2027,12 +2049,15 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { 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_release4(ctx); +#if USE_DL + } +#endif +#if USE_WARN_UNDEFS + if (sexp_oportp(out) && ! sexp_exceptionp(res)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out); +#endif return res; } @@ -2272,17 +2297,17 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { stack[--offset] = sexp_car(ls); stack[top] = sexp_make_fixnum(len); top++; - sexp_context_top(ctx) = top + 3; stack[top++] = sexp_make_fixnum(0); stack[top++] = final_resumer; stack[top++] = sexp_make_fixnum(0); + sexp_context_top(ctx) = top; res = sexp_vm(ctx, proc); return res; } sexp sexp_compile (sexp ctx, sexp x) { - sexp_gc_var4(ast, ctx2, vec, res); - sexp_gc_preserve4(ctx, ast, ctx2, vec, res); + sexp_gc_var3(ast, vec, res); + sexp_gc_preserve3(ctx, ast, vec, res); ast = analyze(ctx, x); if (sexp_exceptionp(ast)) { res = ast; @@ -2294,7 +2319,7 @@ sexp sexp_compile (sexp ctx, sexp x) { res = sexp_make_procedure(ctx, sexp_make_fixnum(0), sexp_make_fixnum(0), res, vec); } - sexp_gc_release4(ctx); + sexp_gc_release3(ctx); return res; } diff --git a/include/chibi/config.h b/include/chibi/config.h index 834c3ea2..7436a2c0 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -5,6 +5,9 @@ /* uncomment this to disable the module system */ /* #define USE_MODULES 0 */ +/* uncomment this to disable dynamic loading */ +/* #define USE_DL 0 */ + /* uncomment this to use the Boehm conservative GC */ /* #define USE_BOEHM 1 */ @@ -67,6 +70,14 @@ #define USE_MODULES 1 #endif +#ifndef USE_DL +#ifdef PLAN9 +#define USE_DL 0 +#else +#define USE_DL 1 +#endif +#endif + #ifndef USE_BOEHM #define USE_BOEHM 0 #endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 3b0c9183..001217a5 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -11,6 +11,10 @@ #include #include +#if USE_DL +#include +#endif + #ifdef PLAN9 #include #include @@ -555,6 +559,9 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_bignum_length(x) ((x)->value.bignum.length) #define sexp_bignum_data(x) ((x)->value.bignum.data) +#define sexp_dllib_file(x) ((x)->value.dllib.file) +#define sexp_dllib_handle(x) ((x)->value.dllib.handle) + /****************************** arithmetic ****************************/ #define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) diff --git a/main.c b/main.c index 7f05c55e..7ded21c5 100644 --- a/main.c +++ b/main.c @@ -50,10 +50,8 @@ sexp find_module_file (sexp ctx, char *file) { sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { sexp res = SEXP_VOID; - sexp_gc_var(ctx, path, s_path); - sexp_gc_var(ctx, irr, s_irr); - sexp_gc_preserve(ctx, path, s_path); - sexp_gc_preserve(ctx, irr, s_irr); + sexp_gc_var2(path, irr); + sexp_gc_preserve2(ctx, path, irr); path = find_module_file(ctx, file); if (! sexp_stringp(path)) { path = sexp_c_string(ctx, chibi_module_dir, -1); @@ -67,32 +65,32 @@ sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { } else { res = sexp_load(ctx, path, env); } - sexp_gc_release(ctx, path, s_path); + sexp_gc_release2(ctx); return res; } sexp sexp_init_environments (sexp ctx) { sexp res, env; - sexp_gc_var(ctx, confenv, s_confenv); + sexp_gc_var1(confenv); env = sexp_context_env(ctx); res = sexp_load_module_file(ctx, sexp_init_file, env); if (! sexp_exceptionp(res)) { res = SEXP_UNDEF; - sexp_gc_preserve(ctx, confenv, s_confenv); + sexp_gc_preserve1(ctx, confenv); confenv = sexp_make_env(ctx); sexp_env_copy(ctx, confenv, env, SEXP_FALSE); sexp_load_module_file(ctx, sexp_config_file, confenv); env_define(ctx, env, sexp_intern(ctx, "*config-env*"), confenv); env_define(ctx, confenv, sexp_intern(ctx, "*config-env*"), confenv); - sexp_gc_release(ctx, confenv, s_confenv); + sexp_gc_release1(ctx); } 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); + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); env = sexp_context_env(ctx); sexp_context_tracep(ctx) = 1; in = sexp_eval_string(ctx, "(current-input-port)", env); @@ -120,18 +118,16 @@ void repl (sexp ctx) { } } } - sexp_gc_release(ctx, obj, s_obj); + sexp_gc_release1(ctx); } void run_main (int argc, char **argv) { sexp env, out=NULL, res=SEXP_VOID, ctx; sexp_uint_t i, quit=0, init_loaded=0; - sexp_gc_var(ctx, str, s_str); - sexp_gc_var(ctx, confenv, s_confenv); + sexp_gc_var1(str); ctx = sexp_make_context(NULL, NULL, NULL); - sexp_gc_preserve(ctx, str, s_str); - sexp_gc_preserve(ctx, confenv, s_confenv); + sexp_gc_preserve1(ctx, str); env = sexp_context_env(ctx); out = sexp_eval_string(ctx, "(current-output-port)", env); @@ -185,7 +181,7 @@ void run_main (int argc, char **argv) { repl(ctx); } - sexp_gc_release(ctx, str, s_str); + sexp_gc_release1(ctx); } int main (int argc, char **argv) { From f9b50ba909c72c6346c19f2ac8d51863410c9601 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 5 Nov 2009 20:51:35 +0900 Subject: [PATCH 192/535] renaming env_define to sexp_env_define since it's a public API --- eval.c | 92 ++++++++++++++++++++++---------------------- include/chibi/eval.h | 2 +- main.c | 4 +- 3 files changed, 48 insertions(+), 50 deletions(-) diff --git a/eval.c b/eval.c index 98f44e26..95fa12c8 100644 --- a/eval.c +++ b/eval.c @@ -13,7 +13,7 @@ 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_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),the_cur_out_symbol,SEXP_FALSE) #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 @@ -29,7 +29,7 @@ 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); -static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { +static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) { sexp exn; sexp_gc_var2(irritants, msg); sexp_gc_preserve2(ctx, irritants, msg); @@ -44,7 +44,7 @@ static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { /********************** environment utilities ***************************/ -static sexp env_cell(sexp e, sexp key) { +static sexp sexp_env_cell (sexp e, sexp key) { sexp ls; do { @@ -57,9 +57,9 @@ static sexp env_cell(sexp e, sexp key) { return NULL; } -static sexp env_cell_create(sexp ctx, sexp e, sexp key, sexp value) { +static sexp sexp_env_cell_create (sexp ctx, sexp e, sexp key, sexp value) { sexp_gc_var1(cell); - cell = env_cell(e, key); + cell = sexp_env_cell(e, key); if (! cell) { sexp_gc_preserve1(ctx, cell); cell = sexp_cons(ctx, key, value); @@ -71,15 +71,15 @@ static sexp env_cell_create(sexp ctx, sexp e, sexp key, sexp value) { return cell; } -static sexp env_global_ref(sexp e, sexp key, sexp dflt) { +static sexp 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); + cell = sexp_env_cell(e, key); return (cell ? sexp_cdr(cell) : dflt); } -void env_define(sexp ctx, sexp e, sexp key, sexp value) { +void sexp_env_define (sexp ctx, sexp e, sexp key, sexp value) { sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e)); sexp_gc_var1(tmp); if (sexp_immutablep(e)) { @@ -96,7 +96,7 @@ void env_define(sexp ctx, sexp e, sexp key, sexp value) { } } -static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { +static sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { sexp_gc_var2(e, tmp); sexp_gc_preserve2(ctx, e, tmp); e = sexp_alloc_type(ctx, env, SEXP_ENV); @@ -364,10 +364,10 @@ static sexp sexp_identifier_eq(sexp ctx, sexp e1, sexp id1, sexp e2, sexp id2) { e2 = sexp_synclo_env(id2); id2 = sexp_synclo_expr(id2); } - cell = env_cell(e1, id1); + cell = sexp_env_cell(e1, id1); if (cell && sexp_lambdap(sexp_cdr(cell))) lam1 = sexp_cdr(cell); - cell = env_cell(e2, id2); + cell = sexp_env_cell(e2, id2); if (cell && sexp_lambdap(sexp_cdr(cell))) lam2 = sexp_cdr(cell); return sexp_make_boolean((id1 == id2) && (lam1 == lam2)); @@ -415,14 +415,14 @@ static sexp analyze_var_ref (sexp ctx, sexp x) { sexp env = sexp_context_env(ctx), res; sexp_gc_var1(cell); sexp_gc_preserve1(ctx, cell); - cell = env_cell(env, x); + cell = sexp_env_cell(env, x); if (! cell) { if (sexp_synclop(x)) { if (sexp_truep(sexp_memq(ctx, x, sexp_context_fv(ctx)))) env = sexp_synclo_env(x); x = sexp_synclo_expr(x); } - cell = env_cell_create(ctx, env, x, SEXP_UNDEF); + cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF); } if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) res = sexp_compile_error(ctx, "invalid use of syntax as value", x); @@ -473,7 +473,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { res = sexp_make_lambda(ctx, sexp_cadr(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_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); sexp_env_lambda(sexp_context_env(ctx2)) = res; body = analyze_seq(ctx2, sexp_cddr(x)); if (sexp_exceptionp(body)) sexp_return(res, body); @@ -545,7 +545,7 @@ static sexp analyze_define (sexp ctx, sexp x) { res = SEXP_VOID; } else { if (sexp_synclop(name)) name = sexp_synclo_expr(name); - env_cell_create(ctx, env, name, SEXP_VOID); + sexp_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); @@ -646,10 +646,10 @@ static sexp analyze (sexp ctx, sexp object) { 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)); + cell = sexp_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))); + cell = sexp_env_cell(sexp_synclo_env(sexp_car(x)), + sexp_synclo_expr(sexp_car(x))); if (! cell) { res = analyze_app(ctx, x); } else { @@ -1132,10 +1132,10 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { 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); + env = sexp_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))); + ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(env, sexp_car(ls))); sexp_push(ctx2, refs, ref); } refs = sexp_reverse(ctx2, refs); @@ -1212,7 +1212,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { #ifdef DEBUG_VM if (sexp_context_tracep(ctx)) { sexp_print_stack(ctx, stack, top, fp, - env_global_ref(env, the_cur_err_symbol, SEXP_FALSE)); + sexp_env_global_ref(env, the_cur_err_symbol, SEXP_FALSE)); fprintf(stderr, "%s\n", (*ip<=OP_NUM_OPCODES) ? reverse_opcode_names[*ip] : "UNKNOWN"); } @@ -1227,7 +1227,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { stack[top+2] = self; stack[top+3] = sexp_make_fixnum(fp); top += 4; - self = env_global_ref(env, the_err_handler_symbol, SEXP_FALSE); + self = sexp_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); @@ -2027,16 +2027,14 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp_gc_preserve4(ctx, ctx2, x, in, res); res = SEXP_VOID; in = sexp_open_input_file(ctx, source); - out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); + out = sexp_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)) { if (! sexp_oportp(out)) - out = env_global_ref(sexp_context_env(ctx), - the_cur_err_symbol, - SEXP_FALSE); + out = sexp_env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE); sexp_print_exception(ctx, in, out); res = in; } else { @@ -2210,8 +2208,8 @@ static sexp sexp_make_null_env (sexp ctx, sexp version) { sexp_uint_t i; sexp e = sexp_make_env(ctx); 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])), - sexp_copy_core(ctx, &core_forms[i])); + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i])), + sexp_copy_core(ctx, &core_forms[i])); return e; } @@ -2225,24 +2223,24 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { op = sexp_copy_opcode(ctx, &opcodes[i]); if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { sym = sexp_intern(ctx, (char*)sexp_opcode_data(op)); - cell = env_cell_create(ctx, e, sym, SEXP_VOID); + cell = sexp_env_cell_create(ctx, e, sym, SEXP_VOID); sexp_opcode_data(op) = cell; } - env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); + sexp_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, - sexp_make_output_port(ctx, stdout, SEXP_FALSE)); - 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); - env_define(ctx, e, sexp_intern(ctx, "*module-directory*"), - sexp_c_string(ctx, sexp_module_dir, -1)); + sexp_env_define(ctx, e, the_cur_in_symbol, + sexp_make_input_port(ctx, stdin, SEXP_FALSE)); + sexp_env_define(ctx, e, the_cur_out_symbol, + sexp_make_output_port(ctx, stdout, SEXP_FALSE)); + sexp_env_define(ctx, e, the_cur_err_symbol, + sexp_make_output_port(ctx, stderr, SEXP_FALSE)); + sexp_env_define(ctx, e, the_interaction_env_symbol, e); + sexp_env_define(ctx, e, sexp_intern(ctx, "*module-directory*"), + sexp_c_string(ctx, sexp_module_dir, -1)); /* add default exception handler */ - err_cell = env_cell(e, the_cur_err_symbol); - perr_cell = env_cell(e, sexp_intern(ctx, "print-exception")); + err_cell = sexp_env_cell(e, the_cur_err_symbol); + perr_cell = sexp_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))) { @@ -2261,7 +2259,7 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_make_fixnum(0), finalize_bytecode(ctx2), tmp); - env_define(ctx2, e, the_err_handler_symbol, err_handler); + sexp_env_define(ctx2, e, the_err_handler_symbol, err_handler); sexp_gc_release4(ctx); return e; } @@ -2272,7 +2270,7 @@ sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) { if (! sexp_envp(from)) from = sexp_context_env(ctx); if (sexp_not(ls)) { for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls)) - env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls)); + sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls)); } else { for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { if (sexp_pairp(sexp_car(ls))) { @@ -2280,7 +2278,7 @@ sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) { } else { newname = oldname = sexp_car(ls); } - env_define(ctx, to, newname, env_global_ref(from, oldname, SEXP_FALSE)); + sexp_env_define(ctx, to, newname, sexp_env_global_ref(from, oldname, SEXP_FALSE)); } } return SEXP_VOID; @@ -2332,9 +2330,9 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) { thunk = sexp_compile(ctx2, obj); if (sexp_exceptionp(thunk)) { sexp_print_exception(ctx2, thunk, - env_global_ref(sexp_context_env(ctx2), - the_cur_err_symbol, - SEXP_FALSE)); + sexp_env_global_ref(sexp_context_env(ctx2), + the_cur_err_symbol, + SEXP_FALSE)); res = thunk; } else { res = sexp_apply(ctx2, thunk, SEXP_NULL); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 8eb003d6..2bdd81ff 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -127,7 +127,7 @@ SEXP_API sexp sexp_eval_string(sexp context, char *str, sexp env); SEXP_API sexp sexp_load(sexp context, sexp expr, sexp env); SEXP_API sexp sexp_make_env(sexp context); SEXP_API sexp sexp_env_copy(sexp context, sexp to, sexp from, sexp ls); -SEXP_API void env_define(sexp context, sexp env, sexp sym, sexp val); +SEXP_API void sexp_env_define(sexp context, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_make_context(sexp context, sexp stack, sexp env); SEXP_API void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out); diff --git a/main.c b/main.c index 7ded21c5..f6b448a2 100644 --- a/main.c +++ b/main.c @@ -80,8 +80,8 @@ sexp sexp_init_environments (sexp ctx) { confenv = sexp_make_env(ctx); sexp_env_copy(ctx, confenv, env, SEXP_FALSE); sexp_load_module_file(ctx, sexp_config_file, confenv); - env_define(ctx, env, sexp_intern(ctx, "*config-env*"), confenv); - env_define(ctx, confenv, sexp_intern(ctx, "*config-env*"), confenv); + sexp_env_define(ctx, env, sexp_intern(ctx, "*config-env*"), confenv); + sexp_env_define(ctx, confenv, sexp_intern(ctx, "*config-env*"), confenv); sexp_gc_release1(ctx); } return res; From f53e4df20869321c98454cd2cf25bdcbe637fa9b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 10 Nov 2009 21:50:59 +0900 Subject: [PATCH 193/535] adding support for runtime definition of new types --- TODO | 2 +- config.scm | 2 + debug.c | 8 ++- eval.c | 137 ++++++++++++++++++++++++++++++++++++----- gc.c | 2 +- include/chibi/config.h | 11 ++++ include/chibi/eval.h | 14 ++++- include/chibi/sexp.h | 26 ++++++-- init.scm | 5 +- main.c | 10 +-- opcodes.c | 15 +++-- opt/bignum.c | 7 +-- sexp.c | 68 ++++++++++++++++++-- tests/r5rs-tests.scm | 2 + 14 files changed, 267 insertions(+), 42 deletions(-) diff --git a/TODO b/TODO index 790de726..8caf9b8e 100644 --- a/TODO +++ b/TODO @@ -26,7 +26,7 @@ **- only/except/rename modifiers **- scheme-complete.el support *= ffi -**- libdl interface +**+ libdl interface **- opcode generation interface **- stub generator *= cleanup diff --git a/config.scm b/config.scm index 8bd17f2f..ebf744db 100644 --- a/config.scm +++ b/config.scm @@ -131,6 +131,8 @@ open-input-string open-output-string get-output-string sc-macro-transformer rsc-macro-transformer er-macro-transformer identifier? identifier=? identifier->symbol make-syntactic-closure + register-simple-type make-constructor make-type-predicate + make-getter make-setter ))) (set! *modules* (list (cons '(scheme) (make-module exports diff --git a/debug.c b/debug.c index 74c4774e..31a351df 100644 --- a/debug.c +++ b/debug.c @@ -11,7 +11,8 @@ static const char* reverse_opcode_names[] = "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", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", + "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE", "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", @@ -47,6 +48,11 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); ip += sizeof(sexp); break; + case OP_SLOT_REF: + case OP_SLOT_SET: + case OP_MAKE: + ip += sizeof(sexp)*2; + break; case OP_GLOBAL_REF: case OP_GLOBAL_KNOWN_REF: case OP_TAIL_CALL: diff --git a/eval.c b/eval.c index 95fa12c8..6bb2c927 100644 --- a/eval.c +++ b/eval.c @@ -286,6 +286,14 @@ sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { sexp_gc_var1(res); if (ctx) sexp_gc_preserve1(ctx, res); res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); + sexp_context_parent(res) = ctx; + sexp_context_lambda(res) = SEXP_FALSE; + sexp_context_fv(res) = SEXP_NULL; + sexp_context_saves(res) = 0; + sexp_context_depth(res) = 0; + sexp_context_pos(res) = 0; + sexp_context_tailp(res) = 1; + sexp_context_tracep(res) = 0; if ((! stack) || (stack == SEXP_FALSE)) { stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK); sexp_stack_length(stack) = INIT_STACK_SIZE; @@ -300,15 +308,6 @@ 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) = ctx; - sexp_context_lambda(res) = SEXP_FALSE; - sexp_context_fv(res) = SEXP_NULL; - sexp_context_saves(res) = 0; - sexp_context_depth(res) = 0; - sexp_context_pos(res) = 0; - sexp_context_top(res) = 0; - sexp_context_tailp(res) = 1; - sexp_context_tracep(res) = 0; if (ctx) sexp_gc_release1(ctx); return res; } @@ -913,9 +912,16 @@ static void generate_opcode_app (sexp ctx, sexp app) { emit_word(ctx, (sexp_uint_t)op); break; case OPC_TYPE_PREDICATE: + case OPC_ACCESSOR: + case OPC_CONSTRUCTOR: emit(ctx, sexp_opcode_code(op)); - if (sexp_opcode_data(op)) - emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op)); + if ((sexp_opcode_class(op) != OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == OP_MAKE) { + if (sexp_opcode_data(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); + if (sexp_opcode_data2(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + } break; case OPC_PARAMETER: emit_push(ctx, sexp_opcode_data(op)); @@ -1181,6 +1187,9 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define _WORD0 ((sexp*)ip)[0] #define _UWORD0 ((sexp_uint_t*)ip)[0] #define _SWORD0 ((sexp_sint_t*)ip)[0] +#define _WORD1 ((sexp*)ip)[1] +#define _UWORD1 ((sexp_uint_t*)ip)[1] +#define _SWORD1 ((sexp_sint_t*)ip)[1] #define sexp_raise(msg, args) \ do {sexp_context_top(ctx) = top+1; \ @@ -1537,11 +1546,29 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_CHARP: _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; case OP_TYPEP: - _ARG1 = sexp_make_boolean(sexp_pointerp(_ARG1) - && (sexp_make_fixnum(sexp_pointer_tag(_ARG1)) - == _WORD0)); + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); ip += sizeof(sexp); break; + case OP_MAKE: + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case OP_SLOT_REF: + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(_UWORD0), -1), _ARG1)); + _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); + ip += sizeof(sexp)*2; + break; + case OP_SLOT_SET: + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(_UWORD0), -1), _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); + sexp_slot_set(_ARG1, _UWORD1, _ARG2); + _ARG2 = SEXP_VOID; + ip += sizeof(sexp)*2; + top--; + break; case OP_CAR: if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); @@ -2196,6 +2223,86 @@ static sexp sexp_copy_opcode (sexp ctx, sexp op) { return res; } + +sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code, + sexp num_args, sexp flags, sexp arg1t, sexp arg2t, + sexp invp, sexp data, sexp data2, sexp_proc0 func) { + sexp res; + if (! sexp_stringp(name)) + res = sexp_type_exception(ctx, "make-opcode: not a string", name); + else if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0) + || (sexp_unbox_fixnum(op_class) >= OPC_NUM_OP_CLASSES)) + res = sexp_type_exception(ctx, "make-opcode: bad opcode class", op_class); + else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) + || (sexp_unbox_fixnum(code) >= OP_NUM_OPCODES)) + res = sexp_type_exception(ctx, "make-opcode: bad opcode", code); + else if (! sexp_fixnump(num_args)) + res = sexp_type_exception(ctx, "make-opcode: bad num_args", num_args); + else if (! sexp_fixnump(flags)) + res = sexp_type_exception(ctx, "make-opcode: bad flags", flags); + else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_arg1_type(res) = sexp_unbox_fixnum(arg1t); + sexp_opcode_arg2_type(res) = sexp_unbox_fixnum(arg2t); + sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_data(res) = data; + sexp_opcode_data2(res) = data2; + sexp_opcode_func(res) = func; + sexp_opcode_name(res) + = strndup(sexp_string_data(name), sexp_string_length(name)+1); + } + return res; +} + +#if USE_TYPE_DEFS + +sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < SEXP_NUM_CORE_TYPES)) + return sexp_type_exception(ctx, "make-type-predicate: bad type", type); + return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_TYPE_PREDICATE), + sexp_make_fixnum(OP_TYPEP), sexp_make_fixnum(1), + sexp_make_fixnum(0), sexp_make_fixnum(0), + sexp_make_fixnum(0), sexp_make_fixnum(0), type, + NULL, NULL); +} + +sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { + sexp_uint_t type_size; + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < SEXP_NUM_CORE_TYPES)) + return sexp_type_exception(ctx, "make-constructor: bad type", type); + type_size = sexp_type_size_base(&(sexp_type_specs[sexp_unbox_fixnum(type)])); + return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_CONSTRUCTOR), + sexp_make_fixnum(OP_MAKE), sexp_make_fixnum(0), + sexp_make_fixnum(0), sexp_make_fixnum(0), + sexp_make_fixnum(0), sexp_make_fixnum(0), type, + sexp_make_fixnum(type_size), NULL); +} + +sexp sexp_make_accessor (sexp ctx, sexp name, sexp type, sexp index, sexp code) { + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < SEXP_NUM_CORE_TYPES)) + return sexp_type_exception(ctx, "make-accessor: bad type", type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, "make-accessor: bad index", index); + return + sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_ACCESSOR), code, + sexp_make_fixnum(sexp_unbox_fixnum(code)==OP_SLOT_REF?1:2), + sexp_make_fixnum(0), type, sexp_make_fixnum(0), + sexp_make_fixnum(0), type, index, NULL); +} + +sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(OP_SLOT_REF)); +} +sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index) { + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(OP_SLOT_SET)); +} + +#endif + sexp sexp_make_env (sexp ctx) { sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); sexp_env_lambda(e) = NULL; @@ -2326,7 +2433,7 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) { sexp_gc_var1(thunk); sexp_gc_preserve1(ctx, thunk); ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); - sexp_context_parent(ctx2) = ctx; + /* sexp_context_parent(ctx2) = ctx; */ thunk = sexp_compile(ctx2, obj); if (sexp_exceptionp(thunk)) { sexp_print_exception(ctx2, thunk, diff --git a/gc.c b/gc.c index e9d5577e..f62a02c4 100644 --- a/gc.c +++ b/gc.c @@ -45,7 +45,7 @@ static sexp_heap sexp_heap_last (sexp_heap 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)) + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_num_types)) 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)); diff --git a/include/chibi/config.h b/include/chibi/config.h index 7436a2c0..e539ebf3 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -8,6 +8,9 @@ /* uncomment this to disable dynamic loading */ /* #define USE_DL 0 */ +/* uncomment this to disable dynamic type definitions */ +/* #define USE_TYPE_DEFS 0 */ + /* uncomment this to use the Boehm conservative GC */ /* #define USE_BOEHM 1 */ @@ -70,6 +73,14 @@ #define USE_MODULES 1 #endif +#ifndef USE_TYPE_DEFS +#define USE_TYPE_DEFS 1 +#endif + +#ifndef SEXP_MAXIMUM_TYPES +#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1) +#endif + #ifndef USE_DL #ifdef PLAN9 #define USE_DL 0 diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 2bdd81ff..f069437a 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -38,7 +38,8 @@ enum opcode_classes { OPC_CONSTRUCTOR, OPC_ACCESSOR, OPC_PARAMETER, - OPC_FOREIGN + OPC_FOREIGN, + OPC_NUM_OP_CLASSES }; enum opcode_names { @@ -82,6 +83,9 @@ enum opcode_names { OP_CHARP, OP_EOFP, OP_TYPEP, + OP_MAKE, + OP_SLOT_REF, + OP_SLOT_SET, OP_CAR, OP_CDR, OP_SET_CAR, @@ -130,6 +134,14 @@ SEXP_API sexp sexp_env_copy(sexp context, sexp to, sexp from, sexp ls); SEXP_API void sexp_env_define(sexp context, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_make_context(sexp context, sexp stack, sexp env); SEXP_API void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out); +SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc0); + +#if USE_TYPE_DEFS +SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); +SEXP_API sexp sexp_make_constructor (sexp ctx, sexp name, sexp type); +SEXP_API sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index); +SEXP_API sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index); +#endif #endif /* ! SEXP_EVAL_H */ diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 001217a5..723e05a0 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -93,11 +93,16 @@ enum sexp_types { SEXP_LIT, SEXP_STACK, SEXP_CONTEXT, - SEXP_NUM_TYPES + SEXP_NUM_CORE_TYPES }; typedef unsigned long sexp_uint_t; typedef long sexp_sint_t; +/* #if SEXP_64_BIT */ +/* typedef unsigned int sexp_tag_t; */ +/* #else */ +/* typedef unsigned short sexp_tag_t; */ +/* #endif */ typedef unsigned char sexp_tag_t; typedef struct sexp_struct *sexp; @@ -200,7 +205,7 @@ struct sexp_struct { unsigned char op_class, code, num_args, flags, arg1_type, arg2_type, inverse; char *name; - sexp data, proc; + sexp data, data2, proc; sexp_proc0 func; } opcode; struct { @@ -347,10 +352,14 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_gc_mark(x) ((x)->gc_mark) #define sexp_immutablep(x) ((x)->immutablep) -#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag])) -#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x))) +#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag])) +#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x))) +#define sexp_type_name_by_index(x) (sexp_type_name(&(sexp_type_specs[(x)]))) -#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) +#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) #if USE_IMMEDIATE_FLONUMS union sexp_flonum_conv { @@ -495,6 +504,7 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #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_data2(x) ((x)->value.opcode.data2) #define sexp_opcode_proc(x) ((x)->value.opcode.proc) #define sexp_opcode_func(x) ((x)->value.opcode.func) @@ -634,6 +644,7 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); #define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) +SEXP_API struct sexp_struct *sexp_type_specs; 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); @@ -674,5 +685,10 @@ 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(void); +#if USE_TYPE_DEFS +SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots); +#endif + #endif /* ! SEXP_H */ diff --git a/init.scm b/init.scm index 4e971d9f..14173846 100644 --- a/init.scm +++ b/init.scm @@ -431,7 +431,10 @@ (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-char n) + (if (<= n 9) + (integer->char (+ n (char->integer #\0))) + (integer->char (+ (- n 10) (char->integer #\A))))) (define (digit-value ch) (if (char-numeric? ch) (- (char->integer ch) (char->integer #\0)) diff --git a/main.c b/main.c index f6b448a2..961791c7 100644 --- a/main.c +++ b/main.c @@ -74,6 +74,7 @@ sexp sexp_init_environments (sexp ctx) { sexp_gc_var1(confenv); env = sexp_context_env(ctx); res = sexp_load_module_file(ctx, sexp_init_file, env); +#if USE_MODULES if (! sexp_exceptionp(res)) { res = SEXP_UNDEF; sexp_gc_preserve1(ctx, confenv); @@ -84,13 +85,14 @@ sexp sexp_init_environments (sexp ctx) { sexp_env_define(ctx, confenv, sexp_intern(ctx, "*config-env*"), confenv); sexp_gc_release1(ctx); } +#endif return res; } void repl (sexp ctx) { - sexp tmp, res, env, in, out, err; - sexp_gc_var1(obj); - sexp_gc_preserve1(ctx, obj); + sexp in, out, err; + sexp_gc_var4(obj, tmp, res, env); + sexp_gc_preserve4(ctx, obj, tmp, res, env); env = sexp_context_env(ctx); sexp_context_tracep(ctx) = 1; in = sexp_eval_string(ctx, "(current-input-port)", env); @@ -118,7 +120,7 @@ void repl (sexp ctx) { } } } - sexp_gc_release1(ctx); + sexp_gc_release4(ctx); } void run_main (int argc, char **argv) { diff --git a/opcodes.c b/opcodes.c index 55c859bd..191d6811 100644 --- a/opcodes.c +++ b/opcodes.c @@ -1,7 +1,7 @@ #define _OP(c,o,n,m,t,u,i,s,d,f) \ {.tag=SEXP_OPCODE, \ - .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, f}}} + .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}} #define _FN(o,n,m,t,u,s,f,p) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp_proc0)p) #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) @@ -107,6 +107,9 @@ _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), +_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_MATH _FN1(0, "exp", 0, sexp_exp), _FN1(0, "log", 0, sexp_log), @@ -123,9 +126,13 @@ _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_TYPE_DEFS +_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter), +#endif #if USE_DEBUG _FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), #endif diff --git a/opt/bignum.c b/opt/bignum.c index 4ffafa1e..ed75b6bd 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -466,12 +466,11 @@ enum sexp_number_combs { SEXP_NUM_BIG_BIG }; -static int sexp_number_types[SEXP_NUM_TYPES] = - {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, }; +static int sexp_number_types[] = + {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, 0}; static int sexp_number_type (sexp a) { - return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)] + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&1111] : sexp_fixnump(a); } diff --git a/sexp.c b/sexp.c index 946a1319..2f4388cb 100644 --- a/sexp.c +++ b/sexp.c @@ -62,7 +62,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_type_specs[] = { +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"), @@ -84,7 +84,7 @@ static struct sexp_struct sexp_type_specs[] = { _DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"), _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"), _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"), - _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 2, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"), + _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"), _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"), _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional"), _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"), @@ -94,9 +94,67 @@ static struct sexp_struct sexp_type_specs[] = { _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack"), _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"), }; - #undef _DEF_TYPE +struct sexp_struct *sexp_type_specs = _sexp_type_specs; + +#if USE_TYPE_DEFS + +static sexp_uint_t sexp_num_types = SEXP_NUM_CORE_TYPES; +static sexp_uint_t sexp_type_array_size = SEXP_NUM_CORE_TYPES; + +sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp flb, sexp flo, sexp fls, + sexp sb, sexp so, sexp sc) { + struct sexp_struct *type, *new, *tmp; + sexp res; + sexp_uint_t i, len; + if (sexp_num_types >= SEXP_MAXIMUM_TYPES) { + fprintf(stderr, "chibi: exceeded maximum type limit\n"); + res = SEXP_FALSE; + } else if (! sexp_stringp(name)) { + res = sexp_type_exception(ctx, "register-type: not a string", name); + } else { + if (sexp_num_types >= sexp_type_array_size) { + len = sexp_type_array_size*2; + if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES; + new = malloc(len * sizeof(_sexp_type_specs[0])); + for (i=0; i sexp_num_types) free(tmp); + sexp_type_array_size = len; + } + type = &(sexp_type_specs[sexp_num_types]); + sexp_pointer_tag(type) = SEXP_TYPE; + sexp_type_tag(type) = sexp_num_types++; + sexp_type_field_base(type) = sexp_unbox_fixnum(fb); + sexp_type_field_len_base(type) = sexp_unbox_fixnum(flb); + sexp_type_field_len_off(type) = sexp_unbox_fixnum(flo); + sexp_type_field_len_scale(type) = sexp_unbox_fixnum(fls); + sexp_type_size_base(type) = sexp_unbox_fixnum(sb); + sexp_type_size_off(type) = sexp_unbox_fixnum(so); + sexp_type_size_scale(type) = sexp_unbox_fixnum(sc); + sexp_type_name(type) = strndup(sexp_string_data(name), sexp_string_length(name)+1); + res = sexp_make_fixnum(sexp_type_tag(type)); + } + return res; +} + +sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) { + short type_size + = sexp_sizeof(flonum) - sizeof(double) + sizeof(sexp)*sexp_unbox_fixnum(slots); + return sexp_register_type(ctx, name, + sexp_make_fixnum(offsetof(struct sexp_struct, value)), + slots, sexp_make_fixnum(0), sexp_make_fixnum(0), + sexp_make_fixnum(type_size), sexp_make_fixnum(0), + sexp_make_fixnum(0)); +} + +#else +#define sexp_num_types SEXP_NUM_CORE_TYPES +#endif + #if ! USE_BOEHM #if ! USE_MALLOC @@ -877,8 +935,8 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { 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", + (i < sexp_num_types) + ? sexp_type_name_by_index(i) : "invalid", out); sexp_write_char(ctx, '>', out); break; diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 9e06318d..7b881b9d 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -229,6 +229,8 @@ (test "100" (number->string 256 16)) +(test "FF" (number->string 255 16)) + (test "177" (number->string 127 8)) (test "101" (number->string 5 2)) From edd08d674055ba2ec891b161b36ad5741449bacb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 11 Nov 2009 01:27:20 +0900 Subject: [PATCH 194/535] adding srfi-9 based on native types --- TODO | 4 +-- lib/srfi/9.module | 82 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 84 insertions(+), 2 deletions(-) create mode 100644 lib/srfi/9.module diff --git a/TODO b/TODO index 8caf9b8e..f1d1da2a 100644 --- a/TODO +++ b/TODO @@ -27,7 +27,7 @@ **- scheme-complete.el support *= ffi **+ libdl interface -**- opcode generation interface +**= opcode generation interface **- stub generator *= cleanup *- user documentation @@ -45,5 +45,5 @@ **- plugin infrastructure *- type inference with warnings *- SRFI-0 cond-expand -*- SRFI-9 define-record-type +*+ SRFI-9 define-record-type *- code repository with install tools diff --git a/lib/srfi/9.module b/lib/srfi/9.module new file mode 100644 index 00000000..87af7e73 --- /dev/null +++ b/lib/srfi/9.module @@ -0,0 +1,82 @@ + +(define-module (srfi 9) + (export define-record-type) + (import (scheme)) + (body + (define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((name (cadr expr)) + (make (caaddr expr)) + (make-fields (cdaddr expr)) + (pred (cadddr expr)) + (fields (cddddr expr)) + (num-fields (length fields)) + (index (register-simple-type (symbol->string name) num-fields)) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let))) + (define (index-of field ls) + (let lp ((ls ls) (i 0)) + (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) + `(,(rename 'begin) + (,_define ,make + ,(let lp ((ls make-fields) (sets '()) (set-defs '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string make) + ,index)) + ,@set-defs) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets) + set-defs)) + (else + (let* ((setter-name + (string-append "%" (symbol->string name) "-" + (symbol->string (car ls)) "-set!")) + (setter (rename (string->symbol setter-name))) + (i (index-of (car ls) fields))) + (lp (cdr ls) + (cons (list setter 'res (car ls)) sets) + (cons (list setter + (list (rename 'make-setter) + setter-name + index + (index-of (car ls) fields))) + set-defs)))))))))) + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string pred) + ,index)) + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string (cadar ls)) + ,index + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string (caddar ls)) + ,index + ,i)) + res) + res)))))))))))) + From 6db4ed915518d595cb03373ae825872a0ea7305c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 11 Nov 2009 01:43:47 +0900 Subject: [PATCH 195/535] removing strndups --- eval.c | 3 +-- sexp.c | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/eval.c b/eval.c index 6bb2c927..30b6553f 100644 --- a/eval.c +++ b/eval.c @@ -2252,8 +2252,7 @@ sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code, sexp_opcode_data(res) = data; sexp_opcode_data2(res) = data2; sexp_opcode_func(res) = func; - sexp_opcode_name(res) - = strndup(sexp_string_data(name), sexp_string_length(name)+1); + sexp_opcode_name(res) = strdup(sexp_string_data(name)); } return res; } diff --git a/sexp.c b/sexp.c index 2f4388cb..e732005e 100644 --- a/sexp.c +++ b/sexp.c @@ -135,7 +135,7 @@ sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp flb, sexp flo, sexp sexp_type_size_base(type) = sexp_unbox_fixnum(sb); sexp_type_size_off(type) = sexp_unbox_fixnum(so); sexp_type_size_scale(type) = sexp_unbox_fixnum(sc); - sexp_type_name(type) = strndup(sexp_string_data(name), sexp_string_length(name)+1); + sexp_type_name(type) = strdup(sexp_string_data(name)); res = sexp_make_fixnum(sexp_type_tag(type)); } return res; From 311c567c06b44f4bbf5ed8473daf843662172a85 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Nov 2009 18:45:08 +0900 Subject: [PATCH 196/535] making EQUAL? comparison data-driven all native types, present and future, now supported. allows for distinguishing which slots should be used for comparison (e.g. source info of pairs isn't compared). --- eval.c | 10 +-- gc.c | 10 +-- include/chibi/sexp.h | 71 +++++++++++------ sexp.c | 179 ++++++++++++++++++++++++------------------- 4 files changed, 151 insertions(+), 119 deletions(-) diff --git a/eval.c b/eval.c index 30b6553f..fb4c6b2c 100644 --- a/eval.c +++ b/eval.c @@ -1533,14 +1533,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_NULLP: _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; case OP_INTEGERP: - j = sexp_integerp(_ARG1); -#if USE_FLONUMS - if (! j) - j = (sexp_flonump(_ARG1) - && (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1)))); -#endif - _ARG1 = sexp_make_boolean(j); - break; + _ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break; case OP_SYMBOLP: _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; case OP_CHARP: @@ -2432,7 +2425,6 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) { sexp_gc_var1(thunk); sexp_gc_preserve1(ctx, thunk); ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); - /* sexp_context_parent(ctx2) = ctx; */ thunk = sexp_compile(ctx2, obj); if (sexp_exceptionp(thunk)) { sexp_print_exception(ctx2, thunk, diff --git a/gc.c b/gc.c index f62a02c4..c0ef988b 100644 --- a/gc.c +++ b/gc.c @@ -43,18 +43,16 @@ static sexp_heap sexp_heap_last (sexp_heap h) { } sexp_uint_t sexp_allocated_bytes (sexp x) { - sexp_uint_t res, *len_ptr; + sexp_uint_t res; sexp t; if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_num_types)) 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); + res = sexp_type_size_of_object(t, x); 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; @@ -67,9 +65,7 @@ void sexp_mark (sexp x) { 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; + len = sexp_type_num_slots_of_object(t, x) - 1; if (len >= 0) { for (i=0; igc_mark) #define sexp_immutablep(x) ((x)->immutablep) -#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag])) -#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x))) -#define sexp_type_name_by_index(x) (sexp_type_name(&(sexp_type_specs[(x)]))) +#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag])) +#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x))) +#define sexp_type_name_by_index(x) (sexp_type_name(&(sexp_type_specs[(x)]))) + +#define sexp_type_size_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \ + * sexp_type_size_scale(t) \ + + sexp_type_size_base(t)) +#define sexp_type_num_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_len_base(t)) +#define sexp_type_num_eq_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_eq_len_base(t)) #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) @@ -419,12 +434,19 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) +#if USE_FLONUMS +#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x))) +#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x)) +#else +#define _or_integer_flonump(x) +#endif + #if USE_BIGNUMS SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); -#define sexp_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) +#define sexp_integerp(x) (sexp_fixnump(x) || sexp_bignump(x) _or_integer_flonump(x)) #else #define sexp_make_integer(ctx, x) sexp_make_fixnum(x) -#define sexp_integerp sexp_fixnump +#define sexp_integerp(x) (sexp_fixnump(x) _or_integer_flonump(x)) #endif #if USE_FLONUMS @@ -555,15 +577,16 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #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_type_tag(x) ((x)->value.type.tag) +#define sexp_type_field_base(x) ((x)->value.type.field_base) +#define sexp_type_field_eq_len_base(x) ((x)->value.type.field_eq_len_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) @@ -686,7 +709,7 @@ SEXP_API sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); SEXP_API void sexp_init(void); #if USE_TYPE_DEFS -SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots); #endif diff --git a/sexp.c b/sexp.c index e732005e..ebe94201 100644 --- a/sexp.c +++ b/sexp.c @@ -59,40 +59,40 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { return res; } -#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}}} +#define _DEF_TYPE(t,fb,felb,flb,flo,fls,sb,so,sc,n) \ + {.tag=SEXP_TYPE, .value={.type={t,fb,felb,flb,flo,fls,sb,so,sc,n}}} 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"), - _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), 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), sizeof(sexp), "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), sizeof(sexp), "bignum"), - _DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, sexp_sizeof(cpointer), 0, 0, "cpointer"), - _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"), - _DEF_TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"), - _DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"), - _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"), - _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"), - _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"), - _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"), - _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional"), - _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"), - _DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"), - _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"), - _DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"), - _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack"), - _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"), + _DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, "object"), + _DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"), + _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, "fixnum"), + _DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, "char"), + _DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, "boolean"), + _DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, "pair"), + _DEF_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"), + _DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string"), + _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector"), + _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"), + _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum"), + _DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, 0, sexp_sizeof(cpointer), 0, 0, "cpointer"), + _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port"), + _DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port"), + _DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception"), + _DEF_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"), + _DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro"), + _DEF_TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"), + _DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"), + _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"), + _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"), + _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"), + _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"), + _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional"), + _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"), + _DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"), + _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"), + _DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"), + _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack"), + _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 6, 0, 0, sexp_sizeof(context), 0, 0, "context"), }; #undef _DEF_TYPE @@ -103,8 +103,8 @@ struct sexp_struct *sexp_type_specs = _sexp_type_specs; static sexp_uint_t sexp_num_types = SEXP_NUM_CORE_TYPES; static sexp_uint_t sexp_type_array_size = SEXP_NUM_CORE_TYPES; -sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp flb, sexp flo, sexp fls, - sexp sb, sexp so, sexp sc) { +sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp felb, sexp flb, + sexp flo, sexp fls, sexp sb, sexp so, sexp sc) { struct sexp_struct *type, *new, *tmp; sexp res; sexp_uint_t i, len; @@ -129,6 +129,7 @@ sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp flb, sexp flo, sexp sexp_pointer_tag(type) = SEXP_TYPE; sexp_type_tag(type) = sexp_num_types++; sexp_type_field_base(type) = sexp_unbox_fixnum(fb); + sexp_type_field_eq_len_base(type) = sexp_unbox_fixnum(felb); sexp_type_field_len_base(type) = sexp_unbox_fixnum(flb); sexp_type_field_len_off(type) = sexp_unbox_fixnum(flo); sexp_type_field_len_scale(type) = sexp_unbox_fixnum(fls); @@ -144,11 +145,12 @@ sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp flb, sexp flo, sexp sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) { short type_size = sexp_sizeof(flonum) - sizeof(double) + sizeof(sexp)*sexp_unbox_fixnum(slots); - return sexp_register_type(ctx, name, - sexp_make_fixnum(offsetof(struct sexp_struct, value)), - slots, sexp_make_fixnum(0), sexp_make_fixnum(0), - sexp_make_fixnum(type_size), sexp_make_fixnum(0), - sexp_make_fixnum(0)); + return + sexp_register_type(ctx, name, + sexp_make_fixnum(offsetof(struct sexp_struct, value)), + slots, slots, sexp_make_fixnum(0), sexp_make_fixnum(0), + sexp_make_fixnum(type_size), sexp_make_fixnum(0), + sexp_make_fixnum(0)); } #else @@ -382,64 +384,81 @@ sexp sexp_length (sexp ctx, sexp ls) { } sexp sexp_equalp (sexp ctx, sexp a, sexp b) { - sexp_uint_t len; - sexp *v1, *v2; + sexp_uint_t size; + sexp_sint_t i, len; + sexp t, tmp, *p, *q; + char *p0, *q0; + 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_fixnum(sexp_flonum_value(a)) == b) - || (sexp_flonump(b) - && sexp_make_fixnum(sexp_flonum_value(b)) == a)); + sexp_make_boolean((sexp_flonump(a) && sexp_fixnump(b) + && sexp_flonum_value(a) == sexp_unbox_fixnum(b)) + || (sexp_flonump(b) && sexp_fixnump(a) + && sexp_flonum_value(b) == sexp_unbox_fixnum(a))); #else if (! sexp_pointerp(a)) - return sexp_make_boolean(sexp_fixnump(a) && sexp_pointerp(b) - && (sexp_unbox_fixnum(a) - == sexp_flonum_value(b))); + return sexp_make_boolean(sexp_fixnump(a) && sexp_flonump(b) + && (sexp_unbox_fixnum(a) == sexp_flonum_value(b))); else if (! sexp_pointerp(b)) - return sexp_make_boolean(sexp_fixnump(b) && sexp_pointerp(a) - && (sexp_unbox_fixnum(b) - == sexp_flonum_value(a))); + return sexp_make_boolean(sexp_fixnump(b) && sexp_flonump(a) + && (sexp_unbox_fixnum(b) == sexp_flonum_value(a))); +#endif + + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) { +#if USE_BIGNUMS && ! USE_IMMEDIATE_FLONUMS + if (sexp_pointer_tag(a) == SEXP_FLONUM) {tmp=a; a=b; b=tmp;} + if (sexp_pointer_tag(a) == SEXP_BIGNUM) + return sexp_make_boolean((sexp_pointer_tag(b) == SEXP_FLONUM) + && sexp_fp_integerp(b) + && ! sexp_bignum_compare(a, sexp_double_to_bignum(ctx, sexp_flonum_value(b)))); + else #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)))); + } + + /* a and b are both pointers of the same type */ #if USE_BIGNUMS - case SEXP_BIGNUM: + if (sexp_pointer_tag(a) == SEXP_BIGNUM) return sexp_make_boolean(!sexp_bignum_compare(a, b)); #endif -#if ! USE_IMMEDIATE_FLONUMS - case SEXP_FLONUM: +#if USE_FLONUMS && ! USE_IMMEDIATE_FLONUMS + if (sexp_pointer_tag(a) == SEXP_FLONUM) return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); #endif - default: + t = &(sexp_type_specs[sexp_pointer_tag(a)]); + p0 = ((char*)a) + offsetof(struct sexp_struct, value); + p = (sexp*) (((char*)a) + sexp_type_field_base(t)); + q0 = ((char*)b) + offsetof(struct sexp_struct, value); + q = (sexp*) (((char*)b) + sexp_type_field_base(t)); + if ((sexp)p == a) {p=(sexp*)p0; q=(sexp*)q0;} + /* check preliminary non-object data */ + if ((p0 < (char*)p) && memcmp(p0, q0, ((char*)p - p0))) return SEXP_FALSE; + /* check trailing non-object data */ + size = sexp_type_size_of_object(t, a) - offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,a)*sizeof(sexp)); + if (((char*)a + size) > p0) { + q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp)); + if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value)) + return SEXP_FALSE; + if (memcmp(p0, q0, size-((char*)p0-(char*)p))) + return SEXP_FALSE; } + /* check eq-object slots */ + len = sexp_type_num_eq_slots_of_object(t, a); + if (len > 0) { + for (i=0; isymbol: not a string", str); return sexp_intern(ctx, sexp_string_data(str)); } From 0581b41b1efa2241e2e85728b8bb4aea6bc51114 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 16 Nov 2009 00:52:16 +0900 Subject: [PATCH 197/535] adding hash-tables and a more friendly FFI --- Makefile | 9 +- README | 48 ++++++++++ TODO | 3 + eval.c | 66 ++++++++++--- include/chibi/eval.h | 25 ++--- include/chibi/sexp.h | 2 +- lib/srfi/69.module | 18 ++++ lib/srfi/69/hash.c | 196 ++++++++++++++++++++++++++++++++++++++ lib/srfi/69/interface.scm | 110 +++++++++++++++++++++ lib/srfi/69/type.scm | 9 ++ lib/srfi/9.module | 50 +++++----- opcodes.c | 2 +- sexp.c | 2 +- 13 files changed, 485 insertions(+), 55 deletions(-) create mode 100644 lib/srfi/69.module create mode 100644 lib/srfi/69/hash.c create mode 100644 lib/srfi/69/interface.scm create mode 100644 lib/srfi/69/type.scm diff --git a/Makefile b/Makefile index 05579c84..f8627fe7 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ # -*- makefile-gmake -*- -.PHONY: all doc dist clean cleaner test install uninstall +.PHONY: all libs doc dist clean cleaner test install uninstall CC ?= cc PREFIX ?= /usr/local @@ -48,7 +48,9 @@ STATICFLAGS = -static endif endif -all: chibi-scheme$(EXE) +all: chibi-scheme$(EXE) libs + +libs: lib/srfi/69/hash$(SO) ifeq ($(USE_BOEHM),1) GCLDFLAGS := -lgc @@ -90,6 +92,9 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO) chibi-scheme-static$(EXE): main.o eval.o sexp.o $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) +lib/srfi/69/hash$(SO): lib/srfi/69/hash.c + $(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + clean: rm -f *.o *.i *.s *.8 diff --git a/README b/README index bfd07571..e6c01034 100644 --- a/README +++ b/README @@ -41,6 +41,8 @@ directly from make with: See the file main.c for an example of using chibi-scheme as a library. The essential functions to remember are: + #include + sexp_make_context(NULL, NULL, NULL) returns a new context @@ -50,3 +52,49 @@ The essential functions to remember are: sexp_eval_string(context, str) reads an s-expression from str and evaluates it + sexp_env_define(context, env, symbol, value) + +A minimal module system is provided by default. Currently you can +load the following SRFIs with (import (srfi N)): + + 1, 2, 6, 8, 9, 11, 16, 26, 69 + +LOAD is extended to accept an optional environment argument, like +EVAL. You can also LOAD shared libraries in addition to Scheme source +files - in this case the function sexp_init_library is automatically +called with the following signature: + + sexp_init_library(sexp context, sexp environment) + +To define new primitive functions from C, use sexp_define_foreign, +which takes a Scheme environment, a name, a number of arguments the C +function takes (not counting the context argument), and a C function. + + /* sexp_define_foreign(context, env, name, num_args, f) */ + + sexp add1 (sexp context, sexp x) { + return sexp_fx_add(x, sexp_make_fixnum(1)); + } + + sexp_define_foreign(context, env, "add1", 1, add1) + +See the SRFI-69 implementation for more detailed examples of this. + +You can define new data types with SRFI-9. This is just syntactic +sugar for the following more primitive type constructors: + +(register-simple-type ) + => ; a fixnum + +(make-type-predicate ) + => ; takes 1 arg, returns #t iff that arg is of the type + +(make-constructor ) + => ; takes 0 args, returns a newly allocated instance of type + +(make-getter ) + => ; takes 1 args, retrieves the field located at the index + +(make-setter ) + => ; takes 2 args, sets the field located at the index + diff --git a/TODO b/TODO index f1d1da2a..98e4e0d6 100644 --- a/TODO +++ b/TODO @@ -46,4 +46,7 @@ *- type inference with warnings *- SRFI-0 cond-expand *+ SRFI-9 define-record-type +*+ SRFI-69 hash-tables +*- tcp interface +*- posix interface *- code repository with install tools diff --git a/eval.c b/eval.c index fb4c6b2c..cc553b2f 100644 --- a/eval.c +++ b/eval.c @@ -2035,7 +2035,7 @@ sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { #endif sexp sexp_load (sexp ctx, sexp source, sexp env) { - sexp tmp, out; + sexp tmp, out=SEXP_FALSE; sexp_gc_var4(ctx2, x, in, res); #if USE_DL char *suffix = sexp_string_data(source) @@ -2053,9 +2053,10 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { tmp = sexp_env_bindings(env); sexp_context_tailp(ctx2) = 0; if (sexp_exceptionp(in)) { - if (! sexp_oportp(out)) + if (sexp_not(out)) out = sexp_env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE); - sexp_print_exception(ctx, in, out); + if (sexp_oportp(out)) + sexp_print_exception(ctx, in, out); res = in; } else { sexp_port_sourcep(in) = 1; @@ -2219,7 +2220,7 @@ static sexp sexp_copy_opcode (sexp ctx, sexp op) { sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code, sexp num_args, sexp flags, sexp arg1t, sexp arg2t, - sexp invp, sexp data, sexp data2, sexp_proc0 func) { + sexp invp, sexp data, sexp data2, sexp_proc1 func) { sexp res; if (! sexp_stringp(name)) res = sexp_type_exception(ctx, "make-opcode: not a string", name); @@ -2250,6 +2251,36 @@ sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code, return res; } +sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_proc1 f) { + sexp res; + if (num_args > 6) { + res = sexp_type_exception(ctx, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); + } else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = OPC_FOREIGN; + sexp_opcode_code(res) = OP_FCALL1+num_args-1; + sexp_opcode_num_args(res) = num_args; + sexp_opcode_name(res) = name; + sexp_opcode_func(res) = f; + } + return res; +} + +sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, + int num_args, sexp_proc1 f) { + sexp_gc_var1(op); + sexp_gc_preserve1(ctx, op); + sexp res = SEXP_VOID; + op = sexp_make_foreign(ctx, name, num_args, (sexp_proc1)f); + if (sexp_exceptionp(op)) + res = op; + else + sexp_env_define(ctx, env, sexp_intern(ctx, name), op); + sexp_gc_release1(ctx); + return res; +} + #if USE_TYPE_DEFS sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { @@ -2389,16 +2420,23 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); sexp_sint_t top = sexp_context_top(ctx), len, offset; len = sexp_unbox_fixnum(sexp_length(ctx, args)); - offset = top + len; - for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) - stack[--offset] = sexp_car(ls); - stack[top] = sexp_make_fixnum(len); - top++; - stack[top++] = sexp_make_fixnum(0); - stack[top++] = final_resumer; - stack[top++] = sexp_make_fixnum(0); - sexp_context_top(ctx) = top; - res = sexp_vm(ctx, proc); + if (sexp_opcodep(proc)) + proc = make_opcode_procedure(ctx, proc, len); + if (! sexp_procedurep(proc)) { + res = sexp_exceptionp(proc) ? proc : + sexp_type_exception(ctx, "apply: not a procedure", proc); + } else { + offset = top + len; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) + stack[--offset] = sexp_car(ls); + stack[top] = sexp_make_fixnum(len); + top++; + stack[top++] = sexp_make_fixnum(0); + stack[top++] = final_resumer; + stack[top++] = sexp_make_fixnum(0); + sexp_context_top(ctx) = top; + res = sexp_vm(ctx, proc); + } return res; } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index f069437a..5312893d 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -124,17 +124,20 @@ enum opcode_names { /**************************** prototypes ******************************/ -SEXP_API void sexp_scheme_init(void); -SEXP_API sexp sexp_apply(sexp context, sexp proc, sexp args); -SEXP_API sexp sexp_eval(sexp context, sexp obj, sexp env); -SEXP_API sexp sexp_eval_string(sexp context, char *str, sexp env); -SEXP_API sexp sexp_load(sexp context, sexp expr, sexp env); -SEXP_API sexp sexp_make_env(sexp context); -SEXP_API sexp sexp_env_copy(sexp context, sexp to, sexp from, sexp ls); -SEXP_API void sexp_env_define(sexp context, sexp env, sexp sym, sexp val); -SEXP_API sexp sexp_make_context(sexp context, sexp stack, sexp env); -SEXP_API void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out); -SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc0); +SEXP_API void sexp_scheme_init (void); +SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); +SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); +SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); +SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); +SEXP_API sexp sexp_make_env (sexp context); +SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls); +SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val); +SEXP_API sexp sexp_make_context (sexp context, sexp stack, sexp env); +SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); +SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); +SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_proc1 f); +SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, sexp_proc1 f); +#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,(sexp_proc1)f) #if USE_TYPE_DEFS SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 5ffacc13..d25dc6a4 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -208,7 +208,7 @@ struct sexp_struct { arg1_type, arg2_type, inverse; char *name; sexp data, data2, proc; - sexp_proc0 func; + sexp_proc1 func; } opcode; struct { char code; diff --git a/lib/srfi/69.module b/lib/srfi/69.module new file mode 100644 index 00000000..8c64a4e9 --- /dev/null +++ b/lib/srfi/69.module @@ -0,0 +1,18 @@ + +(define-module (srfi 69) + (export + make-hash-table hash-table? alist->hash-table + hash-table-equivalence-function hash-table-hash-function + hash-table-ref hash-table-ref/default hash-table-set! + hash-table-delete! hash-table-exists? + hash-table-update! hash-table-update!/default + hash-table-size hash-table-keys hash-table-values + hash-table-walk hash-table-fold hash-table->alist + hash-table-copy hash-table-merge! + hash string-hash string-ci-hash hash-by-identity) + (import (scheme)) + (import (srfi 9)) + (include "srfi/69/type.scm" + "srfi/69/hash.so" + "srfi/69/interface.scm")) + diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c new file mode 100644 index 00000000..c08a3708 --- /dev/null +++ b/lib/srfi/69/hash.c @@ -0,0 +1,196 @@ + +#include + +#define HASH_DEPTH 5 + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0) +#define sexp_hash_table_size(x) sexp_slot_ref(x, 1) +#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2) +#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3) + +static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc % bound; +} + +static sexp sexp_string_hash (sexp ctx, sexp str, sexp bound) { + return sexp_make_fixnum(string_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= tolower(*str++);} + return acc % bound; +} + +static sexp sexp_string_ci_hash (sexp ctx, sexp str, sexp bound) { + return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t hash_one (sexp obj, sexp_uint_t bound, sexp_sint_t depth) { + sexp_uint_t acc = FNV_OFFSET_BASIS, size; + sexp_sint_t i, len; + sexp t, *p; + char *p0; + loop: +#if USE_FLONUMS + if (sexp_flonump(obj)) + acc ^= (sexp_sint_t) sexp_flonum_value(obj); + else +#endif + if (sexp_pointerp(obj)) { + if (depth) { + t = &(sexp_type_specs[sexp_pointer_tag(obj)]); + p = (sexp*) (((char*)obj) + sexp_type_field_base(t)); + p0 = ((char*)obj) + offsetof(struct sexp_struct, value); + if ((sexp)p == obj) p=(sexp*)p0; + /* hash trailing non-object data */ + size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp)); + if (((char*)obj + size) > p0) + for (i=0; i 0) { + depth--; + for (i=0; ialist table) + (hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '())) + +(define (hash-table-keys table) + (hash-table-fold table (lambda (k v a) (cons k a)) '())) + +(define (hash-table-values table) + (hash-table-fold table (lambda (k v a) (cons v a)) '())) + +(define (alist->hash-table ls . o) + (let ((res (apply make-hash-table o))) + (for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls) + res)) + +(define (hash-table-merge! a b) + (hash-table-walk b (lambda (k v) (hash-table-set! a k v))) + a) + +(define (hash-table-copy table) + (assert-hash-table "hash-table-copy" table) + (let ((res (make-hash-table (hash-table-equivalence-function table)))) + (hash-table-merge! res table) + res)) + diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm new file mode 100644 index 00000000..849d6a14 --- /dev/null +++ b/lib/srfi/69/type.scm @@ -0,0 +1,9 @@ + +(define-record-type hash-table + (%make-hash-table buckets size hash-fn eq-fn) + hash-table? + (buckets hash-table-buckets hash-table-buckets-set!) + (size hash-table-size hash-table-size-set!) + (hash-fn %hash-table-hash-function) + (eq-fn %hash-table-equivalence-function)) + diff --git a/lib/srfi/9.module b/lib/srfi/9.module index 87af7e73..aca550a4 100644 --- a/lib/srfi/9.module +++ b/lib/srfi/9.module @@ -20,6 +20,30 @@ (let lp ((ls ls) (i 0)) (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) `(,(rename 'begin) + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string pred) + ,index)) + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string (cadar ls)) + ,index + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string (caddar ls)) + ,index + ,i)) + res) + res))))) (,_define ,make ,(let lp ((ls make-fields) (sets '()) (set-defs '())) (cond @@ -54,29 +78,5 @@ setter-name index (index-of (car ls) fields))) - set-defs)))))))))) - (,_define ,pred (,(rename 'make-type-predicate) - ,(symbol->string pred) - ,index)) - ,@(let lp ((ls fields) (i 0) (res '())) - (if (null? ls) - res - (let ((res - (cons `(,_define ,(cadar ls) - (,(rename 'make-getter) - ,(symbol->string (cadar ls)) - ,index - ,i)) - res))) - (lp (cdr ls) - (+ i 1) - (if (pair? (cddar ls)) - (cons - `(,_define ,(caddar ls) - (,(rename 'make-setter) - ,(symbol->string (caddar ls)) - ,index - ,i)) - res) - res)))))))))))) + set-defs))))))))))))))))) diff --git a/opcodes.c b/opcodes.c index 191d6811..4e135bf8 100644 --- a/opcodes.c +++ b/opcodes.c @@ -2,7 +2,7 @@ #define _OP(c,o,n,m,t,u,i,s,d,f) \ {.tag=SEXP_OPCODE, \ .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}} -#define _FN(o,n,m,t,u,s,f,p) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp_proc0)p) +#define _FN(o,n,m,t,u,s,f,p) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp_proc1)p) #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) diff --git a/sexp.c b/sexp.c index ebe94201..dd8dac2b 100644 --- a/sexp.c +++ b/sexp.c @@ -446,7 +446,7 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) { q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp)); if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value)) return SEXP_FALSE; - if (memcmp(p0, q0, size-((char*)p0-(char*)p))) + if (memcmp(p0, q0, size)) return SEXP_FALSE; } /* check eq-object slots */ From 3ecea4d66608527a445e511b61d7032343ef9ceb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 16 Nov 2009 04:04:23 +0900 Subject: [PATCH 198/535] adding define_foreign_opt to bind C functions with optional parameters moving several opcodes to normal FFI functions, considering doing the same for all I/O opcodes. --- Makefile | 8 ++++---- README | 10 +++++++--- TODO | 2 +- config.scm | 4 ++-- debug.c | 11 ++++------- eval.c | 47 +++++++++----------------------------------- include/chibi/eval.h | 13 +++++------- include/chibi/sexp.h | 4 +++- init.scm | 2 -- lib/srfi/69/hash.c | 21 ++++++++++++++++---- opcodes.c | 33 +++++++++++++++++-------------- sexp.c | 18 ++++++++++++++++- 12 files changed, 87 insertions(+), 86 deletions(-) diff --git a/Makefile b/Makefile index f8627fe7..b6350aa3 100644 --- a/Makefile +++ b/Makefile @@ -92,7 +92,7 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO) chibi-scheme-static$(EXE): main.o eval.o sexp.o $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) -lib/srfi/69/hash$(SO): lib/srfi/69/hash.c +lib/srfi/69/hash$(SO): lib/srfi/69/hash.c $(INCLUDES) $(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme clean: @@ -113,10 +113,10 @@ test-basic: chibi-scheme$(EXE) done test-numbers: chibi-scheme$(EXE) - ./chibi-scheme$(EXE) tests/numeric-tests.scm + LD_LIBRARY_PATH=.:$LD_LIBRARY_PATH ./chibi-scheme$(EXE) tests/numeric-tests.scm -test: chibi-scheme$(EXE) - ./chibi-scheme$(EXE) tests/r5rs-tests.scm +test: all + LD_LIBRARY_PATH=.:$LD_LIBRARY_PATH ./chibi-scheme$(EXE) tests/r5rs-tests.scm install: chibi-scheme$(EXE) mkdir -p $(DESTDIR)$(BINDIR) diff --git a/README b/README index e6c01034..9e203db2 100644 --- a/README +++ b/README @@ -72,11 +72,15 @@ function takes (not counting the context argument), and a C function. /* sexp_define_foreign(context, env, name, num_args, f) */ - sexp add1 (sexp context, sexp x) { - return sexp_fx_add(x, sexp_make_fixnum(1)); + sexp add (sexp context, sexp x, sexp y) { + return sexp_fx_add(x, y); } - sexp_define_foreign(context, env, "add1", 1, add1) + sexp_define_foreign(context, env, "add", 2, add); + +You can also define functions with a single optional argument: + + sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); See the SRFI-69 implementation for more detailed examples of this. diff --git a/TODO b/TODO index 98e4e0d6..e9cb620b 100644 --- a/TODO +++ b/TODO @@ -27,7 +27,7 @@ **- scheme-complete.el support *= ffi **+ libdl interface -**= opcode generation interface +**+ opcode generation interface **- stub generator *= cleanup *- user documentation diff --git a/config.scm b/config.scm index ebf744db..1208c201 100644 --- a/config.scm +++ b/config.scm @@ -34,7 +34,7 @@ (define (load-module-definition name) (let* ((file (module-name->file name)) (path (find-module-file name file))) - (if path (%load path *config-env*)))) + (if path (load path *config-env*)))) (define (find-module name) (cond @@ -53,7 +53,7 @@ (let ((mod2 (load-module (cadr x)))) (%env-copy! env (module-env mod2) (module-exports mod2)))) ((include) - (for-each (lambda (f) (%load (find-module-file name f) env)) (cdr x))) + (for-each (lambda (f) (load (find-module-file name f) env)) (cdr x))) ((body) (for-each (lambda (expr) (eval expr env)) (cdr x))))) (module-meta-data mod)) diff --git a/debug.c b/debug.c index 31a351df..051e4123 100644 --- a/debug.c +++ b/debug.c @@ -5,20 +5,17 @@ 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", + "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", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE", - "LT", "LE", "EQN", "EQ", - "EXACT->INEXACT", "INEXACT->EXACT", + "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", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", }; static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { diff --git a/eval.c b/eval.c index cc553b2f..ac694626 100644 --- a/eval.c +++ b/eval.c @@ -871,7 +871,7 @@ static void generate_opcode_app (sexp ctx, sexp app) { num_args++; } - /* push the arguments onto the stack */ + /* push the arguments onto the stack in reverse order */ ls = ((sexp_opcode_inverse(op) && (sexp_opcode_class(op) != OPC_ARITHMETIC_INV)) ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); @@ -1401,12 +1401,6 @@ sexp sexp_vm (sexp ctx, sexp proc) { ip += sizeof(sexp); sexp_check_exception(); break; - case OP_EVAL: - sexp_context_top(ctx) = top; - _ARG2 = sexp_eval(ctx, _ARG1, _ARG2); - top--; - sexp_check_exception(); - break; case OP_JUMP_UNLESS: if (stack[--top] == SEXP_FALSE) ip += _SWORD0; @@ -1886,24 +1880,6 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); _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: if (! sexp_charp(_ARG1)) sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); @@ -1915,15 +1891,6 @@ sexp sexp_vm (sexp ctx, sexp proc) { 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); @@ -2251,7 +2218,8 @@ sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code, return res; } -sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_proc1 f) { +sexp sexp_make_foreign (sexp ctx, char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { sexp res; if (num_args > 6) { res = sexp_type_exception(ctx, "make-foreign: exceeded foreign arg limit", @@ -2260,19 +2228,22 @@ sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_proc1 f) { res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); sexp_opcode_class(res) = OPC_FOREIGN; sexp_opcode_code(res) = OP_FCALL1+num_args-1; + if (flags & 1) num_args--; sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; sexp_opcode_name(res) = name; + sexp_opcode_data(res) = data; sexp_opcode_func(res) = f; } return res; } -sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, - int num_args, sexp_proc1 f) { +sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { sexp_gc_var1(op); sexp_gc_preserve1(ctx, op); sexp res = SEXP_VOID; - op = sexp_make_foreign(ctx, name, num_args, (sexp_proc1)f); + op = sexp_make_foreign(ctx, name, num_args, flags, f, data); if (sexp_exceptionp(op)) res = op; else diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 5312893d..5137b235 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -57,7 +57,6 @@ enum opcode_names { OP_FCALL4, OP_FCALL5, OP_FCALL6, - OP_EVAL, OP_JUMP_UNLESS, OP_JUMP, OP_PUSH, @@ -109,12 +108,8 @@ enum opcode_names { 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, @@ -135,9 +130,11 @@ SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_make_context (sexp context, sexp stack, sexp env); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); -SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_proc1 f); -SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, sexp_proc1 f); -#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,(sexp_proc1)f) +SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data); +SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, int flags, sexp_proc1 f, sexp data); + +#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL) +#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d) #if USE_TYPE_DEFS SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index d25dc6a4..7152b806 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -688,7 +688,9 @@ 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_make_cpointer(sexp ctx, void* value); -SEXP_API void sexp_write(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_flush_output(sexp ctx, 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); diff --git a/init.scm b/init.scm index 14173846..b5b372e6 100644 --- a/init.scm +++ b/init.scm @@ -487,8 +487,6 @@ (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))) diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c index c08a3708..7be9e2d7 100644 --- a/lib/srfi/69/hash.c +++ b/lib/srfi/69/hash.c @@ -2,6 +2,7 @@ #include #define HASH_DEPTH 5 +#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM) #define FNV_PRIME 16777619 #define FNV_OFFSET_BASIS 2166136261uL @@ -11,6 +12,8 @@ #define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2) #define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3) +#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2)) + static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { sexp_uint_t acc = FNV_OFFSET_BASIS; while (*str) {acc *= FNV_PRIME; acc ^= *str++;} @@ -147,6 +150,9 @@ static sexp sexp_scan_bucket (sexp ctx, sexp ls, sexp obj, sexp eq_fn) { return res; } +/* static sexp sexp_regrow_hash_table (sexp ctx, sexp ht) { */ +/* } */ + static sexp sexp_hash_table_cell (sexp ctx, sexp ht, sexp obj, sexp createp) { sexp_gc_var1(res); sexp_uint_t size; @@ -158,6 +164,11 @@ static sexp sexp_hash_table_cell (sexp ctx, sexp ht, sexp obj, sexp createp) { } else if (sexp_truep(createp)) { sexp_gc_preserve1(ctx, res); size = sexp_unbox_fixnum(sexp_hash_table_size(ht)); + /* if (sexp_hash_resize_check(size, sexp_vector_length(buckets))) { */ + /* sexp_regrow_hash_table(ctx, ht); */ + /* buckets = sexp_hash_table_buckets(ht); */ + /* i = sexp_get_bucket(ctx, ht, obj); */ + /* } */ res = sexp_cons(ctx, obj, createp); sexp_vector_set(buckets, i, sexp_cons(ctx, res, sexp_vector_ref(buckets, i))); sexp_hash_table_size(ht) = sexp_make_fixnum(size+1); @@ -171,6 +182,8 @@ static sexp sexp_hash_table_delete (sexp ctx, sexp ht, sexp obj) { i=sexp_get_bucket(ctx, ht, obj), p, res; res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn); if (sexp_pairp(res)) { + sexp_hash_table_size(ht) + = sexp_fx_sub(sexp_hash_table_size(ht), sexp_make_fixnum(1)); if (res == sexp_vector_ref(buckets, i)) { sexp_vector_set(buckets, i, sexp_cdr(res)); } else { @@ -184,10 +197,10 @@ static sexp sexp_hash_table_delete (sexp ctx, sexp ht, sexp obj) { sexp sexp_init_library (sexp ctx, sexp env) { - sexp_define_foreign(ctx, env, "string-hash", 2, sexp_string_hash); - sexp_define_foreign(ctx, env, "string-ci-hash", 2, sexp_string_ci_hash); - sexp_define_foreign(ctx, env, "hash", 2, sexp_hash); - sexp_define_foreign(ctx, env, "hash-by-identity", 2, sexp_hash_by_identity); + sexp_define_foreign_opt(ctx, env, "string-hash", 2, sexp_string_hash, HASH_BOUND); + sexp_define_foreign_opt(ctx, env, "string-ci-hash", 2, sexp_string_ci_hash, HASH_BOUND); + sexp_define_foreign_opt(ctx, env, "hash", 2, sexp_hash, HASH_BOUND); + sexp_define_foreign_opt(ctx, env, "hash-by-identity", 2, sexp_hash_by_identity, HASH_BOUND); sexp_define_foreign(ctx, env, "hash-table-cell", 3, sexp_hash_table_cell); sexp_define_foreign(ctx, env, "hash-table-delete!", 2, sexp_hash_table_delete); diff --git a/opcodes.c b/opcodes.c index 4e135bf8..c11154b9 100644 --- a/opcodes.c +++ b/opcodes.c @@ -2,15 +2,18 @@ #define _OP(c,o,n,m,t,u,i,s,d,f) \ {.tag=SEXP_OPCODE, \ .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}} -#define _FN(o,n,m,t,u,s,f,p) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp_proc1)p) -#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 _FN(o,n,m,t,u,s,d,f) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f) +#define _FN0(s, d, f) _FN(OP_FCALL0, 0, 0, 0, 0, s, d, f) +#define _FN1(t, s, d, f) _FN(OP_FCALL1, 1, 0, t, 0, s, d, f) +#define _FN1OPT(t, s, d, f) _FN(OP_FCALL1, 0, 1, t, u, s, d, f) +#define _FN1OPTP(t, s, d, f) _FN(OP_FCALL1, 0, 3, t, 0, s, d, f) +#define _FN2(t, u, s, d, f) _FN(OP_FCALL2, 2, 0, t, u, s, d, f) +#define _FN2OPT(t, u, s, d, f) _FN(OP_FCALL2, 1, 1, t, u, s, d, f) +#define _FN2OPTP(t, u, s, d, f) _FN(OP_FCALL2, 1, 3, t, u, s, d, f) +#define _FN3(t, u, s, d, f) _FN(OP_FCALL3, 3, 0, t, u, s, d, f) +#define _FN4(t, u, s, d, f) _FN(OP_FCALL4, 4, 0, t, u, s, d, f) +#define _FN5(t, u, s, d, f) _FN(OP_FCALL5, 5, 0, t, u, s, d, f) +#define _FN6(t, u, s, d, f) _FN(OP_FCALL6, 6, 0, t, u, s, d, f) #define _PARAM(n, a, t) _OP(OPC_PARAMETER, OP_NOOP, 0, 3, t, 0, 0, n, a, 0) static struct sexp_struct opcodes[] = { @@ -61,15 +64,14 @@ _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixn _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), +_FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read), +_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write), +_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display), +_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output), _FN2(0, 0, "equal?", 0, sexp_equalp), _FN1(0, "list?", 0, sexp_listp), _FN1(0, "identifier?", 0, sexp_identifierp), @@ -88,7 +90,8 @@ _FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), _FN0("make-environment", 0, sexp_make_env), _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), +_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval), +_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load), _FN3(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), _FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), diff --git a/sexp.c b/sexp.c index dd8dac2b..ea068bf4 100644 --- a/sexp.c +++ b/sexp.c @@ -863,7 +863,7 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { return p; } -void sexp_write (sexp ctx, sexp obj, sexp out) { +sexp sexp_write (sexp ctx, sexp obj, sexp out) { unsigned long len, c, res; long i=0; double f; @@ -1026,6 +1026,22 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { sexp_write_string(ctx, "#", out); } } + return SEXP_VOID; +} + +sexp sexp_display (sexp ctx, sexp obj, sexp out) { + if (sexp_stringp(obj)) + sexp_write_string(ctx, sexp_string_data(obj), out); + else if (sexp_charp(obj)) + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else + sexp_write(ctx, obj, out); + return SEXP_VOID; +} + +sexp sexp_flush_output (sexp ctx, sexp out) { + sexp_flush(ctx, out); + return SEXP_VOID; } #define INIT_STRING_BUFFER_SIZE 128 From 636e9d75c0c9ce6adfb576e567f36817c537478b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 18 Nov 2009 01:11:28 +0900 Subject: [PATCH 199/535] adding #! as a line-comment to support unix scripts --- sexp.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/sexp.c b/sexp.c index ea068bf4..bef4d6dd 100644 --- a/sexp.c +++ b/sexp.c @@ -1318,6 +1318,12 @@ sexp sexp_read_raw (sexp ctx, sexp in) { else goto scan_loop; break; + case '!': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + sexp_port_line(in)++; + goto scan_loop; case '\\': c1 = sexp_read_char(ctx, in); res = sexp_read_symbol(ctx, in, c1, 0); From 3a47a903e8d35c7e02391d9c237705c0becb462c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 22 Nov 2009 17:54:45 +0900 Subject: [PATCH 200/535] disasm defaults to printing to (current-error-port) --- opcodes.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/opcodes.c b/opcodes.c index c11154b9..04f7b4e6 100644 --- a/opcodes.c +++ b/opcodes.c @@ -137,7 +137,7 @@ _FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter), _FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter), #endif #if USE_DEBUG -_FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), +_FN2OPTP(SEXP_PROCEDURE, SEXP_OPORT, "disasm", (sexp)"*current-error-port*", sexp_disasm), #endif #if PLAN9 #include "opt/plan9-opcodes.c" From bb251082f69a616906c947c3c631a15c83bc2751 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 22 Nov 2009 18:14:46 +0900 Subject: [PATCH 201/535] fixing a small bug that missed some tail-recursion cases --- eval.c | 1 + init.scm | 4 +++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/eval.c b/eval.c index ac694626..6612907d 100644 --- a/eval.c +++ b/eval.c @@ -960,6 +960,7 @@ static void generate_general_app (sexp ctx, sexp app) { emit(ctx, (tailp ? OP_TAIL_CALL : OP_CALL)); emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); + sexp_context_tailp(ctx) = tailp; sexp_context_depth(ctx) -= len; sexp_gc_release1(ctx); } diff --git a/init.scm b/init.scm index b5b372e6..629d4de7 100644 --- a/init.scm +++ b/init.scm @@ -122,7 +122,9 @@ #f ((lambda (cl) (if (compare 'else (car cl)) - (cons (rename 'begin) (cdr cl)) + (if (pair? (cddr expr)) + (error "non-final else in cond" expr) + (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) From 3a55e2b6f397e7c89d28672655427e83f8f2f863 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 22 Nov 2009 18:20:24 +0900 Subject: [PATCH 202/535] moving debug.c to opt/ dir --- Makefile | 6 +++--- eval.c | 2 +- debug.c => opt/debug.c | 0 3 files changed, 4 insertions(+), 4 deletions(-) rename debug.c => opt/debug.c (100%) diff --git a/Makefile b/Makefile index b6350aa3..e14d865a 100644 --- a/Makefile +++ b/Makefile @@ -62,10 +62,10 @@ endif ifeq ($(USE_DL),0) XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm -XCFLAGS := -Wall -DUSE_DL=0 -g3 $(CFLAGS) +XCFLAGS := -Wall -DUSE_DL=0 -g3 -O2 $(CFLAGS) else XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -ldl -lm -XCFLAGS := -Wall -g3 $(CFLAGS) +XCFLAGS := -Wall -g3 -O2 $(CFLAGS) endif INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h @@ -77,7 +77,7 @@ include/chibi/install.h: Makefile sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< -eval.o: eval.c debug.c opcodes.c $(INCLUDES) include/chibi/eval.h Makefile +eval.o: eval.c opt/debug.c opcodes.c $(INCLUDES) include/chibi/eval.h Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile diff --git a/eval.c b/eval.c index 6612907d..f4a74b3b 100644 --- a/eval.c +++ b/eval.c @@ -17,7 +17,7 @@ static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; #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" +#include "opt/debug.c" #else #define print_stack(...) #define print_bytecode(...) diff --git a/debug.c b/opt/debug.c similarity index 100% rename from debug.c rename to opt/debug.c From 66bd9a52bb71613fc3094fd514470faeeb8559e3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 23 Nov 2009 01:13:42 +0900 Subject: [PATCH 203/535] no more globals! Each contexts keep a link to the heap which it is a part of (when using the native GC), as well as a vector of special globals that it needs quick access to (e.g. the `quote' and `quasiquote', etc. symbols. You can use this to manage multiple completely unrelated VMs in the same application, and everything will be thread-safe. The old behavior is still available by editing config.h, which now includes somewhat better descriptions of all the settings. --- README | 19 +++- eval.c | 208 ++++++++++++++++++----------------------- gc.c | 38 +++----- include/chibi/config.h | 84 ++++++++++++++++- include/chibi/eval.h | 13 +-- include/chibi/sexp.h | 69 ++++++++++++-- main.c | 2 +- opt/debug.c | 3 +- sexp.c | 131 +++++++++++++++++++------- 9 files changed, 374 insertions(+), 193 deletions(-) diff --git a/README b/README index 9e203db2..4357c8b3 100644 --- a/README +++ b/README @@ -43,16 +43,27 @@ The essential functions to remember are: #include - sexp_make_context(NULL, NULL, NULL) - returns a new context + sexp_make_eval_context(NULL, NULL, NULL) + returns a new context with a fresh stack and standard environment - sexp_eval(context, expr) - evaluates an s-expression + sexp_destroy_context(context) + free a context and all associated memory + + sexp_eval(context, expr, env) + evaluates an s-expression in an environment + env can be NULL to use the context's default env sexp_eval_string(context, str) reads an s-expression from str and evaluates it + sexp_load(context, file, env) + read and eval all top-level forms from file + + sexp_context_env(context) + a macro returning the environment associated with a context + sexp_env_define(context, env, symbol, value) + define a variable in an environment A minimal module system is provided by default. Currently you can load the following SRFIs with (import (srfi N)): diff --git a/eval.c b/eval.c index f4a74b3b..118127a0 100644 --- a/eval.c +++ b/eval.c @@ -8,14 +8,6 @@ static int scheme_initialized_p = 0; -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; - -#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),the_cur_out_symbol,SEXP_FALSE) -#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 "opt/debug.c" #else @@ -31,14 +23,14 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version); static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) { sexp exn; - sexp_gc_var2(irritants, msg); - sexp_gc_preserve2(ctx, irritants, msg); + sexp_gc_var3(sym, irritants, msg); + sexp_gc_preserve3(ctx, sym, irritants, msg); irritants = sexp_list1(ctx, obj); msg = sexp_c_string(ctx, message, -1); - exn = sexp_make_exception(ctx, the_compile_error_symbol, msg, irritants, + exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile"), msg, irritants, SEXP_FALSE, (sexp_pairp(obj) ? sexp_pair_source(obj) : SEXP_FALSE)); - sexp_gc_release2(ctx); + sexp_gc_release3(ctx); return exn; } @@ -156,7 +148,7 @@ static int sexp_param_index (sexp lambda, sexp name) { /************************* bytecode utilities ***************************/ -static void shrink_bcode(sexp ctx, sexp_uint_t i) { +static void shrink_bcode (sexp ctx, sexp_uint_t i) { sexp tmp; if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) { tmp = sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE); @@ -171,7 +163,7 @@ static void shrink_bcode(sexp ctx, sexp_uint_t i) { } } -static void expand_bcode(sexp ctx, sexp_uint_t size) { +static void expand_bcode (sexp ctx, sexp_uint_t size) { sexp tmp; if (sexp_bytecode_length(sexp_context_bc(ctx)) < (sexp_context_pos(ctx))+size) { @@ -191,12 +183,12 @@ static void expand_bcode(sexp ctx, sexp_uint_t size) { } } -static void emit(sexp ctx, char 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 ctx, sexp_uint_t val) { +static void emit_word (sexp ctx, sexp_uint_t val) { unsigned char *data; expand_bcode(ctx, sizeof(sexp)); data = sexp_bytecode_data(sexp_context_bc(ctx)); @@ -204,15 +196,21 @@ static void emit_word(sexp ctx, sexp_uint_t val) { sexp_context_pos(ctx) += sizeof(sexp); } -static void emit_push(sexp ctx, sexp obj) { +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(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); } -static sexp sexp_make_procedure(sexp ctx, sexp flags, sexp num_args, - sexp bc, sexp vars) { +static sexp finalize_bytecode (sexp ctx) { + emit(ctx, OP_RET); + shrink_bcode(ctx, sexp_context_pos(ctx)); + return sexp_context_bc(ctx); +} + +static sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args, + sexp bc, sexp vars) { 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; @@ -241,7 +239,7 @@ static sexp sexp_make_synclo (sexp ctx, sexp env, sexp fv, sexp expr) { /* internal AST */ -static sexp sexp_make_lambda(sexp ctx, sexp params) { +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; @@ -252,21 +250,21 @@ static sexp sexp_make_lambda(sexp ctx, sexp params) { return res; } -static sexp sexp_make_set(sexp ctx, sexp var, sexp value) { +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 ctx, sexp name, sexp cell) { +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 ctx, sexp test, sexp pass, sexp fail) { +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; @@ -274,57 +272,68 @@ static sexp sexp_make_cnd(sexp ctx, sexp test, sexp pass, sexp fail) { return res; } -static sexp sexp_make_lit(sexp ctx, sexp value) { +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; } -#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE) +/****************************** contexts ******************************/ -sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { +#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) + +void sexp_init_eval_context_globals (sexp ctx) { + ctx = sexp_make_child_context(ctx, NULL); + emit(ctx, OP_RESUMECC); + sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); + ctx = sexp_make_child_context(ctx, NULL); + emit(ctx, OP_DONE); + sexp_global(ctx, SEXP_G_FINAL_RESUMER) + = sexp_make_procedure(ctx, + sexp_make_fixnum(0), + sexp_make_fixnum(0), + finalize_bytecode(ctx), + sexp_make_vector(ctx, 0, SEXP_VOID)); + sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) + = sexp_intern(ctx, "final-resumer"); +} + +sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env) { sexp_gc_var1(res); if (ctx) sexp_gc_preserve1(ctx, res); - res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); - sexp_context_parent(res) = ctx; - sexp_context_lambda(res) = SEXP_FALSE; - sexp_context_fv(res) = SEXP_NULL; - sexp_context_saves(res) = 0; - sexp_context_depth(res) = 0; - sexp_context_pos(res) = 0; - sexp_context_tailp(res) = 1; - sexp_context_tracep(res) = 0; + res = sexp_make_context(ctx); + sexp_context_bc(res) + = sexp_alloc_tagged(res, sexp_sizeof(bytecode)+SEXP_INIT_BCODE_SIZE, + SEXP_BYTECODE); + sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; + sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE; + sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; if ((! stack) || (stack == SEXP_FALSE)) { - stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK); - sexp_stack_length(stack) = INIT_STACK_SIZE; + stack = sexp_alloc_tagged(res, SEXP_STACK_SIZE, SEXP_STACK); + sexp_stack_length(stack) = SEXP_INIT_STACK_SIZE; sexp_stack_top(stack) = 0; } sexp_context_stack(res) = stack; + if (! ctx) sexp_init_eval_context_globals(res); sexp_context_env(res) = (env ? env : sexp_make_standard_env(res, sexp_make_fixnum(5))); - sexp_context_bc(res) - = 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; if (ctx) sexp_gc_release1(ctx); return res; } -sexp sexp_make_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); - sexp_context_fv(ctx) = sexp_context_fv(context); - sexp_context_tracep(ctx) = sexp_context_tracep(context); - return ctx; +sexp sexp_make_child_context (sexp ctx, sexp lambda) { + sexp res = sexp_make_eval_context(ctx, + sexp_context_stack(ctx), + sexp_context_env(ctx)); + sexp_context_lambda(res) = lambda; + sexp_context_top(res) = sexp_context_top(ctx); + sexp_context_fv(res) = sexp_context_fv(ctx); + sexp_context_tracep(res) = sexp_context_tracep(ctx); + return res; } +/**************************** identifiers *****************************/ + static sexp sexp_identifierp (sexp ctx, sexp x) { return sexp_make_boolean(sexp_idp(x)); } @@ -353,7 +362,7 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) { return res; } -static sexp sexp_identifier_eq(sexp ctx, 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); @@ -742,12 +751,6 @@ static void sexp_context_patch_label (sexp ctx, sexp_sint_t 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); } @@ -980,7 +983,7 @@ static void generate_lambda (sexp ctx, sexp lambda) { 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_eval_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)) @@ -1120,7 +1123,7 @@ static sexp free_vars (sexp ctx, sexp x, sexp fv) { return fv1; } -static sexp make_param_list(sexp ctx, sexp_uint_t i) { +static sexp make_param_list (sexp ctx, sexp_uint_t i) { sexp_gc_var1(res); sexp_gc_preserve1(ctx, res); res = SEXP_NULL; @@ -1160,7 +1163,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { /*********************** the virtual machine **************************/ -static sexp sexp_save_stack(sexp ctx, 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(ctx, sexp_make_fixnum(to), SEXP_VOID); @@ -1170,7 +1173,7 @@ static sexp sexp_save_stack(sexp ctx, sexp *stack, sexp_uint_t to) { return res; } -static 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= INIT_STACK_SIZE) + if (top+16 >= SEXP_INIT_STACK_SIZE) errx(70, "out of stack space at %ld", top); #endif i = sexp_unbox_fixnum(_WORD0); @@ -1851,9 +1855,11 @@ sexp sexp_vm (sexp ctx, sexp proc) { if (sexp_flonump(_ARG1)) { if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); +#if USE_BIGNUMS } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); +#endif } else { _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); } @@ -2015,14 +2021,13 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp_gc_preserve4(ctx, ctx2, x, in, res); res = SEXP_VOID; in = sexp_open_input_file(ctx, source); - out = sexp_env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); - ctx2 = sexp_make_context(ctx, NULL, env); + out = sexp_current_error_port(ctx); + ctx2 = sexp_make_eval_context(ctx, NULL, env); sexp_context_parent(ctx2) = ctx; tmp = sexp_env_bindings(env); sexp_context_tailp(ctx2) = 0; if (sexp_exceptionp(in)) { - if (sexp_not(out)) - out = sexp_env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE); + if (sexp_not(out)) out = sexp_current_error_port(ctx); if (sexp_oportp(out)) sexp_print_exception(ctx, in, out); res = in; @@ -2124,8 +2129,10 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { if ((f > SEXP_MAX_FIXNUM) || sexp_flonump(x) || sexp_flonump(e)) { if (sexp_flonump(x) || sexp_flonump(e)) res = sexp_make_flonum(ctx, f); +#if USE_BIGNUMS else res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); +#endif } else #endif res = sexp_make_fixnum((sexp_sint_t)round(f)); @@ -2331,19 +2338,19 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); } /* add io port and interaction env parameters */ - sexp_env_define(ctx, e, the_cur_in_symbol, + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), sexp_make_input_port(ctx, stdin, SEXP_FALSE)); - sexp_env_define(ctx, e, the_cur_out_symbol, + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), sexp_make_output_port(ctx, stdout, SEXP_FALSE)); - sexp_env_define(ctx, e, the_cur_err_symbol, + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), sexp_make_output_port(ctx, stderr, SEXP_FALSE)); - sexp_env_define(ctx, e, the_interaction_env_symbol, e); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); sexp_env_define(ctx, e, sexp_intern(ctx, "*module-directory*"), sexp_c_string(ctx, sexp_module_dir, -1)); /* add default exception handler */ - err_cell = sexp_env_cell(e, the_cur_err_symbol); + err_cell = sexp_env_cell(e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL)); perr_cell = sexp_env_cell(e, sexp_intern(ctx, "print-exception")); - ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), e); + ctx2 = sexp_make_eval_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); @@ -2361,7 +2368,7 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_make_fixnum(0), finalize_bytecode(ctx2), tmp); - sexp_env_define(ctx2, e, the_err_handler_symbol, err_handler); + sexp_env_define(ctx2, e, sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL), err_handler); sexp_gc_release4(ctx); return e; } @@ -2404,7 +2411,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { stack[top] = sexp_make_fixnum(len); top++; stack[top++] = sexp_make_fixnum(0); - stack[top++] = final_resumer; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); stack[top++] = sexp_make_fixnum(0); sexp_context_top(ctx) = top; res = sexp_vm(ctx, proc); @@ -2434,13 +2441,10 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) { sexp res, ctx2; sexp_gc_var1(thunk); sexp_gc_preserve1(ctx, thunk); - ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); + ctx2 = sexp_make_eval_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); thunk = sexp_compile(ctx2, obj); if (sexp_exceptionp(thunk)) { - sexp_print_exception(ctx2, thunk, - sexp_env_global_ref(sexp_context_env(ctx2), - the_cur_err_symbol, - SEXP_FALSE)); + sexp_print_exception(ctx2, thunk, sexp_current_error_port(ctx)); res = thunk; } else { res = sexp_apply(ctx2, thunk, SEXP_NULL); @@ -2460,34 +2464,8 @@ sexp sexp_eval_string (sexp ctx, char *str, sexp env) { } void sexp_scheme_init (void) { - sexp ctx; if (! scheme_initialized_p) { scheme_initialized_p = 1; sexp_init(); - 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); - GC_add_roots((char*)&final_resumer, - ((char*)&final_resumer)+sizeof(continuation_resumer)+1); - GC_add_roots((char*)&opcodes, ((char*)&opcodes)+sizeof(opcodes)+1); -#endif - emit(ctx, OP_RESUMECC); - continuation_resumer = finalize_bytecode(ctx); - ctx = sexp_make_child_context(ctx, NULL); - emit(ctx, OP_DONE); - final_resumer = sexp_make_procedure(ctx, - sexp_make_fixnum(0), - sexp_make_fixnum(0), - finalize_bytecode(ctx), - sexp_make_vector(ctx, 0, SEXP_VOID)); - sexp_bytecode_name(sexp_procedure_code(final_resumer)) - = sexp_intern(ctx, "final-resumer"); } } diff --git a/gc.c b/gc.c index c0ef988b..290e6e38 100644 --- a/gc.c +++ b/gc.c @@ -15,28 +15,14 @@ #define sexp_heap_align(n) sexp_align(n, 4) #endif -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 free_list; - sexp_heap next; - char *data; -}; - -static sexp_heap heap; +#if USE_GLOBAL_HEAP +static sexp_heap sexp_global_heap; +#endif #if USE_DEBUG_GC static sexp* stack_base; #endif -extern sexp continuation_resumer, final_resumer; - static sexp_heap sexp_heap_last (sexp_heap h) { while (h->next) h = h->next; return h; @@ -88,7 +74,7 @@ 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_heap h = sexp_context_heap(ctx); sexp p; sexp_free_list q, r, s; char *end; @@ -150,11 +136,11 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { sexp sexp_gc (sexp ctx, size_t *sum_freed) { sexp res; +#if USE_GLOBAL_SYMBOLS int i; - sexp_mark(continuation_resumer); - sexp_mark(final_resumer); for (i=0; isize; new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2); h->next = sexp_make_heap(new_size); @@ -189,7 +175,7 @@ int sexp_grow_heap (sexp ctx, size_t size) { 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 (h=sexp_context_heap(ctx); 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)) { @@ -214,7 +200,7 @@ void* sexp_alloc (sexp ctx, size_t size) { res = sexp_try_alloc(ctx, size); if (! res) { max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed)); - h = sexp_heap_last(heap); + h = sexp_heap_last(sexp_context_heap(ctx)); if (((max_freed < size) || ((h->size - sum_freed) < (h->size*(1 - SEXP_GROW_HEAP_RATIO)))) && ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE))) @@ -227,8 +213,12 @@ void* sexp_alloc (sexp ctx, size_t size) { } void sexp_gc_init (void) { +#if USE_GLOBAL_HEAP || USE_DEBUG_GC sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); - heap = sexp_make_heap(size); +#endif +#if USE_GLOBAL_HEAP + sexp_global_heap = sexp_make_heap(size); +#endif #if USE_DEBUG_GC /* the +32 is a hack, but this is just for debugging anyway */ stack_base = ((sexp*)&size) + 32; diff --git a/include/chibi/config.h b/include/chibi/config.h index e539ebf3..f033e622 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -3,53 +3,109 @@ /* BSD-style license: http://synthcode.com/license.txt */ /* uncomment this to disable the module system */ +/* Currently this just loads the config.scm from main and */ +/* sets up an (import (module name)) macro. */ /* #define USE_MODULES 0 */ /* uncomment this to disable dynamic loading */ +/* If enabled, you can LOAD .so files with a */ +/* sexp_init_library(ctx, env) function provided. */ /* #define USE_DL 0 */ /* uncomment this to disable dynamic type definitions */ +/* This enables register-simple-type and related */ +/* opcodes for defining types, needed by the default */ +/* implementation of (srfi 9). */ /* #define USE_TYPE_DEFS 0 */ /* uncomment this to use the Boehm conservative GC */ +/* Conservative GCs make it easier to write extensions, */ +/* since you don't have to keep track of intermediate */ +/* variables, but can leak memory. Boehm is also a */ +/* very large library to link in. You may want to */ +/* enable this when debugging your own extensions, or */ +/* if you suspect a bug in the native GC. */ /* #define USE_BOEHM 1 */ /* uncomment this to just malloc manually instead of any GC */ +/* Mostly for debugging purposes, this is the no GC option. */ +/* You can use the just with the read/write API and */ +/* explicitly free sexps though. */ /* #define USE_MALLOC 1 */ /* uncomment this to add conservative checks to the native GC */ +/* Please mail the author if enabling this makes a bug */ +/* go away and you're not working on your own C extension. */ /* #define USE_DEBUG_GC 1 */ -/* uncomment this if you only want fixnum support */ +/* uncomment this to make the heap common to all contexts */ +/* By default separate contexts can have separate heaps, */ +/* and are thus thread-safe and independant. */ +/* #define USE_GLOBAL_HEAP 1 */ + +/* uncomment this to make the symbol table common to all contexts */ +/* Will still be restricted to all contexts sharing the same */ +/* heap, of course. */ +/* #define USE_GLOBAL_SYMBOLS 1 */ + +/* uncomment this if you don't need flonum support */ +/* This is only for EVAL - you'll still be able to read */ +/* and write flonums directly through the sexp API. */ /* #define USE_FLONUMS 0 */ /* uncomment this if you want immediate flonums */ +/* This is experimental, enablde at your own risk. */ /* #define USE_IMMEDIATE_FLONUMS 1 */ /* uncomment this if you don't want bignum support */ +/* Bignums are implemented with a small, custom library */ +/* in opt/bignum.c. */ /* #define USE_BIGNUMS 0 */ /* uncomment this if you don't need extended math operations */ +/* This includes the trigonometric and expt functions. */ +/* Automatically disabled if you've disabled flonums. */ /* #define USE_MATH 0 */ /* uncomment this to disable warning about references to undefined variables */ +/* This is something of a hack, but can be quite useful. */ +/* It's very fast and doesn't involve any separate analysis */ +/* passes. */ /* #define USE_WARN_UNDEFS 0 */ /* uncomment this to disable huffman-coded immediate symbols */ +/* By default (this may change) small symbols are represented */ +/* as immediates using a simple huffman encoding. This keeps */ +/* the symbol table small, and minimizes hashing when doing a */ +/* lot of reading. */ /* #define USE_HUFF_SYMS 0 */ /* uncomment this to just use a single list for hash tables */ +/* You can trade off some space in exchange for longer read */ +/* times by disabling hashing and just putting all */ +/* non-immediate symbols in a single list. */ /* #define USE_HASH_SYMS 0 */ /* uncomment this to disable string ports */ +/* If disabled some basic functionality such as number->string */ +/* will not be available by default. */ /* #define USE_STRING_STREAMS 0 */ -/* uncomment this to enable stack overflow checks */ -/* #define USE_CHECK_STACK 1 */ +/* uncomment this to disable stack overflow checks */ +/* By default stacks are fairly small, so it's good to leave */ +/* this enabled. */ +/* #define USE_CHECK_STACK 0 */ /* uncomment this to disable debugging utilities */ +/* By default there's a `disasm' procedure you can use to */ +/* view the compiled VM instructions of a procedure. You can */ +/* disable this if you don't need it. */ /* #define USE_DEBUG 0 */ +/* #define USE_DEBUG_VM 0 */ +/* Experts only. */ +/* For *very* verbose output on every VM operation. */ + /************************************************************************/ /* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ /************************************************************************/ @@ -101,6 +157,22 @@ #define USE_DEBUG_GC 0 #endif +#ifndef USE_GLOBAL_HEAP +#if USE_BOEHM || USE_MALLOC +#define USE_GLOBAL_HEAP 1 +#else +#define USE_GLOBAL_HEAP 0 +#endif +#endif + +#ifndef USE_GLOBAL_SYMBOLS +#if USE_BOEHM || USE_MALLOC +#define USE_GLOBAL_SYMBOLS 1 +#else +#define USE_GLOBAL_SYMBOLS 0 +#endif +#endif + #ifndef USE_FLONUMS #define USE_FLONUMS 1 #endif @@ -114,7 +186,7 @@ #endif #ifndef USE_MATH -#define USE_MATH 1 +#define USE_MATH USE_FLONUMS #endif #ifndef USE_WARN_UNDEFS @@ -133,6 +205,10 @@ #define USE_DEBUG 1 #endif +#ifndef USE_DEBUG_VM +#define USE_DEBUG_VM 0 +#endif + #ifndef USE_STRING_STREAMS #define USE_STRING_STREAMS 1 #endif diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 5137b235..f7340132 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -9,13 +9,13 @@ /************************* additional types ***************************/ -#define INIT_BCODE_SIZE 128 -#define INIT_STACK_SIZE 8192 +#define SEXP_INIT_BCODE_SIZE 128 +#define SEXP_INIT_STACK_SIZE 8192 #define sexp_init_file "init.scm" #define sexp_config_file "config.scm" -enum core_form_names { +enum sexp_core_form_names { CORE_DEFINE = 1, CORE_SET, CORE_LAMBDA, @@ -27,7 +27,7 @@ enum core_form_names { CORE_LETREC_SYNTAX }; -enum opcode_classes { +enum sexp_opcode_classes { OPC_GENERIC = 1, OPC_TYPE_PREDICATE, OPC_PREDICATE, @@ -42,7 +42,7 @@ enum opcode_classes { OPC_NUM_OP_CLASSES }; -enum opcode_names { +enum sexp_opcode_names { OP_NOOP, OP_RAISE, OP_RESUMECC, @@ -120,6 +120,8 @@ enum opcode_names { /**************************** prototypes ******************************/ SEXP_API void sexp_scheme_init (void); +SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env); +SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); @@ -127,7 +129,6 @@ SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); SEXP_API sexp sexp_make_env (sexp context); SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls); SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val); -SEXP_API sexp sexp_make_context (sexp context, sexp stack, sexp env); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 7152b806..6dc5a43f 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -127,6 +127,20 @@ 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 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 free_list; + sexp_heap next; + char *data; +}; + struct sexp_gc_var_t { sexp *var; /* char *name; */ @@ -239,9 +253,10 @@ struct sexp_struct { sexp data[]; } stack; struct { + sexp_heap heap; struct sexp_gc_var_t *saves; sexp_uint_t pos, depth, tailp, tracep; - sexp bc, lambda, stack, env, fv, parent; + sexp bc, lambda, stack, env, fv, parent, globals; } context; } value; }; @@ -561,8 +576,6 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #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) @@ -574,6 +587,21 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #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_globals(x) ((x)->value.context.globals) + +#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) + +#if USE_GLOBAL_HEAP +#define sexp_context_heap(ctx) sexp_global_heap +#else +#define sexp_context_heap(ctx) ((ctx)->value.context.heap) +#endif + +#if USE_GLOBAL_SYMBOLS +#define sexp_context_symbols(ctx) sexp_symbol_table +#else +#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) +#endif #define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) @@ -613,6 +641,25 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); /****************************** utilities *****************************/ +enum sexp_context_globals { +#if ! USE_GLOBAL_SYMBOLS + SEXP_G_SYMBOLS, +#endif + SEXP_G_QUOTE_SYMBOL, + SEXP_G_QUASIQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SPLICING_SYMBOL, + SEXP_G_EMPTY_VECTOR, + SEXP_G_CUR_IN_SYMBOL, + SEXP_G_CUR_OUT_SYMBOL, + SEXP_G_CUR_ERR_SYMBOL, + SEXP_G_ERR_HANDLER_SYMBOL, + SEXP_G_INTERACTION_ENV_SYMBOL, + SEXP_G_RESUMECC_BYTECODE, + SEXP_G_FINAL_RESUMER, + SEXP_G_NUM_GLOBALS +}; + #define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL) #define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) @@ -668,6 +715,7 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); #define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) SEXP_API struct sexp_struct *sexp_type_specs; +SEXP_API sexp sexp_make_context(sexp ctx); 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); @@ -704,16 +752,25 @@ 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 source); -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_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(void); +#if USE_GLOBAL_HEAP +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_destroy_context(sexp ctx); +#endif + #if USE_TYPE_DEFS SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots); #endif +#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) +#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))) + #endif /* ! SEXP_H */ diff --git a/main.c b/main.c index 961791c7..2a24db43 100644 --- a/main.c +++ b/main.c @@ -128,7 +128,7 @@ void run_main (int argc, char **argv) { sexp_uint_t i, quit=0, init_loaded=0; sexp_gc_var1(str); - ctx = sexp_make_context(NULL, NULL, NULL); + ctx = sexp_make_eval_context(NULL, NULL, NULL); sexp_gc_preserve1(ctx, str); env = sexp_context_env(ctx); out = sexp_eval_string(ctx, "(current-output-port)", env); diff --git a/opt/debug.c b/opt/debug.c index 051e4123..0df9ea17 100644 --- a/opt/debug.c +++ b/opt/debug.c @@ -65,9 +65,10 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { return SEXP_VOID; } -#ifdef DEBUG_VM +#if USE_DEBUG_VM static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { int i; + if (! sexp_oport(out)) out = sexp_current_error_port(ctx); for (i=0; i Date: Mon, 23 Nov 2009 01:54:22 +0900 Subject: [PATCH 204/535] cleanup, making infinities optional, fixing build for plan9 --- config.scm | 3 ++- eval.c | 2 ++ include/chibi/config.h | 12 ++++++++++ lib/srfi/1.module | 6 ++--- lib/srfi/1/fold.scm | 2 +- lib/srfi/1/misc.scm | 15 ++++--------- lib/srfi/1/predicates.scm | 8 +++++++ opcodes.c | 2 +- opt/plan9.c | 47 ++++++++++++++++++++++++--------------- sexp.c | 12 +++++++--- 10 files changed, 71 insertions(+), 38 deletions(-) diff --git a/config.scm b/config.scm index 1208c201..0a8f0f5c 100644 --- a/config.scm +++ b/config.scm @@ -108,7 +108,8 @@ 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 + null? list? list length append reverse 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? diff --git a/eval.c b/eval.c index 118127a0..fec23de4 100644 --- a/eval.c +++ b/eval.c @@ -1976,12 +1976,14 @@ static sexp sexp_close_port (sexp ctx, sexp port) { return SEXP_VOID; } +#ifndef PLAN9 static sexp sexp_file_exists_p (sexp ctx, sexp path) { struct stat buf; if (! sexp_stringp(path)) return sexp_type_exception(ctx, "not a string", path); return (stat(sexp_string_data(path), &buf) ? SEXP_FALSE : SEXP_TRUE); } +#endif void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) { sexp x; diff --git a/include/chibi/config.h b/include/chibi/config.h index f033e622..4b9957b7 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -53,6 +53,10 @@ /* and write flonums directly through the sexp API. */ /* #define USE_FLONUMS 0 */ +/* uncomment this to disable reading/writing IEEE infinities */ +/* By default you can read/write +inf.0, -inf.0 and +nan.0 */ +/* #define USE_INFINITIES 0 */ + /* uncomment this if you want immediate flonums */ /* This is experimental, enablde at your own risk. */ /* #define USE_IMMEDIATE_FLONUMS 1 */ @@ -177,6 +181,14 @@ #define USE_FLONUMS 1 #endif +#ifndef USE_INFINITIES +#if defined(PLAN9) || ! USE_FLONUMS +#define USE_INFINITIES 0 +#else +#define USE_INFINITIES 1 +#endif +#endif + #ifndef USE_IMMEDIATE_FLONUMS #define USE_IMMEDIATE_FLONUMS 0 #endif diff --git a/lib/srfi/1.module b/lib/srfi/1.module index 1d76a116..93477756 100644 --- a/lib/srfi/1.module +++ b/lib/srfi/1.module @@ -19,11 +19,11 @@ lset-intersection! lset-difference lset-difference! lset-xor lset-xor! lset-diff+intersection lset-diff+intersection!) (import (scheme)) - (include "srfi/1/constructors.scm" - "srfi/1/predicates.scm" + (include "srfi/1/predicates.scm" "srfi/1/selectors.scm" - "srfi/1/misc.scm" "srfi/1/search.scm" + "srfi/1/misc.scm" + "srfi/1/constructors.scm" "srfi/1/fold.scm" "srfi/1/deletion.scm" "srfi/1/alists.scm" diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm index 8bb25b4a..4c0c2afa 100644 --- a/lib/srfi/1/fold.scm +++ b/lib/srfi/1/fold.scm @@ -59,7 +59,7 @@ (let lp ((ls (cdr rev-ls)) (res (car rev-ls))) (if (null? ls) res (lp (cdr ls) (append (f (car ls) res)))) ))) - (if (and (pair? ls) (every pair lists)) + (if (and (pair? ls) (every pair? lists)) (let lp ((lists (cons ls lists))) (let ((vals (apply f (map car lists))) (cdrs (map cdr lists))) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm index 20011c44..c40afa1d 100644 --- a/lib/srfi/1/misc.scm +++ b/lib/srfi/1/misc.scm @@ -3,18 +3,11 @@ (let lp ((ls ls) (res init)) (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res))))) -(define (length+ x) - (if (not (pair? x)) - 0 - (let lp ((hare (cdr x)) (tortoise x) (res 0)) - (and (not (eq? hare tortoise)) - (if (pair? hare) - (lp (cddr hare) (cdr tortoise) (+ res 1)) - res))))) - (define (append! . lists) (concatenate! lists)) -(define (concatenate lists) (reduce-right append '() lists)) +(define (concatenate lists) + (let lp ((ls (reverse lists)) (res '())) + (if (null? ls) res (lp (cdr ls) (append (car ls) res))))) (define (concatenate! lists) (if (null? lists) @@ -45,7 +38,7 @@ (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) (define (unzip5 ls) (values (map car ls) (map cadr ls) (map caddr ls) - (map cadddr ls) (map fifth ls))) + (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls))) (define (count pred ls . lists) (if (null? lists) diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm index fe1dc77b..70144660 100644 --- a/lib/srfi/1/predicates.scm +++ b/lib/srfi/1/predicates.scm @@ -29,3 +29,11 @@ (and (eq (car ls1) (car ls2)) (lp2 (cdr ls1) (cdr ls2)))))))) +(define (length+ x) + (if (not (pair? x)) + 0 + (let lp ((hare (cdr x)) (tortoise x) (res 0)) + (and (not (eq? hare tortoise)) + (if (pair? hare) + (lp (cddr hare) (cdr tortoise) (+ res 1)) + res))))) diff --git a/opcodes.c b/opcodes.c index 04f7b4e6..28f2aa2e 100644 --- a/opcodes.c +++ b/opcodes.c @@ -86,7 +86,6 @@ _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_STRING, "file-exists?", 0, sexp_file_exists_p), _FN0("make-environment", 0, sexp_make_env), _FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), _FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), @@ -142,5 +141,6 @@ _FN2OPTP(SEXP_PROCEDURE, SEXP_OPORT, "disasm", (sexp)"*current-error-port*", sex #if PLAN9 #include "opt/plan9-opcodes.c" #endif +_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), }; diff --git a/opt/plan9.c b/opt/plan9.c index 024e37d0..68346ab8 100644 --- a/opt/plan9.c +++ b/opt/plan9.c @@ -3,21 +3,30 @@ /* BSD-style license: http://synthcode.com/license.txt */ sexp sexp_rand (sexp ctx) { - return sexp_make_integer(rand()); + return sexp_make_fixnum(rand()); } sexp sexp_srand (sexp ctx, sexp seed) { - srand(sexp_unbox_integer(seed)); + srand(sexp_unbox_fixnum(seed)); return SEXP_VOID; } +sexp sexp_file_exists_p (sexp ctx, sexp path) { + int res; + uchar statbuf[STATMAX]; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "file-exists?: not a string", path); + res = stat(sexp_string_data(path), statbuf, sizeof(statbuf)); + return (res < 0) ? SEXP_FALSE : SEXP_TRUE; +} + sexp sexp_fdopen (sexp ctx, sexp fd, sexp mode) { FILE *f; if (! sexp_integerp(fd)) return sexp_type_exception(ctx, "fdopen: not an integer", fd); if (! sexp_stringp(mode)) return sexp_type_exception(ctx, "fdopen: not a mode string", mode); - f = fdopen(sexp_unbox_integer(fd), sexp_string_data(mode)); + f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode)); if (! f) return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd); /* maybe use fd2path to get the name of the fd */ @@ -30,15 +39,15 @@ sexp sexp_fdopen (sexp ctx, sexp fd, sexp mode) { sexp sexp_fileno (sexp ctx, sexp port) { if (! sexp_portp(port)) return sexp_type_exception(ctx, "fileno: not a port", port); - return sexp_make_integer(fileno(sexp_port_stream(port))); + return sexp_make_fixnum(fileno(sexp_port_stream(port))); } sexp sexp_fork (sexp ctx) { - return sexp_make_integer(fork()); + return sexp_make_fixnum(fork()); } sexp sexp_exec (sexp ctx, sexp name, sexp args) { - int i, len = sexp_unbox_integer(sexp_length(ctx, args)); + int i, len = sexp_unbox_fixnum(sexp_length(ctx, args)); char **argv = malloc((len+1)*sizeof(char*)); for (i=0; imsg, -1); - res = sexp_list2(ctx, sexp_make_integer(wmsg->pid), msg); + res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg); sexp_gc_release(ctx, msg, s_msg); return res; } @@ -116,7 +125,7 @@ sexp sexp_postnote (sexp ctx, sexp pid, sexp note) { return sexp_type_exception(ctx, "postnote: not an integer", pid); if (! sexp_stringp(note)) return sexp_type_exception(ctx, "postnote: not a string", note); - postnote(PNPROC, sexp_unbox_integer(pid), sexp_string_data(note)); + postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note)); return SEXP_VOID; } @@ -303,28 +312,30 @@ sexp sexp_postmountsrv (sexp ctx, sexp ls, sexp name, sexp mtpt, sexp flags) { s.destroyreq = &sexp_9p_destroyreq; s.end = &sexp_9p_end; postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt), - sexp_unbox_integer(flags)); + sexp_unbox_fixnum(flags)); return SEXP_UNDEF; } sexp sexp_9p_req_offset (sexp ctx, sexp req) { - return sexp_make_integer(ctx, (Req*)sexp_cpointer_value(req)->ifcall.offset); + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset); } sexp sexp_9p_req_count (sexp ctx, sexp req) { - return sexp_make_integer(ctx, (Req*)sexp_cpointer_value(req)->ifcall.count); + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count); } +#if 0 sexp sexp_9p_req_path (sexp ctx, sexp req) { - return sexp_c_string(ctx, (Req*)sexp_cpointer_value(req)->fid.qid.path, -1); + return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1); } +#endif sexp sexp_9p_req_fid (sexp ctx, sexp req) { - return sexp_make_cpointer(ctx, (Req*)sexp_cpointer_value(req)->fid); + return sexp_make_cpointer(ctx, ((Req*)sexp_cpointer_value(req))->fid); } sexp sexp_9p_req_newfid (sexp ctx, sexp req) { - return sexp_make_cpointer(ctx, (Req*)sexp_cpointer_value(req)->newfid); + return sexp_make_cpointer(ctx, ((Req*)sexp_cpointer_value(req))->newfid); } sexp sexp_9p_respond (sexp ctx, sexp req, sexp err) { diff --git a/sexp.c b/sexp.c index d0b9a8c9..64650fc1 100644 --- a/sexp.c +++ b/sexp.c @@ -976,10 +976,13 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) { #if ! USE_IMMEDIATE_FLONUMS case SEXP_FLONUM: f = sexp_flonum_value(obj); +#if USE_INFINITIES if (isinf(f) || isnan(f)) { numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); - } else { + } else +#endif + { i = sprintf(numbuf, "%.15g", f); if (f == trunc(f) && ! strchr(numbuf, '.')) { numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; @@ -1039,10 +1042,13 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) { #if USE_IMMEDIATE_FLONUMS } else if (sexp_flonump(obj)) { f = sexp_flonum_value(obj); +#if USE_INFINITIES if (isinf(f) || isnan(f)) { numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); - } else { + } else +#endif + { i = sprintf(numbuf, "%.15g", f); if (f == trunc(f) && ! strchr(numbuf, '.')) { numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; @@ -1485,7 +1491,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } else { sexp_push_char(ctx, c2, in); res = sexp_read_symbol(ctx, in, c1, 1); -#if USE_FLONUMS +#if USE_INFINITIES if (res == sexp_intern(ctx, "+inf.0")) res = sexp_make_flonum(ctx, 1.0/0.0); else if (res == sexp_intern(ctx, "-inf.0")) From 671b98321488a98710b4eb098df253d79ad681eb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 23 Nov 2009 02:07:05 +0900 Subject: [PATCH 205/535] adding (chibi match) module --- TODO | 2 +- include/chibi/sexp.h | 2 + lib/chibi/match.module | 6 + lib/chibi/match/match.scm | 589 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 598 insertions(+), 1 deletion(-) create mode 100644 lib/chibi/match.module create mode 100644 lib/chibi/match/match.scm diff --git a/TODO b/TODO index e9cb620b..ef3a06c0 100644 --- a/TODO +++ b/TODO @@ -2,7 +2,7 @@ *+ precise gc rewrite **+ fix heap growing -**- separate gc heaps +**+ separate gc heaps **- finalizers **- weak references *+ ast rewrite diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 6dc5a43f..d9b1d87e 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -161,6 +161,7 @@ struct sexp_struct { short size_base, size_off; unsigned short size_scale; char *name; + sexp_proc2 finalize; } type; struct { sexp car, cdr; @@ -615,6 +616,7 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #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_type_finalize(x) ((x)->value.type.finalize) #define sexp_bignum_sign(x) ((x)->value.bignum.sign) #define sexp_bignum_length(x) ((x)->value.bignum.length) diff --git a/lib/chibi/match.module b/lib/chibi/match.module new file mode 100644 index 00000000..87382e95 --- /dev/null +++ b/lib/chibi/match.module @@ -0,0 +1,6 @@ + +(define-module (chibi match) + (export match match-lambda match-lambda* match-let match-letrec match-let*) + (import (scheme)) + (include "chibi/match/match.scm")) + diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm new file mode 100644 index 00000000..6557ac0e --- /dev/null +++ b/lib/chibi/match/match.scm @@ -0,0 +1,589 @@ +;;;; match.scm -- portable hygienic pattern matcher +;; +;; This code is written by Alex Shinn and placed in the +;; Public Domain. All warranties are disclaimed. + +;; This is a full superset of the popular MATCH package by Andrew +;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks +;; in R6RS SYNTAX-RULES), and thus preserving hygiene. + +;; This is a simple generative pattern matcher - each pattern is +;; expanded into the required tests, calling a failure continuation if +;; the tests fail. This makes the logic easy to follow and extend, +;; but produces sub-optimal code in cases where you have many similar +;; clauses due to repeating the same tests. Nonetheless a smart +;; compiler should be able to remove the redundant tests. For +;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance +;; hit. + +;; The original version was written on 2006/11/29 and described in the +;; following Usenet post: +;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd +;; and is still available at +;; http://synthcode.com/scheme/match-simple.scm +;; A variant of this file which uses COND-EXPAND in a few places can +;; be found at +;; http://synthcode.com/scheme/match-cond-expand.scm +;; +;; 2008/03/20 - fixing bug where (a ...) matched non-lists +;; 2008/03/15 - removing redundant check in vector patterns +;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) +;; 2007/09/04 - fixing quasiquote patterns +;; 2007/07/21 - allowing ellipse patterns in non-final list positions +;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse +;; (thanks to Taylor Campbell) +;; 2007/04/08 - clean up, commenting +;; 2006/12/24 - bugfixes +;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; force compile-time syntax errors with useful messages + +(define-syntax match-syntax-error + (syntax-rules () + ((_) + (match-syntax-error "invalid match-syntax-error usage")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The basic interface. MATCH just performs some basic syntax +;; validation, binds the match expression to a temporary variable `v', +;; and passes it on to MATCH-NEXT. It's a constant throughout the +;; code below that the binding `v' is a direct variable reference, not +;; an expression. + +(define-syntax match + (syntax-rules () + ((match) + (match-syntax-error "missing match expression")) + ((match atom) + (match-syntax-error "missing match clause")) + ((match (app ...) (pat . body) ...) + (let ((v (app ...))) + (match-next v (app ...) (set! (app ...)) (pat . body) ...))) + ((match #(vec ...) (pat . body) ...) + (let ((v #(vec ...))) + (match-next v v (set! v) (pat . body) ...))) + ((match atom (pat . body) ...) + (match-next atom atom (set! atom) (pat . body) ...)) + )) + +;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure +;; thunk, which is expanded by recursing MATCH-NEXT on the remaining +;; clauses. `g' and `s' are the get! and set! expressions +;; respectively. + +(define-syntax match-next + (syntax-rules (=>) + ;; no more clauses, the match failed + ((match-next v g s) + (error 'match "no matching pattern")) + ;; named failure continuation + ((match-next v g s (pat (=> failure) . body) . rest) + (let ((failure (lambda () (match-next v g s . rest)))) + ;; match-one analyzes the pattern for us + (match-one v pat g s (match-drop-ids (begin . body)) (failure) ()))) + ;; anonymous failure continuation, give it a dummy name + ((match-next v g s (pat . body) . rest) + (match-next v g s (pat (=> failure) . body) . rest)))) + +;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to +;; MATCH-TWO. + +(define-syntax match-one + (syntax-rules () + ;; If it's a list of two values, check to see if the second one is + ;; an ellipse and handle accordingly, otherwise go to MATCH-TWO. + ((match-one v (p q . r) g s sk fk i) + (match-check-ellipse + q + (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ()) + (match-two v (p q . r) g s sk fk i))) + ;; Otherwise, go directly to MATCH-TWO. + ((match-one . x) + (match-two . x)))) + +;; This is the guts of the pattern matcher. We are passed a lot of +;; information in the form: +;; +;; (match-two var pattern getter setter success-k fail-k (ids ...)) +;; +;; usually abbreviated +;; +;; (match-two v p g s sk fk i) +;; +;; where VAR is the symbol name of the current variable we are +;; matching, PATTERN is the current pattern, getter and setter are the +;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding +;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure +;; continuation (which is just a thunk call and is thus safe to expand +;; multiple times) and IDS are the list of identifiers bound in the +;; pattern so far. + +(define-syntax match-two + (syntax-rules (_ ___ quote quasiquote ? $ = and or not set! get!) + ((match-two v () g s (sk ...) fk i) + (if (null? v) (sk ... i) fk)) + ((match-two v (quote p) g s (sk ...) fk i) + (if (equal? v 'p) (sk ... i) fk)) + ((match-two v (quasiquote p) g s sk fk i) + (match-quasiquote v p g s sk fk i)) + ((match-two v (and) g s (sk ...) fk i) (sk ... i)) + ((match-two v (and p q ...) g s sk fk i) + (match-one v p g s (match-one v (and q ...) g s sk fk) fk i)) + ((match-two v (or) g s sk fk i) fk) + ((match-two v (or p) g s sk fk i) + (match-one v p g s sk fk i)) + ((match-two v (or p ...) g s sk fk i) + (match-extract-vars (or p ...) + (match-gen-or v (p ...) g s sk fk i) + i + ())) + ((match-two v (not p) g s (sk ...) fk i) + (match-one v p g s (match-drop-ids fk) (sk ... i) i)) + ((match-two v (get! getter) g s (sk ...) fk i) + (let ((getter (lambda () g))) (sk ... i))) + ((match-two v (set! setter) g (s ...) (sk ...) fk i) + (let ((setter (lambda (x) (s ... x)))) (sk ... i))) + ((match-two v (? pred p ...) g s sk fk i) + (if (pred v) (match-one v (and p ...) g s sk fk i) fk)) + ((match-two v (= proc p) g s sk fk i) + (let ((w (proc v))) + (match-one w p g s sk fk i))) + ((match-two v (p ___ . r) g s sk fk i) + (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ())) + ((match-two v (p) g s sk fk i) + (if (and (pair? v) (null? (cdr v))) + (let ((w (car v))) + (match-one w p (car v) (set-car! v) sk fk i)) + fk)) + ((match-two v (p . q) g s sk fk i) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-one w p (car v) (set-car! v) + (match-one x q (cdr v) (set-cdr! v) sk fk) + fk + i)) + fk)) + ((match-two v #(p ...) g s sk fk i) + (match-vector v 0 () (p ...) sk fk i)) + ((match-two v _ g s (sk ...) fk i) (sk ... i)) + ;; Not a pair or vector or special literal, test to see if it's a + ;; new symbol, in which case we just bind it, or if it's an + ;; already bound symbol or some other literal, in which case we + ;; compare it with EQUAL?. + ((match-two v x g s (sk ...) fk (id ...)) + (let-syntax + ((new-sym? + (syntax-rules (id ...) + ((new-sym? x sk2 fk2) sk2) + ((new-sym? y sk2 fk2) fk2)))) + (new-sym? random-sym-to-match + (let ((x v)) (sk ... (id ... x))) + (if (equal? v x) (sk ... (id ...)) fk)))) + )) + +;; QUASIQUOTE patterns + +(define-syntax match-quasiquote + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ v (unquote p) g s sk fk i) + (match-one v p g s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g s sk fk i) + (if (pair? v) + (match-one v + (p . tmp) + (match-quasiquote tmp rest g s sk fk) + fk + i) + fk)) + ((_ v (quasiquote p) g s sk fk i . depth) + (match-quasiquote v p g s sk fk i #f . depth)) + ((_ v (unquote p) g s sk fk i x . depth) + (match-quasiquote v p g s sk fk i . depth)) + ((_ v (unquote-splicing p) g s sk fk i x . depth) + (match-quasiquote v p g s sk fk i . depth)) + ((_ v (p . q) g s sk fk i . depth) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-quasiquote + w p g s + (match-quasiquote-step x q g s sk fk depth) + fk i . depth)) + fk)) + ((_ v #(elt ...) g s sk fk i . depth) + (if (vector? v) + (let ((ls (vector->list v))) + (match-quasiquote ls (elt ...) g s sk fk i . depth)) + fk)) + ((_ v x g s sk fk i . depth) + (match-one v 'x g s sk fk i)))) + +(define-syntax match-quasiquote-step + (syntax-rules () + ((match-quasiquote-step x q g s sk fk depth i) + (match-quasiquote x q g s sk fk i . depth)) + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities + +;; A CPS utility that takes two values and just expands into the +;; first. +(define-syntax match-drop-ids + (syntax-rules () + ((_ expr ids ...) expr))) + +;; Generating OR clauses just involves binding the success +;; continuation into a thunk which takes the identifiers common to +;; each OR clause, and trying each clause, calling the thunk as soon +;; as we succeed. + +(define-syntax match-gen-or + (syntax-rules () + ((_ v p g s (sk ...) fk (i ...) ((id id-ls) ...)) + (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) + (match-gen-or-step + v p g s (match-drop-ids (sk2 id ...)) fk (i ...)))))) + +(define-syntax match-gen-or-step + (syntax-rules () + ((_ v () g s sk fk i) + ;; no OR clauses, call the failure continuation + fk) + ((_ v (p) g s sk fk i) + ;; last (or only) OR clause, just expand normally + (match-one v p g s sk fk i)) + ((_ v (p . q) g s sk fk i) + ;; match one and try the remaining on failure + (match-one v p g s sk (match-gen-or-step v q g s sk fk i) i)) + )) + +;; We match a pattern (p ...) by matching the pattern p in a loop on +;; each element of the variable, accumulating the bound ids into lists. + +;; Look at the body - it's just a named let loop, matching each +;; element in turn to the same pattern. This illustrates the +;; simplicity of this generative-style pattern matching. It would be +;; just as easy to implement a tree searching pattern. + +(define-syntax match-gen-ellipses + (syntax-rules () + ((_ v p () g s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to ( . p), just bind the list + (let ((p v)) + (if (list? p) + (sk ... i) + fk)) + ;; simple case, match all elements of the list + (let loop ((ls v) (id-ls '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p (car ls) (set-car! ls) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) + fk i))) + (else + fk))))) + ((_ v p (r ...) g s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match + (match-verify-no-ellipses + (r ...) + (let* ((tail-len (length '(r ...))) + (ls v) + (len (length ls))) + (if (< len tail-len) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond + ((= n tail-len) + (let ((id (reverse id-ls)) ...) + (match-one ls (r ...) #f #f (sk ... i) fk i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p (car ls) (set-car! ls) + (match-drop-ids + (loop (cdr ls) (- n 1) (cons id id-ls) ...)) + fk + i))) + (else + fk))))))) + )) + +(define-syntax match-verify-no-ellipses + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipse + x + (match-syntax-error + "multiple ellipse patterns not allowed at same level") + (match-verify-no-ellipses y sk))) + ((_ x sk) sk) + )) + +;; Vector patterns are just more of the same, with the slight +;; exception that we pass around the current vector index being +;; matched. + +(define-syntax match-vector + (syntax-rules (___) + ((_ v n pats (p q) sk fk i) + (match-check-ellipse q + (match-vector-ellipses v n pats p sk fk i) + (match-vector-two v n pats (p q) sk fk i))) + ((_ v n pats (p ___) sk fk i) + (match-vector-ellipses v n pats p sk fk i)) + ((_ . x) + (match-vector-two . x)))) + +;; Check the exact vector length, then check each element in turn. + +(define-syntax match-vector-two + (syntax-rules () + ((_ v n ((pat index) ...) () sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (= len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) sk fk i) + (match-vector v (+ n 1) (pats ... (p n)) q sk fk i)) + )) + +(define-syntax match-vector-step + (syntax-rules () + ((_ v () (sk ...) fk i) (sk ... i)) + ((_ v ((pat index) . rest) sk fk i) + (let ((w (vector-ref v index))) + (match-one w pat (vector-ref v index) (vector-set! v index) + (match-vector-step v rest sk fk) + fk i))))) + +;; With a vector ellipse pattern we first check to see if the vector +;; length is at least the required length. + +(define-syntax match-vector-ellipses + (syntax-rules () + ((_ v n ((pat index) ...) p sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (>= len n) + (match-vector-step v ((pat index) ...) + (match-vector-tail v p n len sk fk) + fk i) + fk)) + fk)))) + +(define-syntax match-vector-tail + (syntax-rules () + ((_ v p n len sk fk i) + (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())))) + +(define-syntax match-vector-tail-two + (syntax-rules () + ((_ v p n len (sk ...) fk i ((id id-ls) ...)) + (let loop ((j n) (id-ls '()) ...) + (if (>= j len) + (let ((id (reverse id-ls)) ...) (sk ... i)) + (let ((w (vector-ref v j))) + (match-one w p (vector-ref v j) (vetor-set! v j) + (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) + fk i))))))) + +;; Extract all identifiers in a pattern. A little more complicated +;; than just looking for symbols, we need to ignore special keywords +;; and not pattern forms (such as the predicate expression in ? +;; patterns). +;; +;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) + +(define-syntax match-extract-vars + (syntax-rules (_ ___ ? $ = quote quasiquote and or not get! set!) + ((match-extract-vars (? pred . p) k i v) + (match-extract-vars p k i v)) + ((match-extract-vars ($ rec . p) k i v) + (match-extract-vars p k i v)) + ((match-extract-vars (= proc p) k i v) + (match-extract-vars p k i v)) + ((match-extract-vars (quote x) (k ...) i v) + (k ... v)) + ((match-extract-vars (quasiquote x) k i v) + (match-extract-quasiquote-vars x k i v (#t))) + ((match-extract-vars (and . p) k i v) + (match-extract-vars p k i v)) + ((match-extract-vars (or . p) k i v) + (match-extract-vars p k i v)) + ((match-extract-vars (not . p) k i v) + (match-extract-vars p k i v)) + ;; A non-keyword pair, expand the CAR with a continuation to + ;; expand the CDR. + ((match-extract-vars (p q . r) k i v) + (match-check-ellipse + q + (match-extract-vars (p . r) k i v) + (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) + ((match-extract-vars (p . q) k i v) + (match-extract-vars p (match-extract-vars-step q k i v) i ())) + ((match-extract-vars #(p ...) k i v) + (match-extract-vars (p ...) k i v)) + ((match-extract-vars _ (k ...) i v) (k ... v)) + ((match-extract-vars ___ (k ...) i v) (k ... v)) + ;; This is the main part, the only place where we might add a new + ;; var if it's an unbound symbol. + ((match-extract-vars p (k ...) (i ...) v) + (let-syntax + ((new-sym? + (syntax-rules (i ...) + ((new-sym? p sk fk) sk) + ((new-sym? x sk fk) fk)))) + (new-sym? random-sym-to-match + (k ... ((p p-ls) . v)) + (k ... v)))) + )) + +;; Stepper used in the above so it can expand the CAR and CDR +;; separately. + +(define-syntax match-extract-vars-step + (syntax-rules () + ((_ p k i v ((v2 v2-ls) ...)) + (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) + )) + +(define-syntax match-extract-quasiquote-vars + (syntax-rules (quasiquote unquote unquote-splicing) + ((match-extract-quasiquote-vars (quasiquote x) k i v d) + (match-extract-quasiquote-vars x k i v (#t . d))) + ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) + (match-extract-quasiquote-vars (unquote x) k i v d)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t)) + (match-extract-vars x k i v)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) + (match-extract-quasiquote-vars x k i v d)) + ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) + (match-extract-quasiquote-vars + x + (match-extract-quasiquote-vars-step y k i v d) i ())) + ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) + (match-extract-quasiquote-vars (x ...) k i v d)) + ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) + (k ... v)) + )) + +(define-syntax match-extract-quasiquote-vars-step + (syntax-rules () + ((_ x k i v d ((v2 v2-ls) ...)) + (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d)) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gimme some sugar baby. + +(define-syntax match-lambda + (syntax-rules () + ((_ clause ...) (lambda (expr) (match expr clause ...))))) + +(define-syntax match-lambda* + (syntax-rules () + ((_ clause ...) (lambda expr (match expr clause ...))))) + +(define-syntax match-let + (syntax-rules () + ((_ (vars ...) . body) + (match-let/helper let () () (vars ...) . body)) + ((_ loop . rest) + (match-named-let loop () . rest)))) + +(define-syntax match-letrec + (syntax-rules () + ((_ vars . body) (match-let/helper letrec () () vars . body)))) + +(define-syntax match-let/helper + (syntax-rules () + ((_ let ((var expr) ...) () () . body) + (let ((var expr) ...) . body)) + ((_ let ((var expr) ...) ((pat tmp) ...) () . body) + (let ((var expr) ...) + (match-let* ((pat tmp) ...) + . body))) + ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((a expr) . rest) . body) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)) + )) + +(define-syntax match-named-let + (syntax-rules () + ((_ loop ((pat expr var) ...) () . body) + (let loop ((var expr) ...) + (match-let ((pat var) ...) + . body))) + ((_ loop (v ...) ((pat expr) . rest) . body) + (match-named-let loop (v ... (pat expr tmp)) rest . body)))) + +(define-syntax match-let* + (syntax-rules () + ((_ () . body) + (begin . body)) + ((_ ((pat expr) . rest) . body) + (match expr (pat (match-let* rest . body)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Otherwise COND-EXPANDed bits. + +;; This *should* work, but doesn't :( +;; (define-syntax match-check-ellipse +;; (syntax-rules (...) +;; ((_ ... sk fk) sk) +;; ((_ x sk fk) fk))) + +;; This is a little more complicated, and introduces a new let-syntax, +;; but should work portably in any R[56]RS Scheme. Taylor Campbell +;; originally came up with the idea. +(define-syntax match-check-ellipse + (syntax-rules () + ;; these two aren't necessary but provide fast-case failures + ((match-check-ellipse (a . b) success-k failure-k) failure-k) + ((match-check-ellipse #(a ...) success-k failure-k) failure-k) + ;; matching an atom + ((match-check-ellipse id success-k failure-k) + (let-syntax ((ellipse? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipse? (foo id) sk fk) sk) + ((ellipse? other sk fk) fk)))) + ;; this list of three elements will only many the (foo id) list + ;; above if `id' is `...' + (ellipse? (a b c) success-k failure-k))))) + + +;; This is portable but can be more efficient with non-portable +;; extensions. This trick was originally discovered by Oleg Kiselyov. + +(define-syntax match-check-identifier + (syntax-rules () + ;; fast-case failures, lists and vectors are not identifiers + ((_ (x . y) success-k failure-k) failure-k) + ((_ #(x ...) success-k failure-k) failure-k) + ;; x is an atom + ((_ x success-k failure-k) + (let-syntax + ((sym? + (syntax-rules () + ;; if the symbol `abracadabra' matches x, then x is a + ;; symbol + ((sym? x sk fk) sk) + ;; otherwise x is a non-symbol datum + ((sym? y sk fk) fk)))) + (sym? abracadabra success-k failure-k))) + )) From cca25351feb6a972bad62d8aabca611006777882 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 23 Nov 2009 02:42:03 +0900 Subject: [PATCH 206/535] adding srfi-98 --- Makefile | 5 +++-- lib/srfi/98.module | 5 +++++ lib/srfi/98/env.c | 45 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 53 insertions(+), 2 deletions(-) create mode 100644 lib/srfi/98.module create mode 100644 lib/srfi/98/env.c diff --git a/Makefile b/Makefile index e14d865a..e62212b5 100644 --- a/Makefile +++ b/Makefile @@ -50,7 +50,7 @@ endif all: chibi-scheme$(EXE) libs -libs: lib/srfi/69/hash$(SO) +libs: lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) ifeq ($(USE_BOEHM),1) GCLDFLAGS := -lgc @@ -92,11 +92,12 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO) chibi-scheme-static$(EXE): main.o eval.o sexp.o $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) -lib/srfi/69/hash$(SO): lib/srfi/69/hash.c $(INCLUDES) +lib/srfi/%$(SO): lib/srfi/%.c $(INCLUDES) $(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme clean: rm -f *.o *.i *.s *.8 + find lib -name \*.$(SO) -exec rm -f '{}' \; cleaner: clean rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) *$(SO) *.a diff --git a/lib/srfi/98.module b/lib/srfi/98.module new file mode 100644 index 00000000..55dfb45b --- /dev/null +++ b/lib/srfi/98.module @@ -0,0 +1,5 @@ + +(define-module (srfi 98) + (export get-environment-variable get-environment-variables) + (include "srfi/98/env.so")) + diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c new file mode 100644 index 00000000..4a180421 --- /dev/null +++ b/lib/srfi/98/env.c @@ -0,0 +1,45 @@ + +#ifdef __APPLE__ +#include +#define environ (*_NSGetEnviron()) +#else +extern char **environ; +#endif + +#include + +sexp sexp_get_environment_variable (sexp ctx, sexp str) { + char *cstr; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "get-environment-variable: not a string", str); + cstr = getenv(sexp_string_data(str)); + return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE; +} + +sexp sexp_get_environment_variables (sexp ctx) { + int i; + char **env, *cname, *cval; + sexp_gc_var3(res, name, val); + sexp_gc_preserve3(ctx, res, name, val); + res = SEXP_NULL; + env = environ; + for (i=0; env[i]; i++) { + cname = env[i]; + cval = strchr(cname, '='); + if (cval) { + name = sexp_c_string(ctx, cname, cval-cname); + val = sexp_c_string(ctx, cval+1, -1); + val = sexp_cons(ctx, name, val); + res = sexp_cons(ctx, val, res); + } + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable); + sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables); + return SEXP_VOID; +} + From f74fcbce29743af3618e02127820261a97912169 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 23 Nov 2009 03:54:29 +0900 Subject: [PATCH 207/535] adding (command-line-arguments) --- init.scm | 2 ++ main.c | 16 ++++++++++++---- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/init.scm b/init.scm index 629d4de7..b3210595 100644 --- a/init.scm +++ b/init.scm @@ -530,6 +530,8 @@ (current-output-port old-out) res))) +(define (command-line-arguments) *command-line-arguments*) + ;; values (define *values-tag* (list 'values)) diff --git a/main.c b/main.c index 2a24db43..151e5d86 100644 --- a/main.c +++ b/main.c @@ -73,6 +73,7 @@ sexp sexp_init_environments (sexp ctx) { sexp res, env; sexp_gc_var1(confenv); env = sexp_context_env(ctx); + sexp_env_define(ctx, env, sexp_intern(ctx, "*command-line-arguments*"), SEXP_NULL); res = sexp_load_module_file(ctx, sexp_init_file, env); #if USE_MODULES if (! sexp_exceptionp(res)) { @@ -125,13 +126,14 @@ void repl (sexp ctx) { void run_main (int argc, char **argv) { sexp env, out=NULL, res=SEXP_VOID, ctx; - sexp_uint_t i, quit=0, init_loaded=0; - sexp_gc_var1(str); + sexp_sint_t i, quit=0, init_loaded=0; + sexp_gc_var2(str, args); ctx = sexp_make_eval_context(NULL, NULL, NULL); - sexp_gc_preserve1(ctx, str); + sexp_gc_preserve2(ctx, str, args); env = sexp_context_env(ctx); out = sexp_eval_string(ctx, "(current-output-port)", env); + args = SEXP_NULL; /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { @@ -165,6 +167,11 @@ void run_main (int argc, char **argv) { case 'm': chibi_module_dir = argv[++i]; break; + case 's': + for (argc=argc-1; argc>i+1; argc--) + args = sexp_cons(ctx, str=sexp_c_string(ctx,argv[argc],-1), args); + argc++; + break; default: errx(1, "unknown option: %s", argv[i]); } @@ -173,6 +180,7 @@ void run_main (int argc, char **argv) { if (! quit) { if (! init_loaded) res = sexp_init_environments(ctx); + sexp_env_define(ctx, env, sexp_intern(ctx, "*command-line-arguments*"), args); if (res && sexp_exceptionp(res)) sexp_print_exception(ctx, res, sexp_eval_string(ctx, "(current-error-port)", env)); @@ -183,7 +191,7 @@ void run_main (int argc, char **argv) { repl(ctx); } - sexp_gc_release1(ctx); + sexp_gc_release2(ctx); } int main (int argc, char **argv) { From 025aae80d6e0c7560a581a2f4c949d2401550aa9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 25 Nov 2009 22:46:38 +0900 Subject: [PATCH 208/535] adding tree search patterns to (chibi match) --- .hgignore | 1 + Makefile | 9 +- lib/chibi/match/match.scm | 168 +++++++++++++++++++++++--------- tests/match-tests.scm | 196 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 328 insertions(+), 46 deletions(-) create mode 100644 tests/match-tests.scm diff --git a/.hgignore b/.hgignore index 9d217d26..babe41d2 100644 --- a/.hgignore +++ b/.hgignore @@ -17,4 +17,5 @@ junk* gc gc6.8 chibi-scheme +chibi-scheme-static include/chibi/install.h diff --git a/Makefile b/Makefile index e62212b5..7015597b 100644 --- a/Makefile +++ b/Makefile @@ -31,7 +31,7 @@ ifeq ($(PLATFORM),macosx) SO = .dylib EXE = CLIBFLAGS = -dynamiclib -STATICFLAGS = -static-libgcc +STATICFLAGS = -static-libgcc -DUSE_DL=0 else ifeq ($(PLATFORM),mingw) SO = .dll @@ -44,7 +44,7 @@ else SO = .so EXE = CLIBFLAGS = -fPIC -shared -STATICFLAGS = -static +STATICFLAGS = -static -DUSE_DL=0 endif endif @@ -113,9 +113,12 @@ test-basic: chibi-scheme$(EXE) fi; \ done -test-numbers: chibi-scheme$(EXE) +test-numbers: all LD_LIBRARY_PATH=.:$LD_LIBRARY_PATH ./chibi-scheme$(EXE) tests/numeric-tests.scm +test-match: all + LD_LIBRARY_PATH=.:$LD_LIBRARY_PATH ./chibi-scheme$(EXE) tests/match-tests.scm + test: all LD_LIBRARY_PATH=.:$LD_LIBRARY_PATH ./chibi-scheme$(EXE) tests/r5rs-tests.scm diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm index 6557ac0e..6a6407b5 100644 --- a/lib/chibi/match/match.scm +++ b/lib/chibi/match/match.scm @@ -21,10 +21,14 @@ ;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd ;; and is still available at ;; http://synthcode.com/scheme/match-simple.scm -;; A variant of this file which uses COND-EXPAND in a few places can -;; be found at +;; It's just 80 lines for the core MATCH, and an extra 40 lines for +;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar. +;; +;; A variant of this file which uses COND-EXPAND in a few places for +;; performance can be found at ;; http://synthcode.com/scheme/match-cond-expand.scm ;; +;; 2009/11/25 - adding `***' tree search patterns ;; 2008/03/20 - fixing bug where (a ...) matched non-lists ;; 2008/03/15 - removing redundant check in vector patterns ;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) @@ -121,7 +125,7 @@ ;; pattern so far. (define-syntax match-two - (syntax-rules (_ ___ quote quasiquote ? $ = and or not set! get!) + (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!) ((match-two v () g s (sk ...) fk i) (if (null? v) (sk ... i) fk)) ((match-two v (quote p) g s (sk ...) fk i) @@ -135,10 +139,7 @@ ((match-two v (or p) g s sk fk i) (match-one v p g s sk fk i)) ((match-two v (or p ...) g s sk fk i) - (match-extract-vars (or p ...) - (match-gen-or v (p ...) g s sk fk i) - i - ())) + (match-extract-vars (or p ...) (match-gen-or v (p ...) g s sk fk i) i ())) ((match-two v (not p) g s (sk ...) fk i) (match-one v p g s (match-drop-ids fk) (sk ... i) i)) ((match-two v (get! getter) g s (sk ...) fk i) @@ -154,17 +155,21 @@ (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ())) ((match-two v (p) g s sk fk i) (if (and (pair? v) (null? (cdr v))) - (let ((w (car v))) - (match-one w p (car v) (set-car! v) sk fk i)) - fk)) + (let ((w (car v))) + (match-one w p (car v) (set-car! v) sk fk i)) + fk)) + ((match-two v (p *** q) g s sk fk i) + (match-extract-vars p (match-gen-search v p q g s sk fk i) i ())) + ((match-two v (p *** . q) g s sk fk i) + (match-syntax-error "invalid use of ***" (p *** . q))) ((match-two v (p . q) g s sk fk i) (if (pair? v) - (let ((w (car v)) (x (cdr v))) - (match-one w p (car v) (set-car! v) - (match-one x q (cdr v) (set-cdr! v) sk fk) - fk - i)) - fk)) + (let ((w (car v)) (x (cdr v))) + (match-one w p (car v) (set-car! v) + (match-one x q (cdr v) (set-cdr! v) sk fk) + fk + i)) + fk)) ((match-two v #(p ...) g s sk fk i) (match-vector v 0 () (p ...) sk fk i)) ((match-two v _ g s (sk ...) fk i) (sk ... i)) @@ -234,10 +239,12 @@ (syntax-rules () ((_ expr ids ...) expr))) -;; Generating OR clauses just involves binding the success -;; continuation into a thunk which takes the identifiers common to -;; each OR clause, and trying each clause, calling the thunk as soon -;; as we succeed. +;; To expand an OR group we try each clause in succession, passing the +;; first that succeeds to the success continuation. On failure for +;; any clause, we just try the next clause, finally resorting to the +;; failure continuation fk if all clauses fail. The only trick is +;; that we want to unify the identifiers, so that the success +;; continuation can refer to a variable from any of the OR clauses. (define-syntax match-gen-or (syntax-rules () @@ -262,16 +269,19 @@ ;; We match a pattern (p ...) by matching the pattern p in a loop on ;; each element of the variable, accumulating the bound ids into lists. -;; Look at the body - it's just a named let loop, matching each -;; element in turn to the same pattern. This illustrates the -;; simplicity of this generative-style pattern matching. It would be -;; just as easy to implement a tree searching pattern. +;; Look at the body of the simple case - it's just a named let loop, +;; matching each element in turn to the same pattern. The only trick +;; is that we want to keep track of the lists of each extracted id, so +;; when the loop recurses we cons the ids onto their respective list +;; variables, and on success we bind the ids (what the user input and +;; expects to see in the success body) to the reversed accumulated +;; list IDs. (define-syntax match-gen-ellipses (syntax-rules () ((_ v p () g s (sk ...) fk i ((id id-ls) ...)) (match-check-identifier p - ;; simplest case equivalent to ( . p), just bind the list + ;; simplest case equivalent to (p ...), just bind the list (let ((p v)) (if (list? p) (sk ... i) @@ -288,11 +298,12 @@ fk i))) (else fk))))) - ((_ v p (r ...) g s (sk ...) fk i ((id id-ls) ...)) - ;; general case, trailing patterns to match + ((_ v p r g s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking (match-verify-no-ellipses - (r ...) - (let* ((tail-len (length '(r ...))) + r + (let* ((tail-len (length 'r)) (ls v) (len (length ls))) (if (< len tail-len) @@ -301,7 +312,7 @@ (cond ((= n tail-len) (let ((id (reverse id-ls)) ...) - (match-one ls (r ...) #f #f (sk ... i) fk i))) + (match-one ls r #f #f (sk ... i) fk i))) ((pair? ls) (let ((w (car ls))) (match-one w p (car ls) (set-car! ls) @@ -310,8 +321,73 @@ fk i))) (else - fk))))))) - )) + fk))))))))) + +;; Matching a tree search pattern is only slightly more complicated. +;; Here we allow patterns of the form +;; +;; (x *** y) +;; +;; to represent the pattern y located somewhere in a tree where the +;; path from the current object to y can be seen as a list of the form +;; (X ...). Y can immediately match the current object in which case +;; the path is the empty list. In a sense it's a 2-dimensional +;; version of the ... pattern. +;; +;; As a common case the pattern (_ *** y) can be used to search for Y +;; anywhere in a tree, regardless of the path used. +;; +;; To implement the search, we use two recursive procedures. TRY +;; attempts to match Y once, and on success it calls the normal SK on +;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we +;; call NEXT which first checks if the current value is a list +;; beginning with X, then calls TRY on each remaining element of the +;; list. Since TRY will recursively call NEXT again on failure, this +;; effects a full depth-first search. +;; +;; The failure continuation throughout is a jump to the next step in +;; the tree search, initialized with the original failure continuation +;; FK. + +(define-syntax match-gen-search + (syntax-rules () + ((match-gen-search v p q g s sk fk i ((id id-ls) ...)) + (letrec ((try (lambda (w fail id-ls ...) + (match-one w q g s + (match-drop-ids + (let ((id (reverse id-ls)) ...) + sk)) + (next w fail id-ls ...) i))) + (next (lambda (w fail id-ls ...) + (if (not (pair? w)) + (fail) + (let ((u (car w))) + (match-one + u p (car w) (set-car! w) + (match-drop-ids + ;; accumulate the head variables from + ;; the p pattern, and loop over the tail + (let ((id-ls (cons id id-ls)) ...) + (let lp ((ls (cdr w))) + (if (pair? ls) + (try (car ls) + (lambda () (lp (cdr ls))) + id-ls ...) + (fail))))) + (fail) i)))))) + ;; the initial id-ls binding here is a dummy to get the right + ;; number of '()s + (let ((id-ls '()) ...) + (try v (lambda () fk) id-ls ...)))))) + +;; This is just a safety check. Although unlike syntax-rules we allow +;; trailing patterns after an ellipses, we explicitly disable multiple +;; ellipses at the same level. This is because in the general case +;; such patterns are exponential in the number of ellipses, and we +;; don't want to make it easy to construct very expensive operations +;; with simple looking patterns. For example, it would be O(n^2) for +;; patterns like (a ... b ...) because we must consider every trailing +;; element for every possible break for the leading "a ...". (define-syntax match-verify-no-ellipses (syntax-rules () @@ -321,7 +397,9 @@ (match-syntax-error "multiple ellipse patterns not allowed at same level") (match-verify-no-ellipses y sk))) - ((_ x sk) sk) + ((_ () sk) sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipse" x)) )) ;; Vector patterns are just more of the same, with the slight @@ -332,10 +410,10 @@ (syntax-rules (___) ((_ v n pats (p q) sk fk i) (match-check-ellipse q - (match-vector-ellipses v n pats p sk fk i) + (match-gen-vector-ellipses v n pats p sk fk i) (match-vector-two v n pats (p q) sk fk i))) ((_ v n pats (p ___) sk fk i) - (match-vector-ellipses v n pats p sk fk i)) + (match-gen-vector-ellipses v n pats p sk fk i)) ((_ . x) (match-vector-two . x)))) @@ -366,7 +444,7 @@ ;; With a vector ellipse pattern we first check to see if the vector ;; length is at least the required length. -(define-syntax match-vector-ellipses +(define-syntax match-gen-vector-ellipses (syntax-rules () ((_ v n ((pat index) ...) p sk fk i) (if (vector? v) @@ -396,13 +474,18 @@ ;; Extract all identifiers in a pattern. A little more complicated ;; than just looking for symbols, we need to ignore special keywords -;; and not pattern forms (such as the predicate expression in ? -;; patterns). +;; and non-pattern forms (such as the predicate expression in ? +;; patterns), and also ignore previously bound identifiers. +;; +;; Calls the continuation with all new vars as a list of the form +;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely +;; pair with the original variable (e.g. it's used in the ellipse +;; generation for list variables). ;; ;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) (define-syntax match-extract-vars - (syntax-rules (_ ___ ? $ = quote quasiquote and or not get! set!) + (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!) ((match-extract-vars (? pred . p) k i v) (match-extract-vars p k i v)) ((match-extract-vars ($ rec . p) k i v) @@ -432,6 +515,7 @@ (match-extract-vars (p ...) k i v)) ((match-extract-vars _ (k ...) i v) (k ... v)) ((match-extract-vars ___ (k ...) i v) (k ... v)) + ((match-extract-vars *** (k ...) i v) (k ... v)) ;; This is the main part, the only place where we might add a new ;; var if it's an unbound symbol. ((match-extract-vars p (k ...) (i ...) v) @@ -518,8 +602,7 @@ (match-let/helper let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) ((_ let (v ...) (p ...) ((a expr) . rest) . body) - (match-let/helper let (v ... (a expr)) (p ...) rest . body)) - )) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)))) (define-syntax match-named-let (syntax-rules () @@ -585,5 +668,4 @@ ((sym? x sk fk) sk) ;; otherwise x is a non-symbol datum ((sym? y sk fk) fk)))) - (sym? abracadabra success-k failure-k))) - )) + (sym? abracadabra success-k failure-k))))) diff --git a/tests/match-tests.scm b/tests/match-tests.scm new file mode 100644 index 00000000..a223e729 --- /dev/null +++ b/tests/match-tests.scm @@ -0,0 +1,196 @@ + +(import (chibi match)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test "any" (match 'any (_ 'ok)) 'ok) +(test "symbol" (match 'ok (x x)) 'ok) +(test "number" (match 28 (28 'ok)) 'ok) +(test "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok) +(test "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok) +(test "null" (match '() (() 'ok)) 'ok) +(test "pair" (match '(ok) ((x) x)) 'ok) +(test "vector" (match '#(ok) (#(x) x)) 'ok) +(test "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok) +(test "and empty" (match '(o k) ((and) 'ok)) 'ok) +(test "and single" (match 'ok ((and x) x)) 'ok) +(test "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok) +(test "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok) +(test "or single" (match 'ok ((or x) 'ok)) 'ok) +(test "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok) +(test "not" (match 28 ((not (a . b)) 'ok)) 'ok) +(test "pred" (match 28 ((? number?) 'ok)) 'ok) +(test "named pred" (match 28 ((? number? x) (+ x 1))) 29) + +(test "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok) +(test "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok) +(test "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok) + +(test "ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ___) (list x y))) + '((a b c) (1 2 3))) + +(test "real ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ...) (list x y))) + '((a b c) (1 2 3))) + +(test "vector ellipses" + (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) + (#(a b c (hd . tl) ...) (list a b c hd tl))) + '(1 2 3 (a b c) (1 2 3))) + +(test "pred ellipses" + (match '(1 2 3) + (((? odd? n) ___) n) + (((? number? n) ___) n)) + '(1 2 3)) + +(test "failure continuation" + (match '(1 2) + ((a . b) (=> next) (if (even? a) 'fail (next))) + ((a . b) 'ok)) + 'ok) + +(test "let" + (match-let ((x 'ok) (y '(o k))) + y) + '(o k)) + +(test "let*" + (match-let* ((x 'f) (y 'o) ((z w) (list y x))) + (list x y z w)) + '(f o o f)) + +(test "getter car" + (match '(1 . 2) (((get! a) . b) (list (a) b))) + '(1 2)) + +(test "getter cdr" + (match '(1 . 2) ((a . (get! b)) (list a (b)))) + '(1 2)) + +(test "getter vector" + (match '#(1 2 3) (#((get! a) b c) (list (a) b c))) + '(1 2 3)) + +(test "setter car" + (let ((x (cons 1 2))) + (match x (((set! a) . b) (a 3))) + x) + '(3 . 2)) + +(test "setter cdr" + (let ((x (cons 1 2))) + (match x ((a . (set! b)) (b 3))) + x) + '(1 . 3)) + +(test "setter vector" + (let ((x (vector 1 2 3))) + (match x (#(a (set! b) c) (b 0))) + x) + '#(1 0 3)) + +(test "single tail" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) (c . 3))) + +(test "single tail 2" + (match '((a . 1) (b . 2) 3) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) 3)) + +(test "multiple tail" + (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) + (((x . y) ... u v w) (list x y u v w))) + '((a b) (1 2) (c . 3) (d . 4) (e . 5))) + +(test "Riastradh quasiquote" + (match '(1 2 3) (`(1 ,b ,c) (list b c))) + '(2 3)) + +(test "trivial tree search" + (match '(1 2 3) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "simple tree search" + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "deep tree search" + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "non-tail tree search" + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "restricted tree search" + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "fail restricted tree search" + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f)) + #f) + +(test "sxml tree search" + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f)) + '(((href . "http://synthcode.com/")) ("synthcode"))) + +(test "failed sxml tree search" + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f)) + #f) + +(test "collect tree search" + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f)) + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))) + +(test-report) + From 353594a028a2f01fb1f4dc78e412f4b85ec5c892 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 28 Nov 2009 16:05:59 +0900 Subject: [PATCH 209/535] fixing some 64-bit bignum arithmetic cases --- eval.c | 4 ++-- include/chibi/sexp.h | 2 +- opt/bignum.c | 42 ++++++++++++++++++----------------------- tests/numeric-tests.scm | 12 ++++++++++++ 4 files changed, 33 insertions(+), 27 deletions(-) diff --git a/eval.c b/eval.c index fec23de4..3e1a1f6e 100644 --- a/eval.c +++ b/eval.c @@ -63,7 +63,7 @@ static sexp sexp_env_cell_create (sexp ctx, sexp e, sexp key, sexp value) { return cell; } -static sexp sexp_env_global_ref (sexp e, sexp key, sexp dflt) { +sexp sexp_env_global_ref (sexp e, sexp key, sexp dflt) { sexp cell; while (sexp_env_parent(e)) e = sexp_env_parent(e); @@ -1650,7 +1650,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { #if USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { - prod = sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); + prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) _ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); else diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index d9b1d87e..f304cc9d 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -632,7 +632,7 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #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_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b))) #define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b))) -#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(int)*8 - 1))) +#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1))) #define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a)))) #define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) diff --git a/opt/bignum.c b/opt/bignum.c index ed75b6bd..3cd89f8b 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -130,17 +130,11 @@ double sexp_bignum_to_double (sexp a) { sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) { sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), - carry=b, i, n; - for (i=0; i (SEXP_UINT_T_MAX - carry)) { - carry = 1; - } else { - carry = 0; - break; - } - } + carry=b, i=0, n; + do { n = data[i]; + data[i] += carry; + carry = (n > (SEXP_UINT_T_MAX - carry)); + } while (++i=offset; i--) { @@ -470,13 +464,13 @@ static int sexp_number_types[] = {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, 0}; static int sexp_number_type (sexp a) { - return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&1111] + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] : sexp_fixnump(a); } sexp sexp_add (sexp ctx, sexp a, sexp b) { int at=sexp_number_type(a), bt=sexp_number_type(b), t; - sexp r; + sexp r=SEXP_VOID; if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: @@ -484,7 +478,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) { r = sexp_type_exception(ctx, "+: not a number", a); break; case SEXP_NUM_FIX_FIX: - r = sexp_fx_add(a, b); /* XXXX check overflow */ + r = sexp_fx_add(a, b); /* VM catches this case */ break; case SEXP_NUM_FIX_FLO: r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b)); @@ -507,7 +501,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) { sexp sexp_sub (sexp ctx, sexp a, sexp b) { int at=sexp_number_type(a), bt=sexp_number_type(b); - sexp r; + sexp r=SEXP_VOID; switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: @@ -517,7 +511,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { r = sexp_type_exception(ctx, "-: not a number", b); break; case SEXP_NUM_FIX_FIX: - r = sexp_fx_sub(a, b); /* XXXX check overflow */ + r = sexp_fx_sub(a, b); /* VM catches this case */ break; case SEXP_NUM_FIX_FLO: r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b)); @@ -550,7 +544,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { sexp sexp_mul (sexp ctx, sexp a, sexp b) { int at=sexp_number_type(a), bt=sexp_number_type(b), t; - sexp r; + sexp r=SEXP_VOID; if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: @@ -583,7 +577,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) { sexp sexp_div (sexp ctx, sexp a, sexp b) { int at=sexp_number_type(a), bt=sexp_number_type(b); double f; - sexp r, rem; + sexp r=SEXP_VOID, rem; switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: @@ -632,7 +626,7 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) { sexp sexp_quotient (sexp ctx, sexp a, sexp b) { int at=sexp_number_type(a), bt=sexp_number_type(b); - sexp r; + sexp r=SEXP_VOID; switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: @@ -665,7 +659,7 @@ sexp sexp_quotient (sexp ctx, sexp a, sexp b) { sexp sexp_remainder (sexp ctx, sexp a, sexp b) { int at=sexp_number_type(a), bt=sexp_number_type(b); - sexp r; + sexp r=SEXP_VOID; switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: @@ -698,7 +692,7 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) { sexp sexp_compare (sexp ctx, sexp a, sexp b) { int at=sexp_number_type(a), bt=sexp_number_type(b); - sexp r; + sexp r=SEXP_VOID; double f; if (at > bt) { r = sexp_compare(ctx, b, a); diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm index a5d17b2f..76a783f0 100644 --- a/tests/numeric-tests.scm +++ b/tests/numeric-tests.scm @@ -128,6 +128,12 @@ (-12884901889 4294967297 36893488151714070528 0 -4294967296)) (sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) +(test '((18446744078004518913 -18446744069414584321 79228162514264337597838917632 0 4294967296) + (18446744069414584321 -18446744078004518913 -79228162514264337597838917632 0 -4294967296) + (-18446744069414584321 18446744078004518913 -79228162514264337597838917632 0 4294967296) + (-18446744078004518913 18446744069414584321 79228162514264337597838917632 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 64)))) + ;; bigger x big (test '((12884901889 4294967297 36893488151714070528 2 1) (-4294967297 -12884901889 -36893488151714070528 -2 -1) @@ -135,4 +141,10 @@ (-12884901889 -4294967297 36893488151714070528 2 -1)) (sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) +(test '((18446744078004518913 18446744069414584321 79228162514264337597838917632 4294967296 1) + (-18446744069414584321 -18446744078004518913 -79228162514264337597838917632 -4294967296 -1) + (18446744069414584321 18446744078004518913 -79228162514264337597838917632 -4294967296 1) + (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1)) + (sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) + (test-report) From 0746c445edf9ee6c1f9d7cbff231797e7358c3a9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 28 Nov 2009 16:49:31 +0900 Subject: [PATCH 210/535] type checking on load, better error message for missing includes --- Makefile | 4 ++-- config.scm | 7 ++++++- eval.c | 9 ++++++++- 3 files changed, 16 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 7015597b..8b85794c 100644 --- a/Makefile +++ b/Makefile @@ -62,10 +62,10 @@ endif ifeq ($(USE_DL),0) XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm -XCFLAGS := -Wall -DUSE_DL=0 -g3 -O2 $(CFLAGS) +XCFLAGS := -Wall -DUSE_DL=0 -g3 $(CFLAGS) else XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -ldl -lm -XCFLAGS := -Wall -g3 -O2 $(CFLAGS) +XCFLAGS := -Wall -g3 $(CFLAGS) endif INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h diff --git a/config.scm b/config.scm index 0a8f0f5c..decc94d1 100644 --- a/config.scm +++ b/config.scm @@ -53,7 +53,12 @@ (let ((mod2 (load-module (cadr x)))) (%env-copy! env (module-env mod2) (module-exports mod2)))) ((include) - (for-each (lambda (f) (load (find-module-file name f) env)) (cdr x))) + (for-each + (lambda (f) + (cond + ((find-module-file name f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f)))) + (cdr x))) ((body) (for-each (lambda (expr) (eval expr env)) (cdr x))))) (module-meta-data mod)) diff --git a/eval.c b/eval.c index 3e1a1f6e..1cff2b2f 100644 --- a/eval.c +++ b/eval.c @@ -2011,10 +2011,17 @@ sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { #endif sexp sexp_load (sexp ctx, sexp source, sexp env) { +#if USE_DL + char *suffix; +#endif sexp tmp, out=SEXP_FALSE; sexp_gc_var4(ctx2, x, in, res); + if (! sexp_stringp(source)) + return sexp_type_exception(ctx, "not a string", source); + if (! sexp_envp(env)) + return sexp_type_exception(ctx, "not an environment", env); #if USE_DL - char *suffix = sexp_string_data(source) + suffix = sexp_string_data(source) + sexp_string_length(source) - strlen(sexp_so_extension); if (strcmp(suffix, sexp_so_extension) == 0) { res = sexp_load_dl(ctx, source, env); From 574b1daa32c580bde48885282afedc3811b42cd5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 28 Nov 2009 17:27:01 +0900 Subject: [PATCH 211/535] using include-shared for shared object files for portability --- config.scm | 12 ++++++++---- eval.c | 2 ++ lib/srfi/69.module | 5 ++--- lib/srfi/98.module | 2 +- 4 files changed, 13 insertions(+), 8 deletions(-) diff --git a/config.scm b/config.scm index decc94d1..f93ebd5e 100644 --- a/config.scm +++ b/config.scm @@ -52,12 +52,15 @@ ((import) (let ((mod2 (load-module (cadr x)))) (%env-copy! env (module-env mod2) (module-exports mod2)))) - ((include) + ((include include-shared) (for-each (lambda (f) - (cond - ((find-module-file name f) => (lambda (x) (load x env))) - (else (error "couldn't find include" f)))) + (let ((f (if (eq? (car x) 'include) + f + (string-append f *shared-object-extension*)))) + (cond + ((find-module-file name f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) (cdr x))) ((body) (for-each (lambda (expr) (eval expr env)) (cdr x))))) @@ -98,6 +101,7 @@ (define-config-primitive import) (define-config-primitive export) (define-config-primitive include) +(define-config-primitive include-shared) (define-config-primitive body) (let ((exports diff --git a/eval.c b/eval.c index 1cff2b2f..21c23513 100644 --- a/eval.c +++ b/eval.c @@ -2356,6 +2356,8 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); sexp_env_define(ctx, e, sexp_intern(ctx, "*module-directory*"), sexp_c_string(ctx, sexp_module_dir, -1)); + sexp_env_define(ctx, e, sexp_intern(ctx, "*shared-object-extension*"), + sexp_c_string(ctx, sexp_so_extension, -1)); /* add default exception handler */ err_cell = sexp_env_cell(e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL)); perr_cell = sexp_env_cell(e, sexp_intern(ctx, "print-exception")); diff --git a/lib/srfi/69.module b/lib/srfi/69.module index 8c64a4e9..5d2f040b 100644 --- a/lib/srfi/69.module +++ b/lib/srfi/69.module @@ -12,7 +12,6 @@ hash string-hash string-ci-hash hash-by-identity) (import (scheme)) (import (srfi 9)) - (include "srfi/69/type.scm" - "srfi/69/hash.so" - "srfi/69/interface.scm")) + (include-shared "srfi/69/hash") + (include "srfi/69/type.scm" "srfi/69/interface.scm")) diff --git a/lib/srfi/98.module b/lib/srfi/98.module index 55dfb45b..b3e58525 100644 --- a/lib/srfi/98.module +++ b/lib/srfi/98.module @@ -1,5 +1,5 @@ (define-module (srfi 98) (export get-environment-variable get-environment-variables) - (include "srfi/98/env.so")) + (include-shared "srfi/98/env")) From 532a717ed9d82fd4ae541fcf6dfbbab0e2d6d533 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 28 Nov 2009 17:44:47 +0900 Subject: [PATCH 212/535] using relative paths for include files --- config.scm | 12 ++++++++---- lib/chibi/match.module | 2 +- lib/srfi/1.module | 18 +++++++++--------- lib/srfi/1/fold.scm | 4 ++-- lib/srfi/69.module | 4 ++-- lib/srfi/98.module | 2 +- 6 files changed, 23 insertions(+), 19 deletions(-) diff --git a/config.scm b/config.scm index f93ebd5e..dc54b1fd 100644 --- a/config.scm +++ b/config.scm @@ -31,6 +31,9 @@ (string-concatenate (reverse (cons ".module" (cdr (module-name->strings name '())))))) +(define (module-name-prefix name) + (string-concatenate (reverse (cdr (cdr (module-name->strings name '())))))) + (define (load-module-definition name) (let* ((file (module-name->file name)) (path (find-module-file name file))) @@ -45,7 +48,8 @@ (else #f))))) (define (eval-module name mod) - (let ((env (make-environment))) + (let ((env (make-environment)) + (prefix (module-name-prefix name))) (for-each (lambda (x) (case (and (pair? x) (car x)) @@ -55,9 +59,9 @@ ((include include-shared) (for-each (lambda (f) - (let ((f (if (eq? (car x) 'include) - f - (string-append f *shared-object-extension*)))) + (let ((f (string-append + prefix f + (if (eq? (car x) 'include) "" *shared-object-extension*)))) (cond ((find-module-file name f) => (lambda (x) (load x env))) (else (error "couldn't find include" f))))) diff --git a/lib/chibi/match.module b/lib/chibi/match.module index 87382e95..afce8975 100644 --- a/lib/chibi/match.module +++ b/lib/chibi/match.module @@ -2,5 +2,5 @@ (define-module (chibi match) (export match match-lambda match-lambda* match-let match-letrec match-let*) (import (scheme)) - (include "chibi/match/match.scm")) + (include "match/match.scm")) diff --git a/lib/srfi/1.module b/lib/srfi/1.module index 93477756..3d3da044 100644 --- a/lib/srfi/1.module +++ b/lib/srfi/1.module @@ -19,13 +19,13 @@ lset-intersection! lset-difference lset-difference! lset-xor lset-xor! lset-diff+intersection lset-diff+intersection!) (import (scheme)) - (include "srfi/1/predicates.scm" - "srfi/1/selectors.scm" - "srfi/1/search.scm" - "srfi/1/misc.scm" - "srfi/1/constructors.scm" - "srfi/1/fold.scm" - "srfi/1/deletion.scm" - "srfi/1/alists.scm" - "srfi/1/lset.scm")) + (include "1/predicates.scm" + "1/selectors.scm" + "1/search.scm" + "1/misc.scm" + "1/constructors.scm" + "1/fold.scm" + "1/deletion.scm" + "1/alists.scm" + "1/lset.scm")) diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm index 4c0c2afa..5253dec6 100644 --- a/lib/srfi/1/fold.scm +++ b/lib/srfi/1/fold.scm @@ -91,14 +91,14 @@ init (take-up-to-reverse (cdr from) to (cons (car from) init)))) -(define (filter pred ls) +(define (remove pred ls) (let lp ((ls ls) (rev '())) (let ((tail (find-tail pred ls))) (if tail (lp (cdr tail) (take-up-to-reverse ls tail rev)) (if (pair? rev) (append-reverse! rev ls) ls))))) -(define (remove pred ls) (filter (lambda (x) (not (pred x))) ls)) +(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls)) (define (partition pred ls) (let lp ((ls ls) (good '()) (bad '())) diff --git a/lib/srfi/69.module b/lib/srfi/69.module index 5d2f040b..fd28ecaa 100644 --- a/lib/srfi/69.module +++ b/lib/srfi/69.module @@ -12,6 +12,6 @@ hash string-hash string-ci-hash hash-by-identity) (import (scheme)) (import (srfi 9)) - (include-shared "srfi/69/hash") - (include "srfi/69/type.scm" "srfi/69/interface.scm")) + (include-shared "69/hash") + (include "69/type.scm" "69/interface.scm")) diff --git a/lib/srfi/98.module b/lib/srfi/98.module index b3e58525..9d124d66 100644 --- a/lib/srfi/98.module +++ b/lib/srfi/98.module @@ -1,5 +1,5 @@ (define-module (srfi 98) (export get-environment-variable get-environment-variables) - (include-shared "srfi/98/env")) + (include-shared "98/env")) From d0aa8de1e60273df948454f33e9c72848cada185 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 28 Nov 2009 18:27:42 +0900 Subject: [PATCH 213/535] adding basic finalizer functionality --- gc.c | 4 +++ include/chibi/sexp.h | 3 -- sexp.c | 71 ++++++++++++++++++++++++-------------------- 3 files changed, 43 insertions(+), 35 deletions(-) diff --git a/gc.c b/gc.c index 290e6e38..b5c5b2c3 100644 --- a/gc.c +++ b/gc.c @@ -78,6 +78,7 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { sexp p; sexp_free_list q, r, s; char *end; + sexp_proc2 finalizer; /* scan over the whole heap */ for ( ; h; h=h->next) { p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); @@ -93,6 +94,9 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { } size = sexp_heap_align(sexp_allocated_bytes(p)); if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + /* free p */ + finalizer = sexp_type_finalize(sexp_object_type(p)); + if (finalizer) finalizer(ctx, p); sum_freed += size; if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) { /* merge q with p */ diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index f304cc9d..7c7cfab3 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -622,9 +622,6 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_bignum_length(x) ((x)->value.bignum.length) #define sexp_bignum_data(x) ((x)->value.bignum.data) -#define sexp_dllib_file(x) ((x)->value.dllib.file) -#define sexp_dllib_handle(x) ((x)->value.dllib.handle) - /****************************** arithmetic ****************************/ #define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) diff --git a/sexp.c b/sexp.c index 64650fc1..08f10c1d 100644 --- a/sexp.c +++ b/sexp.c @@ -53,40 +53,47 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { return res; } -#define _DEF_TYPE(t,fb,felb,flb,flo,fls,sb,so,sc,n) \ - {.tag=SEXP_TYPE, .value={.type={t,fb,felb,flb,flo,fls,sb,so,sc,n}}} +sexp sexp_finalize_port (sexp ctx, sexp port) { + if (sexp_port_openp(port) && sexp_port_stream(port) + && sexp_stringp(sexp_port_name(port))) + fclose(sexp_port_stream(port)); + return SEXP_VOID; +} + +#define _DEF_TYPE(t,fb,felb,flb,flo,fls,sb,so,sc,n,f) \ + {.tag=SEXP_TYPE, .value={.type={t,fb,felb,flb,flo,fls,sb,so,sc,n,f}}} static struct sexp_struct _sexp_type_specs[] = { - _DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, "object"), - _DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"), - _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, "fixnum"), - _DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, "char"), - _DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, "boolean"), - _DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, "pair"), - _DEF_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"), - _DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string"), - _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector"), - _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"), - _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum"), - _DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, 0, sexp_sizeof(cpointer), 0, 0, "cpointer"), - _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port"), - _DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port"), - _DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception"), - _DEF_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"), - _DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro"), - _DEF_TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"), - _DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"), - _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"), - _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"), - _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"), - _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"), - _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional"), - _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"), - _DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"), - _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"), - _DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"), - _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack"), - _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 7, 7, 0, 0, sexp_sizeof(context), 0, 0, "context"), + _DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, "object", NULL), + _DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type", NULL), + _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, "fixnum", NULL), + _DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, "char", NULL), + _DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", NULL), + _DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, "pair", NULL), + _DEF_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol", NULL), + _DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string", NULL), + _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector", NULL), + _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum", NULL), + _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum", NULL), + _DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, 0, sexp_sizeof(cpointer), 0, 0, "cpointer", NULL), + _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", sexp_finalize_port), + _DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port", sexp_finalize_port), + _DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception", NULL), + _DEF_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure", NULL), + _DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro", NULL), + _DEF_TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure", NULL), + _DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, "environment", NULL), + _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode", NULL), + _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form", NULL), + _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode", NULL), + _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda", NULL), + _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional", NULL), + _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference", NULL), + _DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 2, 0, 0, sexp_sizeof(set), 0, 0, "set!", NULL), + _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence", NULL), + _DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal", NULL), + _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack", NULL), + _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 7, 7, 0, 0, sexp_sizeof(context), 0, 0, "context", NULL), }; #undef _DEF_TYPE From ce9bc2edeb56a4e1e45919112cc0f3c1e2c082a4 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 30 Nov 2009 01:10:15 +0900 Subject: [PATCH 214/535] minor bignum bugfixes --- eval.c | 32 +++++++++++++++++--------------- include/chibi/config.h | 10 ++++++++++ include/chibi/eval.h | 2 +- include/chibi/sexp.h | 34 +++++++++++++++++++++++++++++----- init.scm | 7 ++++--- opcodes.c | 3 ++- sexp.c | 33 +++++++++++++++++++++++++-------- 7 files changed, 88 insertions(+), 33 deletions(-) diff --git a/eval.c b/eval.c index 21c23513..372f0ef7 100644 --- a/eval.c +++ b/eval.c @@ -1531,8 +1531,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { _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_FIXNUMP: + _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; case OP_SYMBOLP: _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; case OP_CHARP: @@ -2101,24 +2101,24 @@ define_math_op(sexp_ceiling, ceil) #endif static sexp sexp_expt (sexp ctx, sexp x, sexp e) { - double f, x1, e1; + long double f, x1, e1; sexp res; #if USE_BIGNUMS - if (sexp_bignump(e)) { + if (sexp_bignump(e)) { /* bignum exponent needs special handling */ if ((x == sexp_make_fixnum(0)) || (x == sexp_make_fixnum(-1))) - res = sexp_make_flonum(ctx, pow(0, 0)); + res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ else if (x == sexp_make_fixnum(1)) - res = sexp_make_flonum(ctx, sexp_unbox_fixnum(x)); + res = sexp_make_flonum(ctx, 1); /* 1.0 */ else if (sexp_flonump(x)) res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); else - res = sexp_make_flonum(ctx, pow(10.0, 1e100)); + res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */ } else if (sexp_bignump(x)) { res = sexp_bignum_expt(ctx, x, e); } else { #endif if (sexp_fixnump(x)) - x1 = (double)sexp_unbox_fixnum(x); + x1 = sexp_unbox_fixnum(x); #if USE_FLONUMS else if (sexp_flonump(x)) x1 = sexp_flonum_value(x); @@ -2126,7 +2126,7 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { else return sexp_type_exception(ctx, "not a number", x); if (sexp_fixnump(e)) - e1 = (double)sexp_unbox_fixnum(e); + e1 = sexp_unbox_fixnum(e); #if USE_FLONUMS else if (sexp_flonump(e)) e1 = sexp_flonum_value(e); @@ -2135,13 +2135,15 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { return sexp_type_exception(ctx, "not a number", e); f = pow(x1, e1); #if USE_FLONUMS - if ((f > SEXP_MAX_FIXNUM) || sexp_flonump(x) || sexp_flonump(e)) { - if (sexp_flonump(x) || sexp_flonump(e)) - res = sexp_make_flonum(ctx, f); -#if USE_BIGNUMS - else - res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); + if ((f > SEXP_MAX_FIXNUM) || (! sexp_fixnump(x)) || (! sexp_fixnump(e))) { #endif +#if USE_BIGNUMS + if (sexp_fixnump(x) && sexp_fixnump(e)) + res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); + else +#endif +#if USE_FLONUMS + res = sexp_make_flonum(ctx, f); } else #endif res = sexp_make_fixnum((sexp_sint_t)round(f)); diff --git a/include/chibi/config.h b/include/chibi/config.h index 4b9957b7..43625f28 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -95,6 +95,12 @@ /* will not be available by default. */ /* #define USE_STRING_STREAMS 0 */ +/* uncomment this to disable automatic closing of ports */ +/* If enabled, the underlying FILE* for file ports will be */ +/* automatically closed when they're garbage collected. Doesn't */ +/* apply to stdin/stdout/stderr. */ +/* #define USE_AUTOCLOSE_PORTS 0 */ + /* uncomment this to disable stack overflow checks */ /* By default stacks are fairly small, so it's good to leave */ /* this enabled. */ @@ -225,6 +231,10 @@ #define USE_STRING_STREAMS 1 #endif +#ifndef USE_AUTOCLOSE_PORTS +#define USE_AUTOCLOSE_PORTS 1 +#endif + #ifndef USE_CHECK_STACK #define USE_CHECK_STACK 1 #endif diff --git a/include/chibi/eval.h b/include/chibi/eval.h index f7340132..0e9dbdf2 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -77,7 +77,7 @@ enum sexp_opcode_names { OP_MAKE_VECTOR, OP_AND, OP_NULLP, - OP_INTEGERP, + OP_FIXNUMP, OP_SYMBOLP, OP_CHARP, OP_EOFP, diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 7c7cfab3..739b2d29 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -195,7 +195,9 @@ struct sexp_struct { sexp_uint_t data[]; } bignum; struct { + sexp_uint_t freep, length; void *value; + char body[]; } cpointer; /* runtime types */ struct { @@ -459,18 +461,28 @@ sexp sexp_make_flonum(sexp ctx, double f); #if USE_BIGNUMS SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); -#define sexp_integerp(x) (sexp_fixnump(x) || sexp_bignump(x) _or_integer_flonump(x)) +#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) #else #define sexp_make_integer(ctx, x) sexp_make_fixnum(x) -#define sexp_integerp(x) (sexp_fixnump(x) _or_integer_flonump(x)) +#define sexp_exact_integerp(x) sexp_fixnump(x) #endif +#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x)) + #if USE_FLONUMS #define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) #else #define sexp_fixnum_to_flonum(ctx, x) (x) #endif +#if USE_FLONUMS || USE_BIGNUMS +#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0])) +#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0])) +#else +#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x)) +#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x)) +#endif + /*************************** field accessors **************************/ #define sexp_vector_length(x) ((x)->value.vector.length) @@ -509,7 +521,11 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_exception_procedure(p) ((p)->value.exception.procedure) #define sexp_exception_source(p) ((p)->value.exception.source) -#define sexp_cpointer_value(p) ((p)->value.cpointer.value) +#define sexp_cpointer_freep(p) ((p)->value.cpointer.freep) +#define sexp_cpointer_length(p) ((p)->value.cpointer.length) +#define sexp_cpointer_body(p) ((p)->value.cpointer.body) +#define sexp_cpointer_value(p) ((p)->value.cpointer.value) +#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p)) #define sexp_bytecode_length(x) ((x)->value.bytecode.length) #define sexp_bytecode_name(x) ((x)->value.bytecode.name) @@ -734,7 +750,7 @@ 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_make_cpointer(sexp ctx, void* value); +SEXP_API sexp sexp_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, int freep); SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out); SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out); SEXP_API sexp sexp_flush_output(sexp ctx, sexp out); @@ -764,8 +780,16 @@ SEXP_API void sexp_destroy_context(sexp ctx); #endif #if USE_TYPE_DEFS -SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots); +SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); +SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp obj); +#define sexp_register_c_type(ctx, name, finalizer) \ + sexp_register_type(ctx, name, sexp_make_fixnum(0), sexp_make_fixnum(0), \ + sexp_make_fixnum(0), sexp_make_fixnum(0), \ + sexp_make_fixnum(0), \ + sexp_make_fixnum(sexp_sizeof(cpointer)), \ + sexp_make_fixnum(0), sexp_make_fixnum(0), finalizer) #endif #define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) diff --git a/init.scm b/init.scm index b3210595..c457e8b9 100644 --- a/init.scm +++ b/init.scm @@ -383,7 +383,8 @@ (define real? number?) (define exact? fixnum?) (define inexact? flonum?) -(define (integer? x) (if (fixnum? x) #t (and (flonum? x) (= x (truncate x))))) +(define (integer? x) + (if (fixnum? x) #t (if (bignum? x) #t (and (flonum? x) (= x (truncate x)))))) (define (zero? x) (= x 0)) (define (positive? x) (> x 0)) @@ -523,9 +524,9 @@ res))) (define (with-output-to-file file thunk) - (let ((old-out (current-input-port)) + (let ((old-out (current-output-port)) (tmp-out (open-output-file file))) - (current-input-port tmp-out) + (current-output-port tmp-out) (let ((res (thunk))) (current-output-port old-out) res))) diff --git a/opcodes.c b/opcodes.c index 28f2aa2e..79b97313 100644 --- a/opcodes.c +++ b/opcodes.c @@ -52,11 +52,12 @@ _OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), _OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), _OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0), -_OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), +_OP(OPC_TYPE_PREDICATE, OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0), diff --git a/sexp.c b/sexp.c index 08f10c1d..0f2e9cb3 100644 --- a/sexp.c +++ b/sexp.c @@ -53,12 +53,17 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { return res; } -sexp sexp_finalize_port (sexp ctx, sexp port) { +#if USE_AUTOCLOSE_PORTS +static sexp sexp_finalize_port (sexp ctx, sexp port) { if (sexp_port_openp(port) && sexp_port_stream(port) && sexp_stringp(sexp_port_name(port))) fclose(sexp_port_stream(port)); return SEXP_VOID; } +#define SEXP_FINALIZE_PORT sexp_finalize_port +#else +#define SEXP_FINALIZE_PORT NULL +#endif #define _DEF_TYPE(t,fb,felb,flb,flo,fls,sb,so,sc,n,f) \ {.tag=SEXP_TYPE, .value={.type={t,fb,felb,flb,flo,fls,sb,so,sc,n,f}}} @@ -75,9 +80,9 @@ static struct sexp_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector", NULL), _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum", NULL), _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum", NULL), - _DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, 0, sexp_sizeof(cpointer), 0, 0, "cpointer", NULL), - _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", sexp_finalize_port), - _DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port", sexp_finalize_port), + _DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL), + _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", SEXP_FINALIZE_PORT), + _DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port", SEXP_FINALIZE_PORT), _DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception", NULL), _DEF_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure", NULL), _DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro", NULL), @@ -105,7 +110,8 @@ static sexp_uint_t sexp_num_types = SEXP_NUM_CORE_TYPES; static sexp_uint_t sexp_type_array_size = SEXP_NUM_CORE_TYPES; sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp felb, sexp flb, - sexp flo, sexp fls, sexp sb, sexp so, sexp sc) { + sexp flo, sexp fls, sexp sb, sexp so, sexp sc, + sexp_proc2 f) { struct sexp_struct *type, *new, *tmp; sexp res; sexp_uint_t i, len; @@ -138,6 +144,7 @@ sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp felb, sexp flb, sexp_type_size_off(type) = sexp_unbox_fixnum(so); sexp_type_size_scale(type) = sexp_unbox_fixnum(sc); sexp_type_name(type) = strdup(sexp_string_data(name)); + sexp_type_finalize(type) = f; res = sexp_make_fixnum(sexp_type_tag(type)); } return res; @@ -151,7 +158,13 @@ sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) { sexp_make_fixnum(offsetof(struct sexp_struct, value)), slots, slots, sexp_make_fixnum(0), sexp_make_fixnum(0), sexp_make_fixnum(type_size), sexp_make_fixnum(0), - sexp_make_fixnum(0)); + sexp_make_fixnum(0), NULL); +} + +sexp sexp_finalize_c_type (sexp ctx, sexp obj) { + if (sexp_cpointer_freep(obj)) + free(sexp_cpointer_value(obj)); + return SEXP_VOID; } #else @@ -696,9 +709,13 @@ sexp sexp_list_to_vector(sexp ctx, sexp ls) { return vec; } -sexp sexp_make_cpointer (sexp ctx, void *value) { - sexp ptr = sexp_alloc_type(ctx, port, SEXP_CPOINTER); +sexp sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, int freep) { + sexp ptr; + if (! value) return SEXP_FALSE; + ptr = sexp_alloc_type(ctx, cpointer, typeid); sexp_cpointer_value(ptr) = value; + sexp_cpointer_freep(ptr) = freep; + sexp_cpointer_length(ptr) = 0; return ptr; } From f9e67daf43650d5ac90223fc930115911e64b2d6 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 30 Nov 2009 04:07:57 +0900 Subject: [PATCH 215/535] adding initial stubber with partial posix and net modules --- Makefile | 12 +- lib/chibi/net.module | 10 + lib/chibi/net.scm | 20 ++ lib/chibi/net.stub | 26 +++ lib/chibi/posix.module | 8 + lib/chibi/posix.stub | 18 ++ sexp.c | 2 + tools/genstubs.scm | 451 +++++++++++++++++++++++++++++++++++++++++ 8 files changed, 544 insertions(+), 3 deletions(-) create mode 100644 lib/chibi/net.module create mode 100644 lib/chibi/net.scm create mode 100644 lib/chibi/net.stub create mode 100644 lib/chibi/posix.module create mode 100644 lib/chibi/posix.stub create mode 100755 tools/genstubs.scm diff --git a/Makefile b/Makefile index 8b85794c..437d4355 100644 --- a/Makefile +++ b/Makefile @@ -11,7 +11,9 @@ INCDIR ?= $(PREFIX)/include/chibi MODDIR ?= $(PREFIX)/share/chibi LIBDIR ?= $(PREFIX)/lib/chibi -DESTDIR ?= +DESTDIR ?= + +GENSTUBS ?= ./tools/genstubs.scm ifndef PLATFORM ifeq ($(shell uname),Darwin) @@ -50,7 +52,8 @@ endif all: chibi-scheme$(EXE) libs -libs: lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) +libs: lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ + lib/chibi/net$(SO) lib/chibi/posix$(SO) ifeq ($(USE_BOEHM),1) GCLDFLAGS := -lgc @@ -92,7 +95,10 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO) chibi-scheme-static$(EXE): main.o eval.o sexp.o $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) -lib/srfi/%$(SO): lib/srfi/%.c $(INCLUDES) +%.c: %.stub chibi-scheme$(EXE) $(GENSTUBS) + $(GENSTUBS) $< + +lib/%$(SO): lib/%.c $(INCLUDES) $(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme clean: diff --git a/lib/chibi/net.module b/lib/chibi/net.module new file mode 100644 index 00000000..d17c1791 --- /dev/null +++ b/lib/chibi/net.module @@ -0,0 +1,10 @@ + +(define-module (chibi net) + (export sockaddr? addressinfo? get-address-info socket connect with-net-io + address-info-family address-info-socket-type address-info-protocol + address-info-address address-info-address-length address-info-next) + (import (scheme)) + (import (chibi posix)) + (include-shared "net") + (include "net.scm")) + diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm new file mode 100644 index 00000000..a6fd78e0 --- /dev/null +++ b/lib/chibi/net.scm @@ -0,0 +1,20 @@ + +(define (with-net-io host service proc) + (let lp ((addr (get-address-info host service #f))) + (if (not addr) + (error "couldn't find address" host service) + (let ((sock (socket (address-info-family addr) + (address-info-socket-type addr) + (address-info-protocol addr)))) + (if (negative? sock) + (lp (address-info-next addr)) + (if (negative? + (connect sock + (address-info-address addr) + (address-info-address-length addr))) + (lp (address-info-next addr)) + (let ((in (open-input-fd sock)) + (out (open-output-fd sock))) + (let ((res (proc in out))) + (close-input-port in) + res)))))))) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub new file mode 100644 index 00000000..86f89457 --- /dev/null +++ b/lib/chibi/net.stub @@ -0,0 +1,26 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/socket.h") +(c-system-include "netdb.h") + +(define-c-struct sockaddr + predicate: sockaddr?) + +(define-c-struct addrinfo + finalizer: freeaddrinfo + predicate: address-info? + (int ai_family address-info-family) + (int ai_socktype address-info-socket-type) + (int ai_protocol address-info-protocol) + (sockaddr ai_addr address-info-address) + (size_t ai_addrlen address-info-address-length) + (addrinfo ai_next address-info-next)) + +(define-c errno (get-address-info getaddrinfo) + (string string (maybe-null addrinfo) (result free addrinfo))) + +(define-c int bind (int sockaddr int)) +(define-c int listen (int int)) +(define-c int socket (int int int)) +(define-c int connect (int sockaddr int)) + diff --git a/lib/chibi/posix.module b/lib/chibi/posix.module new file mode 100644 index 00000000..28e52939 --- /dev/null +++ b/lib/chibi/posix.module @@ -0,0 +1,8 @@ + +(define-module (chibi posix) + (export open-input-fd open-output-fd + delete-file link-file symbolic-link rename-file + create-directory delete-directory) + (import (scheme)) + (include-shared "posix")) + diff --git a/lib/chibi/posix.stub b/lib/chibi/posix.stub new file mode 100644 index 00000000..a1a16245 --- /dev/null +++ b/lib/chibi/posix.stub @@ -0,0 +1,18 @@ + +(c-system-include "sys/types.h") +(c-system-include "unistd.h") + +(define-c input-port (open-input-fd fdopen) (int (value "r"))) +(define-c output-port (open-output-fd fdopen) (int (value "w"))) + +(define-c errno (delete-file unlink) (string)) +(define-c errno (link-file link) (string string)) +(define-c errno (symbolic-link symlink) (string string)) +(define-c errno (rename-file rename) (string string)) + +(define-c errno (create-directory mkdir) (string int)) +(define-c errno (delete-directory rmdir) (string)) + +(define-c int (duplicate-fd dup) (int)) +;;(define-c errno pipe ((array int 2))) + diff --git a/sexp.c b/sexp.c index 0f2e9cb3..c73a2776 100644 --- a/sexp.c +++ b/sexp.c @@ -308,6 +308,8 @@ sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { sexp ls; + if (! sexp_oportp(out)) + out = sexp_make_output_port(ctx, stderr, SEXP_FALSE); sexp_write_string(ctx, "ERROR", out); if (sexp_exceptionp(exn)) { if (sexp_procedurep(sexp_exception_procedure(exn))) { diff --git a/tools/genstubs.scm b/tools/genstubs.scm new file mode 100755 index 00000000..d2ece356 --- /dev/null +++ b/tools/genstubs.scm @@ -0,0 +1,451 @@ +#! chibi-scheme -s + +(define types '()) +(define funcs '()) + +(define (cat . args) + (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (strip-extension path) + (let lp ((i (- (string-length path) 1))) + (cond ((<= i 0) path) + ((eq? #\. (string-ref path i)) (substring path 0 i)) + (else (lp (- i 1)))))) + +(define (string-concatenate-reverse ls) + (cond ((null? ls) "") + ((null? (cdr ls)) (car ls)) + (else (string-concatenate (reverse ls))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((eqv? c (string-ref str i)) + (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else + (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (x->string x) #\- "_") #\? "_p") + #\! "_x")) + +(define (func-name func) + (caddr func)) + +(define (func-scheme-name x) + (if (pair? x) (car x) x)) + +(define (func-c-name x) + (if (pair? x) (cadr x) x)) + +(define (stub-name sym) + (string-append "sexp_" (mangle sym) "_stub")) + +(define (type-id-name sym) + (string-append "sexp_" (mangle sym) "_type_id")) + +(define (signed-int-type? type) + (memq type '(short int long))) + +(define (unsigned-int-type? type) + (memq type '(unsigned-short unsigned-int unsigned-long size_t))) + +(define (int-type? type) + (or (signed-int-type? type) (unsigned-int-type? type))) + +(define (float-type? type) + (memq type '(float double long-double))) + +(define (c-declare . args) + (apply cat args) + (newline)) + +(define (c-system-include header) + (cat "\n#include <" header ">\n")) + +(define-syntax define-c-struct + (er-macro-transformer + (lambda (expr rename compare) + (set! types (cons (cdr expr) types)) + `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) + +(define-syntax define-c + (er-macro-transformer + (lambda (expr rename compare) + (set! funcs (cons (cons (stub-name (func-scheme-name (caddr expr))) + (cdr expr)) + funcs)) + #f))) + +(define (delq x ls) + (cond ((not (pair? ls)) ls) + ((eq? x (car ls)) (cdr ls)) + (else (cons (car ls) (delq x (cdr ls)))))) + +(define (without-mod x ls) + (let ((res (delq x ls))) + (if (and (pair? res) (null? (cdr res))) + (car res) + res))) + +(define (with-parsed-type type proc) + (let* ((free? (and (pair? type) (memq 'free type))) + (type (if free? (without-mod 'free type) type)) + (const? (and (pair? type) (memq 'const type))) + (type (if const? (without-mod 'const type) type)) + (null-ptr? (and (pair? type) (memq 'maybe-null type))) + (type (if null-ptr? (without-mod 'maybe-null type) type)) + (pointer? (and (pair? type) (memq 'pointer type))) + (type (if pointer? (without-mod 'pointer type) type)) + (result? (and (pair? type) (memq 'result type))) + (type (if result? (without-mod 'result type) type))) + (proc type free? const? null-ptr? pointer? result?))) + +(define (c->scheme-converter type val) + (with-parsed-type + type + (lambda (type free? const? null-ptr? pointer? result?) + (cond + ((memq type '(sexp errno)) + (cat val)) + ((int-type? type) + (cat "sexp_make_integer(ctx, " val ")")) + ((eq? 'string type) + (cat "sexp_c_string(ctx, " val ", -1)")) + ((eq? 'input-port type) + (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)")) + ((eq? 'output-port type) + (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) + (else + (let ((ctype (assq type types))) + (cond + (ctype + (cat "sexp_make_cpointer(ctx, " (type-id-name type) ", " + val ", " (if free? 1 0) ")")) + (else + (error "unknown type" type))))))))) + +(define (scheme->c-converter type val) + (with-parsed-type + type + (lambda (type free? const? null-ptr? pointer? result?) + (cond + ((eq? 'sexp type) + (cat val)) + ((signed-int-type? type) + (cat "sexp_sint_value(" val ")")) + ((unsigned-int-type? type) + (cat "sexp_uint_value(" val ")")) + ((eq? 'string type) + (cat "sexp_string_data(" val ")")) + (else + (let ((ctype (assq type types))) + (cond + (ctype + (cat (if null-ptr? + "sexp_cpointer_maybe_null_value" + "sexp_cpointer_value") + "(" val ")")) + (else + (error "unknown type" type))))))))) + +(define (type-predicate type) + (with-parsed-type + type + (lambda (type free? const? null-ptr? pointer? result?) + (cond + ((int-type? type) "sexp_exact_integerp") + ((float-type? type) "sexp_flonump") + ((eq? 'string type) "sexp_stringp") + (else #f))))) + +(define (type-name type) + (with-parsed-type + type + (lambda (type free? const? null-ptr? pointer? result?) + (cond + ((int-type? type) "integer") + ((float-type? type) "flonum") + (else type))))) + +(define (type-c-name type) + (with-parsed-type + type + (lambda (base-type free? const? null-ptr? pointer? result?) + (let ((struct? (assq base-type types))) + (string-append + (if const? "const " "") + (if struct? "struct " "") + (string-replace (symbol->string base-type) #\- #\space) + (if struct? "*" "") + (if pointer? "*" "")))))) + +(define (check-type arg type) + (with-parsed-type + type + (lambda (base-type free? const? null-ptr? pointer? result?) + (cond + ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type)) + (cat (type-predicate type) "(" arg ")")) + (else + (cond + ((assq base-type types) + (cat + (if null-ptr? "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " (type-id-name base-type) "))" + (lambda () (if null-ptr? (cat " || sexp_not(" arg "))"))))) + (else + (display "WARNING: don't know how to check: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (cat "1")))))))) + +(define (validate-type arg type) + (with-parsed-type + type + (lambda (base-type free? const? null-ptr? pointer? result?) + (cond + ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, \"not a " (type-name type) "\", " + arg ");\n")) + (else + (cond + ((assq base-type types) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, \"not a " type "\", " arg ");\n")) + (else + (display "WARNING: don't know how to validate: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (write type)))))))) + +(define (get-func-result func) + (let lp ((ls (cadddr func))) + (and (pair? ls) + (if (memq 'result (car ls)) + (car ls) + (lp (cdr ls)))))) + +(define (get-func-args func) + (let lp ((ls (cadddr func)) (res '())) + (if (pair? ls) + (if (and (pair? (car ls)) + (or (memq 'result (car ls)) (memq 'value (car ls)))) + (lp (cdr ls) res) + (lp (cdr ls) (cons (car ls) res))) + (reverse res)))) + +(define (write-func func) + (let ((ret-type (cadr func)) + (result (get-func-result func)) + (args (get-func-args func))) + (cat "static sexp " (car func) "(sexp ctx, ") + (let lp ((ls args) (i 0)) + (cond ((pair? ls) + (cat "sexp arg" i (if (pair? (cdr ls)) ", " "")) + (lp (cdr ls) (+ i 1))))) + (cat ") {\n sexp res;\n") + (if (eq? 'errno ret-type) (cat " int err;\n")) + (if result (cat " " (type-c-name result) " tmp;\n")) + (let lp ((ls args) (i 0)) + (cond ((pair? ls) + (validate-type (string-append "arg" (number->string i)) (car ls)) + (lp (cdr ls) (+ i 1))))) + (cat (if (eq? 'errno ret-type) " err = " " res = ")) + (c->scheme-converter + ret-type + (lambda () + (cat (func-c-name (func-name func)) "(") + (let lp ((ls (cadddr func)) (i 0)) + (cond ((pair? ls) + (cat (cond + ((eq? (car ls) result) + "&tmp") + ((and (pair? (car ls)) (memq 'value (car ls))) + => (lambda (x) (write (cadr x)) "")) + (else + (lambda () + (scheme->c-converter + (car ls) + (string-append "arg" (number->string i)))))) + (if (pair? (cdr ls)) ", " "")) + (lp (cdr ls) (+ i 1))))) + (cat ")"))) + (cat ";\n") + (if (eq? 'errno ret-type) + (if result + (cat " res = (err ? SEXP_FALSE : " + (lambda () (c->scheme-converter result "tmp")) + ");\n") + (cat " res = sexp_make_boolean(! err);\n"))) + (cat " return res;\n" + "}\n\n"))) + +(define (write-func-binding func) + (cat " sexp_define_foreign(ctx, env, " + (lambda () (write (symbol->string (func-scheme-name (func-name func))))) + ", " (length (get-func-args func)) ", " (car func) ");\n")) + +(define (write-type type) + (let ((name (car type)) + (type (cdr type))) + (with-parsed-type + type + (lambda (base-type free? const? null-ptr? pointer? result?) + (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" + " " (type-id-name name) + " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, " + (cond ((memq 'finalizer: base-type) + => (lambda (x) (stub-name (cadr x)))) + (else "sexp_finalize_c_type")) + "));\n") + (cond + ((memq 'predicate: base-type) + => (lambda (x) + (let ((pred (cadr x))) + (cat " tmp = sexp_make_type_predicate(ctx, name, " + "sexp_make_fixnum(" (type-id-name name) "));\n" + " name = sexp_intern(ctx, \"" pred "\");\n" + " sexp_env_define(ctx, env, name, tmp);\n"))))))))) + +(define (type-getter-name type name field) + (string-append "sexp_" (x->string (type-name name)) + "_get_" (x->string (cadr field)))) + +(define (write-type-getter type name field) + (cat "static sexp " (type-getter-name type name field) + " (sexp ctx, sexp x) {\n" + (lambda () (validate-type "x" name)) + " return " + (lambda () (c->scheme-converter + (car field) + (string-append "((struct " (mangle name) "*)" + "sexp_cpointer_value(x))->" + (x->string (cadr field))))) + ";\n" + "}\n\n")) + +(define (type-setter-name type name field) + (string-append "sexp_" (x->string (type-name name)) + "_set_" (x->string (car field)))) + +(define (write-type-setter type name field) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx, sexp x, sexp v) {\n" + (lambda () (validate-type "x" name)) + (lambda () (validate-type "v" (car field))) + " " + (lambda () (c->scheme-converter + (car field) + (string-append "((struct " (mangle name) "*)" + "sexp_cpointer_value(x))->" + (x->string (cadr field))))) + " = v;\n" + " return SEXP_VOID;" + "}\n\n")) + +(define (write-type-funcs type) + (let ((name (car type)) + (type (cdr type))) + (with-parsed-type + type + (lambda (base-type free? const? null-ptr? pointer? result?) + (cond + ((memq 'finalizer: base-type) + => (lambda (x) + (cat "static sexp " (stub-name (cadr x)) + " (sexp ctx, sexp x) {\n" + " if (sexp_cpointer_freep(x))\n" + " " (cadr x) "(sexp_cpointer_value(x));\n" + " return SEXP_VOID;\n" + "}\n\n")))) + (cond + ((memq 'constructor: base-type) + => (lambda (x) + (let ((make (caadr x)) + (args (cdadr x))) + (cat "static sexp " (stub-name make) + " (sexp ctx" + (lambda () (for-each (lambda (x) (cat ", sexp " x)) args)) + ") {\n" + " struct " (type-name name) " *r;\n" + " sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + (type-id-name name) + ");\n" + " sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " r = sexp_cpointer_value(res);\n" + " return res;\n" + "}\n\n") + (set! funcs + (cons (list (stub-name make) 'void make args) funcs)))))) + (for-each + (lambda (field) + (cond + ((and (pair? field) (pair? (cdr field))) + (cond + ((and (pair? (cddr field)) (caddr field)) + (write-type-getter type name field) + (set! funcs + (cons (list (type-getter-name type name field) + (car field) (caddr field) (list name)) + funcs)))) + (cond + ((and (pair? (cddr field)) + (pair? (cdddr field)) + (car (cdddr field))) + (write-type-setter type name field) + (set! funcs + (cons (list (type-setter-name type name field) + (car field) (cadddr field) + (list name (car field))) + funcs)) + ))))) + base-type))))) + +(define (write-init) + (newline) + (for-each write-func funcs) + (for-each write-type-funcs types) + (cat "sexp sexp_init_library (sexp ctx, sexp env) {\n" + " sexp_gc_var2(name, tmp);\n" + " sexp_gc_preserve2(ctx, name, tmp);\n") + (for-each write-type types) + (for-each write-func-binding funcs) + (cat " sexp_gc_release2(ctx);\n" + " return SEXP_VOID;\n" + "}\n\n")) + +(define (generate file) + (display "/* automatically generated by chibi genstubs */\n") + (c-system-include "chibi/eval.h") + (load file) + (write-init)) + +(define (main args) + (case (length args) + ((1) + (with-output-to-file (string-append (strip-extension (car args)) ".c") + (lambda () (generate (car args))))) + ((2) + (if (equal? "-" (cadr args)) + (generate (car args)) + (with-output-to-file (cadr args) (lambda () (generate (car args)))))) + (else + (error "usage: genstubs []")))) + +(main (command-line-arguments)) + From a3578d1ef8c2d47fccf2c5772eb54df271d2f6ab Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 2 Dec 2009 02:09:48 +0900 Subject: [PATCH 216/535] going slightly overboard in auto-generating the correct indefinite article --- tools/genstubs.scm | 44 ++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 42 insertions(+), 2 deletions(-) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index d2ece356..b7395e77 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -39,6 +39,44 @@ (string-replace (string-replace (x->string x) #\- "_") #\? "_p") #\! "_x")) +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase str) + (list->string (map char-downcase (string->list str)))) + +(define (with-output-to-string thunk) + (call-with-output-string + (lambda (out) + (let ((old-out (current-output-port))) + (current-output-port out) + (thunk) + (current-output-port old-out))))) + +(define (definite-article x) + (define (vowel? c) + (memv c '(#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U))) + (define (vowel-exception? str) + (member (string-downcase str) + '("european" "ewe" "unicorn" "unicycle" "university" "user"))) + (define (consonant-exception? str) + ;; not "historic" according to elements of style + (member (string-downcase str) + '("heir" "herb" "herbal" "herbivore" "honest" "honor" "hour"))) + (let* ((full-str (with-output-to-string (lambda () (cat x)))) + (i (string-scan #\space full-str)) + (str (if i (substring full-str 0 i) full-str))) + (string-append + (cond + ((equal? str "") "a ") + ((vowel? (string-ref str 0)) (if (vowel-exception? str) "a " "an ")) + (else (if (consonant-exception? str) "an " "a "))) + full-str))) + (define (func-name func) (caddr func)) @@ -219,14 +257,16 @@ ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type)) (cat " if (! " (lambda () (check-type arg type)) ")\n" - " return sexp_type_exception(ctx, \"not a " (type-name type) "\", " + " return sexp_type_exception(ctx, \"not " + (definite-article (type-name type)) "\", " arg ");\n")) (else (cond ((assq base-type types) (cat " if (! " (lambda () (check-type arg type)) ")\n" - " return sexp_type_exception(ctx, \"not a " type "\", " arg ");\n")) + " return sexp_type_exception(ctx, \"not " + (definite-article type) "\", " arg ");\n")) (else (display "WARNING: don't know how to validate: " (current-error-port)) (write type (current-error-port)) From b49153dfdf320e3b0fdcb94594c50c90469e54a3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 2 Dec 2009 03:13:04 +0900 Subject: [PATCH 217/535] adding time_t type handling to stubber, with 2010 "chibi" epoch --- TODO | 8 ++++---- include/chibi/config.h | 18 ++++++++++++++++++ include/chibi/sexp.h | 3 +++ lib/chibi/posix.module | 3 ++- lib/chibi/posix.stub | 5 ++++- tools/genstubs.scm | 8 ++++++-- 6 files changed, 37 insertions(+), 8 deletions(-) diff --git a/TODO b/TODO index ef3a06c0..01137858 100644 --- a/TODO +++ b/TODO @@ -3,7 +3,7 @@ *+ precise gc rewrite **+ fix heap growing **+ separate gc heaps -**- finalizers +**+ finalizers **- weak references *+ ast rewrite *+ full r5rs @@ -28,7 +28,7 @@ *= ffi **+ libdl interface **+ opcode generation interface -**- stub generator +**= stub generator *= cleanup *- user documentation *- unicode @@ -47,6 +47,6 @@ *- SRFI-0 cond-expand *+ SRFI-9 define-record-type *+ SRFI-69 hash-tables -*- tcp interface -*- posix interface +*= net interface +*= posix interface *- code repository with install tools diff --git a/include/chibi/config.h b/include/chibi/config.h index 43625f28..10836648 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -101,6 +101,12 @@ /* apply to stdin/stdout/stderr. */ /* #define USE_AUTOCLOSE_PORTS 0 */ +/* uncomment this to use the normal 1970 unix epoch */ +/* By default chibi uses an datetime epoch starting at */ +/* 2010/01/01 00:00:00 in order to be able to represent */ +/* more common times as fixnums. */ +/* #define USE_2010_EPOCH 0 */ + /* uncomment this to disable stack overflow checks */ /* By default stacks are fairly small, so it's good to leave */ /* this enabled. */ @@ -235,6 +241,18 @@ #define USE_AUTOCLOSE_PORTS 1 #endif +#ifndef USE_2010_EPOCH +#define USE_2010_EPOCH 1 +#endif + +#ifndef SEXP_EPOCH_OFFSET +#if USE_2010_EPOCH +#define SEXP_EPOCH_OFFSET 1262271600 +#else +#define SEXP_EPOCH_OFFSET 0 +#endif +#endif + #ifndef USE_CHECK_STACK #define USE_CHECK_STACK 1 #endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 739b2d29..8d850472 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -483,6 +483,9 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x)) #endif +#define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET) +#define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET) + /*************************** field accessors **************************/ #define sexp_vector_length(x) ((x)->value.vector.length) diff --git a/lib/chibi/posix.module b/lib/chibi/posix.module index 28e52939..77394032 100644 --- a/lib/chibi/posix.module +++ b/lib/chibi/posix.module @@ -2,7 +2,8 @@ (define-module (chibi posix) (export open-input-fd open-output-fd delete-file link-file symbolic-link rename-file - create-directory delete-directory) + create-directory delete-directory + current-seconds) (import (scheme)) (include-shared "posix")) diff --git a/lib/chibi/posix.stub b/lib/chibi/posix.stub index a1a16245..680084a9 100644 --- a/lib/chibi/posix.stub +++ b/lib/chibi/posix.stub @@ -1,5 +1,6 @@ (c-system-include "sys/types.h") +(c-system-include "time.h") (c-system-include "unistd.h") (define-c input-port (open-input-fd fdopen) (int (value "r"))) @@ -7,7 +8,7 @@ (define-c errno (delete-file unlink) (string)) (define-c errno (link-file link) (string string)) -(define-c errno (symbolic-link symlink) (string string)) +(define-c errno (symbolic-link-file symlink) (string string)) (define-c errno (rename-file rename) (string string)) (define-c errno (create-directory mkdir) (string int)) @@ -16,3 +17,5 @@ (define-c int (duplicate-fd dup) (int)) ;;(define-c errno pipe ((array int 2))) +(define-c time_t (current-seconds time) ((value NULL))) + diff --git a/tools/genstubs.scm b/tools/genstubs.scm index b7395e77..1f446f41 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -156,6 +156,8 @@ (cond ((memq type '(sexp errno)) (cat val)) + ((eq? type 'time_t) + (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) ((int-type? type) (cat "sexp_make_integer(ctx, " val ")")) ((eq? 'string type) @@ -180,6 +182,8 @@ (cond ((eq? 'sexp type) (cat val)) + ((eq? type 'time_t) + (cat "sexp_uint_value(sexp_unshift_epoch(" val "))")) ((signed-int-type? type) (cat "sexp_sint_value(" val ")")) ((unsigned-int-type? type) @@ -293,10 +297,10 @@ (let ((ret-type (cadr func)) (result (get-func-result func)) (args (get-func-args func))) - (cat "static sexp " (car func) "(sexp ctx, ") + (cat "static sexp " (car func) "(sexp ctx") (let lp ((ls args) (i 0)) (cond ((pair? ls) - (cat "sexp arg" i (if (pair? (cdr ls)) ", " "")) + (cat ", sexp arg" i) (lp (cdr ls) (+ i 1))))) (cat ") {\n sexp res;\n") (if (eq? 'errno ret-type) (cat " int err;\n")) From 6bd1bd3687195732b9c65e2e43268db9499a724a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 2 Dec 2009 03:51:39 +0900 Subject: [PATCH 218/535] adding directory-files to posix module --- lib/chibi/posix.module | 5 +++-- lib/chibi/posix.scm | 7 +++++++ lib/chibi/posix.stub | 19 ++++++++++++++++++- tools/genstubs.scm | 2 +- 4 files changed, 29 insertions(+), 4 deletions(-) create mode 100644 lib/chibi/posix.scm diff --git a/lib/chibi/posix.module b/lib/chibi/posix.module index 77394032..95502c94 100644 --- a/lib/chibi/posix.module +++ b/lib/chibi/posix.module @@ -2,8 +2,9 @@ (define-module (chibi posix) (export open-input-fd open-output-fd delete-file link-file symbolic-link rename-file - create-directory delete-directory + directory-files create-directory delete-directory current-seconds) (import (scheme)) - (include-shared "posix")) + (include-shared "posix") + (include "posix.scm")) diff --git a/lib/chibi/posix.scm b/lib/chibi/posix.scm new file mode 100644 index 00000000..e2c6d56f --- /dev/null +++ b/lib/chibi/posix.scm @@ -0,0 +1,7 @@ + +(define (directory-files path) + (let ((dir (opendir path))) + (let lp ((res '())) + (let ((file (readdir dir))) + (if file (lp (cons (dirent-name file) res)) res))))) + diff --git a/lib/chibi/posix.stub b/lib/chibi/posix.stub index 680084a9..a38eb0b1 100644 --- a/lib/chibi/posix.stub +++ b/lib/chibi/posix.stub @@ -2,6 +2,13 @@ (c-system-include "sys/types.h") (c-system-include "time.h") (c-system-include "unistd.h") +(c-system-include "dirent.h") + +(define-c-struct DIR + finalizer: closedir) + +(define-c-struct dirent + (string d_name dirent-name)) (define-c input-port (open-input-fd fdopen) (int (value "r"))) (define-c output-port (open-output-fd fdopen) (int (value "w"))) @@ -11,11 +18,21 @@ (define-c errno (symbolic-link-file symlink) (string string)) (define-c errno (rename-file rename) (string string)) +;; (define-c string (current-directory getcwd) ()) (define-c errno (create-directory mkdir) (string int)) (define-c errno (delete-directory rmdir) (string)) +(define-c (free DIR) opendir (string)) +(define-c dirent readdir (DIR)) + (define-c int (duplicate-fd dup) (int)) -;;(define-c errno pipe ((array int 2))) + +(define-c pid_t fork ()) +;; (define-c pid_t wait ((result pointer int))) +;; (define-c void exit (int)) +;; (define-c int (execute execvp) (string (array string null))) + +;;(define-c errno pipe ((result array int 2))) (define-c time_t (current-seconds time) ((value NULL))) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 1f446f41..e5d5ea66 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -96,7 +96,7 @@ (memq type '(short int long))) (define (unsigned-int-type? type) - (memq type '(unsigned-short unsigned-int unsigned-long size_t))) + (memq type '(unsigned-short unsigned-int unsigned-long size_t pid_t))) (define (int-type? type) (or (signed-int-type? type) (unsigned-int-type? type))) From 5d2f5912ce26ed4b22adbb0a0824663f79fa6542 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 5 Dec 2009 17:17:55 +0900 Subject: [PATCH 219/535] adding parent links to cpointers to prevent freeing shared structures --- Makefile | 8 +-- eval.c | 31 ++++++----- include/chibi/eval.h | 1 + include/chibi/sexp.h | 19 ++++--- lib/chibi/net.stub | 12 ++--- sexp.c | 13 +++-- tools/genstubs.scm | 125 ++++++++++++++++++++++--------------------- 7 files changed, 112 insertions(+), 97 deletions(-) diff --git a/Makefile b/Makefile index 437d4355..47f9ff6c 100644 --- a/Makefile +++ b/Makefile @@ -52,8 +52,10 @@ endif all: chibi-scheme$(EXE) libs -libs: lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ - lib/chibi/net$(SO) lib/chibi/posix$(SO) +COMPILED_LIBS := lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ + lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/posix$(SO) + +libs: $(COMPILED_LIBS) ifeq ($(USE_BOEHM),1) GCLDFLAGS := -lgc @@ -106,7 +108,7 @@ clean: find lib -name \*.$(SO) -exec rm -f '{}' \; cleaner: clean - rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) *$(SO) *.a + rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a rm -rf *.dSYM test-basic: chibi-scheme$(EXE) diff --git a/eval.c b/eval.c index 372f0ef7..49fd8a31 100644 --- a/eval.c +++ b/eval.c @@ -16,7 +16,6 @@ static int scheme_initialized_p = 0; #define sexp_disasm(...) #endif -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); @@ -354,7 +353,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); + sexp_immutablep(res) = 1; } else { res = x; } @@ -388,7 +387,7 @@ static sexp analyze_app (sexp ctx, sexp x) { sexp_gc_preserve2(ctx, res, tmp); for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) { sexp_push(ctx, res, SEXP_FALSE); - tmp = analyze(ctx, sexp_car(x)); + tmp = sexp_analyze(ctx, sexp_car(x)); if (sexp_exceptionp(tmp)) { res = tmp; break; @@ -406,7 +405,7 @@ static sexp analyze_seq (sexp ctx, sexp ls) { if (sexp_nullp(ls)) res = SEXP_VOID; else if (sexp_nullp(sexp_cdr(ls))) - res = analyze(ctx, sexp_car(ls)); + res = sexp_analyze(ctx, sexp_car(ls)); else { res = sexp_alloc_type(ctx, seq, SEXP_SEQ); tmp = analyze_app(ctx, ls); @@ -451,7 +450,7 @@ static sexp analyze_set (sexp ctx, sexp x) { 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)); + value = sexp_analyze(ctx, sexp_caddr(x)); if (sexp_exceptionp(ref)) res = ref; else if (sexp_exceptionp(value)) @@ -495,7 +494,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { value = analyze_lambda(ctx2, sexp_cons(ctx2, SEXP_VOID, tmp)); } else { name = sexp_cadr(tmp); - value = analyze(ctx2, sexp_caddr(tmp)); + value = sexp_analyze(ctx2, sexp_caddr(tmp)); } if (sexp_exceptionp(value)) sexp_return(res, value); sexp_push(ctx2, defs, @@ -522,10 +521,10 @@ static sexp analyze_if (sexp ctx, sexp x) { 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)); + test = sexp_analyze(ctx, sexp_cadr(x)); + pass = sexp_analyze(ctx, sexp_caddr(x)); fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; - fail = analyze(ctx, fail_expr); + fail = sexp_analyze(ctx, fail_expr); res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass : sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail)); } @@ -559,7 +558,7 @@ static sexp analyze_define (sexp ctx, sexp x) { tmp = sexp_cons(ctx, SEXP_VOID, tmp); value = analyze_lambda(ctx, tmp); } else - value = analyze(ctx, sexp_caddr(x)); + value = sexp_analyze(ctx, sexp_caddr(x)); ref = analyze_var_ref(ctx, name); if (sexp_exceptionp(ref)) res = ref; @@ -644,7 +643,7 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x) { return res; } -static sexp analyze (sexp ctx, sexp object) { +sexp sexp_analyze (sexp ctx, sexp object) { sexp op; sexp_gc_var4(res, tmp, x, cell); sexp_gc_preserve4(ctx, res, tmp, x, cell); @@ -731,7 +730,7 @@ static sexp analyze (sexp ctx, sexp object) { sexp_synclo_free_vars(x), sexp_context_fv(tmp)); x = sexp_synclo_expr(x); - res = analyze(tmp, x); + res = sexp_analyze(tmp, x); } else { res = x; } @@ -2274,7 +2273,7 @@ sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, #if USE_TYPE_DEFS sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { - if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < SEXP_NUM_CORE_TYPES)) + if (! sexp_fixnump(type)) return sexp_type_exception(ctx, "make-type-predicate: bad type", type); return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_TYPE_PREDICATE), sexp_make_fixnum(OP_TYPEP), sexp_make_fixnum(1), @@ -2285,7 +2284,7 @@ sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { sexp_uint_t type_size; - if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < SEXP_NUM_CORE_TYPES)) + if (! sexp_fixnump(type)) return sexp_type_exception(ctx, "make-constructor: bad type", type); type_size = sexp_type_size_base(&(sexp_type_specs[sexp_unbox_fixnum(type)])); return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_CONSTRUCTOR), @@ -2296,7 +2295,7 @@ sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { } sexp sexp_make_accessor (sexp ctx, sexp name, sexp type, sexp index, sexp code) { - if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < SEXP_NUM_CORE_TYPES)) + if (! sexp_fixnump(type)) return sexp_type_exception(ctx, "make-accessor: bad type", type); if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) return sexp_type_exception(ctx, "make-accessor: bad index", index); @@ -2435,7 +2434,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { sexp sexp_compile (sexp ctx, sexp x) { sexp_gc_var3(ast, vec, res); sexp_gc_preserve3(ctx, ast, vec, res); - ast = analyze(ctx, x); + ast = sexp_analyze(ctx, x); if (sexp_exceptionp(ast)) { res = ast; } else { diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 0e9dbdf2..1326333e 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -122,6 +122,7 @@ enum sexp_opcode_names { SEXP_API void sexp_scheme_init (void); SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env); SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); +SEXP_API sexp sexp_analyze (sexp context, sexp x); SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 8d850472..575eeaad 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -149,8 +149,9 @@ struct sexp_gc_var_t { struct sexp_struct { sexp_tag_t tag; - char immutablep; char gc_mark; + unsigned int immutablep:1; + unsigned int freep:1; union { /* basic types */ double flonum; @@ -195,8 +196,9 @@ struct sexp_struct { sexp_uint_t data[]; } bignum; struct { - sexp_uint_t freep, length; + sexp_uint_t length; void *value; + sexp parent; char body[]; } cpointer; /* runtime types */ @@ -368,9 +370,11 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #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_pointer_tag(x) ((x)->tag) +#define sexp_gc_mark(x) ((x)->gc_mark) +#define sexp_flags(x) ((x)->flags) +#define sexp_immutablep(x) ((x)->immutablep) +#define sexp_freep(x) ((x)->freep) #define sexp_object_type(x) (&(sexp_type_specs[(x)->tag])) #define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x))) @@ -524,9 +528,10 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_exception_procedure(p) ((p)->value.exception.procedure) #define sexp_exception_source(p) ((p)->value.exception.source) -#define sexp_cpointer_freep(p) ((p)->value.cpointer.freep) +#define sexp_cpointer_freep(p) (sexp_freep(p)) #define sexp_cpointer_length(p) ((p)->value.cpointer.length) #define sexp_cpointer_body(p) ((p)->value.cpointer.body) +#define sexp_cpointer_parent(p) ((p)->value.cpointer.parent) #define sexp_cpointer_value(p) ((p)->value.cpointer.value) #define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p)) @@ -753,7 +758,7 @@ 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_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, int freep); +SEXP_API sexp sexp_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, sexp parent, int freep); SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out); SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out); SEXP_API sexp sexp_flush_output(sexp ctx, sexp out); diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub index 86f89457..8e595f8f 100644 --- a/lib/chibi/net.stub +++ b/lib/chibi/net.stub @@ -9,12 +9,12 @@ (define-c-struct addrinfo finalizer: freeaddrinfo predicate: address-info? - (int ai_family address-info-family) - (int ai_socktype address-info-socket-type) - (int ai_protocol address-info-protocol) - (sockaddr ai_addr address-info-address) - (size_t ai_addrlen address-info-address-length) - (addrinfo ai_next address-info-next)) + (int ai_family address-info-family) + (int ai_socktype address-info-socket-type) + (int ai_protocol address-info-protocol) + ((link sockaddr) ai_addr address-info-address) + (size_t ai_addrlen address-info-address-length) + ((link addrinfo) ai_next address-info-next)) (define-c errno (get-address-info getaddrinfo) (string string (maybe-null addrinfo) (result free addrinfo))) diff --git a/sexp.c b/sexp.c index c73a2776..47b7fb2c 100644 --- a/sexp.c +++ b/sexp.c @@ -80,7 +80,7 @@ static struct sexp_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector", NULL), _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum", NULL), _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum", NULL), - _DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL), + _DEF_TYPE(SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL), _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", SEXP_FINALIZE_PORT), _DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port", SEXP_FINALIZE_PORT), _DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception", NULL), @@ -711,12 +711,13 @@ sexp sexp_list_to_vector(sexp ctx, sexp ls) { return vec; } -sexp sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, int freep) { +sexp sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, sexp parent, int freep) { sexp ptr; if (! value) return SEXP_FALSE; ptr = sexp_alloc_type(ctx, cpointer, typeid); + sexp_freep(ptr) = freep; sexp_cpointer_value(ptr) = value; - sexp_cpointer_freep(ptr) = freep; + sexp_cpointer_parent(ptr) = parent; sexp_cpointer_length(ptr) = 0; return ptr; } @@ -1158,7 +1159,11 @@ sexp sexp_read_string(sexp ctx, sexp in) { 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;} + switch (c) { + case 'n': c = '\n'; break; + case 'r': c = '\r'; break; + case 't': c = '\t'; break; + } } if (c == EOF) { res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in); diff --git a/tools/genstubs.scm b/tools/genstubs.scm index e5d5ea66..779b8afd 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -125,34 +125,27 @@ funcs)) #f))) -(define (delq x ls) - (cond ((not (pair? ls)) ls) - ((eq? x (car ls)) (cdr ls)) - (else (cons (car ls) (delq x (cdr ls)))))) - -(define (without-mod x ls) - (let ((res (delq x ls))) - (if (and (pair? res) (null? (cdr res))) - (car res) - res))) - (define (with-parsed-type type proc) - (let* ((free? (and (pair? type) (memq 'free type))) - (type (if free? (without-mod 'free type) type)) - (const? (and (pair? type) (memq 'const type))) - (type (if const? (without-mod 'const type) type)) - (null-ptr? (and (pair? type) (memq 'maybe-null type))) - (type (if null-ptr? (without-mod 'maybe-null type) type)) - (pointer? (and (pair? type) (memq 'pointer type))) - (type (if pointer? (without-mod 'pointer type) type)) - (result? (and (pair? type) (memq 'result type))) - (type (if result? (without-mod 'result type) type))) - (proc type free? const? null-ptr? pointer? result?))) + (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) + (pointer? #f) (struct? #f) (link? #f) (result? #f)) + (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) + (case (and (pair? type) (car type)) + ((free) (lp (next) #t const? null-ptr? pointer? struct? link? result?)) + ((const) (lp (next) free? #t null-ptr? pointer? struct? link? result?)) + ((maybe-null) (lp (next) free? const? #t pointer? struct? link? result?)) + ((pointer) (lp (next) free? const? null-ptr? #t struct? link? result?)) + ((struct) (lp (next) free? const? null-ptr? pointer? #t link? result?)) + ((link) (lp (next) free? const? null-ptr? pointer? struct? #t result?)) + ((result) (lp (next) free? const? null-ptr? pointer? struct? link? #t)) + (else (proc type free? const? null-ptr? pointer? struct? link? result?))))) -(define (c->scheme-converter type val) +(define (get-base-type type) + (with-parsed-type type (lambda (x . args) x))) + +(define (c->scheme-converter type val . o) (with-parsed-type type - (lambda (type free? const? null-ptr? pointer? result?) + (lambda (type free? const? null-ptr? pointer? struct? link? result?) (cond ((memq type '(sexp errno)) (cat val)) @@ -171,14 +164,15 @@ (cond (ctype (cat "sexp_make_cpointer(ctx, " (type-id-name type) ", " - val ", " (if free? 1 0) ")")) + val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " + (if free? 1 0) ")")) (else (error "unknown type" type))))))))) (define (scheme->c-converter type val) (with-parsed-type type - (lambda (type free? const? null-ptr? pointer? result?) + (lambda (type free? const? null-ptr? pointer? struct? link? result?) (cond ((eq? 'sexp type) (cat val)) @@ -204,7 +198,7 @@ (define (type-predicate type) (with-parsed-type type - (lambda (type free? const? null-ptr? pointer? result?) + (lambda (type free? const? null-ptr? pointer? struct? link? result?) (cond ((int-type? type) "sexp_exact_integerp") ((float-type? type) "sexp_flonump") @@ -214,7 +208,7 @@ (define (type-name type) (with-parsed-type type - (lambda (type free? const? null-ptr? pointer? result?) + (lambda (type free? const? null-ptr? pointer? struct? link? result?) (cond ((int-type? type) "integer") ((float-type? type) "flonum") @@ -223,7 +217,7 @@ (define (type-c-name type) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? result?) + (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) (let ((struct? (assq base-type types))) (string-append (if const? "const " "") @@ -235,7 +229,7 @@ (define (check-type arg type) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? result?) + (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) (cond ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type)) (cat (type-predicate type) "(" arg ")")) @@ -256,7 +250,7 @@ (define (validate-type arg type) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? result?) + (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) (cond ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type)) (cat @@ -349,7 +343,7 @@ (type (cdr type))) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? result?) + (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" " " (type-id-name name) " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, " @@ -368,46 +362,56 @@ (define (type-getter-name type name field) (string-append "sexp_" (x->string (type-name name)) - "_get_" (x->string (cadr field)))) + "_get_" (x->string (get-base-type (cadr field))))) (define (write-type-getter type name field) - (cat "static sexp " (type-getter-name type name field) - " (sexp ctx, sexp x) {\n" - (lambda () (validate-type "x" name)) - " return " - (lambda () (c->scheme-converter - (car field) - (string-append "((struct " (mangle name) "*)" - "sexp_cpointer_value(x))->" - (x->string (cadr field))))) - ";\n" - "}\n\n")) + (with-parsed-type + (car field) + (lambda (field-type free? const? null-ptr? pointer? struct? link? result?) + (cat "static sexp " (type-getter-name type name field) + " (sexp ctx, sexp x) {\n" + (lambda () (validate-type "x" name)) + " return " + (lambda () + (c->scheme-converter + field-type + (string-append "((struct " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if struct? "." "->") + (x->string (cadr field))) + (and (or struct? link?) "x"))) + ";\n" + "}\n\n")))) (define (type-setter-name type name field) (string-append "sexp_" (x->string (type-name name)) - "_set_" (x->string (car field)))) + "_set_" (x->string (get-base-type (car field))))) (define (write-type-setter type name field) - (cat "static sexp " (type-setter-name type name field) - " (sexp ctx, sexp x, sexp v) {\n" - (lambda () (validate-type "x" name)) - (lambda () (validate-type "v" (car field))) - " " - (lambda () (c->scheme-converter - (car field) - (string-append "((struct " (mangle name) "*)" - "sexp_cpointer_value(x))->" - (x->string (cadr field))))) - " = v;\n" - " return SEXP_VOID;" - "}\n\n")) + (with-parsed-type + (car field) + (lambda (field-type free? const? null-ptr? pointer? struct? link? result?) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx, sexp x, sexp v) {\n" + (lambda () (validate-type "x" name)) + (lambda () (validate-type "v" (car field))) + " " + (lambda () (c->scheme-converter + field-type + (string-append "((struct " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if struct? "." "->") + (x->string (cadr field))))) + " = v;\n" + " return SEXP_VOID;" + "}\n\n")))) (define (write-type-funcs type) (let ((name (car type)) (type (cdr type))) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? result?) + (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) (cond ((memq 'finalizer: base-type) => (lambda (x) @@ -456,8 +460,7 @@ (cons (list (type-setter-name type name field) (car field) (cadddr field) (list name (car field))) - funcs)) - ))))) + funcs))))))) base-type))))) (define (write-init) From 035aa7005c0ec3ea49f67fa8843e792ddb0d72fb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 5 Dec 2009 17:34:27 +0900 Subject: [PATCH 220/535] no longer exit(2)ing on OOM, pre-allocating a global OOM exception --- gc.c | 24 ++++++++++++++++++++---- include/chibi/sexp.h | 1 + sexp.c | 30 ++++++++++++++++++++++-------- 3 files changed, 43 insertions(+), 12 deletions(-) diff --git a/gc.c b/gc.c index b5c5b2c3..c2933930 100644 --- a/gc.c +++ b/gc.c @@ -4,10 +4,26 @@ #include "chibi/sexp.h" +/* These settings are configurable but only recommended for */ +/* experienced users, so they're not in config.h. */ + +/* the initial heap size in bytes */ +#ifndef SEXP_INITIAL_HEAP_SIZE #define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) -#define SEXP_MAXIMUM_HEAP_SIZE 0 +#endif + +/* the maximum heap size in bytes - if 0 there is no limit */ +#ifndef SEXP_MAXIMUM_HEAP_SIZE +#define SEXP_MAXIMUM_HEAP_SIZE (4*1024*1024) +#endif + +/* if after GC more than this percentage of memory is still in use, */ +/* and we've not exceeded the maximum size, grow the heap */ +#ifndef SEXP_GROW_HEAP_RATIO +#define SEXP_GROW_HEAP_RATIO 0.75 +#endif + #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair)) -#define SEXP_GROW_HEAP_RATIO 0.7 #if SEXP_64_BIT #define sexp_heap_align(n) sexp_align(n, 5) @@ -206,12 +222,12 @@ void* sexp_alloc (sexp ctx, size_t size) { max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed)); h = sexp_heap_last(sexp_context_heap(ctx)); if (((max_freed < size) - || ((h->size - sum_freed) < (h->size*(1 - SEXP_GROW_HEAP_RATIO)))) + || ((h->size - sum_freed) > (h->size*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); + res = sexp_global(ctx, SEXP_G_OOM_ERROR); } return res; } diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 575eeaad..03b044a0 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -668,6 +668,7 @@ enum sexp_context_globals { #if ! USE_GLOBAL_SYMBOLS SEXP_G_SYMBOLS, #endif + SEXP_G_OOM_ERROR, SEXP_G_QUOTE_SYMBOL, SEXP_G_QUASIQUOTE_SYMBOL, SEXP_G_UNQUOTE_SYMBOL, diff --git a/sexp.c b/sexp.c index 47b7fb2c..9ee6037a 100644 --- a/sexp.c +++ b/sexp.c @@ -49,7 +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) sexp_pointer_tag(res) = tag; + if (res && ! sexp_exceptionp(res)) sexp_pointer_tag(res) = tag; return res; } @@ -187,6 +187,7 @@ void sexp_init_context_globals (sexp ctx) { #if ! USE_GLOBAL_SYMBOLS sexp_global(ctx, SEXP_G_SYMBOLS) = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_SYMBOL_TABLE_SIZE), SEXP_NULL); #endif + sexp_global(ctx, SEXP_G_OOM_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of memory", SEXP_NULL); sexp_global(ctx, SEXP_G_QUOTE_SYMBOL) = sexp_intern(ctx, "quote"); sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote"); sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote"); @@ -211,6 +212,7 @@ sexp sexp_bootstrap_context (void) { ctx = sexp_alloc_type(dummy_ctx, context, SEXP_CONTEXT); sexp_context_heap(dummy_ctx) = NULL; sexp_context_heap(ctx) = heap; + free(dummy_ctx); return ctx; } #endif @@ -385,6 +387,7 @@ static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) { sexp sexp_cons (sexp ctx, sexp head, sexp tail) { sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); + if (sexp_exceptionp(pair)) return pair; sexp_car(pair) = head; sexp_cdr(pair) = tail; sexp_pair_source(pair) = SEXP_FALSE; @@ -559,6 +562,7 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) { #if ! USE_IMMEDIATE_FLONUMS sexp sexp_make_flonum(sexp ctx, double f) { sexp x = sexp_alloc_type(ctx, flonum, SEXP_FLONUM); + if (sexp_exceptionp(x)) return x; sexp_flonum_value(x) = f; return x; } @@ -570,6 +574,7 @@ sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { if (! sexp_fixnump(len)) return sexp_type_exception(ctx, "bad length", len); if (clen < 0) return sexp_type_exception(ctx, "negative length", len); s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); + if (sexp_exceptionp(s)) return s; sexp_pointer_tag(s) = SEXP_STRING; sexp_string_length(s) = clen; if (sexp_charp(ch)) @@ -677,6 +682,7 @@ sexp sexp_intern(sexp ctx, char *str) { /* not found, make a new symbol */ sexp_gc_preserve1(ctx, sym); sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); + if (sexp_exceptionp(sym)) return sym; sexp_symbol_string(sym) = sexp_c_string(ctx, str, len); sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); sexp_gc_release1(ctx); @@ -690,22 +696,25 @@ sexp sexp_string_to_symbol (sexp ctx, sexp str) { } sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { - sexp v, *x; + sexp vec, *x; int i, clen = sexp_unbox_fixnum(len); if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR); - v = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), - SEXP_VECTOR); - x = sexp_vector_data(v); + vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); + if (sexp_exceptionp(vec)) return vec; + x = sexp_vector_data(vec); for (i=0; i Date: Sat, 5 Dec 2009 17:39:27 +0900 Subject: [PATCH 221/535] removing small maximum heap size from testing --- gc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gc.c b/gc.c index c2933930..7b9307d6 100644 --- a/gc.c +++ b/gc.c @@ -14,7 +14,7 @@ /* the maximum heap size in bytes - if 0 there is no limit */ #ifndef SEXP_MAXIMUM_HEAP_SIZE -#define SEXP_MAXIMUM_HEAP_SIZE (4*1024*1024) +#define SEXP_MAXIMUM_HEAP_SIZE 0 #endif /* if after GC more than this percentage of memory is still in use, */ From fa879e183cf0b3182798565e45ad271fa844eed3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 5 Dec 2009 18:07:41 +0900 Subject: [PATCH 222/535] removing errx on failed heap allocation --- gc.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/gc.c b/gc.c index 7b9307d6..b3d85c62 100644 --- a/gc.c +++ b/gc.c @@ -169,8 +169,7 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) { sexp_heap sexp_make_heap (size_t size) { 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); + if (! h) return NULL; h->size = size; h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); free = h->free_list = (sexp_free_list) h->data; From 9ed0d705c6e8d306303c29b4fc41e8b382a29b01 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 5 Dec 2009 18:13:01 +0900 Subject: [PATCH 223/535] adding type checking to disasm Fixes issue #8: http://code.google.com/p/chibi-scheme/issues/detail?id=8 Note disasm is likely to be moved out of the core soon. --- opt/debug.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/opt/debug.c b/opt/debug.c index 0df9ea17..6d8b5de6 100644 --- a/opt/debug.c +++ b/opt/debug.c @@ -20,8 +20,14 @@ static const char* reverse_opcode_names[] = static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { unsigned char *ip, opcode; - if (sexp_procedurep(bc)) + if (sexp_procedurep(bc)) { bc = sexp_procedure_code(bc); + } else if (sexp_opcodep(bc)) { + sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); + return SEXP_VOID; + } else if (! sexp_bytecodep(bc)) { + return sexp_type_exception(ctx, "not a procedure", bc); + } ip = sexp_bytecode_data(bc); loop: opcode = *ip++; From d67e8b46aade5b8bc7542edbc50a5ecf0b8a8da0 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 5 Dec 2009 18:54:04 +0900 Subject: [PATCH 224/535] makefile fixes from derick eddington --- Makefile | 26 +++++++++++++++----------- include/chibi/config.h | 6 +++--- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/Makefile b/Makefile index 47f9ff6c..d8099808 100644 --- a/Makefile +++ b/Makefile @@ -98,17 +98,18 @@ chibi-scheme-static$(EXE): main.o eval.o sexp.o $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) %.c: %.stub chibi-scheme$(EXE) $(GENSTUBS) - $(GENSTUBS) $< + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) $(GENSTUBS) $< lib/%$(SO): lib/%.c $(INCLUDES) $(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme clean: rm -f *.o *.i *.s *.8 - find lib -name \*.$(SO) -exec rm -f '{}' \; + find lib -name \*$(SO) -exec rm -f '{}' \; + rm -f tests/basic/*.out tests/basic/*.err cleaner: clean - rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a + rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h rm -rf *.dSYM test-basic: chibi-scheme$(EXE) @@ -122,13 +123,13 @@ test-basic: chibi-scheme$(EXE) done test-numbers: all - LD_LIBRARY_PATH=.:$LD_LIBRARY_PATH ./chibi-scheme$(EXE) tests/numeric-tests.scm + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/numeric-tests.scm test-match: all - LD_LIBRARY_PATH=.:$LD_LIBRARY_PATH ./chibi-scheme$(EXE) tests/match-tests.scm + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/match-tests.scm test: all - LD_LIBRARY_PATH=.:$LD_LIBRARY_PATH ./chibi-scheme$(EXE) tests/r5rs-tests.scm + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/r5rs-tests.scm install: chibi-scheme$(EXE) mkdir -p $(DESTDIR)$(BINDIR) @@ -139,16 +140,19 @@ install: chibi-scheme$(EXE) mkdir -p $(DESTDIR)$(INCDIR) cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ mkdir -p $(DESTDIR)$(LIBDIR) + mkdir -p $(DESTDIR)$(SOLIBDIR) + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi uninstall: - rm -f $(BINDIR)/chibi-scheme* - rm -f $(SOLIBDIR)/libchibi-scheme$(SO) - rm -f $(LIBDIR)/libchibi-scheme$(SO).a - cd $(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h - rm -rf $(MODDIR) + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE) + rm -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO) + rm -f $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a + cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -rf $(DESTDIR)$(MODDIR) dist: cleaner rm -f chibi-scheme-`cat VERSION`.tgz diff --git a/include/chibi/config.h b/include/chibi/config.h index 10836648..61dd03b2 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -29,8 +29,8 @@ /* uncomment this to just malloc manually instead of any GC */ /* Mostly for debugging purposes, this is the no GC option. */ -/* You can use the just with the read/write API and */ -/* explicitly free sexps though. */ +/* You can use just the read/write API and */ +/* explicitly free sexps, though. */ /* #define USE_MALLOC 1 */ /* uncomment this to add conservative checks to the native GC */ @@ -58,7 +58,7 @@ /* #define USE_INFINITIES 0 */ /* uncomment this if you want immediate flonums */ -/* This is experimental, enablde at your own risk. */ +/* This is experimental, enable at your own risk. */ /* #define USE_IMMEDIATE_FLONUMS 1 */ /* uncomment this if you don't want bignum support */ From 01f21cc9058fa3d37c1d8301d44eb0e1265f5df5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 5 Dec 2009 19:05:41 +0900 Subject: [PATCH 225/535] adding initial ast module --- lib/chibi/ast.c | 53 ++++++++++++++++++++++++++++++++++++++++++++ lib/chibi/ast.module | 12 ++++++++++ 2 files changed, 65 insertions(+) create mode 100644 lib/chibi/ast.c create mode 100644 lib/chibi/ast.module diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c new file mode 100644 index 00000000..62779b54 --- /dev/null +++ b/lib/chibi/ast.c @@ -0,0 +1,53 @@ + +#include + +static void sexp_define_type_predicate (sexp ctx, sexp env, + char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname), op); + sexp_gc_release2(ctx); +} + +static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, + sexp_uint_t cindex, char* get, char *set) { + sexp type, index; + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + type = sexp_make_fixnum(ctype); + index = sexp_make_fixnum(cindex); + op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, get), op); + op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, set), op); + sexp_gc_release2(ctx); +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); + sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); + sexp_define_type_predicate(ctx, env, "set?", SEXP_SET); + sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF); + sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ); + sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-body", "lambda-body-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); + sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); + sexp_define_accessors(ctx, env, SEXP_LIT, 0, "list-value", "lit-value-set!"); + sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze); + sexp_gc_release2(ctx); + return SEXP_VOID; +} + diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module new file mode 100644 index 00000000..c487aa37 --- /dev/null +++ b/lib/chibi/ast.module @@ -0,0 +1,12 @@ + +(define-module (chibi ast) + (export analyze + lambda? cnd? set? ref? seq? lit? + lambda-name lambda-params lambda-body + cnd-test cnd-pass cnd-fail + set-var set-value + ref-name ref-cell + seq-ls + lit-value) + (include-shared "ast")) + From 0efd491c24bff9919f68d61781f9353a963c9fba Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 6 Dec 2009 17:40:50 +0900 Subject: [PATCH 226/535] fixing nested let-syntax hygiene, simplifying error handling also providing better errors in some cases, and exiting with a non-zero status on script errors --- Makefile | 3 + config.scm | 2 +- eval.c | 112 ++++----- include/chibi/eval.h | 4 + init.scm | 52 +++-- lib/chibi/ast.c | 28 ++- lib/chibi/ast.module | 14 +- lib/chibi/loop.module | 10 + lib/chibi/loop/loop.scm | 404 +++++++++++++++++++++++++++++++++ main.c | 29 ++- tests/basic/test09-hygiene.scm | 22 +- tests/loop-tests.scm | 202 +++++++++++++++++ 12 files changed, 763 insertions(+), 119 deletions(-) create mode 100644 lib/chibi/loop.module create mode 100644 lib/chibi/loop/loop.scm create mode 100644 tests/loop-tests.scm diff --git a/Makefile b/Makefile index d8099808..02e20cb9 100644 --- a/Makefile +++ b/Makefile @@ -128,6 +128,9 @@ test-numbers: all test-match: all LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/match-tests.scm +test-loop: all + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/loop-tests.scm + test: all LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/r5rs-tests.scm diff --git a/config.scm b/config.scm index dc54b1fd..1267bd81 100644 --- a/config.scm +++ b/config.scm @@ -134,7 +134,7 @@ 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 scheme-report-environment + call-with-values interaction-environment 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 diff --git a/eval.c b/eval.c index 49fd8a31..a5e46b5d 100644 --- a/eval.c +++ b/eval.c @@ -16,6 +16,7 @@ static int scheme_initialized_p = 0; #define sexp_disasm(...) #endif +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); @@ -35,7 +36,7 @@ static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) { /********************** environment utilities ***************************/ -static sexp sexp_env_cell (sexp e, sexp key) { +sexp sexp_env_cell (sexp e, sexp key) { sexp ls; do { @@ -87,7 +88,7 @@ void sexp_env_define (sexp ctx, sexp e, sexp key, sexp value) { } } -static sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { +sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { sexp_gc_var2(e, tmp); sexp_gc_preserve2(ctx, e, tmp); e = sexp_alloc_type(ctx, env, SEXP_ENV); @@ -101,22 +102,6 @@ static sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { return e; } -#if 0 -static sexp sexp_chain_env (sexp ctx, sexp env1, sexp env2) { - sexp_gc_var1(res); - sexp_gc_preserve1(ctx, 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_release1(ctx); - return res; -} -#endif - static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { sexp_gc_var1(res); sexp_gc_preserve1(ctx, res); @@ -387,7 +372,7 @@ static sexp analyze_app (sexp ctx, sexp x) { sexp_gc_preserve2(ctx, res, tmp); for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) { sexp_push(ctx, res, SEXP_FALSE); - tmp = sexp_analyze(ctx, sexp_car(x)); + tmp = analyze(ctx, sexp_car(x)); if (sexp_exceptionp(tmp)) { res = tmp; break; @@ -405,7 +390,7 @@ static sexp analyze_seq (sexp ctx, sexp ls) { if (sexp_nullp(ls)) res = SEXP_VOID; else if (sexp_nullp(sexp_cdr(ls))) - res = sexp_analyze(ctx, sexp_car(ls)); + res = analyze(ctx, sexp_car(ls)); else { res = sexp_alloc_type(ctx, seq, SEXP_SEQ); tmp = analyze_app(ctx, ls); @@ -425,7 +410,8 @@ static sexp analyze_var_ref (sexp ctx, sexp x) { cell = sexp_env_cell(env, x); if (! cell) { if (sexp_synclop(x)) { - if (sexp_truep(sexp_memq(ctx, x, sexp_context_fv(ctx)))) + if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_context_fv(ctx))) + && sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_synclo_free_vars(x)))) env = sexp_synclo_env(x); x = sexp_synclo_expr(x); } @@ -450,7 +436,7 @@ static sexp analyze_set (sexp ctx, sexp x) { 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 = sexp_analyze(ctx, sexp_caddr(x)); + value = analyze(ctx, sexp_caddr(x)); if (sexp_exceptionp(ref)) res = ref; else if (sexp_exceptionp(value)) @@ -494,7 +480,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { value = analyze_lambda(ctx2, sexp_cons(ctx2, SEXP_VOID, tmp)); } else { name = sexp_cadr(tmp); - value = sexp_analyze(ctx2, sexp_caddr(tmp)); + value = analyze(ctx2, sexp_caddr(tmp)); } if (sexp_exceptionp(value)) sexp_return(res, value); sexp_push(ctx2, defs, @@ -521,10 +507,10 @@ static sexp analyze_if (sexp ctx, sexp x) { if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { res = sexp_compile_error(ctx, "bad if syntax", x); } else { - test = sexp_analyze(ctx, sexp_cadr(x)); - pass = sexp_analyze(ctx, sexp_caddr(x)); + 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 = sexp_analyze(ctx, fail_expr); + 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)); } @@ -558,7 +544,7 @@ static sexp analyze_define (sexp ctx, sexp x) { tmp = sexp_cons(ctx, SEXP_VOID, tmp); value = analyze_lambda(ctx, tmp); } else - value = sexp_analyze(ctx, sexp_caddr(x)); + value = analyze(ctx, sexp_caddr(x)); ref = analyze_var_ref(ctx, name); if (sexp_exceptionp(ref)) res = ref; @@ -643,7 +629,7 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x) { return res; } -sexp sexp_analyze (sexp ctx, sexp object) { +static sexp analyze (sexp ctx, sexp object) { sexp op; sexp_gc_var4(res, tmp, x, cell); sexp_gc_preserve4(ctx, res, tmp, x, cell); @@ -674,7 +660,14 @@ sexp sexp_analyze (sexp ctx, sexp object) { 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))); + case CORE_SYNTAX_QUOTE: + if (! (sexp_pairp(sexp_cdr(x)) && sexp_nullp(sexp_cddr(x)))) + res = sexp_compile_error(ctx, "bad quote form", x); + else + res = sexp_make_lit(ctx, + (sexp_core_code(op) == CORE_QUOTE) ? + sexp_strip_synclos(ctx, sexp_cadr(x)) : + sexp_cadr(x)); break; case CORE_DEFINE_SYNTAX: res = analyze_define_syntax(ctx, x); break; @@ -691,12 +684,9 @@ sexp sexp_analyze (sexp ctx, sexp object) { tmp = sexp_cons(ctx, x, tmp); x = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); x = sexp_apply(x, sexp_macro_proc(op), tmp); + if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x))) + sexp_exception_source(x) = sexp_pair_source(sexp_car(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_fixnum(res) < sexp_opcode_num_args(op)) { @@ -729,8 +719,10 @@ sexp sexp_analyze (sexp ctx, sexp object) { sexp_context_fv(tmp) = sexp_append2(tmp, sexp_synclo_free_vars(x), sexp_context_fv(tmp)); + if (sexp_pairp(sexp_synclo_free_vars(x))) + sexp_debug(ctx, "free vars: ", sexp_context_fv(tmp)); x = sexp_synclo_expr(x); - res = sexp_analyze(tmp, x); + res = analyze(tmp, x); } else { res = x; } @@ -738,6 +730,10 @@ sexp sexp_analyze (sexp ctx, sexp object) { return res; } +sexp sexp_analyze (sexp ctx, sexp x) { + return analyze(ctx, x); +} + 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); @@ -1233,12 +1229,14 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case OP_RAISE: call_error_handler: + tmp1 = sexp_env_global_ref(env, sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL), SEXP_FALSE); + if (! sexp_procedurep(tmp1)) goto end_loop; stack[top] = (sexp) 1; stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc)); stack[top+2] = self; stack[top+3] = sexp_make_fixnum(fp); top += 4; - self = sexp_env_global_ref(env, sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL), SEXP_FALSE); + self = tmp1; bc = sexp_procedure_code(self); ip = sexp_bytecode_data(bc); cp = sexp_procedure_vars(self); @@ -2183,6 +2181,7 @@ static struct sexp_struct core_forms[] = { {.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_SYNTAX_QUOTE, "syntax-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"}}}, @@ -2334,7 +2333,7 @@ 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 ctx2, cell, sym, perr_cell, err_cell; + sexp cell, sym; sexp_gc_var4(e, op, tmp, err_handler); sexp_gc_preserve4(ctx, e, op, tmp, err_handler); e = sexp_make_null_env(ctx, version); @@ -2359,28 +2358,6 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_c_string(ctx, sexp_module_dir, -1)); sexp_env_define(ctx, e, sexp_intern(ctx, "*shared-object-extension*"), sexp_c_string(ctx, sexp_so_extension, -1)); - /* add default exception handler */ - err_cell = sexp_env_cell(e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL)); - perr_cell = sexp_env_cell(e, sexp_intern(ctx, "print-exception")); - ctx2 = sexp_make_eval_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_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_fixnum(0), - sexp_make_fixnum(0), - finalize_bytecode(ctx2), - tmp); - sexp_env_define(ctx2, e, sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL), err_handler); sexp_gc_release4(ctx); return e; } @@ -2427,6 +2404,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { stack[top++] = sexp_make_fixnum(0); sexp_context_top(ctx) = top; res = sexp_vm(ctx, proc); + if (! res) res = SEXP_VOID; } return res; } @@ -2450,17 +2428,13 @@ sexp sexp_compile (sexp ctx, sexp x) { } sexp sexp_eval (sexp ctx, sexp obj, sexp env) { - sexp res, ctx2; - sexp_gc_var1(thunk); - sexp_gc_preserve1(ctx, thunk); + sexp ctx2; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); ctx2 = sexp_make_eval_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); - thunk = sexp_compile(ctx2, obj); - if (sexp_exceptionp(thunk)) { - sexp_print_exception(ctx2, thunk, sexp_current_error_port(ctx)); - res = thunk; - } else { - res = sexp_apply(ctx2, thunk, SEXP_NULL); - } + res = sexp_compile(ctx2, obj); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); sexp_gc_release1(ctx); return res; } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 1326333e..7009a29a 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -22,6 +22,7 @@ enum sexp_core_form_names { CORE_IF, CORE_BEGIN, CORE_QUOTE, + CORE_SYNTAX_QUOTE, CORE_DEFINE_SYNTAX, CORE_LET_SYNTAX, CORE_LETREC_SYNTAX @@ -128,8 +129,11 @@ SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); SEXP_API sexp sexp_make_env (sexp context); +SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls); SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val); +SEXP_API sexp sexp_env_cell (sexp env, sexp sym); +SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data); diff --git a/init.scm b/init.scm index c457e8b9..a1038829 100644 --- a/init.scm +++ b/init.scm @@ -84,7 +84,10 @@ (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f)))) (define (any pred ls) - (if (pair? ls) (if (pred (car ls)) #t (any pred (cdr ls))) #f)) + (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f)) + +(define (every pred ls) + (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t)) ;; syntax @@ -200,21 +203,39 @@ (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))))))) + (if (null? (cdr expr)) (error "empty let" expr)) + (if (null? (cddr expr)) (error "no let body" expr)) + ((lambda (bindings) + (if (list? bindings) #f (error "bad let bindings")) + (if (every (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + bindings) + (if (identifier? (cadr expr)) + `(,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,(map car bindings) + ,@(cdddr expr)))) + ,(cons (cadr expr) (map cadr (caddr expr)))) + `((,(rename 'lambda) ,(map car bindings) ,@(cddr expr)) + ,@(map cadr bindings))) + (error "bad let syntax" expr))) + (if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) (define-syntax let* (er-macro-transformer (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let*" expr)) + (if (null? (cddr expr)) (error "no let* body" expr)) (if (null? (cadr expr)) `(,(rename 'begin) ,@(cddr expr)) - `(,(rename 'let) (,(caadr expr)) - (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))))))) + (if (if (list? (cadr expr)) + (every + (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + (cadr expr)) + #f) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))) + (error "bad let* syntax")))))) (define-syntax case (er-macro-transformer @@ -566,7 +587,7 @@ (_cons (rename 'cons)) (_pair? (rename 'pair?)) (_null? (rename 'null?)) (_expr (rename 'expr)) (_rename (rename 'rename)) (_compare (rename 'compare)) - (_quote (rename 'quote)) (_apply (rename 'apply)) + (_quote (rename 'syntax-quote)) (_apply (rename 'apply)) (_append (rename 'append)) (_map (rename 'map)) (_vector? (rename 'vector?)) (_list? (rename 'list?)) (_lp (rename 'lp)) (_reverse (rename 'reverse)) @@ -659,9 +680,10 @@ (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))) + (cond ((identifier? x) + (if (any (lambda (lit) (compare x lit)) 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)) @@ -683,7 +705,7 @@ (cond ((identifier? t) (cond - ((assq t vars) + ((any (lambda (v) (compare t (car v))) vars) => (lambda (cell) (if (<= (cdr cell) dim) t diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 62779b54..c3391a64 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -25,15 +25,38 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, sexp_gc_release2(ctx); } +static sexp sexp_get_env_cell (sexp ctx, sexp env, sexp id) { + sexp cell = sexp_env_cell(env, id); + while ((! cell) && sexp_synclop(id)) { + env = sexp_synclo_env(id); + id = sexp_synclo_expr(id); + } + return cell ? cell : SEXP_FALSE; +} + +static sexp sexp_get_opcode_name (sexp ctx, sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, "not an opcode", op); + else if (! sexp_opcode_name(op)) + return SEXP_FALSE; + else + return sexp_intern(ctx, sexp_opcode_name(op)); +} + sexp sexp_init_library (sexp ctx, sexp env) { sexp_gc_var2(name, op); sexp_gc_preserve2(ctx, name, op); + sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); sexp_define_type_predicate(ctx, env, "set?", SEXP_SET); sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF); sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ); sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); + sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!"); sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!"); sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-body", "lambda-body-set!"); @@ -45,8 +68,11 @@ sexp sexp_init_library (sexp ctx, sexp env) { sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!"); sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); - sexp_define_accessors(ctx, env, SEXP_LIT, 0, "list-value", "lit-value-set!"); + sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze); + sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); + sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); + sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); sexp_gc_release2(ctx); return SEXP_VOID; } diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index c487aa37..d95b97d5 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -1,12 +1,14 @@ (define-module (chibi ast) - (export analyze - lambda? cnd? set? ref? seq? lit? + (export analyze env-cell opcode-name + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars lambda-name lambda-params lambda-body + lambda-name-set! lambda-params-set! lambda-body-set! cnd-test cnd-pass cnd-fail - set-var set-value - ref-name ref-cell - seq-ls - lit-value) + cnd-test-set! cnd-pass-set! cnd-fail-set! + set-var set-value set-var-set! set-value-set! + ref-name ref-cell ref-name-set! ref-cell-set! + seq-ls seq-ls-set! lit-value lit-value-set!) (include-shared "ast")) diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module new file mode 100644 index 00000000..24c5397c --- /dev/null +++ b/lib/chibi/loop.module @@ -0,0 +1,10 @@ + +(define-module (chibi loop) + (export loop in-list in-lists in-port in-file up-from down-from + listing listing-reverse appending appending-reverse + summing multiplying in-string in-string-reverse + in-vector in-vector-reverse) + (import (scheme)) + (import (chibi match)) + (include "loop.scm")) + diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm new file mode 100644 index 00000000..0c7cc4a5 --- /dev/null +++ b/lib/chibi/loop/loop.scm @@ -0,0 +1,404 @@ +;;;; loop.scm - the chibi loop (aka foof-loop) +;; +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; The loop API is compatible with Taylor Campbell's foof-loop, but +;; the iterator API is different and subject to change. All loop +;; variables may be implicitly destructured with MATCH semantics. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax let-keyword-form + (syntax-rules () + ((let-keyword-form + ((labeled-arg-macro-name + (positional-form-name (arg-name . arg-default) ...))) + . body) + (letrec-syntax + ((labeled-arg-macro-name + (syntax-rules () + ((labeled-arg-macro-name . keyword-val-pairs) + (letrec-syntax + ((find + (syntax-rules (=> arg-name ...) + ((find kvp k-args (arg-name . default) (=> arg-name val) + . others) ; found arg-name among keyword-val-pairs + (next kvp val . k-args)) ... + ((find kvp k-args key (=> arg-no-match-name val) . others) + (find kvp k-args key . others)) + ;; default must be here + ((find kvp k-args (arg-name default)) + (next kvp default . k-args)) ... + )) + (next ; pack the continuation to find + (syntax-rules () + ((next kvp val vals key . keys) + (find kvp ((val . vals) . keys) key . kvp)) + ((next kvp val vals) ; processed all arg-descriptors + (rev-apply (val) vals)))) + (match-positionals + (syntax-rules (=>) + ((match-positionals () res . rest) + (rev-apply () res)) + ((match-positionals args (val . vals) (=> name value) + . rest) + (next ((=> name value) . rest) val vals . args)) + ((match-positionals args (val . vals)) + (next () val vals . args)) + ((match-positionals (arg1 . args) res pos-arg . rest) + (match-positionals args (pos-arg . res) . rest)))) + (rev-apply + (syntax-rules () + ((rev-apply form (x . xs)) + (rev-apply (x . form) xs)) + ((rev-apply form ()) form)))) + (match-positionals ((arg-name . arg-default) ...) + (positional-form-name) + . keyword-val-pairs) + ))))) + . body)))) + +;; (define-syntax let-keyword-form +;; (syntax-rules () +;; ((let-keyword-form +;; ((labeled-arg-macro-name (positional-name (arg default) ...))) +;; . body) +;; (letrec-syntax +;; ((labeled-arg-macro-name +;; (er-macro-transformer +;; (lambda (expr rename compare) +;; (receive (named posns) +;; (partition (lambda (x) (and (list? x) (compare (car x) '=>))) +;; (cdr expr)) +;; (let lp ((ls '((arg default) ...)) (posns posns) (args '())) +;; (cond +;; ((null? ls) +;; (if (pair? posns) +;; (error "let-keyword-form: too many args" expr) +;; (cons 'positional-name (reverse args)))) +;; ((find (lambda (x) (compare (caar ls) (cadr x))) named) +;; => (lambda (x) +;; (lp (cdr ls) posns (cons (caddr x) args)))) +;; ((pair? posns) +;; (lp (cdr ls) (cdr posns) (cons (car posns) args))) +;; (else +;; (lp (cdr ls) posns (cons (cadar ls) args)))))))))) +;; . body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax loop + (syntax-rules () + ;; unnamed, implicit recursion + ((loop (vars ...) body ...) + (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop))) + ;; named, explicit recursion + ((loop name (vars ...) body ...) + (%loop name () () () () () (vars ...) body ...)))) + +;; Main LOOP macro. Separate the variables from the iterator and +;; parameters, then walk through each parameter expanding the +;; bindings, and build the final form. + +(define-syntax %loop + (syntax-rules (=> for with let while until) + ;; automatic iteration + ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body) + (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ;; do equivalents, with optional guards + ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body) + (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init step) rest ...) . body) + (%loop name l (vars ... (var init step)) c r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init) rest ...) . body) + (%loop name l (vars ... (var init var)) c r f (rest ...) . body)) + ;; user-specified terminators + ((_ name l vars (checks ...) r f ((until expr) rest ...) . body) + (%loop name l vars (checks ... expr) r f (rest ...) . body)) + ((_ name l vars (checks ...) r f ((while expr) rest ...) . body) + (%loop name l vars (checks ... (not expr)) r f (rest ...) . body)) + ;; specify a default done? + ((_ name l v c r f ()) + (%loop name l v c r f () (#f #f))) + ((_ name l v c r f () () . body) + (%loop name l v c r f () (#f #f) . body)) + ;; final expansion + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => result + . body) + (let* (lets ...) + (letrec ((tmp (lambda (var ...) + (if (or checks ...) + (let-keyword-form ((name (tmp (var step) ...))) + (match-let (finals ...) result)) + (match-let (refs ...) + (let-keyword-form ((name (tmp (var step) ...))) + (if #f #f) + . body)))))) + (tmp init ...)))) + ;; unspecified return value case + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + . body) + (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => (if #f #f) . body)) + )) + +(define-syntax %loop-next + (syntax-rules () + ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...) + name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...) + . rest) + (%loop name (lets ... new-lets ...) (vars ... new-vars ...) + (checks ... new-checks ...) (refs ... new-refs ...) + (finals ... new-finals ...) + . rest)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Iterators + +;; Each gets passed two lists, those items left of the <- and those to +;; the right, followed by a NEXT and REST continuation. + +;; Should finish with +;; +;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...) +;; (loop-vars ...) (final-vars ...) . rest) +;; +;; OUTER-VARS: bound once outside the loop in a LET* +;; CURSOR-VARS: DO-style bindings of the form (name init update) +;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t +;; LOOP-VARS: inner variables, updated in parallel after the cursors +;; FINAL-VARS: final variables, bound only in the => result + +(define-syntax in-list ; called just "IN" in ITER + (syntax-rules () + ((in-list ((var) source) next . rest) + (in-list ((var cursor) source) next . rest)) + ((in-list ((var cursor) source) next . rest) + (in-list ((var cursor succ) source) next . rest)) + ((in-list ((var cursor succ) (source)) next . rest) + (next () ; outer let bindings + ((cursor source succ)) ; iterator, init, step + ((not (pair? cursor))) ; finish tests for iterator vars + ;; step variables and values + ((var (car cursor)) + (succ (cdr cursor))) + () ; final result bindings + . rest)) + ((in-list ((var cursor succ) (source step)) next . rest) + (next () + ((cursor source succ)) + ((not (pair? cursor))) + ((var (car cursor)) + (succ (step cursor))) + () + . rest)))) + +;; Iterator from Taylor R. Campbell. If you know the number of lists +;; ahead of time it's much more efficient to iterate over each one +;; separately. +(define-syntax in-lists + (syntax-rules () + ((in-lists ((elts) lol) next . rest) + (in-lists ((elts pairs) lol) next . rest)) + ((in-lists ((elts pairs) lol) next . rest) + (in-lists ((elts pairs succ) lol) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol step)) next . rest) + (in-lists ((elts pairs succ) (lol step null?)) next . rest)) + ((in-lists ((elts pairs succ) (lol step done?)) next . rest) + (next () + ((pairs lol succ)) + ((let lp ((ls pairs)) ; an in-lined ANY + (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls)))))) + ((elts (map car pairs)) + (succ (map step pairs))) + () + . rest)) + )) + +(define-syntax define-in-indexed + (syntax-rules () + ((define-in-indexed in-type in-type-reverse length ref) + (begin + (define-syntax in-type + (syntax-rules () + ((in-type ls next . rest) + (%in-idx >= + 0 (length tmp) ref tmp ls next . rest)))) + (define-syntax in-type-reverse + (syntax-rules () + ((in-type-reverse ls next . rest) + (%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest)))) + )))) + +(define-in-indexed in-string in-string-reverse string-length string-ref) +(define-in-indexed in-vector in-vector-reverse vector-length vector-ref) + +;; helper for the above string and vector iterators +(define-syntax %in-idx + (syntax-rules () + ;; cmp inc start end ref + ((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest) + (%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest) + (next ((tmp-vec vec) (end to)) + ((index from (+ index step))) + ((ge index end)) + ((var (r tmp-vec index))) + () + . rest)) + )) + +(define-syntax in-port + (syntax-rules () + ((in-port ((var) source) next . rest) + (in-port ((var p) source) next . rest)) + ((in-port ((var p) ()) next . rest) + (in-port ((var p) ((current-input-port))) next . rest)) + ((in-port ((var p) (port)) next . rest) + (in-port ((var p) (port read-char)) next . rest)) + ((in-port ((var p) (port read-char)) next . rest) + (in-port ((var p) (port read-char eof-object?)) next . rest)) + ((in-port ((var p) (port reader eof?)) next . rest) + (next ((p port) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + () + . rest)))) + +(define-syntax in-file + (syntax-rules () + ((in-file ((var) source) next . rest) + (in-file ((var p) source) next . rest)) + ((in-file ((var p) (file)) next . rest) + (in-file ((var p) (file read-char)) next . rest)) + ((in-file ((var p) (file reader)) next . rest) + (in-file ((var p) (file reader eof-object?)) next . rest)) + ((in-file ((var p) (file reader eof?)) next . rest) + (next ((p (open-input-file file)) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + ((dummy (close-input-port p))) + . rest)))) + +(define-syntax up-from + (syntax-rules (to by) + ((up-from (() . args) next . rest) + (up-from ((var) . args) next . rest)) + ((up-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var s (+ var e))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var s (+ var 1))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var s (+ var e))) () () () . rest)) + ((up-from ((var) (start)) next . rest) + (next ((s start)) ((var s (+ var 1))) () () () . rest)) + )) + +(define-syntax down-from + (syntax-rules (to by) + ((down-from (() . args) next . rest) + (down-from ((var) . args) next . rest)) + ((down-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var (- s e) (- var e))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var (- s 1) (- var 1))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var (- s e) (- var e))) () () () + . rest)) + ((down-from ((var) (start)) next . rest) + (next ((s start)) ((var (- s 1) (- var 1))) () () () + . rest)) + )) + +(define-syntax accumulating + (syntax-rules (initial if) + ((accumulating (kons final init) ((var) . x) next . rest) + (accumulating (kons final init) ((var cursor) . x) next . rest)) + ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest) + (accumulating (kons final i) ((var cursor) x) n . rest)) + ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (if check (tmp-kons expr cursor) cursor))) + () + () + ((var (final cursor))) + . rest)) + ((accumulating (kons final init) ((var cursor) (expr)) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (tmp-kons expr cursor))) + () + () + ((var (final cursor))) + . rest)))) + +(define-syntax listing + (syntax-rules () + ((listing args next . rest) + (accumulating (cons reverse '()) args next . rest)))) + +(define-syntax listing-reverse + (syntax-rules () + ((listing-reverse args next . rest) + (accumulating (cons (lambda (x) x) '()) args next . rest)))) + +(define (append-reverse ls1 ls2) + (append (reverse ls1) ls2)) + +(define-syntax appending + (syntax-rules () + ((appending args next . rest) + (accumulating (append-reverse reverse '()) args next . rest)))) + +(define-syntax appending-reverse + (syntax-rules () + ((appending-reverse args next . rest) + (accumulating (append-reverse (lambda (x) x) '()) args next . rest)))) + +(define-syntax summing + (syntax-rules () + ((summing args next . rest) + (accumulating (+ (lambda (x) x) 0) args next . rest)))) + +(define-syntax multiplying + (syntax-rules () + ((multiplying args next . rest) + (accumulating (* (lambda (x) x) 1) args next . rest)))) diff --git a/main.c b/main.c index 151e5d86..07e6207a 100644 --- a/main.c +++ b/main.c @@ -112,18 +112,32 @@ void repl (sexp ctx) { tmp = sexp_env_bindings(env); sexp_context_top(ctx) = 0; res = sexp_eval(ctx, obj, env); + if (sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, err); + } else { #if USE_WARN_UNDEFS - sexp_warn_undefs(ctx, 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); - sexp_write_char(ctx, '\n', out); + if (res != SEXP_VOID) { + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } } } } sexp_gc_release4(ctx); } +sexp check_exception (sexp ctx, sexp res) { + if (res && sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, + sexp_eval_string(ctx, "(current-error-port)", + sexp_context_env(ctx))); + exit(EXIT_FAILURE); + } + return res; +} + void run_main (int argc, char **argv) { sexp env, out=NULL, res=SEXP_VOID, ctx; sexp_sint_t i, quit=0, init_loaded=0; @@ -179,14 +193,11 @@ void run_main (int argc, char **argv) { if (! quit) { if (! init_loaded) - res = sexp_init_environments(ctx); + res = check_exception(ctx, sexp_init_environments(ctx)); sexp_env_define(ctx, env, sexp_intern(ctx, "*command-line-arguments*"), args); - if (res && sexp_exceptionp(res)) - sexp_print_exception(ctx, res, - sexp_eval_string(ctx, "(current-error-port)", env)); if (i < argc) for ( ; i < argc; i++) - res = sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env); + res = check_exception(ctx, sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env)); else repl(ctx); } diff --git a/tests/basic/test09-hygiene.scm b/tests/basic/test09-hygiene.scm index 4ec53fe3..820020c1 100644 --- a/tests/basic/test09-hygiene.scm +++ b/tests/basic/test09-hygiene.scm @@ -37,26 +37,12 @@ (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)))))) + (syntax-rules () + ((_ y expr) + (let-syntax ((y (syntax-rules () ((_) x)))) + expr))))) (let ((x 'inner)) (write (with-x z (z))) (newline)))) - diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm new file mode 100644 index 00000000..1c49d48f --- /dev/null +++ b/tests/loop-tests.scm @@ -0,0 +1,202 @@ + +(import (chibi loop)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test + "stepping" + '(0 1 2) + (loop lp ((with i 0 (+ i 1)) + (with res '() (cons i res))) + (if (= i 3) + (reverse res) + (lp)))) + +(test + "basic in-list" + '(c b a) + (let ((res '())) + (loop ((for x (in-list '(a b c)))) + (set! res (cons x res))) + res)) + +(test + "in-list with result" + '(c b a) + (loop ((for x (in-list '(a b c))) + (with res '() (cons x res))) + => res)) + +(test + "in-list with listing" + '(a b c) + (loop ((for x (in-list '(a b c))) (for res (listing x))) => res)) + +(test + "in-list with listing-reverse" + '(c b a) + (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res)) + +(test + "uneven length in-list's" + '((a . 1) (b . 2) (c . 3)) + (loop ((for x (in-list '(a b c))) + (for y (in-list '(1 2 3 4))) + (for res (listing (cons x y)))) + => res)) + +(test + "in-lists" + '((a 1) (b 2) (c 3)) + (loop ((for ls (in-lists '((a b c) (1 2 3)))) + (for res (listing ls))) + => res)) + +(define (flatten ls) + (reverse + (loop lp ((for x ls (in-list ls)) (with res '())) + => res + (if (pair? x) + (lp (=> res (lp (=> ls x)))) + (lp (=> res (cons x res))))))) + +(test + "flatten (recursion test)" + '(1 2 3 4 5 6 7) + (flatten '(1 (2) (3 (4 (5)) 6) 7))) + +(test + "in-string" + '(#\h #\e #\l #\l #\o) + (loop ((for c (in-string "hello")) (for res (listing c))) => res)) + +(test + "in-string with start" + '(#\l #\o) + (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res)) + +(test + "in-string with start and end" + '(#\h #\e #\l #\l) + (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res)) + +(test + "in-string with start, end and step" + '(#\e #\l) + (loop ((for c (in-string "hello" 1 4 2)) (for res (listing c))) => res)) + +(test + "in-string-reverse" + '(#\o #\l #\l #\e #\h) + (loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res)) + +(test + "in-vector" + '(1 2 3) + (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res)) + +(test "up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 8))) + (for res (listing i))) + => res)) + +(test "up-from by" '(5 10 15) + (loop ((for i (up-from 5 (to 20) (by 5))) + (for res (listing i))) + => res)) + +(test "up-from listing if" '(10 12 14 16 18) + (loop ((for i (up-from 10 (to 20))) + (for res (listing i (if (even? i))))) + => res)) + +(test "down-from" '(7 6 5) + (loop ((for i (down-from 8 (to 5))) + (for res (listing i))) + => res)) + +(test "down-from by" '(15 10 5) + (loop ((for i (down-from 20 (to 5) (by 5))) + (for res (listing i))) + => res)) + +(test "down-from listing if" '(18 16 14 12 10) + (loop ((for i (down-from 20 (to 10))) + (for res (listing i (if (even? i))))) + => res)) + +(test "appending" '(1 2 3 4 5 6 7 8 9) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending ls))) + => res)) + +(test "appending-reverse" '(9 8 7 6 5 4 3 2 1) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending-reverse ls))) + => res)) + +(test "while + up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 10))) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "up-from by, open-ended" '(5 7 9) + (loop ((for i (up-from 5 (by 2))) + (while (< i 10)) + (for res (listing i))) + => res)) + +(test "up-from open-ended" '(5 6 7) + (loop ((for i (up-from 5)) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "down-from by, open-ended" '(5 3 1) + (loop ((for i (down-from 7 (by 2))) + (until (< i 1)) + (for res (listing i))) + => res)) + +(test "down-from open-ended" '(4 3 2) + (loop ((for i (down-from 5)) + (until (< i 2)) + (for res (listing i))) + => res)) + +(test-report) + From bb804f8062381d1a6786c54ea8358724d00ef3d3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 6 Dec 2009 17:42:16 +0900 Subject: [PATCH 227/535] fixing path of loop.scm --- lib/chibi/loop.module | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module index 24c5397c..1488a5b6 100644 --- a/lib/chibi/loop.module +++ b/lib/chibi/loop.module @@ -6,5 +6,5 @@ in-vector in-vector-reverse) (import (scheme)) (import (chibi match)) - (include "loop.scm")) + (include "loop/loop.scm")) From f969364176e4846ba6234a6420484bb61b34077b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 6 Dec 2009 23:17:37 +0900 Subject: [PATCH 228/535] adding initial macroexpand utility This expands an expression and gives you an sexp representation of the resulting ast, renaming symbols when there are conflicts. It doesn't guarantee the minimum number of renames (neither in terms of renamed bindings nor renamed instances) but tries to be minimal and does guarantee no renames if there are no conflicts. This is just for debugging purposes - chibi itself directly uses the AST without renaming or doing anything like this. --- lib/chibi/macroexpand.module | 6 +++ lib/chibi/macroexpand.scm | 76 ++++++++++++++++++++++++++++++++++++ 2 files changed, 82 insertions(+) create mode 100644 lib/chibi/macroexpand.module create mode 100644 lib/chibi/macroexpand.scm diff --git a/lib/chibi/macroexpand.module b/lib/chibi/macroexpand.module new file mode 100644 index 00000000..9aac5dbc --- /dev/null +++ b/lib/chibi/macroexpand.module @@ -0,0 +1,6 @@ + +(define-module (chibi macroexpand) + (import (scheme)) + (import (chibi ast)) + (export macroexpand) + (include "macroexpand.scm")) diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm new file mode 100644 index 00000000..897d5169 --- /dev/null +++ b/lib/chibi/macroexpand.scm @@ -0,0 +1,76 @@ + +(define (macroexpand x) + (ast->sexp (analyze x))) + +(define (ast-renames ast) + (define i 0) + (define renames '()) + (define (rename-symbol id) + (set! i (+ i 1)) + (string->symbol + (string-append (symbol->string (identifier->symbol id)) + "." (number->string i)))) + (define (rename-lambda lam) + (or (assq lam renames) + (let ((res (list lam))) + (set! renames (cons res renames)) + res))) + (define (rename! id lam) + (let ((cell (rename-lambda lam))) + (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell))))) + (define (check-ref id lam env) + (let ((sym (identifier->symbol id))) + (let lp1 ((ls env)) + (cond + ((pair? ls) + (let lp2 ((ls2 (car ls)) (found? #f)) + (cond + ((null? ls2) + (if (not found?) (lp1 (cdr ls)))) + ((and (eq? id (caar ls2)) (eq? lam (cdar ls2))) + (lp2 (cdr ls2) #t)) + ((eq? sym (identifier->symbol (caar ls2))) + (rename! (caar ls2) (cdar ls2)) + (lp2 (cdr ls2) found?)) + (else + (lp2 (cdr ls2) found?))))))))) + (define (flatten-dot x) + (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) + ((null? x) x) + (else (list x)))) + (define (extend-env lam env) + (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env)) + (let lp ((x ast) (env '())) + (cond + ((lambda? x) (lp (lambda-body x) (extend-env x env))) + ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env)) + ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env)) + ((set? x) (lp (set-var x) env) (lp (set-value x) env)) + ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x))) + ((pair? x) (for-each (lambda (x) (lp x env)) x)))) + renames) + +(define (get-rename id lam renames) + (let ((ls (assq lam renames))) + (if (not ls) + (identifier->symbol id) + (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id)))))) + +(define (ast->sexp ast) + (let ((renames (ast-renames ast))) + (let a2s ((x ast)) + (cond + ((lambda? x) + `(lambda ,(map (lambda (id) (get-rename id x renames)) (lambda-params x)) + ,(a2s (lambda-body x)))) + ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) + ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) + ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) + ((seq? x) `(begin ,@(map a2s (seq-ls x)))) + ((lit? x) + (let ((v (lit-value x))) + (if (or (pair? v) (null? v) (symbol? v)) `',v v))) + ((pair? x) (map a2s x)) + ((opcode? x) (or (opcode-name x) x)) + (else x))))) + From 14c99c4729bd4f14f50cb981769a187f23f2ae47 Mon Sep 17 00:00:00 2001 From: Derick Eddington Date: Sun, 6 Dec 2009 21:34:30 -0800 Subject: [PATCH 229/535] fixing identifier comparison bugs --- init.scm | 16 ++++++++-------- lib/chibi/loop/loop.scm | 2 +- tests/r5rs-tests.scm | 15 +++++++++++++++ 3 files changed, 24 insertions(+), 9 deletions(-) diff --git a/init.scm b/init.scm index a1038829..0a93458b 100644 --- a/init.scm +++ b/init.scm @@ -124,11 +124,11 @@ (if (null? (cdr expr)) #f ((lambda (cl) - (if (compare 'else (car cl)) + (if (compare (rename 'else) (car cl)) (if (pair? (cddr expr)) (error "non-final else in cond" expr) (cons (rename 'begin) (cdr cl))) - (if (if (null? (cdr cl)) #t (compare '=> (cadr cl))) + (if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl))) (list (list (rename 'lambda) (list (rename 'tmp)) (list (rename 'if) (rename 'tmp) (if (null? (cdr cl)) @@ -169,20 +169,20 @@ (cond ((pair? x) (cond - ((eq? 'unquote (car x)) + ((compare (rename '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)) + ((compare (rename '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)) + ((compare (rename '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))) + ((and (<= d 0) (pair? (car x)) (compare (rename 'unquote-splicing) (caar x))) (if (null? (cdr x)) (cadar x) (list (rename 'append) (cadar x) (qq (cdr x) d)))) @@ -243,7 +243,7 @@ (define (clause ls) (cond ((null? ls) #f) - ((compare 'else (caar ls)) + ((compare (rename 'else) (caar ls)) `(,(rename 'begin) ,@(cdar ls))) (else (if (and (pair? (caar ls)) (null? (cdaar ls))) @@ -669,7 +669,7 @@ ((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)))) + (and (pair? x) (pair? (cdr x)) (compare (rename '...) (cadr x)))) (define (ellipse-depth x) (if (ellipse? x) (+ 1 (ellipse-depth (cdr x))) diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm index 0c7cc4a5..06326d84 100644 --- a/lib/chibi/loop/loop.scm +++ b/lib/chibi/loop/loop.scm @@ -69,7 +69,7 @@ ;; (er-macro-transformer ;; (lambda (expr rename compare) ;; (receive (named posns) -;; (partition (lambda (x) (and (list? x) (compare (car x) '=>))) +;; (partition (lambda (x) (and (list? x) (compare (car x) (rename '=>)))) ;; (cdr expr)) ;; (let lp ((ls '((arg default) ...)) (posns posns) (args '())) ;; (cond diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 7b881b9d..e6017417 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -386,6 +386,21 @@ (test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p)))) +(test 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad)))) + +(test 'ok (let ((=> 1)) (cond (#t => 'ok)))) + +(test '(,foo) (let ((unquote 1)) `(,foo))) + +(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) + +(test 'ok + (let ((... 2)) + (let-syntax ((s (syntax-rules () + ((_ x ...) 'bad) + ((_ . r) 'ok)))) + (s a b c)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test-report) From 7050da677d839e86e51e063f329f1f9f52627fa1 Mon Sep 17 00:00:00 2001 From: Derick Eddington Date: Mon, 7 Dec 2009 16:16:01 -0800 Subject: [PATCH 230/535] fixing let* internal define --- init.scm | 4 ++-- tests/r5rs-tests.scm | 9 +++++++++ 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/init.scm b/init.scm index 0a93458b..f748b98e 100644 --- a/init.scm +++ b/init.scm @@ -214,7 +214,7 @@ `(,(rename 'letrec) ((,(cadr expr) (,(rename 'lambda) ,(map car bindings) ,@(cdddr expr)))) - ,(cons (cadr expr) (map cadr (caddr expr)))) + ,(cons (cadr expr) (map cadr bindings))) `((,(rename 'lambda) ,(map car bindings) ,@(cddr expr)) ,@(map cadr bindings))) (error "bad let syntax" expr))) @@ -226,7 +226,7 @@ (if (null? (cdr expr)) (error "empty let*" expr)) (if (null? (cddr expr)) (error "no let* body" expr)) (if (null? (cadr expr)) - `(,(rename 'begin) ,@(cddr expr)) + `(,(rename 'let) () ,@(cddr expr)) (if (if (list? (cadr expr)) (every (lambda (x) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index e6017417..9c379eb2 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -77,6 +77,15 @@ (test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) +(test -2 (let () + (define x 2) + (define f (lambda () (- x))) + (f))) + +(define let*-def 1) +(let* () (define let*-def 2) #f) +(test 1 let*-def) + (test '#(0 1 2 3 4) (do ((vec (make-vector 5)) (i 0 (+ i 1))) From a1622ad408c8292c2d78e4b30e577c8878f662de Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Dec 2009 16:01:50 +0900 Subject: [PATCH 231/535] marking generated .c files as "PRECIOUS" so they don't get automatically deleted --- Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile b/Makefile index 02e20cb9..17f935f2 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,7 @@ # -*- makefile-gmake -*- .PHONY: all libs doc dist clean cleaner test install uninstall +.PRECIOUS: %.c CC ?= cc PREFIX ?= /usr/local From e5163d7e3b3afbdc6b52d8a74fd232b1920d146f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Dec 2009 16:02:38 +0900 Subject: [PATCH 232/535] expanding internal defines in lambdas --- lib/chibi/macroexpand.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm index 897d5169..f1322c06 100644 --- a/lib/chibi/macroexpand.scm +++ b/lib/chibi/macroexpand.scm @@ -62,7 +62,10 @@ (cond ((lambda? x) `(lambda ,(map (lambda (id) (get-rename id x renames)) (lambda-params x)) - ,(a2s (lambda-body x)))) + ,@(map (lambda (d) `(define ,(identifier->symbol (cadr d)) #f)) (lambda-defs x)) + ,@(if (seq? (lambda-body x)) + (map a2s (seq-ls (lambda-body x))) + (list (a2s (lambda-body x)))))) ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) @@ -70,7 +73,7 @@ ((lit? x) (let ((v (lit-value x))) (if (or (pair? v) (null? v) (symbol? v)) `',v v))) - ((pair? x) (map a2s x)) + ((pair? x) (cons (a2s (car x)) (a2s (cdr x)))) ((opcode? x) (or (opcode-name x) x)) (else x))))) From 7a526b4f1ab9031f552ea1c40ab8f103471f0945 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Dec 2009 16:04:08 +0900 Subject: [PATCH 233/535] adding support for only/except/rename/prefix in import forms (import also now supports multiple arguments) --- config.scm | 55 ++++++++++++++++++++++++++++++++++++++++++++++++++---- init.scm | 24 ++++++++++++++++-------- 2 files changed, 67 insertions(+), 12 deletions(-) diff --git a/config.scm b/config.scm index 1267bd81..84bbfb68 100644 --- a/config.scm +++ b/config.scm @@ -47,20 +47,66 @@ (cond ((assoc name *modules*) => cdr) (else #f))))) +(define (symbol-append a b) + (string->symbol (string-append (symbol->string a) (symbol->string b)))) + +(define (to-id id) (if (pair? id) (car id) id)) +(define (from-id id) (if (pair? id) (cdr id) id)) +(define (id-filter pred ls) + (cond ((null? ls) '()) + ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls)))) + (else (id-filter pred (cdr ls))))) + +(define (resolve-import x) + (cond + ((not (and (pair? x) (list? x))) + (error "invalid module syntax" x)) + ((and (pair? (cdr x)) (pair? (cadr x))) + (if (memq (car x) '(only except renams)) + (let* ((mod-name+imports (resolve-import (cadr x))) + (imp-ids (cdr mod-name+imports))) + (cons (car mod-name+imports) + (case (car x) + ((only) + (id-filter (lambda (i) (memq i (cddr x))) imp-ids)) + ((except) + (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids)) + ((rename) + (map (lambda (i) + (let ((rename (assq (to-id i) (cddr x)))) + (if rename (cons (cdr rename) (from-id i)) i))) + imp-ids))))) + (error "invalid import modifier" x))) + ((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x))) + (let ((mod-name+imports (resolve-import (caddr x)))) + (cons (car mod-name+imports) + (map (lambda (i) + (cons (symbol-append (cadr x) (if (pair? i) (car i) i)) + (if (pair? i) (cdr i) i))) + (cdr mod-name+imports))))) + ((find-module x) + => (lambda (mod) (cons x (module-exports mod)))) + (else + (error "couldn't find import" x)))) + (define (eval-module name mod) (let ((env (make-environment)) - (prefix (module-name-prefix name))) + (dir (module-name-prefix name))) (for-each (lambda (x) (case (and (pair? x) (car x)) ((import) - (let ((mod2 (load-module (cadr x)))) - (%env-copy! env (module-env mod2) (module-exports mod2)))) + (for-each + (lambda (x) + (let* ((mod2-name+imports (resolve-import x)) + (mod2 (load-module (car mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports)))) + (cdr x))) ((include include-shared) (for-each (lambda (f) (let ((f (string-append - prefix f + dir f (if (eq? (car x) 'include) "" *shared-object-extension*)))) (cond ((find-module-file name f) => (lambda (x) (load x env))) @@ -145,6 +191,7 @@ open-input-string open-output-string get-output-string sc-macro-transformer rsc-macro-transformer er-macro-transformer identifier? identifier=? identifier->symbol make-syntactic-closure + syntax-quote register-simple-type make-constructor make-type-predicate make-getter make-setter ))) diff --git a/init.scm b/init.scm index f748b98e..d554bbce 100644 --- a/init.scm +++ b/init.scm @@ -755,11 +755,19 @@ (define-syntax import (er-macro-transformer (lambda (expr rename compare) - (let ((mod (eval `(load-module ',(cadr expr)) *config-env*))) - (if (vector? mod) - `(%env-copy! #f - (vector-ref - (eval '(load-module ',(cadr expr)) *config-env*) - 1) - ',(vector-ref mod 0)) - `(error "couldn't find module" ',(cadr expr))))))) + (let lp ((ls (cdr expr)) (res '())) + (cond + ((null? ls) + (cons 'begin (reverse res))) + (else + (let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*))) + (if (pair? mod+imps) + (lp (cdr ls) + (cons `(%env-copy! + #f + (vector-ref + (eval '(load-module ',(car mod+imps)) *config-env*) + 1) + ',(cdr mod+imps)) + res)) + (error "couldn't find module" (car ls)))))))))) From 9539a2d9a21cc1379ab68798d042983f2516a90c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Dec 2009 16:27:36 +0900 Subject: [PATCH 234/535] converting TODO to org-mode, fleshing out --- TODO | 175 ++++++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 124 insertions(+), 51 deletions(-) diff --git a/TODO b/TODO index 01137858..ee91a9da 100644 --- a/TODO +++ b/TODO @@ -1,52 +1,125 @@ -* -*- outline -*- +-*- org -*- + +* compiler +** DONE ast rewrite + - State "DONE" [2009-04-09 Thu 14:32] +** DONE call/cc support + - State "DONE" [2009-04-09 Thu 14:36] +** DONE exceptions + - State "DONE" [2009-04-09 Thu 14:45] +** TODO native x86 backend +** TODO fasl/image files +** TODO shared stack on EVAL + Arguably a bug, at the moment we create a new stack on every EVAL + (which includes every macro definition, and in particular every + call to let-syntax that a macro may expand into - I'm looking at + you, (chibi loop)). + +* compiler optimizations +** TODO constant folding +** TODO simplification pass, dead-code elimination + This is important in particular for the output generated by + syntax-rules. +** TODO lambda lift + The current closure representation is not very efficient, so this + would help a lot. +** TODO inlining (and disabling primitive inlining) + Being able to redefine procedures is important though. +** TODO unsafe operations + Possibly, don't want to make things too complicated or unstable. +** TODO plugin infrastructure +** TODO type inference with warning + +* macros +** DONE hygiene + - State "DONE" [2009-04-09 Thu 14:41] +** DONE hygienic nested let-syntax + - State "DONE" [2009-12-08 Tue 14:41] +** DONE macroexpand utility + - State "DONE" [2009-12-08 Tue 14:41] +** TODO compiler macros +** TODO SRFI-46 basic syntax-rules extensions +** TODO (... ...) support +** TODO syntax-rules common pattern reduction +** TODO syntax-rules loop optimization + +* garbage collection +** DONE precise gc rewrite + - State "DONE" [2009-06-22 Mon 14:27] +** DONE fix heap growing + - State "DONE" [2009-06-22 Mon 14:29] +** DONE separate gc heaps + - State "DONE" [2009-12-08 Tue 14:29] +** DONE add finalizers + - State "DONE" [2009-12-08 Tue 14:29] +** TODO support weak references + +* runtime +** DONE bignums + - State "DONE" [2009-07-07 Tue 14:42] +** TODO unicode +** TODO threads +** TODO recursive disasm + +* FFI +** DONE libdl support + - State "DONE" [2009-12-08 Tue 14:45] +** DONE opcode generation interface + - State "DONE" [2009-11-15 Sun 14:45] +** TODO stub generator +*** DONE define-c-struct + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE define-c + - State "DONE" [2009-11-29 Sun 14:48] +*** TODO array return types +*** TODO pre-buffered string types (like getcwd) + +* module system +** DONE scheme48-like config language + - State "DONE" [2009-10-13 Tue 14:38] +** DONE shared library includes + - State "DONE" [2009-12-08 Tue 14:39] +** TODO only/except/rename/prefix modifiers +** TODO scheme-complete.el support +** TODO access individual modules from repl + +* core modules +** TODO SRFI-0 cond-expand +** DONE SRFI-9 define-record-type + - State "DONE" [2009-12-08 Tue 14:50] +** DONE SRFI-69 hash-tables + - State "DONE" [2009-11-15 Sun 14:50] +** DONE match library + - State "DONE" [2009-12-08 Tue 14:54] +** DONE loop library + - State "DONE" [2009-12-08 Tue 14:54] +** TODO network interface +** TODO posix interface +** TODO pathname library +** TODO uri library +** TODO http library +** TODO show (formatting) library +** TODO zip library +** TODO tar library +** TODO md5sum library + +* ports +** DONE basic mingw support + - State "DONE" [2009-06-22 Mon 14:36] +** DONE Plan 9 support + - State "DONE" [2009-08-10 Mon 14:37] +** DONE 64-bit support + - State "DONE" [2009-11-01 Sun 14:37] +** TODO iPhone support +** TODO bare-metal support + +* miscellaneous +** TODO overall cleanup +** TODO user documentation +** TODO thorough source documentation + +* distribution +** TODO packaging format +** TODO code repository with fetch+install tool +** TODO translator to/from other implementations -*+ precise gc rewrite -**+ fix heap growing -**+ separate gc heaps -**+ finalizers -**- weak references -*+ ast rewrite -*+ full r5rs -*+ closures -*+ string-ports -*+ argument validation -*+ variadic procedures -*+ call/cc -*+ exceptions -*+ tail-call elimination -*+ internal defines -*+ 1st class primitives -*+ macros -*+ hygiene -**- nested -**- compiler macros -*+ bignums -*= modules -**+ scheme48-like config language -**- only/except/rename modifiers -**- scheme-complete.el support -*= ffi -**+ libdl interface -**+ opcode generation interface -**= stub generator -*= cleanup -*- user documentation -*- unicode -*- condition-case -*- native x86 compilation -*+ plan 9 port -*= 9p support -*- optimization passes -**- constant folding -**- simplification pass, dead-code elimination -**- lambda lift -**- inlining -**- unsafe operations -**- plugin infrastructure -*- type inference with warnings -*- SRFI-0 cond-expand -*+ SRFI-9 define-record-type -*+ SRFI-69 hash-tables -*= net interface -*= posix interface -*- code repository with install tools From 0da9a79bd1b100a567348ccb97e3f01d4bc566dc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Dec 2009 16:29:15 +0900 Subject: [PATCH 235/535] compressing bytecode literal references --- eval.c | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/eval.c b/eval.c index a5e46b5d..6f478fea 100644 --- a/eval.c +++ b/eval.c @@ -183,14 +183,24 @@ static void emit_word (sexp ctx, sexp_uint_t val) { static void emit_push (sexp ctx, sexp obj) { emit(ctx, OP_PUSH); emit_word(ctx, (sexp_uint_t)obj); - if (sexp_pointerp(obj)) + if (sexp_pointerp(obj) && ! sexp_symbolp(obj)) sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); } static sexp finalize_bytecode (sexp ctx) { + sexp bc; emit(ctx, OP_RET); shrink_bcode(ctx, sexp_context_pos(ctx)); - return sexp_context_bc(ctx); + bc = sexp_context_bc(ctx); + if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */ + if (sexp_nullp(sexp_cdr(sexp_bytecode_literals(bc)))) + sexp_bytecode_literals(bc) = sexp_car(sexp_bytecode_literals(bc)); + else if (sexp_nullp(sexp_cddr(sexp_bytecode_literals(bc)))) + sexp_cdr(sexp_bytecode_literals(bc)) = sexp_cadr(sexp_bytecode_literals(bc)); + else + sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc)); + } + return bc; } static sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args, From 2a424658b09e029068f8adbe6d66da673d932b8d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Dec 2009 16:30:06 +0900 Subject: [PATCH 236/535] adding extra lambda accessors to ast lib --- include/chibi/sexp.h | 2 +- lib/chibi/ast.c | 3 ++- lib/chibi/ast.module | 4 ++-- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 03b044a0..7e4a1a10 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -235,7 +235,7 @@ struct sexp_struct { } core; /* ast types */ struct { - sexp name, params, locals, defs, flags, fv, sv, body; + sexp name, params, body, defs, locals, flags, fv, sv; } lambda; struct { sexp test, pass, fail; diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index c3391a64..b21604eb 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -59,7 +59,8 @@ sexp sexp_init_library (sexp ctx, sexp env) { sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!"); sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!"); sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); - sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-body", "lambda-body-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!"); sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!"); sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!"); sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!"); diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index d95b97d5..57068ece 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -3,8 +3,8 @@ (export analyze env-cell opcode-name syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? syntactic-closure-expr syntactic-closure-env syntactic-closure-vars - lambda-name lambda-params lambda-body - lambda-name-set! lambda-params-set! lambda-body-set! + lambda-name lambda-params lambda-body lambda-defs + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! cnd-test cnd-pass cnd-fail cnd-test-set! cnd-pass-set! cnd-fail-set! set-var set-value set-var-set! set-value-set! From d2e094e4c116317c3820a3d99745f5696bac67d9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Dec 2009 16:51:50 +0900 Subject: [PATCH 237/535] simplifying code --- lib/chibi/match/match.scm | 285 +++++++++++++++++++------------------- 1 file changed, 142 insertions(+), 143 deletions(-) diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm index 6a6407b5..963b89ff 100644 --- a/lib/chibi/match/match.scm +++ b/lib/chibi/match/match.scm @@ -45,8 +45,7 @@ (define-syntax match-syntax-error (syntax-rules () - ((_) - (match-syntax-error "invalid match-syntax-error usage")))) + ((_) (match-syntax-error "invalid match-syntax-error usage")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -61,49 +60,50 @@ ((match) (match-syntax-error "missing match expression")) ((match atom) - (match-syntax-error "missing match clause")) + (match-syntax-error "no match clauses")) ((match (app ...) (pat . body) ...) (let ((v (app ...))) - (match-next v (app ...) (set! (app ...)) (pat . body) ...))) + (match-next v ((app ...) (set! (app ...))) (pat . body) ...))) ((match #(vec ...) (pat . body) ...) (let ((v #(vec ...))) - (match-next v v (set! v) (pat . body) ...))) + (match-next v (v (set! v)) (pat . body) ...))) ((match atom (pat . body) ...) - (match-next atom atom (set! atom) (pat . body) ...)) + (match-next atom (atom (set! atom)) (pat . body) ...)) )) ;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure ;; thunk, which is expanded by recursing MATCH-NEXT on the remaining -;; clauses. `g' and `s' are the get! and set! expressions -;; respectively. +;; clauses. `g+s' is a list of two elements, the get! and set! +;; expressions respectively. (define-syntax match-next (syntax-rules (=>) ;; no more clauses, the match failed - ((match-next v g s) + ((match-next v g+s) (error 'match "no matching pattern")) ;; named failure continuation - ((match-next v g s (pat (=> failure) . body) . rest) - (let ((failure (lambda () (match-next v g s . rest)))) + ((match-next v g+s (pat (=> failure) . body) . rest) + (let ((failure (lambda () (match-next v g+s . rest)))) ;; match-one analyzes the pattern for us - (match-one v pat g s (match-drop-ids (begin . body)) (failure) ()))) + (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ()))) ;; anonymous failure continuation, give it a dummy name - ((match-next v g s (pat . body) . rest) - (match-next v g s (pat (=> failure) . body) . rest)))) + ((match-next v g+s (pat . body) . rest) + (match-next v g+s (pat (=> failure) . body) . rest)))) ;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to ;; MATCH-TWO. (define-syntax match-one (syntax-rules () - ;; If it's a list of two values, check to see if the second one is - ;; an ellipse and handle accordingly, otherwise go to MATCH-TWO. - ((match-one v (p q . r) g s sk fk i) + ;; If it's a list of two or more values, check to see if the + ;; second one is an ellipse and handle accordingly, otherwise go + ;; to MATCH-TWO. + ((match-one v (p q . r) g+s sk fk i) (match-check-ellipse q - (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ()) - (match-two v (p q . r) g s sk fk i))) - ;; Otherwise, go directly to MATCH-TWO. + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()) + (match-two v (p q . r) g+s sk fk i))) + ;; Go directly to MATCH-TWO. ((match-one . x) (match-two . x)))) @@ -114,7 +114,7 @@ ;; ;; usually abbreviated ;; -;; (match-two v p g s sk fk i) +;; (match-two v p g+s sk fk i) ;; ;; where VAR is the symbol name of the current variable we are ;; matching, PATTERN is the current pattern, getter and setter are the @@ -126,58 +126,57 @@ (define-syntax match-two (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!) - ((match-two v () g s (sk ...) fk i) + ((match-two v () g+s (sk ...) fk i) (if (null? v) (sk ... i) fk)) - ((match-two v (quote p) g s (sk ...) fk i) + ((match-two v (quote p) g+s (sk ...) fk i) (if (equal? v 'p) (sk ... i) fk)) - ((match-two v (quasiquote p) g s sk fk i) - (match-quasiquote v p g s sk fk i)) - ((match-two v (and) g s (sk ...) fk i) (sk ... i)) - ((match-two v (and p q ...) g s sk fk i) - (match-one v p g s (match-one v (and q ...) g s sk fk) fk i)) - ((match-two v (or) g s sk fk i) fk) - ((match-two v (or p) g s sk fk i) - (match-one v p g s sk fk i)) - ((match-two v (or p ...) g s sk fk i) - (match-extract-vars (or p ...) (match-gen-or v (p ...) g s sk fk i) i ())) - ((match-two v (not p) g s (sk ...) fk i) - (match-one v p g s (match-drop-ids fk) (sk ... i) i)) - ((match-two v (get! getter) g s (sk ...) fk i) + ((match-two v (quasiquote p) . x) + (match-quasiquote v p . x)) + ((match-two v (and) g+s (sk ...) fk i) (sk ... i)) + ((match-two v (and p q ...) g+s sk fk i) + (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i)) + ((match-two v (or) g+s sk fk i) fk) + ((match-two v (or p) . x) + (match-one v p . x)) + ((match-two v (or p ...) g+s sk fk i) + (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ())) + ((match-two v (not p) g+s (sk ...) fk i) + (match-one v p g+s (match-drop-ids fk) (sk ... i) i)) + ((match-two v (get! getter) (g s) (sk ...) fk i) (let ((getter (lambda () g))) (sk ... i))) - ((match-two v (set! setter) g (s ...) (sk ...) fk i) + ((match-two v (set! setter) (g (s ...)) (sk ...) fk i) (let ((setter (lambda (x) (s ... x)))) (sk ... i))) - ((match-two v (? pred p ...) g s sk fk i) - (if (pred v) (match-one v (and p ...) g s sk fk i) fk)) - ((match-two v (= proc p) g s sk fk i) - (let ((w (proc v))) - (match-one w p g s sk fk i))) - ((match-two v (p ___ . r) g s sk fk i) - (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ())) - ((match-two v (p) g s sk fk i) + ((match-two v (? pred . p) g+s sk fk i) + (if (pred v) (match-one v (and . p) g+s sk fk i) fk)) + ((match-two v (= proc p) . x) + (let ((w (proc v))) (match-one w p . x))) + ((match-two v (p ___ . r) g+s sk fk i) + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())) + ((match-two v (p) g+s sk fk i) (if (and (pair? v) (null? (cdr v))) (let ((w (car v))) - (match-one w p (car v) (set-car! v) sk fk i)) + (match-one w p ((car v) (set-car! v)) sk fk i)) fk)) - ((match-two v (p *** q) g s sk fk i) - (match-extract-vars p (match-gen-search v p q g s sk fk i) i ())) - ((match-two v (p *** . q) g s sk fk i) + ((match-two v (p *** q) g+s sk fk i) + (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) + ((match-two v (p *** . q) g+s sk fk i) (match-syntax-error "invalid use of ***" (p *** . q))) - ((match-two v (p . q) g s sk fk i) + ((match-two v (p . q) g+s sk fk i) (if (pair? v) (let ((w (car v)) (x (cdr v))) - (match-one w p (car v) (set-car! v) - (match-one x q (cdr v) (set-cdr! v) sk fk) + (match-one w p ((car v) (set-car! v)) + (match-one x q ((cdr v) (set-cdr! v)) sk fk) fk i)) fk)) - ((match-two v #(p ...) g s sk fk i) - (match-vector v 0 () (p ...) sk fk i)) - ((match-two v _ g s (sk ...) fk i) (sk ... i)) + ((match-two v #(p ...) g+s . x) + (match-vector v 0 () (p ...) . x)) + ((match-two v _ g+s (sk ...) fk i) (sk ... i)) ;; Not a pair or vector or special literal, test to see if it's a ;; new symbol, in which case we just bind it, or if it's an ;; already bound symbol or some other literal, in which case we ;; compare it with EQUAL?. - ((match-two v x g s (sk ...) fk (id ...)) + ((match-two v x g+s (sk ...) fk (id ...)) (let-syntax ((new-sym? (syntax-rules (id ...) @@ -192,53 +191,55 @@ (define-syntax match-quasiquote (syntax-rules (unquote unquote-splicing quasiquote) - ((_ v (unquote p) g s sk fk i) - (match-one v p g s sk fk i)) - ((_ v ((unquote-splicing p) . rest) g s sk fk i) + ((_ v (unquote p) g+s sk fk i) + (match-one v p g+s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g+s sk fk i) (if (pair? v) (match-one v (p . tmp) - (match-quasiquote tmp rest g s sk fk) + (match-quasiquote tmp rest g+s sk fk) fk i) fk)) - ((_ v (quasiquote p) g s sk fk i . depth) - (match-quasiquote v p g s sk fk i #f . depth)) - ((_ v (unquote p) g s sk fk i x . depth) - (match-quasiquote v p g s sk fk i . depth)) - ((_ v (unquote-splicing p) g s sk fk i x . depth) - (match-quasiquote v p g s sk fk i . depth)) - ((_ v (p . q) g s sk fk i . depth) + ((_ v (quasiquote p) g+s sk fk i . depth) + (match-quasiquote v p g+s sk fk i #f . depth)) + ((_ v (unquote p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (unquote-splicing p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (p . q) g+s sk fk i . depth) (if (pair? v) (let ((w (car v)) (x (cdr v))) (match-quasiquote - w p g s - (match-quasiquote-step x q g s sk fk depth) + w p g+s + (match-quasiquote-step x q g+s sk fk depth) fk i . depth)) fk)) - ((_ v #(elt ...) g s sk fk i . depth) + ((_ v #(elt ...) g+s sk fk i . depth) (if (vector? v) (let ((ls (vector->list v))) - (match-quasiquote ls (elt ...) g s sk fk i . depth)) + (match-quasiquote ls (elt ...) g+s sk fk i . depth)) fk)) - ((_ v x g s sk fk i . depth) - (match-one v 'x g s sk fk i)))) + ((_ v x g+s sk fk i . depth) + (match-one v 'x g+s sk fk i)))) (define-syntax match-quasiquote-step (syntax-rules () - ((match-quasiquote-step x q g s sk fk depth i) - (match-quasiquote x q g s sk fk i . depth)) - )) + ((match-quasiquote-step x q g+s sk fk depth i) + (match-quasiquote x q g+s sk fk i . depth)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Utilities -;; A CPS utility that takes two values and just expands into the -;; first. +;; Takes two values and just expands into the first. (define-syntax match-drop-ids (syntax-rules () ((_ expr ids ...) expr))) +(define-syntax match-drop-first-arg + (syntax-rules () + ((_ arg expr) expr))) + ;; To expand an OR group we try each clause in succession, passing the ;; first that succeeds to the success continuation. On failure for ;; any clause, we just try the next clause, finally resorting to the @@ -248,22 +249,21 @@ (define-syntax match-gen-or (syntax-rules () - ((_ v p g s (sk ...) fk (i ...) ((id id-ls) ...)) + ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...)) (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) - (match-gen-or-step - v p g s (match-drop-ids (sk2 id ...)) fk (i ...)))))) + (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...)))))) (define-syntax match-gen-or-step (syntax-rules () - ((_ v () g s sk fk i) + ((_ v () g+s sk fk . x) ;; no OR clauses, call the failure continuation fk) - ((_ v (p) g s sk fk i) + ((_ v (p) . x) ;; last (or only) OR clause, just expand normally - (match-one v p g s sk fk i)) - ((_ v (p . q) g s sk fk i) + (match-one v p . x)) + ((_ v (p . q) g+s sk fk i) ;; match one and try the remaining on failure - (match-one v p g s sk (match-gen-or-step v q g s sk fk i) i)) + (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) )) ;; We match a pattern (p ...) by matching the pattern p in a loop on @@ -279,7 +279,7 @@ (define-syntax match-gen-ellipses (syntax-rules () - ((_ v p () g s (sk ...) fk i ((id id-ls) ...)) + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) (match-check-identifier p ;; simplest case equivalent to (p ...), just bind the list (let ((p v)) @@ -293,12 +293,12 @@ (let ((id (reverse id-ls)) ...) (sk ... i))) ((pair? ls) (let ((w (car ls))) - (match-one w p (car ls) (set-car! ls) + (match-one w p ((car ls) (set-car! ls)) (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) fk i))) (else fk))))) - ((_ v p r g s (sk ...) fk i ((id id-ls) ...)) + ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) ;; general case, trailing patterns to match, keep track of the ;; remaining list length so we don't need any backtracking (match-verify-no-ellipses @@ -312,10 +312,10 @@ (cond ((= n tail-len) (let ((id (reverse id-ls)) ...) - (match-one ls r #f #f (sk ... i) fk i))) + (match-one ls r (#f #f) (sk ... i) fk i))) ((pair? ls) (let ((w (car ls))) - (match-one w p (car ls) (set-car! ls) + (match-one w p ((car ls) (set-car! ls)) (match-drop-ids (loop (cdr ls) (- n 1) (cons id id-ls) ...)) fk @@ -323,6 +323,28 @@ (else fk))))))))) +;; This is just a safety check. Although unlike syntax-rules we allow +;; trailing patterns after an ellipses, we explicitly disable multiple +;; ellipses at the same level. This is because in the general case +;; such patterns are exponential in the number of ellipses, and we +;; don't want to make it easy to construct very expensive operations +;; with simple looking patterns. For example, it would be O(n^2) for +;; patterns like (a ... b ...) because we must consider every trailing +;; element for every possible break for the leading "a ...". + +(define-syntax match-verify-no-ellipses + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipse + x + (match-syntax-error + "multiple ellipse patterns not allowed at same level") + (match-verify-no-ellipses y sk))) + ((_ () sk) + sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipse" x)))) + ;; Matching a tree search pattern is only slightly more complicated. ;; Here we allow patterns of the form ;; @@ -351,9 +373,9 @@ (define-syntax match-gen-search (syntax-rules () - ((match-gen-search v p q g s sk fk i ((id id-ls) ...)) + ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) (letrec ((try (lambda (w fail id-ls ...) - (match-one w q g s + (match-one w q g+s (match-drop-ids (let ((id (reverse id-ls)) ...) sk)) @@ -363,7 +385,7 @@ (fail) (let ((u (car w))) (match-one - u p (car w) (set-car! w) + u p ((car w) (set-car! w)) (match-drop-ids ;; accumulate the head variables from ;; the p pattern, and loop over the tail @@ -380,38 +402,16 @@ (let ((id-ls '()) ...) (try v (lambda () fk) id-ls ...)))))) -;; This is just a safety check. Although unlike syntax-rules we allow -;; trailing patterns after an ellipses, we explicitly disable multiple -;; ellipses at the same level. This is because in the general case -;; such patterns are exponential in the number of ellipses, and we -;; don't want to make it easy to construct very expensive operations -;; with simple looking patterns. For example, it would be O(n^2) for -;; patterns like (a ... b ...) because we must consider every trailing -;; element for every possible break for the leading "a ...". - -(define-syntax match-verify-no-ellipses - (syntax-rules () - ((_ (x . y) sk) - (match-check-ellipse - x - (match-syntax-error - "multiple ellipse patterns not allowed at same level") - (match-verify-no-ellipses y sk))) - ((_ () sk) sk) - ((_ x sk) - (match-syntax-error "dotted tail not allowed after ellipse" x)) - )) - ;; Vector patterns are just more of the same, with the slight ;; exception that we pass around the current vector index being ;; matched. (define-syntax match-vector (syntax-rules (___) - ((_ v n pats (p q) sk fk i) + ((_ v n pats (p q) . x) (match-check-ellipse q - (match-gen-vector-ellipses v n pats p sk fk i) - (match-vector-two v n pats (p q) sk fk i))) + (match-gen-vector-ellipses v n pats p . x) + (match-vector-two v n pats (p q) . x))) ((_ v n pats (p ___) sk fk i) (match-gen-vector-ellipses v n pats p sk fk i)) ((_ . x) @@ -423,21 +423,20 @@ (syntax-rules () ((_ v n ((pat index) ...) () sk fk i) (if (vector? v) - (let ((len (vector-length v))) - (if (= len n) - (match-vector-step v ((pat index) ...) sk fk i) - fk)) - fk)) - ((_ v n (pats ...) (p . q) sk fk i) - (match-vector v (+ n 1) (pats ... (p n)) q sk fk i)) - )) + (let ((len (vector-length v))) + (if (= len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) . x) + (match-vector v (+ n 1) (pats ... (p n)) q . x)))) (define-syntax match-vector-step (syntax-rules () ((_ v () (sk ...) fk i) (sk ... i)) ((_ v ((pat index) . rest) sk fk i) (let ((w (vector-ref v index))) - (match-one w pat (vector-ref v index) (vector-set! v index) + (match-one w pat ((vector-ref v index) (vector-set! v index)) (match-vector-step v rest sk fk) fk i))))) @@ -468,7 +467,7 @@ (if (>= j len) (let ((id (reverse id-ls)) ...) (sk ... i)) (let ((w (vector-ref v j))) - (match-one w p (vector-ref v j) (vetor-set! v j) + (match-one w p ((vector-ref v j) (vetor-set! v j)) (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) fk i))))))) @@ -486,22 +485,22 @@ (define-syntax match-extract-vars (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!) - ((match-extract-vars (? pred . p) k i v) - (match-extract-vars p k i v)) - ((match-extract-vars ($ rec . p) k i v) - (match-extract-vars p k i v)) - ((match-extract-vars (= proc p) k i v) - (match-extract-vars p k i v)) + ((match-extract-vars (? pred . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars ($ rec . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (= proc p) . x) + (match-extract-vars p . x)) ((match-extract-vars (quote x) (k ...) i v) (k ... v)) ((match-extract-vars (quasiquote x) k i v) (match-extract-quasiquote-vars x k i v (#t))) - ((match-extract-vars (and . p) k i v) - (match-extract-vars p k i v)) - ((match-extract-vars (or . p) k i v) - (match-extract-vars p k i v)) - ((match-extract-vars (not . p) k i v) - (match-extract-vars p k i v)) + ((match-extract-vars (and . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (or . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (not . p) . x) + (match-extract-vars p . x)) ;; A non-keyword pair, expand the CAR with a continuation to ;; expand the CDR. ((match-extract-vars (p q . r) k i v) @@ -511,8 +510,8 @@ (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) ((match-extract-vars (p . q) k i v) (match-extract-vars p (match-extract-vars-step q k i v) i ())) - ((match-extract-vars #(p ...) k i v) - (match-extract-vars (p ...) k i v)) + ((match-extract-vars #(p ...) . x) + (match-extract-vars (p ...) . x)) ((match-extract-vars _ (k ...) i v) (k ... v)) ((match-extract-vars ___ (k ...) i v) (k ... v)) ((match-extract-vars *** (k ...) i v) (k ... v)) From 3d022857326c72dcbd6b9c1550fe1152a763e19b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Dec 2009 16:58:31 +0900 Subject: [PATCH 238/535] using ER let-keyword-form, removing match dependency --- lib/chibi/loop.module | 1 - lib/chibi/loop/loop.scm | 109 +++++++++++++--------------------------- 2 files changed, 35 insertions(+), 75 deletions(-) diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module index 1488a5b6..17c8ac2d 100644 --- a/lib/chibi/loop.module +++ b/lib/chibi/loop.module @@ -5,6 +5,5 @@ summing multiplying in-string in-string-reverse in-vector in-vector-reverse) (import (scheme)) - (import (chibi match)) (include "loop/loop.scm")) diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm index 06326d84..09e12856 100644 --- a/lib/chibi/loop/loop.scm +++ b/lib/chibi/loop/loop.scm @@ -9,83 +9,44 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (assoc-pred equal elt ls) + (and (pair? ls) + (if (equal elt (car (car ls))) + (car ls) + (assoc-pred equal elt (cdr ls))))) + (define-syntax let-keyword-form (syntax-rules () ((let-keyword-form - ((labeled-arg-macro-name - (positional-form-name (arg-name . arg-default) ...))) + ((labeled-arg-macro-name (positional-name . params))) . body) - (letrec-syntax + (let-syntax ((labeled-arg-macro-name - (syntax-rules () - ((labeled-arg-macro-name . keyword-val-pairs) - (letrec-syntax - ((find - (syntax-rules (=> arg-name ...) - ((find kvp k-args (arg-name . default) (=> arg-name val) - . others) ; found arg-name among keyword-val-pairs - (next kvp val . k-args)) ... - ((find kvp k-args key (=> arg-no-match-name val) . others) - (find kvp k-args key . others)) - ;; default must be here - ((find kvp k-args (arg-name default)) - (next kvp default . k-args)) ... - )) - (next ; pack the continuation to find - (syntax-rules () - ((next kvp val vals key . keys) - (find kvp ((val . vals) . keys) key . kvp)) - ((next kvp val vals) ; processed all arg-descriptors - (rev-apply (val) vals)))) - (match-positionals - (syntax-rules (=>) - ((match-positionals () res . rest) - (rev-apply () res)) - ((match-positionals args (val . vals) (=> name value) - . rest) - (next ((=> name value) . rest) val vals . args)) - ((match-positionals args (val . vals)) - (next () val vals . args)) - ((match-positionals (arg1 . args) res pos-arg . rest) - (match-positionals args (pos-arg . res) . rest)))) - (rev-apply - (syntax-rules () - ((rev-apply form (x . xs)) - (rev-apply (x . form) xs)) - ((rev-apply form ()) form)))) - (match-positionals ((arg-name . arg-default) ...) - (positional-form-name) - . keyword-val-pairs) - ))))) + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (named '()) (posns '())) + (cond + ((pair? ls) + (if (and (list? (car ls)) (compare (caar ls) (rename '=>))) + (lp (cdr ls) (cons (cdar ls) named) posns) + (lp (cdr ls) named (cons (car ls) posns)))) + (else + (let lp ((ls (syntax-quote params)) + (posns (reverse posns)) + (args '())) + (cond + ((null? ls) + (if (pair? posns) + (error "let-keyword-form: too many args" expr) + (cons (syntax-quote positional-name) (reverse args)))) + ((assoc-pred compare (caar ls) named) + => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args)))) + ((pair? posns) + (lp (cdr ls) (cdr posns) (cons (car posns) args))) + (else + (lp (cdr ls) posns (cons (cadar ls) args)))))))))))) . body)))) -;; (define-syntax let-keyword-form -;; (syntax-rules () -;; ((let-keyword-form -;; ((labeled-arg-macro-name (positional-name (arg default) ...))) -;; . body) -;; (letrec-syntax -;; ((labeled-arg-macro-name -;; (er-macro-transformer -;; (lambda (expr rename compare) -;; (receive (named posns) -;; (partition (lambda (x) (and (list? x) (compare (car x) (rename '=>)))) -;; (cdr expr)) -;; (let lp ((ls '((arg default) ...)) (posns posns) (args '())) -;; (cond -;; ((null? ls) -;; (if (pair? posns) -;; (error "let-keyword-form: too many args" expr) -;; (cons 'positional-name (reverse args)))) -;; ((find (lambda (x) (compare (caar ls) (cadr x))) named) -;; => (lambda (x) -;; (lp (cdr ls) posns (cons (caddr x) args)))) -;; ((pair? posns) -;; (lp (cdr ls) (cdr posns) (cons (car posns) args))) -;; (else -;; (lp (cdr ls) posns (cons (cadar ls) args)))))))))) -;; . body)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-syntax loop @@ -137,8 +98,8 @@ (letrec ((tmp (lambda (var ...) (if (or checks ...) (let-keyword-form ((name (tmp (var step) ...))) - (match-let (finals ...) result)) - (match-let (refs ...) + (let (finals ...) result)) + (let (refs ...) (let-keyword-form ((name (tmp (var step) ...))) (if #f #f) . body)))))) @@ -380,8 +341,8 @@ ((listing-reverse args next . rest) (accumulating (cons (lambda (x) x) '()) args next . rest)))) -(define (append-reverse ls1 ls2) - (append (reverse ls1) ls2)) +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) (define-syntax appending (syntax-rules () From 3f2a9c96303f9d0aef863b22a61b97162664c774 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Dec 2009 17:00:57 +0900 Subject: [PATCH 239/535] adding abstract pathname module this is for use with uri's - it doesn't access the filesystem or resolve symlinks, that functionality will be provided in another module. --- lib/chibi/pathname.module | 7 ++ lib/chibi/pathname.scm | 177 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 184 insertions(+) create mode 100644 lib/chibi/pathname.module create mode 100644 lib/chibi/pathname.scm diff --git a/lib/chibi/pathname.module b/lib/chibi/pathname.module new file mode 100644 index 00000000..2fb46eef --- /dev/null +++ b/lib/chibi/pathname.module @@ -0,0 +1,7 @@ + +(define-module (chibi pathname) + (export path-strip-directory path-directory path-extension-pos + path-extension path-strip-extension path-replace-extension + path-absolute? path-relative? path-normalize make-path) + (import (scheme)) + (include "pathname.scm")) diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm new file mode 100644 index 00000000..b8b28b4b --- /dev/null +++ b/lib/chibi/pathname.scm @@ -0,0 +1,177 @@ + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-scan-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (- i 1)))))) + +(define (string-skip c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (+ i 1))))))) + +(define (string-skip-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (- i 1)))))) + +;; POSIX basename +;; (define (path-strip-directory path) +;; (if (string=? path "") +;; path +;; (let ((end (string-skip-right #\/ path))) +;; (if (not end) +;; "/" +;; (let ((start (string-scan-right #\/ path (- end 1)))) +;; (substring path (if start (+ start 1) 0) (+ end 1))))))) + +;; GNU basename +(define (path-strip-directory path) + (if (string=? path "") + path + (let ((len (string-length path))) + (if (eqv? #\/ (string-ref path (- len 1))) + "" + (let ((slash (string-scan-right #\/ path))) + (if (not slash) + path + (substring path (+ slash 1) len))))))) + +(define (path-directory path) + (if (string=? path "") + "." + (let ((end (string-skip-right #\/ path))) + (if (not end) + "/" + (let ((start (string-scan-right #\/ path (- end 1)))) + (if (not start) + "." + (let ((start (string-skip-right #\/ path start))) + (if (not start) "/" (substring path 0 (+ start 1)))))))))) + +(define (path-extension-pos path) (string-scan-right #\. path)) + +(define (path-extension path) + (let ((i (path-extension-pos path))) + (and i + (let ((start (+ i 1)) (end (string-length path))) + (and (< start end) (substring path start end)))))) + +(define (path-strip-extension path) + (let ((i (path-extension-pos path))) + (if (and i (< (+ i 1) (string-length path))) + (substring path 0 i) + path))) + +(define (path-replace-extension path ext) + (string-append (path-strip-extension path) "." ext)) + +(define (path-absolute? path) + (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0)))) + +(define (path-relative? path) (not (path-absolute? path))) + +;; This looks big and hairy, but it's mutation-free and guarantees: +;; (string=? s (path-normalize s)) <=> (eq? s (path-normalize s)) +;; i.e. fast and simple for already normalized paths. + +(define (path-normalize path) + (let* ((len (string-length path)) (len-1 (- len 1))) + (define (collect i j res) + (if (>= i j) res (cons (substring path i j) res))) + (define (finish i res) + (if (zero? i) + path + (apply string-append (reverse (collect i len res))))) + ;; loop invariants: + ;; - res is a list such that (string-concatenate-reverse res) + ;; is always the normalized string up to j + ;; - the tail of the string from j onward can be concatenated to + ;; the above value to get a partially normalized path referring + ;; to the same location as the original path + (define (inside i j res) + (if (>= j len) + (finish i res) + (if (eqv? #\/ (string-ref path j)) + (boundary i (+ j 1) res) + (inside i (+ j 1) res)))) + (define (boundary i j res) + (if (>= j len-1) + (finish i res) + (case (string-ref path j) + ((#\.) + (case (string-ref path (+ j 1)) + ((#\.) + (if (or (>= j (- len 2)) (eqv? #\/ (string-ref path (+ j 2)))) + (if (>= i (- j 1)) + (if (null? res) + (backup j "" '()) + (backup j (car res) (cdr res))) + (backup j (substring path i j) res)) + (inside i (+ j 2) res))) + ((#\/) + (if (= i j) + (boundary (+ j 2) (+ j 2) res) + (let ((s (substring path i j))) + (boundary (+ j 2) (+ j 2) (cons s res))))) + (else (inside i (+ j 1) res)))) + ((#\/) (boundary (+ j 1) (+ j 1) (collect i j res))) + (else (inside i (+ j 1) res))))) + (define (backup j s res) + (let ((pos (+ j 3))) + (cond + ;; case 1: we're reduced to accumulating parents of the cwd + ((or (string=? s "/..") (string=? s "..")) + (boundary pos pos (cons "/.." (cons s res)))) + ;; case 2: the string isn't a component itself, skip it + ((or (string=? s "") (string=? s ".") (string=? s "/")) + (if (pair? res) + (backup j (car res) (cdr res)) + (boundary pos pos (if (string=? s "/") '("/") '(".."))))) + ;; case3: just take the directory of the string + (else + (let ((d (path-directory s))) + (cond + ((string=? d "/") + (boundary pos pos (if (null? res) '("/") res))) + ((string=? d ".") + (boundary pos pos res)) + (else (boundary pos pos (cons "/" (cons d res)))))))))) + ;; start with boundary if abs path, otherwise inside + (if (zero? len) + path + ((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '())))) + +(define (make-path . args) + (define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "not a valid path component" x)))) + (define (trim-trailing-slash s) + (let ((i (string-skip-right #\/ s))) + (if i (substring s 0 (+ i 1)) ""))) + (if (null? args) + "" + (let ((start (trim-trailing-slash (x->string (car args))))) + (let lp ((ls (cdr args)) + (res (if (string=? "" start) '() (list start)))) + (cond + ((null? ls) + (apply string-append (reverse res))) + ((pair? (car ls)) + (lp (append (car ls) (cdr ls)) res)) + (else + (let ((x (trim-trailing-slash (x->string (car ls))))) + (lp (cdr ls) + (if (string=? x "") res (cons x (cons "/" res))))))))))) From f4bb578d4d6c9b1796e4ba6994707ae5c061cfda Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Dec 2009 17:23:32 +0900 Subject: [PATCH 240/535] adding uri module from hato --- lib/chibi/uri.module | 10 ++ lib/chibi/uri.scm | 303 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 313 insertions(+) create mode 100644 lib/chibi/uri.module create mode 100644 lib/chibi/uri.scm diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module new file mode 100644 index 00000000..825ccd45 --- /dev/null +++ b/lib/chibi/uri.module @@ -0,0 +1,10 @@ + +(define-module (chibi uri) + (export uri->string make-uri string->uri + uri-scheme uri-user uri-host uri-path uri-query uri-fragment + uri-with-scheme uri-with-user uri-with-host uri-with-path + uri-with-query uri-with-fragment + uri-encode uri-decode uri-query->alist uri-alist->query) + (import (scheme) + (srfi 9)) + (include "uri.scm")) diff --git a/lib/chibi/uri.scm b/lib/chibi/uri.scm new file mode 100644 index 00000000..4386837a --- /dev/null +++ b/lib/chibi/uri.scm @@ -0,0 +1,303 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URI representation + +(define-record-type uri + (%make-uri scheme user host port path query fragment) + uri? + (scheme uri-scheme) + (user uri-user) + (host uri-host) + (port uri-port) + (path uri-path) + (query uri-query) + (fragment uri-fragment)) + +;; (make-uri scheme [user host port path query fragment]) +(define (make-uri scheme . o) + (let* ((user (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (host (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (port (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (path (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (query (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f))) + (%make-uri scheme user host port path query fragment))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils (don't feel like using SRFI-13 and these are more +;; specialised) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (string-scan-right str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i (- end 1))) + (and (>= i start) + (if (eqv? ch (string-ref str i)) + i + (lp (- i 1))))))) + +(define (string-index-of str pred . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond ((>= i end) #f) + ((pred (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase->symbol str) + (let ((len (string-length str))) + (let lp ((i 0)) + (cond + ((= i len) + (string->symbol str)) + ((char-upper-case? (string-ref str i)) + (let ((res (make-string len))) + (do ((j 0 (+ j 1))) + ((= j i)) + (string-set! res j (string-ref str j))) + (string-set! res i (char-downcase (string-ref str i))) + (do ((j (+ i 1) (+ j 1))) + ((= j len)) + (string-set! res j (char-downcase (string-ref str j)))) + (string->symbol res))) + (else + (lp (+ i 1))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; functional updaters (uses as much shared state as possible) + +(define (uri-with-scheme u scheme) + (%make-uri scheme (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-user u user) + (%make-uri (uri-scheme u) user (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-host u host) + (%make-uri (uri-scheme u) (uri-user u) host (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-port u port) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) port + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-path u path) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + path (uri-query u) (uri-fragment u))) + +(define (uri-with-query u query) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) query (uri-fragment u))) + +(define (uri-with-fragment u fragment) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) fragment)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parsing - without :// we just split into scheme & path + +(define (char-uri-scheme-unsafe? ch) + (not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\_ #\-))))) + +(define (string->path-uri scheme str . o) + (define decode? (and (pair? o) (car o))) + (define decode (if decode? uri-decode (lambda (x) x))) + (define decode-query + (if (and (pair? o) (pair? (cdr o)) (cadr o)) + uri-query->alist + decode)) + (if (pair? str) + str + (let* ((len (string-length str)) + (colon0 (string-scan str #\:)) + (colon + (and (not (string-index-of str char-uri-scheme-unsafe? + 0 (or colon0 len))) + colon0))) + (if (or (not colon) (zero? colon)) + (and scheme + (let* ((quest (string-scan str #\? 0)) + (pound (string-scan str #\# (or quest 0)))) + (make-uri scheme #f #f #f + (decode (substring str 0 (or quest pound len))) + (and quest + (decode-query + (substring str (+ quest 1) (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len)))))) + (let ((sc1 (+ colon 1)) + (scheme (string-downcase->symbol (substring str 0 colon)))) + (if (= sc1 len) + (make-uri scheme) + (if (or (>= (+ sc1 1) len) + (not (and (eqv? #\/ (string-ref str sc1)) + (eqv? #\/ (string-ref str (+ sc1 1)))))) + (make-uri scheme #f #f #f (substring str sc1 len)) + (if (>= (+ sc1 2) len) + (make-uri scheme #f "") + (let* ((sc2 (+ sc1 2)) + (slash (string-scan str #\/ sc2)) + (sc3 (or slash len)) + (at (string-scan-right str #\@ sc2 sc3)) + (colon3 (string-scan str #\: (or at sc2) sc3)) + (quest (string-scan str #\? sc3)) + (pound (string-scan str #\# (or quest sc3)))) + (%make-uri + scheme + (and at (decode (substring str sc2 at))) + (decode + (substring str + (if at (+ at 1) sc2) + (or colon3 sc3))) + (and colon3 + (string->number + (substring str (+ colon3 1) sc3))) + (and slash + (decode + (substring str slash (or quest pound len)))) + (and quest + (decode-query + (substring str (+ quest 1) + (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len))) + )))))))))) + +(define (string->uri str . o) + (apply string->path-uri #f str o)) + +(define (uri->string uri . o) + (define encode? (and (pair? o) (car o))) + (define encode (if encode? uri-encode (lambda (x) x))) + (if (string? uri) + uri + (let ((fragment (uri-fragment uri)) + (query (uri-query uri)) + (path (uri-path uri)) + (port (uri-port uri)) + (host (uri-host uri)) + (user (uri-user uri))) + (string-append + (symbol->string (uri-scheme uri)) ":" + (if (or user host port) "//" "") + (if user (encode user) "") (if user "@" "") + (or host "") ; host shouldn't need encoding + (if port ":" "") (if port (number->string port) "") + (if path (encode path) "") + (if query "?" "") + (if (pair? query) (uri-alist->query query) (or query "")) + (if fragment "#" "") (if fragment (encode fragment) ""))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; query encoding and decoding + +(define (uri-safe-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (case ch + ((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t) + (else #f)))) + +(define (collect str from to res) + (if (>= from to) + res + (cons (substring str from to) res))) + +(define (uri-encode str . o) + (define (encode-1-space ch) + (if (eqv? ch #\space) + "+" + (encode-1-normal ch))) + (define (encode-1-normal ch) + (let* ((i (char->integer ch)) + (hex (number->string i 16))) + (if (< i 16) + (string-append "%0" hex) + (string-append "%" hex)))) + (let ((start 0) + (end (string-length str)) + (encode-1 (if (and (pair? o) (car o)) + encode-1-space + encode-1-normal))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (if (uri-safe-char? ch) + (lp from next res) + (lp next next (cons (encode-1 ch) + (collect str from to res))))))))) + +(define (uri-decode str . o) + (let ((space-as-plus? (and (pair? o) (car o))) + (start 0) + (end (string-length str))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (cond + ((eqv? ch #\%) + (if (>= next end) + (lp next next (collect str from to res)) + (let ((next2 (+ next 1))) + (if (>= next2 end) + (lp next2 next2 (collect str from to res)) + (let* ((next3 (+ next2 1)) + (hex (substring str next next3)) + (i (string->number hex 16))) + (lp next3 next3 (cons (string (integer->char i)) + (collect str from to res)))))))) + ((and space-as-plus? (eqv? ch #\+)) + (lp next next (cons " " (collect str from to res)))) + (else + (lp from next res)))))))) + +(define (uri-query->alist str . o) + (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;))) + (let ((len (string-length str)) + (plus? (and (pair? o) (car o)))) + (let lp ((i 0) (res '())) + (if (>= i len) + (reverse res) + (let* ((j (or (string-index-of str split-char? i) len)) + (k (string-scan str #\= i j)) + (cell (if k + (cons (uri-decode (substring str i k) plus?) + (uri-decode (substring str (+ k 1) j) plus?)) + (cons (uri-decode (substring str i j) plus?) #f)))) + (lp (+ j 1) (cons cell res))))))) + +(define (uri-alist->query ls . o) + (define plus? (and (pair? o) (car o))) + (define (encode key val res) + (let ((res (cons (uri-encode key plus?) res))) + (if val (cons (uri-encode val plus?) (cons "=" res)) res))) + (if (null? ls) + "" + (let lp ((x (car ls)) (ls (cdr ls)) (res '())) + (let ((res (encode (car x) (cdr x) res))) + (if (null? ls) + (string-concatenate (reverse res)) + (lp (car ls) (cdr ls) (cons "&" res))))))) From 2ddafc2239d07c222d63c9fc6c4d98eb29f4711c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Dec 2009 17:29:54 +0900 Subject: [PATCH 241/535] recovering gracefully from out-of-stack-space errors --- eval.c | 6 ++++-- include/chibi/sexp.h | 3 ++- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/eval.c b/eval.c index 6f478fea..87e76051 100644 --- a/eval.c +++ b/eval.c @@ -1313,8 +1313,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { goto make_call; case OP_CALL: #if USE_CHECK_STACK - if (top+16 >= SEXP_INIT_STACK_SIZE) - errx(70, "out of stack space at %ld", top); + if (top+16 >= SEXP_INIT_STACK_SIZE) { + _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); + goto end_loop; + } #endif i = sexp_unbox_fixnum(_WORD0); tmp1 = _ARG1; diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 7e4a1a10..1b487a54 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -668,7 +668,8 @@ enum sexp_context_globals { #if ! USE_GLOBAL_SYMBOLS SEXP_G_SYMBOLS, #endif - SEXP_G_OOM_ERROR, + SEXP_G_OOM_ERROR, /* out of memory exception object */ + SEXP_G_OOS_ERROR, /* out of stack exception object */ SEXP_G_QUOTE_SYMBOL, SEXP_G_QUASIQUOTE_SYMBOL, SEXP_G_UNQUOTE_SYMBOL, From d6e279eccd76d9bd05b57a5793c99373b718dfca Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 12 Dec 2009 18:47:26 +0900 Subject: [PATCH 242/535] forgot these changes --- sexp.c | 1 + 1 file changed, 1 insertion(+) diff --git a/sexp.c b/sexp.c index 9ee6037a..4a860fc5 100644 --- a/sexp.c +++ b/sexp.c @@ -188,6 +188,7 @@ void sexp_init_context_globals (sexp ctx) { sexp_global(ctx, SEXP_G_SYMBOLS) = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_SYMBOL_TABLE_SIZE), SEXP_NULL); #endif sexp_global(ctx, SEXP_G_OOM_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of memory", SEXP_NULL); + sexp_global(ctx, SEXP_G_OOS_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of stack space", SEXP_NULL); sexp_global(ctx, SEXP_G_QUOTE_SYMBOL) = sexp_intern(ctx, "quote"); sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote"); sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote"); From 178cf109bd94e0bb96a7dd62a9bd2f3b54931038 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 13 Dec 2009 16:59:20 +0900 Subject: [PATCH 243/535] fixing segfault when applying a first-class opcode to the wrong # of arguments --- eval.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/eval.c b/eval.c index 87e76051..1555ede2 100644 --- a/eval.c +++ b/eval.c @@ -1141,8 +1141,13 @@ 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 ls, bc, res, env; sexp_gc_var5(params, ref, refs, lambda, ctx2); - if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) - return sexp_opcode_proc(op); /* return before preserving */ + if (i == sexp_opcode_num_args(op)) { /* return before preserving */ + if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); + } else if (i < sexp_opcode_num_args(op)) { + return sexp_compile_error(ctx, "not enough args for opcode", op); + } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ + return sexp_compile_error(ctx, "too many args for opcode", op); + } sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); params = make_param_list(ctx, i); lambda = sexp_make_lambda(ctx, params); From e03cef72b39aebf4772945a9d3283dafd1d2b9a5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 13 Dec 2009 19:29:35 +0900 Subject: [PATCH 244/535] warning on importing undefined variables --- eval.c | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/eval.c b/eval.c index 1555ede2..caf129f9 100644 --- a/eval.c +++ b/eval.c @@ -2380,7 +2380,7 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { } sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) { - sexp oldname, newname; + sexp oldname, newname, value, out; if (! sexp_envp(to)) to = sexp_context_env(ctx); if (! sexp_envp(from)) from = sexp_context_env(ctx); if (sexp_not(ls)) { @@ -2393,7 +2393,16 @@ sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) { } else { newname = oldname = sexp_car(ls); } - sexp_env_define(ctx, to, newname, sexp_env_global_ref(from, oldname, SEXP_FALSE)); + value = sexp_env_global_ref(from, oldname, SEXP_UNDEF); + if (value != SEXP_UNDEF) { + sexp_env_define(ctx, to, newname, value); +#if USE_WARN_UNDEFS + } else if (sexp_oportp(out=sexp_current_error_port(ctx))) { + sexp_write_string(ctx, "WARNING: importing undefined variable: ", out); + sexp_write(ctx, oldname, out); + sexp_write_char(ctx, '\n', out); +#endif + } } } return SEXP_VOID; From 99d8c585f9097caee5a63944a9bb942a8fffc044 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 14 Dec 2009 13:46:04 +0900 Subject: [PATCH 245/535] adding srfi-33 support (needs testing) --- Makefile | 2 +- config.scm | 4 +- include/chibi/bignum.h | 2 + init.scm | 2 +- lib/srfi/33.module | 17 +++ lib/srfi/33/bit.c | 276 ++++++++++++++++++++++++++++++++++++++++ lib/srfi/33/bitwise.scm | 58 +++++++++ opt/bignum.c | 2 +- 8 files changed, 358 insertions(+), 5 deletions(-) create mode 100644 lib/srfi/33.module create mode 100644 lib/srfi/33/bit.c create mode 100644 lib/srfi/33/bitwise.scm diff --git a/Makefile b/Makefile index 17f935f2..e86023d1 100644 --- a/Makefile +++ b/Makefile @@ -53,7 +53,7 @@ endif all: chibi-scheme$(EXE) libs -COMPILED_LIBS := lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ +COMPILED_LIBS := lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/posix$(SO) libs: $(COMPILED_LIBS) diff --git a/config.scm b/config.scm index 84bbfb68..d71f8180 100644 --- a/config.scm +++ b/config.scm @@ -156,13 +156,13 @@ (let ((exports '(define set! let let* letrec lambda if cond case delay - and or begin do quote quasiquote unquote unquote-splicing + and or begin do quote quasiquote 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 exp log sin cos tan asin acos atan sqrt - expt make-rectangular make-polar real-part imag-part magnitude angle + expt 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 diff --git a/include/chibi/bignum.h b/include/chibi/bignum.h index 8a160c52..580b0a7d 100644 --- a/include/chibi/bignum.h +++ b/include/chibi/bignum.h @@ -19,6 +19,8 @@ sexp_sint_t sexp_bignum_compare (sexp a, sexp b); sexp sexp_compare (sexp ctx, sexp a, sexp b); sexp sexp_make_bignum (sexp ctx, sexp_uint_t len); sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len); +sexp sexp_bignum_normalize (sexp a); +sexp_uint_t sexp_bignum_hi (sexp a); sexp sexp_fixnum_to_bignum (sexp ctx, sexp a); double sexp_bignum_to_double (sexp a); sexp sexp_double_to_bignum (sexp ctx, double f); diff --git a/init.scm b/init.scm index d554bbce..ce2fe440 100644 --- a/init.scm +++ b/init.scm @@ -471,7 +471,7 @@ (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))))) + (if (null? res) "0" (list->string res)))))) (define (string->number str . o) (let ((res diff --git a/lib/srfi/33.module b/lib/srfi/33.module new file mode 100644 index 00000000..81fa0a80 --- /dev/null +++ b/lib/srfi/33.module @@ -0,0 +1,17 @@ + +(define-module (srfi 33) + (export bitwise-not + bitwise-and bitwise-ior + bitwise-xor bitwise-eqv + bitwise-nand bitwise-nor + bitwise-andc1 bitwise-andc2 + bitwise-orc1 bitwise-orc2 + arithmetic-shift bit-count integer-length + bitwise-merge + bit-set? any-bits-set? all-bits-set? + first-set-bit + extract-bit-field test-bit-field? clear-bit-field + replace-bit-field copy-bit-field) + (import (scheme)) + (include-shared "33/bit") + (include "33/bitwise.scm")) diff --git a/lib/srfi/33/bit.c b/lib/srfi/33/bit.c new file mode 100644 index 00000000..4af9118c --- /dev/null +++ b/lib/srfi/33/bit.c @@ -0,0 +1,276 @@ + +#include +#include + +#if USE_BIGNUMS +#include +#endif + +static sexp sexp_bit_and (sexp ctx, sexp x, sexp y) { + sexp res; + sexp_sint_t len, i; + if (sexp_fixnump(x)) { + if (sexp_fixnump(y)) + res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); +#if USE_BIGNUMS + else if (sexp_bignump(y)) + res = sexp_bit_and(ctx, y, x); +#endif + else + res = sexp_type_exception(ctx, "bitwise-and: not an integer", y); +#if USE_BIGNUMS + } else if (sexp_bignump(x)) { + if (sexp_fixnump(y)) { + res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); + } else if (sexp_bignump(y)) { + if (sexp_bignum_length(x) < sexp_bignum_length(y)) + res = sexp_copy_bignum(ctx, NULL, x, 0); + else + res = sexp_copy_bignum(ctx, NULL, y, 0); + for (i=0, len=sexp_bignum_length(res); i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i> -c); + } else { + tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c; +#if USE_BIGNUMS + if (((tmp >> c) == sexp_unbox_fixnum(i)) + && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) { +#endif + res = sexp_make_fixnum(tmp); +#if USE_BIGNUMS + } else { + sexp_gc_preserve1(ctx, res); + res = sexp_fixnum_to_bignum(ctx, i); + res = sexp_arithmetic_shift(ctx, res, count); + sexp_gc_release1(ctx); + } +#endif + } +#if USE_BIGNUMS + } else if (sexp_bignump(i)) { + len = sexp_bignum_hi(i); + if (c < 0) { + c = -c; + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + if (len < offset) { + res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1); + } else { + res = sexp_make_bignum(ctx, len - offset + 1); + for (j=len-offset, tmp=0; j>=0; j--) { + sexp_bignum_data(res)[j] + = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp; + tmp = sexp_bignum_data(i)[j+offset] + << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + } + } else { + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + res = sexp_make_bignum(ctx, len + offset + 1); + for (j=tmp=0; j> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + sexp_bignum_data(res)[len+offset] = tmp; + } +#endif + } else { + res = sexp_type_exception(ctx, "arithmetic-shift: not an integer", i); + } + return sexp_bignum_normalize(res); +} + +/* bit-count and integer-length were adapted from: */ +/* http://graphics.stanford.edu/~seander/bithacks.html */ +static sexp_uint_t bit_count (sexp_uint_t i) { + i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3); + i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3) + + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3)); + i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15; + return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255)) + >> (sizeof(i) - 1) * CHAR_BIT); +} + +static sexp sexp_bit_count (sexp ctx, sexp x) { + sexp res; + sexp_sint_t count, i; + if (sexp_fixnump(x)) { + i = sexp_unbox_fixnum(x); + res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); +#if USE_BIGNUMS + } else if (sexp_bignump(x)) { + for (i=count=0; i> 32)) + return integer_log2(tt) + 32; + else if ((tt = x >> 16)) + return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt]; + else + return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; +} + +static sexp sexp_integer_length (sexp ctx, sexp x) { + sexp_sint_t hi, tmp; + if (sexp_fixnump(x)) { + tmp = sexp_unbox_fixnum(x); + return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp)); +#if USE_BIGNUMS + } else if (sexp_bignump(x)) { + hi = sexp_bignum_hi(x); + return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi]) + + hi*sizeof(sexp_uint_t)); +#endif + } else { + return sexp_type_exception(ctx, "integer-length: not an integer", x); + } +} + +static sexp sexp_bit_set_p (sexp ctx, sexp i, sexp x) { + sexp_uint_t pos; + if (! sexp_fixnump(i)) + return sexp_type_exception(ctx, "bit-set?: not an integer", i); + if (sexp_fixnump(x)) { + return sexp_make_boolean(sexp_unbox_fixnum(x) & (1<0) && ! sexp_bignum_data(a)[i]) i--; From 420ab008ffc4cbcf72de9263df685701863675a7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 14 Dec 2009 13:56:32 +0900 Subject: [PATCH 246/535] fixing maximum heap heuristic --- gc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gc.c b/gc.c index b3d85c62..4f4d43df 100644 --- a/gc.c +++ b/gc.c @@ -222,7 +222,7 @@ void* sexp_alloc (sexp ctx, size_t size) { h = sexp_heap_last(sexp_context_heap(ctx)); if (((max_freed < size) || ((h->size - sum_freed) > (h->size*SEXP_GROW_HEAP_RATIO))) - && ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE))) + && ((! SEXP_MAXIMUM_HEAP_SIZE) || (h->size < SEXP_MAXIMUM_HEAP_SIZE))) sexp_grow_heap(ctx, size); res = sexp_try_alloc(ctx, size); if (! res) From f1263dcc19f65447c3fe40742407ff290b16ef58 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 14 Dec 2009 13:57:40 +0900 Subject: [PATCH 247/535] adding trailing newline --- lib/srfi/1/alists.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm index ffea4bd8..b5032796 100644 --- a/lib/srfi/1/alists.scm +++ b/lib/srfi/1/alists.scm @@ -7,4 +7,5 @@ (let ((eq (if (pair? o) (car o) equal?))) (remove (lambda (x) (eq (car x) key)) ls))) -(define alist-delete! alist-delete) \ No newline at end of file +(define alist-delete! alist-delete) + From 366e0ee726bb7917dd6b46d10a440b12345a3083 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 14 Dec 2009 14:34:46 +0900 Subject: [PATCH 248/535] adding heap-stats module (hackers only, not built by default) --- Makefile | 2 +- lib/chibi/heap-stats.c | 66 +++++++++++++++++++++++++++++++++++++ lib/chibi/heap-stats.module | 5 +++ 3 files changed, 72 insertions(+), 1 deletion(-) create mode 100644 lib/chibi/heap-stats.c create mode 100644 lib/chibi/heap-stats.module diff --git a/Makefile b/Makefile index e86023d1..925b1eb7 100644 --- a/Makefile +++ b/Makefile @@ -54,7 +54,7 @@ endif all: chibi-scheme$(EXE) libs COMPILED_LIBS := lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ - lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/posix$(SO) + lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/posix$(SO) # lib/chibi/heap-stats$(SO) libs: $(COMPILED_LIBS) diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c new file mode 100644 index 00000000..f2f22df1 --- /dev/null +++ b/lib/chibi/heap-stats.c @@ -0,0 +1,66 @@ + +#include + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +extern sexp_uint_t sexp_allocated_bytes (sexp x); + +static sexp sexp_heap_stats (sexp ctx) { + size_t freed; + sexp_uint_t stats[256], hi_type=0, i; + sexp_heap h = sexp_context_heap(ctx); + sexp p; + sexp_free_list q, r; + char *end; + sexp_gc_var3(res, tmp, name); + + /* run gc once to remove unused variables */ + sexp_gc(ctx, &freed); + + /* initialize stats */ + for (i=0; i<256; i++) stats[i]=0; + + /* loop over each heap chunk */ + for ( ; h; h=h->next) { + 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) { /* this is a free block, skip */ + p = (sexp) (((char*)p) + r->size); + continue; + } + /* otherwise increment the stat and continue */ + stats[sexp_pointer_tag(p)]++; + if (sexp_pointer_tag(p) > hi_type) + hi_type = sexp_pointer_tag(p); + p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(p))); + } + } + + /* build and return results */ + sexp_gc_preserve3(ctx, res, tmp, name); + res = SEXP_NULL; + for (i=hi_type; i>0; i--) + if (stats[i]) { + name = sexp_intern(ctx, sexp_type_name_by_index(i)); + tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); + res = sexp_cons(ctx, tmp, res); + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats); + return SEXP_VOID; +} + diff --git a/lib/chibi/heap-stats.module b/lib/chibi/heap-stats.module new file mode 100644 index 00000000..24be3e9b --- /dev/null +++ b/lib/chibi/heap-stats.module @@ -0,0 +1,5 @@ + +(define-module (chibi heap-stats) + (export heap-stats) + (include-shared "heap-stats")) + From c6b0c2319c20a20077f3ce41cf66427a74c04819 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 16 Dec 2009 17:43:56 +0900 Subject: [PATCH 249/535] adding srfi-27 --- Makefile | 6 +- include/chibi/sexp.h | 4 + lib/srfi/27.module | 11 +++ lib/srfi/27/constructors.scm | 7 ++ lib/srfi/27/rand.c | 153 +++++++++++++++++++++++++++++++++++ sexp.c | 6 +- 6 files changed, 181 insertions(+), 6 deletions(-) create mode 100644 lib/srfi/27.module create mode 100644 lib/srfi/27/constructors.scm create mode 100644 lib/srfi/27/rand.c diff --git a/Makefile b/Makefile index 925b1eb7..0a892b6f 100644 --- a/Makefile +++ b/Makefile @@ -53,8 +53,10 @@ endif all: chibi-scheme$(EXE) libs -COMPILED_LIBS := lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ - lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/posix$(SO) # lib/chibi/heap-stats$(SO) +COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ + lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ + lib/chibi/ast$(SO) lib/chibi/net$(SO) \ + lib/chibi/posix$(SO) # lib/chibi/heap-stats$(SO) libs: $(COMPILED_LIBS) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 1b487a54..b4527037 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -352,6 +352,10 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_offsetof(type, f) (offsetof(struct sexp_struct, value.type.f)) +#define sexp_offsetof_slot0 (offsetof(struct sexp_struct, value)) + +#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double)) + #define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) #if USE_BIGNUMS diff --git a/lib/srfi/27.module b/lib/srfi/27.module new file mode 100644 index 00000000..198d444e --- /dev/null +++ b/lib/srfi/27.module @@ -0,0 +1,11 @@ + +(define-module (srfi 27) + (export random-integer random-real default-random-source + make-random-source random-source? + random-source-state-ref random-source-state-set! + random-source-randomize! random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals) + (import (scheme)) + (include-shared "27/rand") + (include "27/constructors.scm")) + diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm new file mode 100644 index 00000000..473ad2a2 --- /dev/null +++ b/lib/srfi/27/constructors.scm @@ -0,0 +1,7 @@ + +(define (random-source-make-integers rs) + (lambda (n) (%random-integer rs n))) + +(define (random-source-make-reals rs . o) + (lambda () (%random-real rs))) + diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c new file mode 100644 index 00000000..4ae30f50 --- /dev/null +++ b/lib/srfi/27/rand.c @@ -0,0 +1,153 @@ + +#include +#include + +#define SEXP_RANDOM_STATE_SIZE 128 + +#define ZERO sexp_make_fixnum(0) +#define ONE sexp_make_fixnum(1) +#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE) + +#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id) + +#define sexp_random_state(x) (sexp_slot_ref((x), 0)) +#define sexp_random_data(x) ((struct random_data*)(&sexp_slot_ref((x), 1))) + +#define sexp_random_init(x, seed) \ + initstate_r(seed, \ + sexp_string_data(sexp_random_state(x)), \ + SEXP_RANDOM_STATE_SIZE, \ + sexp_random_data(x)) + +#define sexp_sizeof_random (sexp_sizeof_header + sizeof(struct random_data) + sizeof(sexp)) + +static sexp_uint_t rs_type_id; +static sexp default_random_source; + +static sexp sexp_rs_random_integer (sexp ctx, sexp rs, sexp bound) { + sexp res; + int32_t n, hi, mod, len, i, *data; + if (! sexp_random_source_p(rs)) + res = sexp_type_exception(ctx, "not a random-source", rs); + if (sexp_fixnump(bound)) { + random_r(sexp_random_data(rs), &n); + res = sexp_make_fixnum(n % sexp_unbox_fixnum(bound)); +#if USE_BIGNUMS + } else if (sexp_bignump(bound)) { + hi = sexp_bignum_hi(bound); + len = hi * sizeof(sexp_uint_t) / sizeof(int32_t); + res = sexp_make_bignum(ctx, hi); + data = (int32_t*) sexp_bignum_data(res); + for (i=0; i Date: Wed, 16 Dec 2009 18:39:11 +0900 Subject: [PATCH 250/535] fixing define splicing for let-syntax (issue #13) --- eval.c | 36 +++++++++++++++++------------------- include/chibi/sexp.h | 4 ++-- tests/r5rs-tests.scm | 20 +++++++++++++++----- 3 files changed, 34 insertions(+), 26 deletions(-) diff --git a/eval.c b/eval.c index caf129f9..c638b10e 100644 --- a/eval.c +++ b/eval.c @@ -533,6 +533,8 @@ static sexp analyze_define (sexp ctx, sexp x) { sexp_gc_var4(ref, value, tmp, env); sexp_gc_preserve4(ctx, ref, value, tmp, env); env = sexp_context_env(ctx); + while (sexp_env_syntactic_p(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { res = sexp_compile_error(ctx, "bad define syntax", x); } else { @@ -606,37 +608,32 @@ static sexp analyze_define_syntax (sexp ctx, sexp x) { return res; } -static sexp analyze_let_syntax (sexp ctx, sexp x) { +static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp) { sexp res; sexp_gc_var3(env, ctx2, tmp); sexp_gc_preserve3(ctx, env, ctx2, tmp); if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { - res = sexp_compile_error(ctx, "bad let-syntax", x); + res = sexp_compile_error(ctx, "bad let(rec)-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_syntactic_p(env) = 1; + 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); + tmp = analyze_bind_syntax(sexp_cadr(x), (recp ? ctx2 : ctx), ctx2); res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x))); } sexp_gc_release3(ctx); return res; } +static sexp analyze_let_syntax (sexp ctx, sexp x) { + return analyze_let_syntax_aux(ctx, x, 0); +} + static sexp analyze_letrec_syntax (sexp ctx, sexp x) { - sexp res; - sexp_gc_var1(tmp); - sexp_gc_preserve1(ctx, tmp); - 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_release1(ctx); - return res; + return analyze_let_syntax_aux(ctx, x, 1); } static sexp analyze (sexp ctx, sexp object) { @@ -736,13 +733,14 @@ static sexp analyze (sexp ctx, sexp object) { } else { res = x; } + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res)) + && sexp_pairp(x)) + sexp_exception_source(res) = sexp_pair_source(x); sexp_gc_release4(ctx); return res; } -sexp sexp_analyze (sexp ctx, sexp x) { - return analyze(ctx, x); -} +sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} static sexp_sint_t sexp_context_make_label (sexp ctx) { sexp_sint_t label = sexp_context_pos(ctx); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index b4527037..ab1e2d07 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -203,7 +203,7 @@ struct sexp_struct { } cpointer; /* runtime types */ struct { - char flags; + unsigned int syntacticp:1; sexp parent, lambda, bindings; } env; struct { @@ -544,7 +544,7 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #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_syntactic_p(x) ((x)->value.env.syntacticp) #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)) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 9c379eb2..5ad8b5b7 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -404,11 +404,21 @@ (test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) (test 'ok - (let ((... 2)) - (let-syntax ((s (syntax-rules () - ((_ x ...) 'bad) - ((_ . r) 'ok)))) - (s a b c)))) + (let ((... 2)) + (let-syntax ((s (syntax-rules () + ((_ x ...) 'bad) + ((_ . r) 'ok)))) + (s a b c)))) + +(test 'ok (let () + (let-syntax () + (define internal-def 'ok)) + internal-def)) + +(test 'ok (let () + (letrec-syntax () + (define internal-def 'ok)) + internal-def)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 9d44cbd99a90e1a59182174d9d22be0148a4f207 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 16 Dec 2009 20:15:45 +0900 Subject: [PATCH 251/535] adding SRFI-0 cond-expand --- Makefile | 1 + TODO | 12 ++++++++---- config.scm | 9 ++++++--- eval.c | 3 +++ include/chibi/sexp.h | 1 + init.scm | 20 ++++++++++++++++++++ 6 files changed, 39 insertions(+), 7 deletions(-) diff --git a/Makefile b/Makefile index 0a892b6f..9ace5e37 100644 --- a/Makefile +++ b/Makefile @@ -81,6 +81,7 @@ INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h include/chibi/install.h: Makefile echo '#define sexp_so_extension "'$(SO)'"' > $@ echo '#define sexp_module_dir "'$(MODDIR)'"' >> $@ + echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< diff --git a/TODO b/TODO index ee91a9da..57f7c861 100644 --- a/TODO +++ b/TODO @@ -79,12 +79,14 @@ - State "DONE" [2009-10-13 Tue 14:38] ** DONE shared library includes - State "DONE" [2009-12-08 Tue 14:39] -** TODO only/except/rename/prefix modifiers +** DONE only/except/rename/prefix modifiers + - State "DONE" [2009-12-16 Wed 18:57] ** TODO scheme-complete.el support ** TODO access individual modules from repl * core modules -** TODO SRFI-0 cond-expand +** DONE SRFI-0 cond-expand + - State "DONE" [2009-12-16 Wed 20:12] ** DONE SRFI-9 define-record-type - State "DONE" [2009-12-08 Tue 14:50] ** DONE SRFI-69 hash-tables @@ -95,8 +97,10 @@ - State "DONE" [2009-12-08 Tue 14:54] ** TODO network interface ** TODO posix interface -** TODO pathname library -** TODO uri library +** DONE pathname library + - State "DONE" [2009-12-16 Wed 18:58] +** DONE uri library + - State "DONE" [2009-12-16 Wed 18:58] ** TODO http library ** TODO show (formatting) library ** TODO zip library diff --git a/config.scm b/config.scm index d71f8180..ebbb8424 100644 --- a/config.scm +++ b/config.scm @@ -124,7 +124,7 @@ mod)) (define-syntax define-module - (rsc-macro-transformer + (er-macro-transformer (lambda (expr env) (let ((name (cadr expr)) (body (cddr expr))) @@ -141,7 +141,7 @@ (set! *this-module* tmp)))))) (define-syntax define-config-primitive - (rsc-macro-transformer + (er-macro-transformer (lambda (expr env) `(define-syntax ,(cadr expr) (er-macro-transformer @@ -198,5 +198,8 @@ (set! *modules* (list (cons '(scheme) (make-module exports (interaction-environment) - (list (cons 'export exports))))))) + (list (cons 'export exports)))) + (cons '(srfi 0) (make-module (list 'cond-expand) + (interaction-environment) + (list (list 'export 'cond-expand))))))) diff --git a/eval.c b/eval.c index c638b10e..69517750 100644 --- a/eval.c +++ b/eval.c @@ -2373,6 +2373,9 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_c_string(ctx, sexp_module_dir, -1)); sexp_env_define(ctx, e, sexp_intern(ctx, "*shared-object-extension*"), sexp_c_string(ctx, sexp_so_extension, -1)); + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform)); + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp); sexp_gc_release4(ctx); return e; } diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index ab1e2d07..88ae48d9 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -674,6 +674,7 @@ enum sexp_context_globals { #endif SEXP_G_OOM_ERROR, /* out of memory exception object */ SEXP_G_OOS_ERROR, /* out of stack exception object */ + SEXP_G_OPTIMIZATIONS, SEXP_G_QUOTE_SYMBOL, SEXP_G_QUASIQUOTE_SYMBOL, SEXP_G_UNQUOTE_SYMBOL, diff --git a/init.scm b/init.scm index ce2fe440..64e3a05a 100644 --- a/init.scm +++ b/init.scm @@ -771,3 +771,23 @@ ',(cdr mod+imps)) res)) (error "couldn't find module" (car ls)))))))))) + +;; SRFI-0 + +(define-syntax cond-expand + (er-macro-transformer + (lambda (expr rename compare) + (define (check x) + (if (pair? x) + (case (car x) + ((and) (every check (cdr x))) + ((or) (any check (cdr x))) + ((not) (not (check (cadr x)))) + (else (error "cond-expand: bad feature" x))) + (memq (identifier->symbol x) (cons 'else *features*)))) + (let expand ((ls (cdr expr))) + (cond ((null? ls) (error "cond-expand: no expansions" (cdr expr))) + ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) + ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) + (else (expand (cdr ls)))))))) + From 2b49406e9364afb6236a2006646610ba2234b35f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 17 Dec 2009 15:54:35 +0900 Subject: [PATCH 252/535] oops, wrong signature for er-macro-transformer on the srfi-0 patch --- config.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config.scm b/config.scm index ebbb8424..e670845d 100644 --- a/config.scm +++ b/config.scm @@ -125,7 +125,7 @@ (define-syntax define-module (er-macro-transformer - (lambda (expr env) + (lambda (expr rename compare) (let ((name (cadr expr)) (body (cddr expr))) `(let ((tmp *this-module*)) @@ -142,7 +142,7 @@ (define-syntax define-config-primitive (er-macro-transformer - (lambda (expr env) + (lambda (expr rename compare) `(define-syntax ,(cadr expr) (er-macro-transformer (lambda (expr rename compare) From e4a792bdc45f34122cf82588127e964dc4ed5080 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 17 Dec 2009 15:57:26 +0900 Subject: [PATCH 253/535] don't stop making if an individual lib fails to build --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 9ace5e37..a2ca3826 100644 --- a/Makefile +++ b/Makefile @@ -86,7 +86,7 @@ include/chibi/install.h: Makefile sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< -eval.o: eval.c opt/debug.c opcodes.c $(INCLUDES) include/chibi/eval.h Makefile +eval.o: eval.c opcodes.c opt/debug.c $(INCLUDES) include/chibi/eval.h Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile @@ -105,7 +105,7 @@ chibi-scheme-static$(EXE): main.o eval.o sexp.o LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) $(GENSTUBS) $< lib/%$(SO): lib/%.c $(INCLUDES) - $(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme clean: rm -f *.o *.i *.s *.8 From 3861a5b599e0b2dd278fc6a8d4c72febe8b6cfc9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 17 Dec 2009 16:27:55 +0900 Subject: [PATCH 254/535] adding optimization plugin infrastructure --- eval.c | 84 ++++++++++++++++++++++++------------------ include/chibi/config.h | 7 ++++ include/chibi/sexp.h | 7 ++++ opt/debug.c | 10 ++++- sexp.c | 20 +++++----- 5 files changed, 81 insertions(+), 47 deletions(-) diff --git a/eval.c b/eval.c index 69517750..6958b9ee 100644 --- a/eval.c +++ b/eval.c @@ -200,6 +200,7 @@ static sexp finalize_bytecode (sexp ctx) { else sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc)); } + /* sexp_disasm(ctx, bc, sexp_current_error_port(ctx)); */ return bc; } @@ -277,19 +278,20 @@ static sexp sexp_make_lit (sexp ctx, sexp value) { #define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) void sexp_init_eval_context_globals (sexp ctx) { + sexp_gc_var2(bc, vec); ctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve2(ctx, bc, vec); emit(ctx, OP_RESUMECC); sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); ctx = sexp_make_child_context(ctx, NULL); emit(ctx, OP_DONE); + bc = finalize_bytecode(ctx); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); sexp_global(ctx, SEXP_G_FINAL_RESUMER) - = sexp_make_procedure(ctx, - sexp_make_fixnum(0), - sexp_make_fixnum(0), - finalize_bytecode(ctx), - sexp_make_vector(ctx, 0, SEXP_VOID)); + = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, bc, vec); sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) = sexp_intern(ctx, "final-resumer"); + sexp_gc_release2(ctx); } sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env) { @@ -842,8 +844,7 @@ static void generate_set (sexp ctx, sexp set) { 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) { + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { /* stack or closure mutable vars are boxed */ generate_ref(ctx, ref, 0); emit(ctx, OP_SET_CDR); @@ -1013,7 +1014,7 @@ static void generate_lambda (sexp ctx, sexp lambda) { sexp_bytecode_name(bc) = sexp_lambda_name(lambda); if (sexp_nullp(fv)) { /* shortcut, no free vars */ - tmp = sexp_make_vector(ctx2, sexp_make_fixnum(0), SEXP_VOID); + tmp = sexp_make_vector(ctx2, SEXP_ZERO, 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); @@ -1161,8 +1162,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { 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_fixnum(0), sexp_make_fixnum(i), - bc, SEXP_VOID); + res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); if (i == sexp_opcode_num_args(op)) sexp_opcode_proc(op) = res; sexp_gc_release5(ctx); @@ -1268,20 +1268,18 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG1 = tmp1; break; case OP_CALLCC: - stack[top] = sexp_make_fixnum(1); + stack[top] = SEXP_ONE; stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc)); stack[top+2] = self; stack[top+3] = sexp_make_fixnum(fp); tmp1 = _ARG1; i = 1; sexp_context_top(ctx) = top; - tmp2 = sexp_make_vector(ctx, sexp_make_fixnum(1), SEXP_UNDEF); - sexp_vector_set(tmp2, - sexp_make_fixnum(0), - sexp_save_stack(ctx, stack, top+4)); + tmp2 = sexp_make_vector(ctx, SEXP_ONE, SEXP_UNDEF); + sexp_vector_set(tmp2, SEXP_ZERO, sexp_save_stack(ctx, stack, top+4)); _ARG1 = sexp_make_procedure(ctx, - sexp_make_fixnum(0), - sexp_make_fixnum(1), + SEXP_ZERO, + SEXP_ONE, sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE), tmp2); top++; @@ -1686,7 +1684,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case OP_DIV: - if (_ARG2 == sexp_make_fixnum(0)) { + if (_ARG2 == SEXP_ZERO) { #if USE_FLONUMS if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); @@ -1722,7 +1720,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case OP_QUOTIENT: if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - if (_ARG2 == sexp_make_fixnum(0)) + if (_ARG2 == SEXP_ZERO) sexp_raise("divide by zero", SEXP_NULL); _ARG2 = sexp_fx_div(_ARG1, _ARG2); top--; @@ -1738,7 +1736,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case OP_REMAINDER: if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - if (_ARG2 == sexp_make_fixnum(0)) + if (_ARG2 == SEXP_ZERO) sexp_raise("divide by zero", SEXP_NULL); tmp1 = sexp_fx_rem(_ARG1, _ARG2); top--; @@ -2117,9 +2115,9 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { sexp res; #if USE_BIGNUMS if (sexp_bignump(e)) { /* bignum exponent needs special handling */ - if ((x == sexp_make_fixnum(0)) || (x == sexp_make_fixnum(-1))) + if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ - else if (x == sexp_make_fixnum(1)) + else if (x == SEXP_ONE) res = sexp_make_flonum(ctx, 1); /* 1.0 */ else if (sexp_flonump(x)) res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); @@ -2187,6 +2185,21 @@ static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { #include "opt/plan9.c" #endif +/************************** optimizations *****************************/ + +static sexp sexp_apply_optimization (sexp ctx, sexp proc, sexp ast) { + sexp res; + sexp_gc_var1(args); + if (sexp_opcodep(proc)) { + res = ((sexp_proc2)sexp_opcode_func(proc))(ctx, ast); + } else { + sexp_gc_preserve1(ctx, args); + res = sexp_apply(ctx, proc, args=sexp_list1(ctx, ast)); + sexp_gc_release1(ctx); + } + return res; +} + /*********************** standard environment *************************/ static struct sexp_struct core_forms[] = { @@ -2290,10 +2303,8 @@ sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { if (! sexp_fixnump(type)) return sexp_type_exception(ctx, "make-type-predicate: bad type", type); return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_TYPE_PREDICATE), - sexp_make_fixnum(OP_TYPEP), sexp_make_fixnum(1), - sexp_make_fixnum(0), sexp_make_fixnum(0), - sexp_make_fixnum(0), sexp_make_fixnum(0), type, - NULL, NULL); + sexp_make_fixnum(OP_TYPEP), SEXP_ONE, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); } sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { @@ -2302,9 +2313,8 @@ sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { return sexp_type_exception(ctx, "make-constructor: bad type", type); type_size = sexp_type_size_base(&(sexp_type_specs[sexp_unbox_fixnum(type)])); return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_CONSTRUCTOR), - sexp_make_fixnum(OP_MAKE), sexp_make_fixnum(0), - sexp_make_fixnum(0), sexp_make_fixnum(0), - sexp_make_fixnum(0), sexp_make_fixnum(0), type, + sexp_make_fixnum(OP_MAKE), SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, sexp_make_fixnum(type_size), NULL); } @@ -2316,8 +2326,7 @@ sexp sexp_make_accessor (sexp ctx, sexp name, sexp type, sexp index, sexp code) return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_ACCESSOR), code, sexp_make_fixnum(sexp_unbox_fixnum(code)==OP_SLOT_REF?1:2), - sexp_make_fixnum(0), type, sexp_make_fixnum(0), - sexp_make_fixnum(0), type, index, NULL); + SEXP_ZERO, type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); } sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { @@ -2376,6 +2385,7 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform)); sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp); + sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; sexp_gc_release4(ctx); return e; } @@ -2426,9 +2436,9 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { stack[--offset] = sexp_car(ls); stack[top] = sexp_make_fixnum(len); top++; - stack[top++] = sexp_make_fixnum(0); + stack[top++] = SEXP_ZERO; stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); - stack[top++] = sexp_make_fixnum(0); + stack[top++] = SEXP_ZERO; sexp_context_top(ctx) = top; res = sexp_vm(ctx, proc); if (! res) res = SEXP_VOID; @@ -2443,12 +2453,16 @@ sexp sexp_compile (sexp ctx, sexp x) { if (sexp_exceptionp(ast)) { res = ast; } else { +#if USE_SIMPLIFY + res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(res); res=sexp_cdr(res)) + ast = sexp_apply_optimization(ctx, sexp_cdar(res), ast); +#endif free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ generate(ctx, ast); res = finalize_bytecode(ctx); vec = sexp_make_vector(ctx, 0, SEXP_VOID); - res = sexp_make_procedure(ctx, sexp_make_fixnum(0), sexp_make_fixnum(0), - res, vec); + res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec); } sexp_gc_release3(ctx); return res; diff --git a/include/chibi/config.h b/include/chibi/config.h index 61dd03b2..779847af 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -12,6 +12,9 @@ /* sexp_init_library(ctx, env) function provided. */ /* #define USE_DL 0 */ +/* uncomment this to disable a simplifying optimization pass */ +/* #define USE_SIMPLIFY 0 */ + /* uncomment this to disable dynamic type definitions */ /* This enables register-simple-type and related */ /* opcodes for defining types, needed by the default */ @@ -161,6 +164,10 @@ #endif #endif +#ifndef USE_SIMPLIFY +#define USE_SIMPLIFY 1 +#endif + #ifndef USE_BOEHM #define USE_BOEHM 0 #endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 88ae48d9..9e58e0b9 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -455,6 +455,12 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_make_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) +#define SEXP_NEG_ONE sexp_make_fixnum(-1) +#define SEXP_ZERO sexp_make_fixnum(0) +#define SEXP_ONE sexp_make_fixnum(1) +#define SEXP_TWO sexp_make_fixnum(2) +#define SEXP_THREE sexp_make_fixnum(3) + #define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) @@ -576,6 +582,7 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #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_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) #define sexp_lambda_name(x) ((x)->value.lambda.name) #define sexp_lambda_params(x) ((x)->value.lambda.params) diff --git a/opt/debug.c b/opt/debug.c index 6d8b5de6..97d46d7b 100644 --- a/opt/debug.c +++ b/opt/debug.c @@ -28,7 +28,13 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { } else if (! sexp_bytecodep(bc)) { return sexp_type_exception(ctx, "not a procedure", bc); } + if (! sexp_oportp(out)) + return SEXP_VOID; ip = sexp_bytecode_data(bc); + sexp_write_string(ctx, "-------------- ", out); + if (sexp_truep(sexp_bytecode_name(bc))) + sexp_write(ctx, sexp_bytecode_name(bc), out); + sexp_write_char(ctx, '\n', out); loop: opcode = *ip++; if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { @@ -43,14 +49,16 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { case OP_CLOSURE_REF: case OP_JUMP: case OP_JUMP_UNLESS: + case OP_TYPEP: 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; + ip += sizeof(sexp); + break; case OP_SLOT_REF: case OP_SLOT_SET: case OP_MAKE: diff --git a/sexp.c b/sexp.c index 2432c264..f6d9d529 100644 --- a/sexp.c +++ b/sexp.c @@ -154,9 +154,8 @@ sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) { short type_size = sexp_sizeof_header + sizeof(sexp)*sexp_unbox_fixnum(slots); return sexp_register_type(ctx, name, sexp_make_fixnum(sexp_offsetof_slot0), - slots, slots, sexp_make_fixnum(0), sexp_make_fixnum(0), - sexp_make_fixnum(type_size), sexp_make_fixnum(0), - sexp_make_fixnum(0), NULL); + slots, slots, SEXP_ZERO, SEXP_ZERO, + sexp_make_fixnum(type_size), SEXP_ZERO, SEXP_ZERO, NULL); } sexp sexp_finalize_c_type (sexp ctx, sexp obj) { @@ -323,8 +322,7 @@ sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { } if (sexp_pairp(sexp_exception_source(exn))) { ls = sexp_exception_source(exn); - if (sexp_fixnump(sexp_cdr(ls)) - && (sexp_cdr(ls) >= sexp_make_fixnum(0))) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { sexp_write_string(ctx, " on line ", out); sexp_write(ctx, sexp_cdr(ls), out); } @@ -743,8 +741,8 @@ sexp sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, sexp parent, #if SEXP_BSD -#define sexp_stream_ctx(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(0)) -#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(1)) +#define sexp_stream_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO) +#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, SEXP_ONE) #define sexp_stream_size(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(2)) #define sexp_stream_pos(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(3)) @@ -801,7 +799,7 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) { sexp_stream_ctx(cookie) = ctx; sexp_stream_buf(cookie) = str; sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str)); - sexp_stream_pos(cookie) = sexp_make_fixnum(0); + sexp_stream_pos(cookie) = SEXP_ZERO; in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); res = sexp_make_input_port(ctx, in, SEXP_FALSE); sexp_port_cookie(res) = cookie; @@ -819,7 +817,7 @@ sexp sexp_make_output_string_port (sexp ctx) { 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_fixnum(0); + sexp_stream_pos(cookie) = SEXP_ZERO; out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); res = sexp_make_output_port(ctx, out, SEXP_FALSE); sexp_port_cookie(res) = cookie; @@ -832,7 +830,7 @@ sexp sexp_get_output_string (sexp ctx, sexp port) { fflush(sexp_port_stream(port)); return sexp_substring(ctx, sexp_stream_buf(cookie), - sexp_make_fixnum(0), + SEXP_ZERO, sexp_stream_pos(cookie)); } @@ -1530,7 +1528,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { sexp_bignum_sign(res) = -sexp_bignum_sign(res); else #endif - res = sexp_fx_mul(res, sexp_make_fixnum(-1)); + res = sexp_fx_mul(res, SEXP_NEG_ONE); } } else { sexp_push_char(ctx, c2, in); From 2baae2cc3b5ac520cb98bee7be9ebd1dcb89e119 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 17 Dec 2009 16:41:49 +0900 Subject: [PATCH 255/535] adding initial optimization pass this includes constant folding, dead-code elimination, and empty let reduction --- Makefile | 2 +- TODO | 3 +- eval.c | 10 ++++++ opt/simplify.c | 97 ++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 110 insertions(+), 2 deletions(-) create mode 100644 opt/simplify.c diff --git a/Makefile b/Makefile index a2ca3826..67ffa658 100644 --- a/Makefile +++ b/Makefile @@ -86,7 +86,7 @@ include/chibi/install.h: Makefile sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< -eval.o: eval.c opcodes.c opt/debug.c $(INCLUDES) include/chibi/eval.h Makefile +eval.o: eval.c opcodes.c opt/debug.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile diff --git a/TODO b/TODO index 57f7c861..4fd8e131 100644 --- a/TODO +++ b/TODO @@ -16,7 +16,8 @@ you, (chibi loop)). * compiler optimizations -** TODO constant folding +** DONE constant folding + - State "DONE" [2009-12-16 Wed 23:25] ** TODO simplification pass, dead-code elimination This is important in particular for the output generated by syntax-rules. diff --git a/eval.c b/eval.c index 6958b9ee..20e27da4 100644 --- a/eval.c +++ b/eval.c @@ -2200,6 +2200,10 @@ static sexp sexp_apply_optimization (sexp ctx, sexp proc, sexp ast) { return res; } +#if USE_SIMPLIFY +#include "opt/simplify.c" +#endif + /*********************** standard environment *************************/ static struct sexp_struct core_forms[] = { @@ -2386,6 +2390,12 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp); sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; +#if USE_SIMPLIFY + op = sexp_make_foreign(ctx, "simplify", 1, 0, + (sexp_proc1)sexp_simplify, SEXP_VOID); + tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); +#endif sexp_gc_release4(ctx); return e; } diff --git a/opt/simplify.c b/opt/simplify.c new file mode 100644 index 00000000..c2241939 --- /dev/null +++ b/opt/simplify.c @@ -0,0 +1,97 @@ + +#define simplify_it(it) it = simplify(ctx, it, substs, lambda) + +static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { + int check; + sexp ls1, ls2, ctx2; + sexp_gc_var3(res, substs, tmp); + sexp_gc_preserve3(ctx, res, substs, tmp); + res = ast; + substs = init_substs; + loop: + switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) { + case SEXP_PAIR: + for (ls1=res; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + simplify_it(sexp_car(ls1)); + if (sexp_opcodep(sexp_car(res))) { + if (sexp_opcode_class(sexp_car(res)) == OPC_ARITHMETIC) { + for (check=1, ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { + if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { + check = 0; + break; + } + } + if (check) { + ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx)); + generate(ctx2, res); + res = finalize_bytecode(ctx2); + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, tmp); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); + } + } + } else if (lambda && sexp_lambdap(sexp_car(res))) { /* let */ + if (sexp_nullp(sexp_cdr(res)) + && sexp_nullp(sexp_lambda_params(sexp_car(res))) + && sexp_nullp(sexp_lambda_defs(sexp_car(res)))) + res = sexp_lambda_body(sexp_car(res)); + } + break; + case SEXP_LAMBDA: + sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res); + break; + case SEXP_CND: + tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda); + if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) { + res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp)) + ? sexp_cnd_fail(res) : sexp_cnd_pass(res); + goto loop; + } else { + sexp_cnd_test(res) = tmp; + simplify_it(sexp_cnd_pass(res)); + simplify_it(sexp_cnd_fail(res)); + } + break; + case SEXP_REF: + tmp = sexp_ref_name(res); + for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) { + res = sexp_cddar(ls1); + break; + } + break; + case SEXP_SET: + simplify_it(sexp_set_value(res)); + break; + case SEXP_SEQ: + ls1 = NULL; + for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { + tmp = simplify(ctx, sexp_car(ls2), substs, lambda); + if (sexp_pairp(sexp_cdr(ls2)) + && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) + || sexp_lambdap(tmp))) { + if (ls1) + sexp_cdr(ls1) = sexp_cdr(ls2); + else + sexp_seq_ls(res) = sexp_cdr(ls2); + } else { + sexp_car(ls2) = tmp; + ls1 = ls2; + } + } + if (sexp_pairp(sexp_seq_ls(res)) && sexp_nullp(sexp_cdr(sexp_seq_ls(res)))) + res = sexp_car(sexp_seq_ls(res)); + break; + case SEXP_SYMBOL: + fprintf(stderr, "WARNING: raw symbol\n"); + break; + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_simplify (sexp ctx, sexp ast) { + return simplify(ctx, ast, SEXP_NULL, NULL); +} + From 8785e858100f7a0e66caf169fbf471f936494743 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 17 Dec 2009 19:02:16 +0900 Subject: [PATCH 256/535] fixing arity of arithmetic comparators --- opcodes.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/opcodes.c b/opcodes.c index 79b97313..c18f7230 100644 --- a/opcodes.c +++ b/opcodes.c @@ -39,11 +39,11 @@ _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_ARITHMETIC_CMP, OP_LT, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 2, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 2, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 2, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_EQN, 2, 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), From 6b3b13dec63dbf85bbe6eb074d990c0596337485 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 18 Dec 2009 11:37:37 +0900 Subject: [PATCH 257/535] adding cases in simplify to optimize let bindings over literals and non-mutated identifiers. helps a lot with the default syntax-rules constructions - in particular reduces the number of bytecode allocations for (chibi match) from 2397 to 1872. --- Makefile | 2 +- config.scm | 3 +- eval.c | 2 - opt/simplify.c | 113 ++++++++++++++++++++++++++++--------------- tests/r5rs-tests.scm | 6 ++- 5 files changed, 82 insertions(+), 44 deletions(-) diff --git a/Makefile b/Makefile index 67ffa658..e6c1d79a 100644 --- a/Makefile +++ b/Makefile @@ -56,7 +56,7 @@ all: chibi-scheme$(EXE) libs COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ lib/chibi/ast$(SO) lib/chibi/net$(SO) \ - lib/chibi/posix$(SO) # lib/chibi/heap-stats$(SO) + lib/chibi/posix$(SO) lib/chibi/heap-stats$(SO) libs: $(COMPILED_LIBS) diff --git a/config.scm b/config.scm index e670845d..141e95f3 100644 --- a/config.scm +++ b/config.scm @@ -187,7 +187,8 @@ 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 - error file-exists? string-concatenate + *current-input-port* *current-output-port* *current-error-port* + error current-error-port file-exists? string-concatenate open-input-string open-output-string get-output-string sc-macro-transformer rsc-macro-transformer er-macro-transformer identifier? identifier=? identifier->symbol make-syntactic-closure diff --git a/eval.c b/eval.c index 20e27da4..8d5dc45a 100644 --- a/eval.c +++ b/eval.c @@ -2463,11 +2463,9 @@ sexp sexp_compile (sexp ctx, sexp x) { if (sexp_exceptionp(ast)) { res = ast; } else { -#if USE_SIMPLIFY res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); for ( ; sexp_pairp(res); res=sexp_cdr(res)) ast = sexp_apply_optimization(ctx, sexp_cdar(res), ast); -#endif free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ generate(ctx, ast); res = finalize_bytecode(ctx); diff --git a/opt/simplify.c b/opt/simplify.c index c2241939..4092f791 100644 --- a/opt/simplify.c +++ b/opt/simplify.c @@ -1,21 +1,29 @@ -#define simplify_it(it) it = simplify(ctx, it, substs, lambda) +#define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda)) static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { int check; - sexp ls1, ls2, ctx2; - sexp_gc_var3(res, substs, tmp); - sexp_gc_preserve3(ctx, res, substs, tmp); - res = ast; + sexp ls1, ls2, p1, p2, sv, ctx2; + sexp_gc_var4(res, substs, tmp, app); + sexp_gc_preserve4(ctx, res, substs, tmp, app); + res = ast; /* return the ast as-is by default */ substs = init_substs; + loop: switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) { + case SEXP_PAIR: - for (ls1=res; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) - simplify_it(sexp_car(ls1)); - if (sexp_opcodep(sexp_car(res))) { - if (sexp_opcode_class(sexp_car(res)) == OPC_ARITHMETIC) { - for (check=1, ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { + /* don't simplify the operator if it's a lambda because we + simplify that as a special case below, with the appropriate + substs list */ + app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res) + : (tmp=simplify(ctx, sexp_car(res), substs, lambda))); + for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); + app = sexp_nreverse(ctx, app); + if (sexp_opcodep(sexp_car(app))) { + if (sexp_opcode_class(sexp_car(app)) == OPC_ARITHMETIC) { + for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { check = 0; break; @@ -23,24 +31,54 @@ static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { } if (check) { ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx)); - generate(ctx2, res); - res = finalize_bytecode(ctx2); - tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); - res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, tmp); - if (! sexp_exceptionp(res)) - res = sexp_apply(ctx2, res, SEXP_NULL); + generate(ctx2, app); + app = finalize_bytecode(ctx2); + if (! sexp_exceptionp(app)) { + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + app = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, app, tmp); + if (! sexp_exceptionp(app)) + app = sexp_apply(ctx2, app, SEXP_NULL); + } } } - } else if (lambda && sexp_lambdap(sexp_car(res))) { /* let */ - if (sexp_nullp(sexp_cdr(res)) - && sexp_nullp(sexp_lambda_params(sexp_car(res))) - && sexp_nullp(sexp_lambda_defs(sexp_car(res)))) - res = sexp_lambda_body(sexp_car(res)); + } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */ + p1 = NULL; + p2 = sexp_lambda_params(sexp_car(app)); + ls1 = app; + ls2 = sexp_cdr(app); + sv = sexp_lambda_sv(sexp_car(app)); + for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) { + if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv)) + && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2)) + || (sexp_refp(sexp_car(ls2)) + && sexp_lambdap(sexp_ref_loc(sexp_car(ls2)))))) { + tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2)); + tmp = sexp_cons(ctx, sexp_car(p2), tmp); + sexp_push(ctx, substs, tmp); + sexp_cdr(ls1) = sexp_cdr(ls2); + if (p1) + sexp_cdr(p1) = sexp_cdr(p2); + else + sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2); + } else { + p1 = p2; + ls1 = ls2; + } + } + sexp_lambda_body(sexp_car(app)) + = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app)); + if (sexp_nullp(sexp_cdr(app)) + && sexp_nullp(sexp_lambda_params(sexp_car(app))) + && sexp_nullp(sexp_lambda_defs(sexp_car(app)))) + app = sexp_lambda_body(sexp_car(app)); } + res = app; break; + case SEXP_LAMBDA: sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res); break; + case SEXP_CND: tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda); if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) { @@ -53,6 +91,7 @@ static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { simplify_it(sexp_cnd_fail(res)); } break; + case SEXP_REF: tmp = sexp_ref_name(res); for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) @@ -61,33 +100,29 @@ static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { break; } break; + case SEXP_SET: simplify_it(sexp_set_value(res)); break; + case SEXP_SEQ: - ls1 = NULL; + app = SEXP_NULL; for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { tmp = simplify(ctx, sexp_car(ls2), substs, lambda); - if (sexp_pairp(sexp_cdr(ls2)) - && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) - || sexp_lambdap(tmp))) { - if (ls1) - sexp_cdr(ls1) = sexp_cdr(ls2); - else - sexp_seq_ls(res) = sexp_cdr(ls2); - } else { - sexp_car(ls2) = tmp; - ls1 = ls2; - } + if (! (sexp_pairp(sexp_cdr(ls2)) + && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) + || sexp_lambdap(tmp)))) + sexp_push(ctx, app, tmp); } - if (sexp_pairp(sexp_seq_ls(res)) && sexp_nullp(sexp_cdr(sexp_seq_ls(res)))) - res = sexp_car(sexp_seq_ls(res)); - break; - case SEXP_SYMBOL: - fprintf(stderr, "WARNING: raw symbol\n"); + if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app))) + res = sexp_car(app); + else + sexp_seq_ls(res) = sexp_nreverse(ctx, app); break; + } - sexp_gc_release3(ctx); + + sexp_gc_release4(ctx); return res; } diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 5ad8b5b7..555caf85 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -7,7 +7,11 @@ ((test expect expr) (begin (set! *tests-run* (+ *tests-run* 1)) - (let ((str (call-with-output-string (lambda (out) (display 'expr out)))) + (let ((str (call-with-output-string + (lambda (out) + (write *tests-run*) + (display ". ") + (display 'expr out)))) (res expr)) (display str) (write-char #\space) From 2583b692d596fc62d4de1e6fbc9569bc26bebff4 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 18 Dec 2009 14:16:10 +0900 Subject: [PATCH 258/535] disasm now recursively prints lets and local lambdas --- TODO | 6 ++++-- opt/debug.c | 44 ++++++++++++++++++++++++++++++++++++-------- tests/r5rs-tests.scm | 12 ++++++++++++ 3 files changed, 52 insertions(+), 10 deletions(-) diff --git a/TODO b/TODO index 4fd8e131..0468bee3 100644 --- a/TODO +++ b/TODO @@ -18,7 +18,8 @@ * compiler optimizations ** DONE constant folding - State "DONE" [2009-12-16 Wed 23:25] -** TODO simplification pass, dead-code elimination +** DONE simplification pass, dead-code elimination + - State "DONE" [2009-12-18 Fri 14:14] This is important in particular for the output generated by syntax-rules. ** TODO lambda lift @@ -60,7 +61,8 @@ - State "DONE" [2009-07-07 Tue 14:42] ** TODO unicode ** TODO threads -** TODO recursive disasm +** DONE recursive disasm + - State "DONE" [2009-12-18 Fri 14:15] * FFI ** DONE libdl support diff --git a/opt/debug.c b/opt/debug.c index 97d46d7b..4d0631f2 100644 --- a/opt/debug.c +++ b/opt/debug.c @@ -2,6 +2,9 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ +#define SEXP_DISASM_MAX_DEPTH 8 +#define SEXP_DISASM_PAD_WIDTH 4 + static const char* reverse_opcode_names[] = {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", @@ -18,8 +21,10 @@ static const char* reverse_opcode_names[] = "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", }; -static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { - unsigned char *ip, opcode; +static sexp disasm (sexp ctx, sexp bc, sexp out, int depth) { + sexp tmp; + unsigned char *ip, opcode, i; + if (sexp_procedurep(bc)) { bc = sexp_procedure_code(bc); } else if (sexp_opcodep(bc)) { @@ -30,12 +35,21 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { } if (! sexp_oportp(out)) return SEXP_VOID; - ip = sexp_bytecode_data(bc); + + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); sexp_write_string(ctx, "-------------- ", out); - if (sexp_truep(sexp_bytecode_name(bc))) + if (sexp_truep(sexp_bytecode_name(bc))) { sexp_write(ctx, sexp_bytecode_name(bc), out); - sexp_write_char(ctx, '\n', out); + sexp_write_char(ctx, ' ', out); + } + sexp_printf(ctx, out, "%p\n", bc); + + ip = sexp_bytecode_data(bc); + loop: + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); opcode = *ip++; if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { sexp_printf(ctx, out, " %s ", reverse_opcode_names[opcode]); @@ -54,11 +68,12 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { case OP_FCALL1: case OP_FCALL2: case OP_FCALL3: + case OP_FCALL4: + case OP_FCALL5: + case OP_FCALL6: sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); ip += sizeof(sexp); break; - ip += sizeof(sexp); - break; case OP_SLOT_REF: case OP_SLOT_SET: case OP_MAKE: @@ -69,16 +84,29 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { case OP_TAIL_CALL: case OP_CALL: case OP_PUSH: - sexp_write(ctx, ((sexp*)ip)[0], out); + tmp = ((sexp*)ip)[0]; + if (((opcode == OP_GLOBAL_REF) || (opcode == OP_GLOBAL_KNOWN_REF)) + && sexp_pairp(tmp)) + tmp = sexp_car(tmp); + else if ((opcode == OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) + sexp_write_char(ctx, '\'', out); + sexp_write(ctx, tmp, out); ip += sizeof(sexp); break; } sexp_write_char(ctx, '\n', out); + if ((opcode == OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) + && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) + disasm(ctx, tmp, out, depth+1); if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) goto loop; return SEXP_VOID; } +static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { + return disasm(ctx, bc, out, 0); +} + #if USE_DEBUG_VM static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { int i; diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 555caf85..1a2091d6 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -424,6 +424,18 @@ (define internal-def 'ok)) internal-def)) +(test '(2 1) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y)))))) + +(test '(2 2) + ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y)))))) + +(test '(1 2) + ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y)))))) + +(test '(2 3) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test-report) From 9c7707088802063b87b5070658105fa6c757e9b4 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 18 Dec 2009 14:43:28 +0900 Subject: [PATCH 259/535] fixing srfi-27 support for systems with posix rand_r but not random_r --- lib/srfi/27/rand.c | 65 +++++++++++++++++++++++++++++++++++++++------- 1 file changed, 55 insertions(+), 10 deletions(-) diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index 4ae30f50..ece6eb53 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -10,16 +10,26 @@ #define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id) -#define sexp_random_state(x) (sexp_slot_ref((x), 0)) -#define sexp_random_data(x) ((struct random_data*)(&sexp_slot_ref((x), 1))) - #define sexp_random_init(x, seed) \ initstate_r(seed, \ sexp_string_data(sexp_random_state(x)), \ SEXP_RANDOM_STATE_SIZE, \ sexp_random_data(x)) -#define sexp_sizeof_random (sexp_sizeof_header + sizeof(struct random_data) + sizeof(sexp)) +#if SEXP_BSD +typedef unsigned int sexp_random_t; +#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs))) +#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n) +#else +typedef struct random_data sexp_random_t; +#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst) +#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs)) +#endif + +#define sexp_random_state(x) (sexp_slot_ref((x), 0)) +#define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1))) + +#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp)) static sexp_uint_t rs_type_id; static sexp default_random_source; @@ -30,7 +40,7 @@ static sexp sexp_rs_random_integer (sexp ctx, sexp rs, sexp bound) { if (! sexp_random_source_p(rs)) res = sexp_type_exception(ctx, "not a random-source", rs); if (sexp_fixnump(bound)) { - random_r(sexp_random_data(rs), &n); + sexp_call_random(rs, n); res = sexp_make_fixnum(n % sexp_unbox_fixnum(bound)); #if USE_BIGNUMS } else if (sexp_bignump(bound)) { @@ -39,10 +49,10 @@ static sexp sexp_rs_random_integer (sexp ctx, sexp rs, sexp bound) { res = sexp_make_bignum(ctx, hi); data = (int32_t*) sexp_bignum_data(res); for (i=0; i Date: Fri, 18 Dec 2009 15:58:23 +0900 Subject: [PATCH 260/535] Renaming all USE_ settings and all OP_, OPC_ and CORE_ enums to have an SEXP_ prefix. Now all values from the headers are prefixed with either sexp_ or SEXP_, important for ease of embedding. "make USE_BOEHM=1" still works as an alias for "make SEXP_USE_BOEHM=1". Sorry if this patch breaks your code, it had to be done sooner or later. --- Makefile | 49 +++-- eval.c | 398 +++++++++++++++++++++-------------------- gc.c | 14 +- include/chibi/config.h | 162 +++++++++-------- include/chibi/eval.h | 190 ++++++++++---------- include/chibi/sexp.h | 32 ++-- lib/chibi/posix.module | 4 +- lib/chibi/posix.stub | 6 +- lib/srfi/27/rand.c | 4 +- lib/srfi/33/bit.c | 26 +-- lib/srfi/69/hash.c | 2 +- main.c | 6 +- mkfile | 3 +- opcodes.c | 136 +++++++------- opt/debug.c | 52 +++--- opt/plan9.c | 20 +-- opt/simplify.c | 2 +- sexp.c | 80 ++++----- tools/genstubs.scm | 2 + 19 files changed, 607 insertions(+), 581 deletions(-) diff --git a/Makefile b/Makefile index e6c1d79a..87ed11d0 100644 --- a/Makefile +++ b/Makefile @@ -3,6 +3,8 @@ .PHONY: all libs doc dist clean cleaner test install uninstall .PRECIOUS: %.c +# install configuration + CC ?= cc PREFIX ?= /usr/local BINDIR ?= $(PREFIX)/bin @@ -16,6 +18,9 @@ DESTDIR ?= GENSTUBS ?= ./tools/genstubs.scm +# system configuration - if not using GNU make, set PLATFORM and the +# following flags as necessary. + ifndef PLATFORM ifeq ($(shell uname),Darwin) PLATFORM=macosx @@ -34,23 +39,45 @@ ifeq ($(PLATFORM),macosx) SO = .dylib EXE = CLIBFLAGS = -dynamiclib -STATICFLAGS = -static-libgcc -DUSE_DL=0 +STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0 else ifeq ($(PLATFORM),mingw) SO = .dll EXE = .exe CC = gcc CLIBFLAGS = -shared -CPPFLAGS += -DUSE_STRING_STREAMS=0 -DBUILDING_DLL -DUSE_DEBUG=0 +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL -DSEXP_USE_DEBUG=0 LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a else SO = .so EXE = CLIBFLAGS = -fPIC -shared -STATICFLAGS = -static -DUSE_DL=0 +STATICFLAGS = -static -DSEXP_USE_DL=0 endif endif +ifeq ($(USE_BOEHM),1) +SEXP_USE_BOEHM = 1 +endif + +ifeq ($(SEXP_USE_BOEHM),1) +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DSEXP_USE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude +endif + +ifeq ($(SEXP_USE_DL),0) +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS) +else +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -ldl -lm +XCFLAGS := -Wall -g3 $(CFLAGS) +endif + +######################################################################## + all: chibi-scheme$(EXE) libs COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ @@ -60,22 +87,6 @@ COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ libs: $(COMPILED_LIBS) -ifeq ($(USE_BOEHM),1) -GCLDFLAGS := -lgc -XCPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1 -else -GCLDFLAGS := -XCPPFLAGS := $(CPPFLAGS) -Iinclude -endif - -ifeq ($(USE_DL),0) -XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm -XCFLAGS := -Wall -DUSE_DL=0 -g3 $(CFLAGS) -else -XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -ldl -lm -XCFLAGS := -Wall -g3 $(CFLAGS) -endif - INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h include/chibi/install.h: Makefile diff --git a/eval.c b/eval.c index 8d5dc45a..883d7d6d 100644 --- a/eval.c +++ b/eval.c @@ -8,7 +8,7 @@ static int scheme_initialized_p = 0; -#if USE_DEBUG +#if SEXP_USE_DEBUG #include "opt/debug.c" #else #define print_stack(...) @@ -181,7 +181,7 @@ static void emit_word (sexp ctx, sexp_uint_t val) { } static void emit_push (sexp ctx, sexp obj) { - emit(ctx, OP_PUSH); + emit(ctx, SEXP_OP_PUSH); emit_word(ctx, (sexp_uint_t)obj); if (sexp_pointerp(obj) && ! sexp_symbolp(obj)) sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); @@ -189,7 +189,7 @@ static void emit_push (sexp ctx, sexp obj) { static sexp finalize_bytecode (sexp ctx) { sexp bc; - emit(ctx, OP_RET); + emit(ctx, SEXP_OP_RET); shrink_bcode(ctx, sexp_context_pos(ctx)); bc = sexp_context_bc(ctx); if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */ @@ -281,10 +281,10 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_gc_var2(bc, vec); ctx = sexp_make_child_context(ctx, NULL); sexp_gc_preserve2(ctx, bc, vec); - emit(ctx, OP_RESUMECC); + emit(ctx, SEXP_OP_RESUMECC); sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); ctx = sexp_make_child_context(ctx, NULL); - emit(ctx, OP_DONE); + emit(ctx, SEXP_OP_DONE); bc = finalize_bytecode(ctx); vec = sexp_make_vector(ctx, 0, SEXP_VOID); sexp_global(ctx, SEXP_G_FINAL_RESUMER) @@ -658,31 +658,31 @@ static sexp analyze (sexp ctx, sexp object) { op = sexp_cdr(cell); if (sexp_corep(op)) { switch (sexp_core_code(op)) { - case CORE_DEFINE: + case SEXP_CORE_DEFINE: res = analyze_define(ctx, x); break; - case CORE_SET: + case SEXP_CORE_SET: res = analyze_set(ctx, x); break; - case CORE_LAMBDA: + case SEXP_CORE_LAMBDA: res = analyze_lambda(ctx, x); break; - case CORE_IF: + case SEXP_CORE_IF: res = analyze_if(ctx, x); break; - case CORE_BEGIN: + case SEXP_CORE_BEGIN: res = analyze_seq(ctx, sexp_cdr(x)); break; - case CORE_QUOTE: - case CORE_SYNTAX_QUOTE: + case SEXP_CORE_QUOTE: + case SEXP_CORE_SYNTAX_QUOTE: if (! (sexp_pairp(sexp_cdr(x)) && sexp_nullp(sexp_cddr(x)))) res = sexp_compile_error(ctx, "bad quote form", x); else res = sexp_make_lit(ctx, - (sexp_core_code(op) == CORE_QUOTE) ? + (sexp_core_code(op) == SEXP_CORE_QUOTE) ? sexp_strip_synclos(ctx, sexp_cadr(x)) : sexp_cadr(x)); break; - case CORE_DEFINE_SYNTAX: + case SEXP_CORE_DEFINE_SYNTAX: res = analyze_define_syntax(ctx, x); break; - case CORE_LET_SYNTAX: + case SEXP_CORE_LET_SYNTAX: res = analyze_let_syntax(ctx, x); break; - case CORE_LETREC_SYNTAX: + case SEXP_CORE_LETREC_SYNTAX: res = analyze_letrec_syntax(ctx, x); break; default: res = sexp_compile_error(ctx, "unknown core form", op); break; @@ -767,7 +767,7 @@ static void generate_seq (sexp ctx, sexp app) { 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); + emit(ctx, SEXP_OP_DROP); sexp_context_depth(ctx)--; } sexp_context_tailp(ctx) = tailp; @@ -779,11 +779,11 @@ static void generate_cnd (sexp ctx, sexp cnd) { sexp_context_tailp(ctx) = 0; generate(ctx, sexp_cnd_test(cnd)); sexp_context_tailp(ctx) = tailp; - emit(ctx, OP_JUMP_UNLESS); + emit(ctx, SEXP_OP_JUMP_UNLESS); sexp_context_depth(ctx)--; label1 = sexp_context_make_label(ctx); generate(ctx, sexp_cnd_pass(cnd)); - emit(ctx, OP_JUMP); + emit(ctx, SEXP_OP_JUMP); sexp_context_depth(ctx)--; label2 = sexp_context_make_label(ctx); sexp_context_patch_label(ctx, label1); @@ -797,7 +797,7 @@ static void generate_non_global_ref (sexp ctx, sexp name, sexp cell, sexp loc = sexp_cdr(cell); if (loc == lambda && sexp_lambdap(lambda)) { /* local ref */ - emit(ctx, OP_LOCAL_REF); + emit(ctx, SEXP_OP_LOCAL_REF); emit_word(ctx, sexp_param_index(lambda, name)); } else { /* closure ref */ @@ -805,11 +805,11 @@ static void generate_non_global_ref (sexp ctx, sexp name, sexp cell, if ((name == sexp_ref_name(sexp_car(fv))) && (loc == sexp_ref_loc(sexp_car(fv)))) break; - emit(ctx, OP_CLOSURE_REF); + emit(ctx, SEXP_OP_CLOSURE_REF); emit_word(ctx, i); } if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) - emit(ctx, OP_CDR); + emit(ctx, SEXP_OP_CDR); sexp_context_depth(ctx)++; } @@ -820,7 +820,7 @@ static void generate_ref (sexp ctx, sexp ref, int unboxp) { if (unboxp) { emit(ctx, (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) - ? OP_GLOBAL_REF : OP_GLOBAL_KNOWN_REF); + ? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF); emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref)); } else emit_push(ctx, sexp_ref_cell(ref)); @@ -841,16 +841,16 @@ static void generate_set (sexp ctx, sexp 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); + emit(ctx, SEXP_OP_SET_CDR); } else { lambda = sexp_ref_loc(ref); if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { /* stack or closure mutable vars are boxed */ generate_ref(ctx, ref, 0); - emit(ctx, OP_SET_CDR); + emit(ctx, SEXP_OP_SET_CDR); } else { /* internally defined variable */ - emit(ctx, OP_LOCAL_SET); + emit(ctx, SEXP_OP_LOCAL_SET); emit_word(ctx, sexp_param_index(lambda, sexp_ref_name(ref))); } } @@ -870,69 +870,69 @@ static void generate_opcode_app (sexp ctx, sexp app) { if ((num_args == sexp_opcode_num_args(op)) && sexp_opcode_variadic_p(op) && sexp_opcode_data(op) - && (sexp_opcode_class(op) != OPC_PARAMETER)) { + && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { emit_push(ctx, sexp_opcode_data(op)); if (sexp_opcode_opt_param_p(op)) - emit(ctx, OP_CDR); + emit(ctx, SEXP_OP_CDR); sexp_context_depth(ctx)++; num_args++; } /* push the arguments onto the stack in reverse order */ ls = ((sexp_opcode_inverse(op) - && (sexp_opcode_class(op) != OPC_ARITHMETIC_INV)) + && (sexp_opcode_class(op) != SEXP_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: + case SEXP_OPC_ARITHMETIC: if (num_args > 1) emit(ctx, sexp_opcode_code(op)); break; - case OPC_ARITHMETIC_INV: + case SEXP_OPC_ARITHMETIC_INV: emit(ctx, (num_args==1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); break; - case OPC_ARITHMETIC_CMP: + case SEXP_OPC_ARITHMETIC_CMP: if (num_args > 2) { - emit(ctx, OP_STACK_REF); + emit(ctx, SEXP_OP_STACK_REF); emit_word(ctx, 2); - emit(ctx, OP_STACK_REF); + emit(ctx, SEXP_OP_STACK_REF); emit_word(ctx, 2); emit(ctx, sexp_opcode_code(op)); - emit(ctx, OP_AND); + emit(ctx, SEXP_OP_AND); for (i=num_args-2; i>0; i--) { - emit(ctx, OP_STACK_REF); + emit(ctx, SEXP_OP_STACK_REF); emit_word(ctx, 3); - emit(ctx, OP_STACK_REF); + emit(ctx, SEXP_OP_STACK_REF); emit_word(ctx, 3); emit(ctx, sexp_opcode_code(op)); - emit(ctx, OP_AND); - emit(ctx, OP_AND); + emit(ctx, SEXP_OP_AND); + emit(ctx, SEXP_OP_AND); } } else emit(ctx, sexp_opcode_code(op)); break; - case OPC_FOREIGN: + case SEXP_OPC_FOREIGN: emit(ctx, sexp_opcode_code(op)); emit_word(ctx, (sexp_uint_t)op); break; - case OPC_TYPE_PREDICATE: - case OPC_ACCESSOR: - case OPC_CONSTRUCTOR: + case SEXP_OPC_TYPE_PREDICATE: + case SEXP_OPC_ACCESSOR: + case SEXP_OPC_CONSTRUCTOR: emit(ctx, sexp_opcode_code(op)); - if ((sexp_opcode_class(op) != OPC_CONSTRUCTOR) - || sexp_opcode_code(op) == OP_MAKE) { + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE) { if (sexp_opcode_data(op)) emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); if (sexp_opcode_data2(op)) emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); } break; - case OPC_PARAMETER: + case SEXP_OPC_PARAMETER: emit_push(ctx, sexp_opcode_data(op)); - emit(ctx, ((num_args == 0) ? OP_CDR : OP_SET_CDR)); + emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); break; default: emit(ctx, sexp_opcode_code(op)); @@ -940,8 +940,8 @@ static void generate_opcode_app (sexp ctx, sexp app) { /* emit optional folding of operator */ if ((num_args > 2) - && (sexp_opcode_class(op) == OPC_ARITHMETIC - || sexp_opcode_class(op) == OPC_ARITHMETIC_INV)) + && (sexp_opcode_class(op) == SEXP_OPC_ARITHMETIC + || sexp_opcode_class(op) == SEXP_OPC_ARITHMETIC_INV)) for (i=num_args-2; i>0; i--) emit(ctx, sexp_opcode_code(op)); @@ -964,7 +964,7 @@ static void generate_general_app (sexp ctx, sexp app) { generate(ctx, sexp_car(app)); /* maybe overwrite the current frame */ - emit(ctx, (tailp ? OP_TAIL_CALL : OP_CALL)); + emit(ctx, (tailp ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); sexp_context_tailp(ctx) = tailp; @@ -996,13 +996,13 @@ static void generate_lambda (sexp ctx, sexp lambda) { 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(ctx2, SEXP_OP_LOCAL_REF); emit_word(ctx2, k); emit_push(ctx2, sexp_car(ls)); - emit(ctx2, OP_CONS); - emit(ctx2, OP_LOCAL_SET); + emit(ctx2, SEXP_OP_CONS); + emit(ctx2, SEXP_OP_LOCAL_SET); emit_word(ctx2, k); - emit(ctx2, OP_DROP); + emit(ctx2, SEXP_OP_DROP); } } sexp_context_tailp(ctx2) = 1; @@ -1022,24 +1022,24 @@ static void generate_lambda (sexp ctx, sexp lambda) { /* push the closed vars */ emit_push(ctx, SEXP_VOID); emit_push(ctx, sexp_length(ctx, fv)); - emit(ctx, OP_MAKE_VECTOR); + emit(ctx, SEXP_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_fixnum(k)); - emit(ctx, OP_STACK_REF); + emit(ctx, SEXP_OP_STACK_REF); emit_word(ctx, 3); - emit(ctx, OP_VECTOR_SET); - emit(ctx, OP_DROP); + emit(ctx, SEXP_OP_VECTOR_SET); + emit(ctx, SEXP_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); + emit(ctx, SEXP_OP_MAKE_PROCEDURE); } sexp_gc_release2(ctx); } @@ -1221,7 +1221,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { *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)); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS sexp_lsint_t prod; #endif sexp_gc_var3(self, tmp1, tmp2); @@ -1230,17 +1230,17 @@ sexp sexp_vm (sexp ctx, sexp proc) { self = proc; loop: -#if USE_DEBUG_VM +#if SEXP_USE_DEBUG_VM if (sexp_context_tracep(ctx)) { sexp_print_stack(ctx, stack, top, fp, SEXP_FALSE); - fprintf(stderr, "%s\n", (*ip<=OP_NUM_OPCODES) ? + fprintf(stderr, "%s\n", (*ip<=SEXP_OP_NUM_OPCODES) ? reverse_opcode_names[*ip] : "UNKNOWN"); } #endif switch (*ip++) { - case OP_NOOP: + case SEXP_OP_NOOP: break; - case OP_RAISE: + case SEXP_OP_RAISE: call_error_handler: tmp1 = sexp_env_global_ref(env, sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL), SEXP_FALSE); if (! sexp_procedurep(tmp1)) goto end_loop; @@ -1255,7 +1255,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { cp = sexp_procedure_vars(self); fp = top-4; break; - case OP_RESUMECC: + case SEXP_OP_RESUMECC: tmp1 = stack[fp-1]; top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack); fp = sexp_unbox_fixnum(_ARG1); @@ -1267,7 +1267,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { top -= 4; _ARG1 = tmp1; break; - case OP_CALLCC: + case SEXP_OP_CALLCC: stack[top] = SEXP_ONE; stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc)); stack[top+2] = self; @@ -1285,7 +1285,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { top++; ip -= sizeof(sexp); goto make_call; - case OP_APPLY1: + case SEXP_OP_APPLY1: tmp1 = _ARG1; tmp2 = _ARG2; i = sexp_unbox_fixnum(sexp_length(ctx, tmp2)); @@ -1295,7 +1295,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { top += i+1; ip -= sizeof(sexp); goto make_call; - case OP_TAIL_CALL: + case SEXP_OP_TAIL_CALL: i = sexp_unbox_fixnum(_WORD0); /* number of params */ tmp1 = _ARG1; /* procedure to call */ /* save frame info */ @@ -1312,8 +1312,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { top = fp+i-j+1; fp = sexp_unbox_fixnum(tmp2); goto make_call; - case OP_CALL: -#if USE_CHECK_STACK + case SEXP_OP_CALL: +#if SEXP_USE_CHECK_STACK if (top+16 >= SEXP_INIT_STACK_SIZE) { _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); goto end_loop; @@ -1369,97 +1369,97 @@ sexp sexp_vm (sexp ctx, sexp proc) { cp = sexp_procedure_vars(self); fp = top-4; break; - case OP_FCALL0: + case SEXP_OP_FCALL0: sexp_context_top(ctx) = top; _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx)); ip += sizeof(sexp); sexp_check_exception(); break; - case OP_FCALL1: + case SEXP_OP_FCALL1: sexp_context_top(ctx) = top; _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx, _ARG1); ip += sizeof(sexp); sexp_check_exception(); break; - case OP_FCALL2: + case SEXP_OP_FCALL2: sexp_context_top(ctx) = top; _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2); top--; ip += sizeof(sexp); sexp_check_exception(); break; - case OP_FCALL3: + case SEXP_OP_FCALL3: sexp_context_top(ctx) = top; _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3); top -= 2; ip += sizeof(sexp); sexp_check_exception(); break; - case OP_FCALL4: + case SEXP_OP_FCALL4: sexp_context_top(ctx) = top; _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4); top -= 3; ip += sizeof(sexp); sexp_check_exception(); break; - case OP_FCALL5: + case SEXP_OP_FCALL5: sexp_context_top(ctx) = top; _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); top -= 4; ip += sizeof(sexp); sexp_check_exception(); break; - case OP_FCALL6: + case SEXP_OP_FCALL6: sexp_context_top(ctx) = top; _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); top -= 5; ip += sizeof(sexp); sexp_check_exception(); break; - case OP_JUMP_UNLESS: + case SEXP_OP_JUMP_UNLESS: if (stack[--top] == SEXP_FALSE) ip += _SWORD0; else ip += sizeof(sexp_sint_t); break; - case OP_JUMP: + case SEXP_OP_JUMP: ip += _SWORD0; break; - case OP_PUSH: + case SEXP_OP_PUSH: _PUSH(_WORD0); ip += sizeof(sexp); break; - case OP_DROP: + case SEXP_OP_DROP: top--; break; - case OP_GLOBAL_REF: + case SEXP_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: + case SEXP_OP_GLOBAL_KNOWN_REF: _PUSH(sexp_cdr(_WORD0)); ip += sizeof(sexp); break; - case OP_STACK_REF: /* `pick' in forth */ + case SEXP_OP_STACK_REF: /* `pick' in forth */ stack[top] = stack[top - _SWORD0]; ip += sizeof(sexp); top++; break; - case OP_LOCAL_REF: + case SEXP_OP_LOCAL_REF: stack[top] = stack[fp - 1 - _SWORD0]; ip += sizeof(sexp); top++; break; - case OP_LOCAL_SET: + case SEXP_OP_LOCAL_SET: stack[fp - 1 - _SWORD0] = _ARG1; _ARG1 = SEXP_VOID; ip += sizeof(sexp); break; - case OP_CLOSURE_REF: + case SEXP_OP_CLOSURE_REF: _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); ip += sizeof(sexp); break; - case OP_VECTOR_REF: + case SEXP_OP_VECTOR_REF: if (! sexp_vectorp(_ARG1)) sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); else if (! sexp_fixnump(_ARG2)) @@ -1470,7 +1470,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG2 = sexp_vector_ref(_ARG1, _ARG2); top--; break; - case OP_VECTOR_SET: + case SEXP_OP_VECTOR_SET: if (! sexp_vectorp(_ARG1)) sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1)); else if (sexp_immutablep(_ARG1)) @@ -1484,12 +1484,12 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG3 = SEXP_VOID; top-=2; break; - case OP_VECTOR_LENGTH: + case SEXP_OP_VECTOR_LENGTH: if (! sexp_vectorp(_ARG1)) sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); break; - case OP_STRING_REF: + case SEXP_OP_STRING_REF: if (! sexp_stringp(_ARG1)) sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); else if (! sexp_fixnump(_ARG2)) @@ -1500,7 +1500,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG2 = sexp_string_ref(_ARG1, _ARG2); top--; break; - case OP_STRING_SET: + case SEXP_OP_STRING_SET: if (! sexp_stringp(_ARG1)) sexp_raise("string-set!: not a string", sexp_list1(ctx, _ARG1)); else if (sexp_immutablep(_ARG1)) @@ -1516,52 +1516,52 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG3 = SEXP_VOID; top-=2; break; - case OP_STRING_LENGTH: + case SEXP_OP_STRING_LENGTH: if (! sexp_stringp(_ARG1)) sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); break; - case OP_MAKE_PROCEDURE: + case SEXP_OP_MAKE_PROCEDURE: sexp_context_top(ctx) = top; _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); top-=3; break; - case OP_MAKE_VECTOR: + case SEXP_OP_MAKE_VECTOR: sexp_context_top(ctx) = top; if (! sexp_fixnump(_ARG1)) sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); top--; break; - case OP_AND: + case SEXP_OP_AND: _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); top--; break; - case OP_EOFP: + case SEXP_OP_EOFP: _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; - case OP_NULLP: + case SEXP_OP_NULLP: _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; - case OP_FIXNUMP: + case SEXP_OP_FIXNUMP: _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; - case OP_SYMBOLP: + case SEXP_OP_SYMBOLP: _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; - case OP_CHARP: + case SEXP_OP_CHARP: _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; - case OP_TYPEP: + case SEXP_OP_TYPEP: _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); ip += sizeof(sexp); break; - case OP_MAKE: + case SEXP_OP_MAKE: _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); ip += sizeof(sexp)*2; break; - case OP_SLOT_REF: + case SEXP_OP_SLOT_REF: if (! sexp_check_tag(_ARG1, _UWORD0)) sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(_UWORD0), -1), _ARG1)); _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); ip += sizeof(sexp)*2; break; - case OP_SLOT_SET: + case SEXP_OP_SLOT_SET: if (! sexp_check_tag(_ARG1, _UWORD0)) sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(_UWORD0), -1), _ARG1)); else if (sexp_immutablep(_ARG1)) @@ -1571,15 +1571,15 @@ sexp sexp_vm (sexp ctx, sexp proc) { ip += sizeof(sexp)*2; top--; break; - case OP_CAR: + case SEXP_OP_CAR: if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_car(_ARG1); break; - case OP_CDR: + case SEXP_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: + case SEXP_OP_SET_CAR: if (! sexp_pairp(_ARG1)) sexp_raise("set-car!: not a pair", sexp_list1(ctx, _ARG1)); else if (sexp_immutablep(_ARG1)) @@ -1588,7 +1588,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG2 = SEXP_VOID; top--; break; - case OP_SET_CDR: + case SEXP_OP_SET_CDR: if (! sexp_pairp(_ARG1)) sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _ARG1)); else if (sexp_immutablep(_ARG1)) @@ -1597,13 +1597,13 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG2 = SEXP_VOID; top--; break; - case OP_CONS: + case SEXP_OP_CONS: sexp_context_top(ctx) = top; _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); top--; break; - case OP_ADD: -#if USE_BIGNUMS + case SEXP_OP_ADD: +#if SEXP_USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); @@ -1617,7 +1617,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { #else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) _ARG2 = sexp_fx_add(_ARG1, _ARG2); -#if USE_FLONUMS +#if SEXP_USE_FLONUMS else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2); else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) @@ -1629,8 +1629,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { #endif top--; break; - case OP_SUB: -#if USE_BIGNUMS + case SEXP_OP_SUB: +#if SEXP_USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); @@ -1644,7 +1644,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { #else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) _ARG2 = sexp_fx_sub(_ARG1, _ARG2); -#if USE_FLONUMS +#if SEXP_USE_FLONUMS else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2); else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) @@ -1656,8 +1656,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { #endif top--; break; - case OP_MUL: -#if USE_BIGNUMS + case SEXP_OP_MUL: +#if SEXP_USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); @@ -1671,7 +1671,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { #else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) _ARG2 = sexp_fx_mul(_ARG1, _ARG2); -#if USE_FLONUMS +#if SEXP_USE_FLONUMS else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2); else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) @@ -1683,16 +1683,16 @@ sexp sexp_vm (sexp ctx, sexp proc) { #endif top--; break; - case OP_DIV: + case SEXP_OP_DIV: if (_ARG2 == SEXP_ZERO) { -#if USE_FLONUMS +#if SEXP_USE_FLONUMS if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); else #endif sexp_raise("divide by zero", SEXP_NULL); } else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { -#if USE_FLONUMS +#if SEXP_USE_FLONUMS _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); _ARG2 = sexp_fixnum_to_flonum(ctx, _ARG2); _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); @@ -1702,11 +1702,11 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG2 = sexp_fx_div(_ARG1, _ARG2); #endif } -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS else _ARG2 = sexp_div(ctx, _ARG1, _ARG2); #else -#if USE_FLONUMS +#if SEXP_USE_FLONUMS else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) @@ -1718,14 +1718,14 @@ sexp sexp_vm (sexp ctx, sexp proc) { #endif top--; break; - case OP_QUOTIENT: + case SEXP_OP_QUOTIENT: if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { if (_ARG2 == SEXP_ZERO) sexp_raise("divide by zero", SEXP_NULL); _ARG2 = sexp_fx_div(_ARG1, _ARG2); top--; } -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS else { _ARG2 = sexp_quotient(ctx, _ARG1, _ARG2); top--; @@ -1734,7 +1734,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); #endif break; - case OP_REMAINDER: + case SEXP_OP_REMAINDER: if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { if (_ARG2 == SEXP_ZERO) sexp_raise("divide by zero", SEXP_NULL); @@ -1742,7 +1742,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; _ARG1 = tmp1; } -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS else { _ARG2 = sexp_remainder(ctx, _ARG1, _ARG2); top--; @@ -1751,34 +1751,34 @@ sexp sexp_vm (sexp ctx, sexp proc) { else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); #endif break; - case OP_NEGATIVE: + case SEXP_OP_NEGATIVE: if (sexp_fixnump(_ARG1)) _ARG1 = sexp_make_fixnum(-sexp_unbox_fixnum(_ARG1)); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS else if (sexp_bignump(_ARG1)) { _ARG1 = sexp_copy_bignum(ctx, NULL, _ARG1, 0); sexp_bignum_sign(_ARG1) = -sexp_bignum_sign(_ARG1); } #endif -#if USE_FLONUMS +#if SEXP_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: + case SEXP_OP_INVERSE: if (sexp_fixnump(_ARG1)) _ARG1 = sexp_make_flonum(ctx, 1/(double)sexp_unbox_fixnum(_ARG1)); -#if USE_FLONUMS +#if SEXP_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: + case SEXP_OP_LT: if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS _ARG2 = sexp_make_boolean(i); } else { tmp1 = sexp_compare(ctx, _ARG1, _ARG2); @@ -1786,7 +1786,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) < 0) : tmp1; } #else -#if USE_FLONUMS +#if SEXP_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_fixnump(_ARG2)) @@ -1799,10 +1799,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { #endif top--; break; - case OP_LE: + case SEXP_OP_LE: if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS _ARG2 = sexp_make_boolean(i); } else { tmp1 = sexp_compare(ctx, _ARG1, _ARG2); @@ -1810,7 +1810,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) <= 0) : tmp1; } #else -#if USE_FLONUMS +#if SEXP_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_fixnump(_ARG2)) @@ -1823,10 +1823,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { #endif top--; break; - case OP_EQN: + case SEXP_OP_EQN: if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { i = _ARG1 == _ARG2; -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS _ARG2 = sexp_make_boolean(i); } else { tmp1 = sexp_compare(ctx, _ARG1, _ARG2); @@ -1834,7 +1834,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) == 0) : tmp1; } #else -#if USE_FLONUMS +#if SEXP_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_fixnump(_ARG2)) @@ -1847,25 +1847,25 @@ sexp sexp_vm (sexp ctx, sexp proc) { #endif top--; break; - case OP_EQ: + case SEXP_OP_EQ: _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); top--; break; - case OP_FIX2FLO: + case SEXP_OP_FIX2FLO: if (sexp_fixnump(_ARG1)) _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS else if (sexp_bignump(_ARG1)) _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); #endif else if (! sexp_flonump(_ARG1)) sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); break; - case OP_FLO2FIX: + case SEXP_OP_FLO2FIX: if (sexp_flonump(_ARG1)) { if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); @@ -1877,47 +1877,47 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); } break; - case OP_CHAR2INT: + case SEXP_OP_CHAR2INT: if (! sexp_charp(_ARG1)) sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); break; - case OP_INT2CHAR: + case SEXP_OP_INT2CHAR: if (! sexp_fixnump(_ARG1)) sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); break; - case OP_CHAR_UPCASE: + case SEXP_OP_CHAR_UPCASE: if (! sexp_charp(_ARG1)) sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); break; - case OP_CHAR_DOWNCASE: + case SEXP_OP_CHAR_DOWNCASE: if (! sexp_charp(_ARG1)) sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); break; - case OP_WRITE_CHAR: + case SEXP_OP_WRITE_CHAR: if (! sexp_charp(_ARG1)) sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); _ARG2 = SEXP_VOID; top--; break; - case OP_NEWLINE: + case SEXP_OP_NEWLINE: sexp_newline(ctx, _ARG1); _ARG1 = SEXP_VOID; break; - case OP_READ_CHAR: + case SEXP_OP_READ_CHAR: i = sexp_read_char(ctx, _ARG1); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; - case OP_PEEK_CHAR: + case SEXP_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: + case SEXP_OP_RET: i = sexp_unbox_fixnum(stack[fp]); stack[fp-i] = _ARG1; top = fp-i+1; @@ -1927,7 +1927,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { cp = sexp_procedure_vars(self); fp = sexp_unbox_fixnum(stack[fp+3]); break; - case OP_DONE: + case SEXP_OP_DONE: goto end_loop; default: sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); @@ -1978,7 +1978,7 @@ static sexp sexp_close_port (sexp ctx, sexp port) { return sexp_user_exception(ctx, SEXP_FALSE, "port already closed", port); if (sexp_port_stream(port)) fclose(sexp_port_stream(port)); -#if ! USE_STRING_STREAMS +#if ! SEXP_USE_STRING_STREAMS if (sexp_port_buf(port) && sexp_oportp(port)) free(sexp_port_buf(port)); #endif @@ -2005,7 +2005,7 @@ void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) { } } -#if USE_DL +#if SEXP_USE_DL sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { sexp_proc2 init; void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); @@ -2021,7 +2021,7 @@ sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { #endif sexp sexp_load (sexp ctx, sexp source, sexp env) { -#if USE_DL +#if SEXP_USE_DL char *suffix; #endif sexp tmp, out=SEXP_FALSE; @@ -2030,7 +2030,7 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { return sexp_type_exception(ctx, "not a string", source); if (! sexp_envp(env)) return sexp_type_exception(ctx, "not an environment", env); -#if USE_DL +#if SEXP_USE_DL suffix = sexp_string_data(source) + sexp_string_length(source) - strlen(sexp_so_extension); if (strcmp(suffix, sexp_so_extension) == 0) { @@ -2062,19 +2062,19 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp_close_port(ctx, in); } sexp_gc_release4(ctx); -#if USE_DL +#if SEXP_USE_DL } #endif -#if USE_WARN_UNDEFS +#if SEXP_USE_WARN_UNDEFS if (sexp_oportp(out) && ! sexp_exceptionp(res)) sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out); #endif return res; } -#if USE_MATH +#if SEXP_USE_MATH -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS #define maybe_convert_bignum(z) \ else if (sexp_bignump(z)) d = sexp_bignum_to_double(z); #else @@ -2113,7 +2113,7 @@ define_math_op(sexp_ceiling, ceil) static sexp sexp_expt (sexp ctx, sexp x, sexp e) { long double f, x1, e1; sexp res; -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS if (sexp_bignump(e)) { /* bignum exponent needs special handling */ if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ @@ -2129,7 +2129,7 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { #endif if (sexp_fixnump(x)) x1 = sexp_unbox_fixnum(x); -#if USE_FLONUMS +#if SEXP_USE_FLONUMS else if (sexp_flonump(x)) x1 = sexp_flonum_value(x); #endif @@ -2137,27 +2137,27 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { return sexp_type_exception(ctx, "not a number", x); if (sexp_fixnump(e)) e1 = sexp_unbox_fixnum(e); -#if USE_FLONUMS +#if SEXP_USE_FLONUMS else if (sexp_flonump(e)) e1 = sexp_flonum_value(e); #endif else return sexp_type_exception(ctx, "not a number", e); f = pow(x1, e1); -#if USE_FLONUMS +#if SEXP_USE_FLONUMS if ((f > SEXP_MAX_FIXNUM) || (! sexp_fixnump(x)) || (! sexp_fixnump(e))) { #endif -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS if (sexp_fixnump(x) && sexp_fixnump(e)) res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); else #endif -#if USE_FLONUMS +#if SEXP_USE_FLONUMS res = sexp_make_flonum(ctx, f); } else #endif res = sexp_make_fixnum((sexp_sint_t)round(f)); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS } #endif return res; @@ -2200,23 +2200,23 @@ static sexp sexp_apply_optimization (sexp ctx, sexp proc, sexp ast) { return res; } -#if USE_SIMPLIFY +#if SEXP_USE_SIMPLIFY #include "opt/simplify.c" #endif /*********************** standard environment *************************/ 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_SYNTAX_QUOTE, "syntax-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"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE, "define"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SET, "set!"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LAMBDA, "lambda"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_IF, "if"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_BEGIN, "begin"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_QUOTE, "quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LET_SYNTAX, "let-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}}}, }; #include "opcodes.c" @@ -2241,10 +2241,10 @@ sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code, if (! sexp_stringp(name)) res = sexp_type_exception(ctx, "make-opcode: not a string", name); else if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0) - || (sexp_unbox_fixnum(op_class) >= OPC_NUM_OP_CLASSES)) + || (sexp_unbox_fixnum(op_class) >= SEXP_OPC_NUM_OP_CLASSES)) res = sexp_type_exception(ctx, "make-opcode: bad opcode class", op_class); else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) - || (sexp_unbox_fixnum(code) >= OP_NUM_OPCODES)) + || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) res = sexp_type_exception(ctx, "make-opcode: bad opcode", code); else if (! sexp_fixnump(num_args)) res = sexp_type_exception(ctx, "make-opcode: bad num_args", num_args); @@ -2275,8 +2275,8 @@ sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_make_fixnum(num_args)); } else { res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); - sexp_opcode_class(res) = OPC_FOREIGN; - sexp_opcode_code(res) = OP_FCALL1+num_args-1; + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; + sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1; if (flags & 1) num_args--; sexp_opcode_num_args(res) = num_args; sexp_opcode_flags(res) = flags; @@ -2301,13 +2301,13 @@ sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, return res; } -#if USE_TYPE_DEFS +#if SEXP_USE_TYPE_DEFS sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { if (! sexp_fixnump(type)) return sexp_type_exception(ctx, "make-type-predicate: bad type", type); - return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_TYPE_PREDICATE), - sexp_make_fixnum(OP_TYPEP), SEXP_ONE, SEXP_ZERO, + return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), + sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); } @@ -2316,8 +2316,8 @@ sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { if (! sexp_fixnump(type)) return sexp_type_exception(ctx, "make-constructor: bad type", type); type_size = sexp_type_size_base(&(sexp_type_specs[sexp_unbox_fixnum(type)])); - return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_CONSTRUCTOR), - sexp_make_fixnum(OP_MAKE), SEXP_ZERO, SEXP_ZERO, + return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), + sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, sexp_make_fixnum(type_size), NULL); } @@ -2328,16 +2328,16 @@ sexp sexp_make_accessor (sexp ctx, sexp name, sexp type, sexp index, sexp code) if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) return sexp_type_exception(ctx, "make-accessor: bad index", index); return - sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_ACCESSOR), code, - sexp_make_fixnum(sexp_unbox_fixnum(code)==OP_SLOT_REF?1:2), + sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_ACCESSOR), code, + sexp_make_fixnum(sexp_unbox_fixnum(code)==SEXP_OP_SLOT_REF?1:2), SEXP_ZERO, type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); } sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { - return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(OP_SLOT_REF)); + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(SEXP_OP_SLOT_REF)); } sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index) { - return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(OP_SLOT_SET)); + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(SEXP_OP_SLOT_SET)); } #endif @@ -2384,13 +2384,15 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); sexp_env_define(ctx, e, sexp_intern(ctx, "*module-directory*"), sexp_c_string(ctx, sexp_module_dir, -1)); +#if SEXP_USE_DL sexp_env_define(ctx, e, sexp_intern(ctx, "*shared-object-extension*"), sexp_c_string(ctx, sexp_so_extension, -1)); +#endif tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform)); sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp); sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; -#if USE_SIMPLIFY +#if SEXP_USE_SIMPLIFY op = sexp_make_foreign(ctx, "simplify", 1, 0, (sexp_proc1)sexp_simplify, SEXP_VOID); tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); @@ -2417,7 +2419,7 @@ sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) { value = sexp_env_global_ref(from, oldname, SEXP_UNDEF); if (value != SEXP_UNDEF) { sexp_env_define(ctx, to, newname, value); -#if USE_WARN_UNDEFS +#if SEXP_USE_WARN_UNDEFS } else if (sexp_oportp(out=sexp_current_error_port(ctx))) { sexp_write_string(ctx, "WARNING: importing undefined variable: ", out); sexp_write(ctx, oldname, out); diff --git a/gc.c b/gc.c index 4f4d43df..e53b83af 100644 --- a/gc.c +++ b/gc.c @@ -31,11 +31,11 @@ #define sexp_heap_align(n) sexp_align(n, 4) #endif -#if USE_GLOBAL_HEAP +#if SEXP_USE_GLOBAL_HEAP static sexp_heap sexp_global_heap; #endif -#if USE_DEBUG_GC +#if SEXP_USE_DEBUG_GC static sexp* stack_base; #endif @@ -76,7 +76,7 @@ void sexp_mark (sexp x) { } } -#if USE_DEBUG_GC +#if SEXP_USE_DEBUG_GC int stack_references_pointer_p (sexp ctx, sexp x) { sexp *p; for (p=(&x)+1; pstring */ /* will not be available by default. */ -/* #define USE_STRING_STREAMS 0 */ +/* #define SEXP_USE_STRING_STREAMS 0 */ /* uncomment this to disable automatic closing of ports */ /* If enabled, the underlying FILE* for file ports will be */ /* automatically closed when they're garbage collected. Doesn't */ /* apply to stdin/stdout/stderr. */ -/* #define USE_AUTOCLOSE_PORTS 0 */ +/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */ /* uncomment this to use the normal 1970 unix epoch */ /* By default chibi uses an datetime epoch starting at */ /* 2010/01/01 00:00:00 in order to be able to represent */ /* more common times as fixnums. */ -/* #define USE_2010_EPOCH 0 */ +/* #define SEXP_USE_2010_EPOCH 0 */ /* uncomment this to disable stack overflow checks */ /* By default stacks are fairly small, so it's good to leave */ /* this enabled. */ -/* #define USE_CHECK_STACK 0 */ +/* #define SEXP_USE_CHECK_STACK 0 */ /* uncomment this to disable debugging utilities */ /* By default there's a `disasm' procedure you can use to */ /* view the compiled VM instructions of a procedure. You can */ /* disable this if you don't need it. */ -/* #define USE_DEBUG 0 */ +/* #define SEXP_USE_DEBUG 0 */ -/* #define USE_DEBUG_VM 0 */ +/* #define SEXP_USE_DEBUG_VM 0 */ /* Experts only. */ /* For *very* verbose output on every VM operation. */ @@ -144,130 +150,131 @@ #define _GNU_SOURCE #endif -#ifndef USE_MODULES -#define USE_MODULES 1 +#ifndef SEXP_USE_MODULES +#define SEXP_USE_MODULES 1 #endif -#ifndef USE_TYPE_DEFS -#define USE_TYPE_DEFS 1 +#ifndef SEXP_USE_TYPE_DEFS +#define SEXP_USE_TYPE_DEFS 1 #endif #ifndef SEXP_MAXIMUM_TYPES #define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1) #endif -#ifndef USE_DL +#ifndef SEXP_USE_DL #ifdef PLAN9 -#define USE_DL 0 +#define SEXP_USE_DL 0 #else -#define USE_DL 1 +#define SEXP_USE_DL 1 #endif #endif -#ifndef USE_SIMPLIFY -#define USE_SIMPLIFY 1 +#ifndef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY 1 #endif -#ifndef USE_BOEHM -#define USE_BOEHM 0 +#ifndef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 0 #endif -#ifndef USE_MALLOC -#define USE_MALLOC 0 +#ifndef SEXP_USE_MALLOC +#define SEXP_USE_MALLOC 0 #endif -#ifndef USE_DEBUG_GC -#define USE_DEBUG_GC 0 +#ifndef SEXP_USE_DEBUG_GC +#define SEXP_USE_DEBUG_GC 0 #endif -#ifndef USE_GLOBAL_HEAP -#if USE_BOEHM || USE_MALLOC -#define USE_GLOBAL_HEAP 1 +#ifndef SEXP_USE_GLOBAL_HEAP +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_HEAP 1 #else -#define USE_GLOBAL_HEAP 0 +#define SEXP_USE_GLOBAL_HEAP 0 #endif #endif -#ifndef USE_GLOBAL_SYMBOLS -#if USE_BOEHM || USE_MALLOC -#define USE_GLOBAL_SYMBOLS 1 +#ifndef SEXP_USE_GLOBAL_SYMBOLS +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_SYMBOLS 1 #else -#define USE_GLOBAL_SYMBOLS 0 +#define SEXP_USE_GLOBAL_SYMBOLS 0 #endif #endif -#ifndef USE_FLONUMS -#define USE_FLONUMS 1 +#ifndef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS 1 #endif -#ifndef USE_INFINITIES -#if defined(PLAN9) || ! USE_FLONUMS -#define USE_INFINITIES 0 +#ifndef SEXP_USE_INFINITIES +#if defined(PLAN9) || ! SEXP_USE_FLONUMS +#define SEXP_USE_INFINITIES 0 #else -#define USE_INFINITIES 1 +#define SEXP_USE_INFINITIES 1 #endif #endif -#ifndef USE_IMMEDIATE_FLONUMS -#define USE_IMMEDIATE_FLONUMS 0 +#ifndef SEXP_USE_IMMEDIATE_FLONUMS +#define SEXP_USE_IMMEDIATE_FLONUMS 0 #endif -#ifndef USE_BIGNUMS -#define USE_BIGNUMS 1 +#ifndef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS 1 #endif -#ifndef USE_MATH -#define USE_MATH USE_FLONUMS +#ifndef SEXP_USE_MATH +#define SEXP_USE_MATH SEXP_USE_FLONUMS #endif -#ifndef USE_WARN_UNDEFS -#define USE_WARN_UNDEFS 1 +#ifndef SEXP_USE_WARN_UNDEFS +#define SEXP_USE_WARN_UNDEFS 1 #endif -#ifndef USE_HUFF_SYMS -#define USE_HUFF_SYMS 1 +#ifndef SEXP_USE_HUFF_SYMS +#define SEXP_USE_HUFF_SYMS 1 #endif -#ifndef USE_HASH_SYMS -#define USE_HASH_SYMS 1 +#ifndef SEXP_USE_HASH_SYMS +#define SEXP_USE_HASH_SYMS 1 #endif -#ifndef USE_DEBUG -#define USE_DEBUG 1 +#ifndef SEXP_USE_DEBUG +#define SEXP_USE_DEBUG 1 #endif -#ifndef USE_DEBUG_VM -#define USE_DEBUG_VM 0 +#ifndef SEXP_USE_DEBUG_VM +#define SEXP_USE_DEBUG_VM 0 #endif -#ifndef USE_STRING_STREAMS -#define USE_STRING_STREAMS 1 +#ifndef SEXP_USE_STRING_STREAMS +#define SEXP_USE_STRING_STREAMS 1 #endif -#ifndef USE_AUTOCLOSE_PORTS -#define USE_AUTOCLOSE_PORTS 1 +#ifndef SEXP_USE_AUTOCLOSE_PORTS +#define SEXP_USE_AUTOCLOSE_PORTS 1 #endif -#ifndef USE_2010_EPOCH -#define USE_2010_EPOCH 1 +#ifndef SEXP_USE_2010_EPOCH +#define SEXP_USE_2010_EPOCH 1 #endif #ifndef SEXP_EPOCH_OFFSET -#if USE_2010_EPOCH +#if SEXP_USE_2010_EPOCH #define SEXP_EPOCH_OFFSET 1262271600 #else #define SEXP_EPOCH_OFFSET 0 #endif #endif -#ifndef USE_CHECK_STACK -#define USE_CHECK_STACK 1 +#ifndef SEXP_USE_CHECK_STACK +#define SEXP_USE_CHECK_STACK 1 #endif #ifdef PLAN9 #define errx(code, msg, ...) exits(msg) #define exit_normally() exits(NULL) +#define exit_failure() exits("ERROR") #define strcasecmp cistrcmp #define strncasecmp cistrncmp #define round(x) floor((x)+0.5) @@ -276,6 +283,7 @@ #else #define exit_normally() exit(0) +#define exit_failure() exit(EXIT_FAILURE) #if HAVE_ERR_H #include #else diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 7009a29a..633771c3 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -16,106 +16,106 @@ #define sexp_config_file "config.scm" enum sexp_core_form_names { - CORE_DEFINE = 1, - CORE_SET, - CORE_LAMBDA, - CORE_IF, - CORE_BEGIN, - CORE_QUOTE, - CORE_SYNTAX_QUOTE, - CORE_DEFINE_SYNTAX, - CORE_LET_SYNTAX, - CORE_LETREC_SYNTAX + SEXP_CORE_DEFINE = 1, + SEXP_CORE_SET, + SEXP_CORE_LAMBDA, + SEXP_CORE_IF, + SEXP_CORE_BEGIN, + SEXP_CORE_QUOTE, + SEXP_CORE_SYNTAX_QUOTE, + SEXP_CORE_DEFINE_SYNTAX, + SEXP_CORE_LET_SYNTAX, + SEXP_CORE_LETREC_SYNTAX }; enum sexp_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, - OPC_NUM_OP_CLASSES + SEXP_OPC_GENERIC = 1, + SEXP_OPC_TYPE_PREDICATE, + SEXP_OPC_PREDICATE, + SEXP_OPC_ARITHMETIC, + SEXP_OPC_ARITHMETIC_INV, + SEXP_OPC_ARITHMETIC_CMP, + SEXP_OPC_IO, + SEXP_OPC_CONSTRUCTOR, + SEXP_OPC_ACCESSOR, + SEXP_OPC_PARAMETER, + SEXP_OPC_FOREIGN, + SEXP_OPC_NUM_OP_CLASSES }; enum sexp_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_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_FIXNUMP, - OP_SYMBOLP, - OP_CHARP, - OP_EOFP, - OP_TYPEP, - OP_MAKE, - OP_SLOT_REF, - OP_SLOT_SET, - 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_WRITE_CHAR, - OP_NEWLINE, - OP_READ_CHAR, - OP_PEEK_CHAR, - OP_RET, - OP_DONE, - OP_NUM_OPCODES + SEXP_OP_NOOP, + SEXP_OP_RAISE, + SEXP_OP_RESUMECC, + SEXP_OP_CALLCC, + SEXP_OP_APPLY1, + SEXP_OP_TAIL_CALL, + SEXP_OP_CALL, + SEXP_OP_FCALL0, + SEXP_OP_FCALL1, + SEXP_OP_FCALL2, + SEXP_OP_FCALL3, + SEXP_OP_FCALL4, + SEXP_OP_FCALL5, + SEXP_OP_FCALL6, + SEXP_OP_JUMP_UNLESS, + SEXP_OP_JUMP, + SEXP_OP_PUSH, + SEXP_OP_DROP, + SEXP_OP_GLOBAL_REF, + SEXP_OP_GLOBAL_KNOWN_REF, + SEXP_OP_STACK_REF, + SEXP_OP_LOCAL_REF, + SEXP_OP_LOCAL_SET, + SEXP_OP_CLOSURE_REF, + SEXP_OP_VECTOR_REF, + SEXP_OP_VECTOR_SET, + SEXP_OP_VECTOR_LENGTH, + SEXP_OP_STRING_REF, + SEXP_OP_STRING_SET, + SEXP_OP_STRING_LENGTH, + SEXP_OP_MAKE_PROCEDURE, + SEXP_OP_MAKE_VECTOR, + SEXP_OP_AND, + SEXP_OP_NULLP, + SEXP_OP_FIXNUMP, + SEXP_OP_SYMBOLP, + SEXP_OP_CHARP, + SEXP_OP_EOFP, + SEXP_OP_TYPEP, + SEXP_OP_MAKE, + SEXP_OP_SLOT_REF, + SEXP_OP_SLOT_SET, + SEXP_OP_CAR, + SEXP_OP_CDR, + SEXP_OP_SET_CAR, + SEXP_OP_SET_CDR, + SEXP_OP_CONS, + SEXP_OP_ADD, + SEXP_OP_SUB, + SEXP_OP_MUL, + SEXP_OP_DIV, + SEXP_OP_QUOTIENT, + SEXP_OP_REMAINDER, + SEXP_OP_NEGATIVE, + SEXP_OP_INVERSE, + SEXP_OP_LT, + SEXP_OP_LE, + SEXP_OP_EQN, + SEXP_OP_EQ, + SEXP_OP_FIX2FLO, + SEXP_OP_FLO2FIX, + SEXP_OP_CHAR2INT, + SEXP_OP_INT2CHAR, + SEXP_OP_CHAR_UPCASE, + SEXP_OP_CHAR_DOWNCASE, + SEXP_OP_WRITE_CHAR, + SEXP_OP_NEWLINE, + SEXP_OP_READ_CHAR, + SEXP_OP_PEEK_CHAR, + SEXP_OP_RET, + SEXP_OP_DONE, + SEXP_OP_NUM_OPCODES }; /**************************** prototypes ******************************/ @@ -142,7 +142,7 @@ SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_a #define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL) #define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d) -#if USE_TYPE_DEFS +#if SEXP_USE_TYPE_DEFS SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); SEXP_API sexp sexp_make_constructor (sexp ctx, sexp name, sexp type); SEXP_API sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 9e58e0b9..ba8c0bf9 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -11,7 +11,7 @@ #include #include -#if USE_DL +#if SEXP_USE_DL #include #endif @@ -56,7 +56,7 @@ typedef unsigned long size_t; #define SEXP_CHAR_TAG 6 #define SEXP_EXTENDED_TAG 14 -#if USE_HASH_SYMS +#if SEXP_USE_HASH_SYMS #define SEXP_SYMBOL_TABLE_SIZE 389 #else #define SEXP_SYMBOL_TABLE_SIZE 1 @@ -278,7 +278,7 @@ struct sexp_struct { #define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */ #define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */ -#if USE_BOEHM +#if SEXP_USE_BOEHM #define sexp_gc_var(ctx, x, y) sexp x; #define sexp_gc_preserve(ctx, x, y) @@ -307,7 +307,7 @@ struct sexp_struct { #define sexp_gc_release(ctx, x, y) (sexp_context_saves(ctx) = y.next) -#if USE_MALLOC +#if SEXP_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) @@ -358,7 +358,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS #include "chibi/bignum.h" #endif @@ -402,7 +402,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) #define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) -#if USE_IMMEDIATE_FLONUMS +#if SEXP_USE_IMMEDIATE_FLONUMS union sexp_flonum_conv { float flonum; sexp_uint_t bits; @@ -466,14 +466,14 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) -#if USE_FLONUMS +#if SEXP_USE_FLONUMS #define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x))) #define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x)) #else #define _or_integer_flonump(x) #endif -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) #else @@ -483,13 +483,13 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x)) -#if USE_FLONUMS +#if SEXP_USE_FLONUMS #define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) #else #define sexp_fixnum_to_flonum(ctx, x) (x) #endif -#if USE_FLONUMS || USE_BIGNUMS +#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS #define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0])) #define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0])) #else @@ -627,13 +627,13 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) -#if USE_GLOBAL_HEAP +#if SEXP_USE_GLOBAL_HEAP #define sexp_context_heap(ctx) sexp_global_heap #else #define sexp_context_heap(ctx) ((ctx)->value.context.heap) #endif -#if USE_GLOBAL_SYMBOLS +#if SEXP_USE_GLOBAL_SYMBOLS #define sexp_context_symbols(ctx) sexp_symbol_table #else #define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) @@ -676,7 +676,7 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); /****************************** utilities *****************************/ enum sexp_context_globals { -#if ! USE_GLOBAL_SYMBOLS +#if ! SEXP_USE_GLOBAL_SYMBOLS SEXP_G_SYMBOLS, #endif SEXP_G_OOM_ERROR, /* out of memory exception object */ @@ -724,7 +724,7 @@ enum sexp_context_globals { /***************************** general API ****************************/ -#if USE_STRING_STREAMS +#if SEXP_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))) @@ -795,13 +795,13 @@ 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(void); -#if USE_GLOBAL_HEAP +#if SEXP_USE_GLOBAL_HEAP #define sexp_destroy_context(ctx) #else SEXP_API void sexp_destroy_context(sexp ctx); #endif -#if USE_TYPE_DEFS +#if SEXP_USE_TYPE_DEFS SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots); SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); diff --git a/lib/chibi/posix.module b/lib/chibi/posix.module index 95502c94..7a05181a 100644 --- a/lib/chibi/posix.module +++ b/lib/chibi/posix.module @@ -3,7 +3,9 @@ (export open-input-fd open-output-fd delete-file link-file symbolic-link rename-file directory-files create-directory delete-directory - current-seconds) + current-seconds + exit + ) (import (scheme)) (include-shared "posix") (include "posix.scm")) diff --git a/lib/chibi/posix.stub b/lib/chibi/posix.stub index a38eb0b1..b986952d 100644 --- a/lib/chibi/posix.stub +++ b/lib/chibi/posix.stub @@ -29,10 +29,10 @@ (define-c pid_t fork ()) ;; (define-c pid_t wait ((result pointer int))) -;; (define-c void exit (int)) -;; (define-c int (execute execvp) (string (array string null))) +(define-c void exit (int)) +;;(define-c int (execute execvp) (string (array string null))) -;;(define-c errno pipe ((result array int 2))) +;;(define-c errno pipe ((result (array int 2)))) (define-c time_t (current-seconds time) ((value NULL))) diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index ece6eb53..d89227cc 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -42,7 +42,7 @@ static sexp sexp_rs_random_integer (sexp ctx, sexp rs, sexp bound) { if (sexp_fixnump(bound)) { sexp_call_random(rs, n); res = sexp_make_fixnum(n % sexp_unbox_fixnum(bound)); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS } else if (sexp_bignump(bound)) { hi = sexp_bignum_hi(bound); len = hi * sizeof(sexp_uint_t) / sizeof(int32_t); @@ -100,7 +100,7 @@ static sexp sexp_random_source_state_set (sexp ctx, sexp rs, sexp state) { return sexp_type_exception(ctx, "not a random-source", rs); else if (sexp_fixnump(state)) *sexp_random_data(rs) = sexp_unbox_fixnum(state); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS else if (sexp_bignump(state)) *sexp_random_data(rs) = sexp_bignum_data(state)[0]*sexp_bignum_sign(state); diff --git a/lib/srfi/33/bit.c b/lib/srfi/33/bit.c index 4af9118c..396dbc6f 100644 --- a/lib/srfi/33/bit.c +++ b/lib/srfi/33/bit.c @@ -2,7 +2,7 @@ #include #include -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS #include #endif @@ -12,13 +12,13 @@ static sexp sexp_bit_and (sexp ctx, sexp x, sexp y) { if (sexp_fixnump(x)) { if (sexp_fixnump(y)) res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS else if (sexp_bignump(y)) res = sexp_bit_and(ctx, y, x); #endif else res = sexp_type_exception(ctx, "bitwise-and: not an integer", y); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS } else if (sexp_bignump(x)) { if (sexp_fixnump(y)) { res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); @@ -46,13 +46,13 @@ static sexp sexp_bit_ior (sexp ctx, sexp x, sexp y) { if (sexp_fixnump(x)) { if (sexp_fixnump(y)) res = (sexp) ((sexp_uint_t)x | (sexp_uint_t)y); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS else if (sexp_bignump(y)) res = sexp_bit_ior(ctx, y, x); #endif else res = sexp_type_exception(ctx, "bitwise-ior: not an integer", y); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS } else if (sexp_bignump(x)) { if (sexp_fixnump(y)) { res = sexp_copy_bignum(ctx, NULL, x, 0); @@ -84,13 +84,13 @@ static sexp sexp_bit_xor (sexp ctx, sexp x, sexp y) { if (sexp_fixnump(x)) { if (sexp_fixnump(y)) res = sexp_make_fixnum(sexp_unbox_fixnum(x) ^ sexp_unbox_fixnum(y)); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS else if (sexp_bignump(y)) res = sexp_bit_xor(ctx, y, x); #endif else res = sexp_type_exception(ctx, "bitwise-xor: not an integer", y); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS } else if (sexp_bignump(x)) { if (sexp_fixnump(y)) { res = sexp_copy_bignum(ctx, NULL, x, 0); @@ -131,12 +131,12 @@ static sexp sexp_arithmetic_shift (sexp ctx, sexp i, sexp count) { res = sexp_make_fixnum(sexp_unbox_fixnum(i) >> -c); } else { tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c; -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS if (((tmp >> c) == sexp_unbox_fixnum(i)) && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) { #endif res = sexp_make_fixnum(tmp); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS } else { sexp_gc_preserve1(ctx, res); res = sexp_fixnum_to_bignum(ctx, i); @@ -145,7 +145,7 @@ static sexp sexp_arithmetic_shift (sexp ctx, sexp i, sexp count) { } #endif } -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS } else if (sexp_bignump(i)) { len = sexp_bignum_hi(i); if (c < 0) { @@ -198,7 +198,7 @@ static sexp sexp_bit_count (sexp ctx, sexp x) { if (sexp_fixnump(x)) { i = sexp_unbox_fixnum(x); res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS } else if (sexp_bignump(x)) { for (i=count=0; i include/chibi/install.h + echo '#define sexp_platform "plan9"' >> include/chibi/install.h install:V: $BIN/$TARG test -d $MODDIR || mkdir -p $MODDIR diff --git a/opcodes.c b/opcodes.c index c18f7230..12949b3d 100644 --- a/opcodes.c +++ b/opcodes.c @@ -2,73 +2,73 @@ #define _OP(c,o,n,m,t,u,i,s,d,f) \ {.tag=SEXP_OPCODE, \ .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}} -#define _FN(o,n,m,t,u,s,d,f) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f) -#define _FN0(s, d, f) _FN(OP_FCALL0, 0, 0, 0, 0, s, d, f) -#define _FN1(t, s, d, f) _FN(OP_FCALL1, 1, 0, t, 0, s, d, f) -#define _FN1OPT(t, s, d, f) _FN(OP_FCALL1, 0, 1, t, u, s, d, f) -#define _FN1OPTP(t, s, d, f) _FN(OP_FCALL1, 0, 3, t, 0, s, d, f) -#define _FN2(t, u, s, d, f) _FN(OP_FCALL2, 2, 0, t, u, s, d, f) -#define _FN2OPT(t, u, s, d, f) _FN(OP_FCALL2, 1, 1, t, u, s, d, f) -#define _FN2OPTP(t, u, s, d, f) _FN(OP_FCALL2, 1, 3, t, u, s, d, f) -#define _FN3(t, u, s, d, f) _FN(OP_FCALL3, 3, 0, t, u, s, d, f) -#define _FN4(t, u, s, d, f) _FN(OP_FCALL4, 4, 0, t, u, s, d, f) -#define _FN5(t, u, s, d, f) _FN(OP_FCALL5, 5, 0, t, u, s, d, f) -#define _FN6(t, u, s, d, f) _FN(OP_FCALL6, 6, 0, t, u, s, d, f) -#define _PARAM(n, a, t) _OP(OPC_PARAMETER, OP_NOOP, 0, 3, t, 0, 0, n, a, 0) +#define _FN(o,n,m,t,u,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f) +#define _FN0(s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, 0, 0, s, d, f) +#define _FN1(t, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, t, 0, s, d, f) +#define _FN1OPT(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, t, u, s, d, f) +#define _FN1OPTP(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, t, 0, s, d, f) +#define _FN2(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, t, u, s, d, f) +#define _FN2OPT(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, t, u, s, d, f) +#define _FN2OPTP(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, t, u, s, d, f) +#define _FN3(t, u, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, t, u, s, d, f) +#define _FN4(t, u, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, t, u, s, d, f) +#define _FN5(t, u, s, d, f) _FN(SEXP_OP_FCALL5, 5, 0, t, u, s, d, f) +#define _FN6(t, u, s, d, f) _FN(SEXP_OP_FCALL6, 6, 0, t, u, s, d, f) +#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_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_fixnum(0), NULL), -_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_fixnum(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, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LE, 2, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LT, 2, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LE, 2, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_EQN, 2, 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?", NULL, 0), -_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), -_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), -_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0), -_OP(OPC_TYPE_PREDICATE, OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0), -_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_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_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(SEXP_OPC_ACCESSOR, SEXP_OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_fixnum(0), NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_fixnum(1), NULL), +_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_SUB, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_NEGATIVE, "-", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_DIV, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_INVERSE, "/", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), _FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read), _FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write), _FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display), @@ -113,7 +113,7 @@ _PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), _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_MATH +#if SEXP_USE_MATH _FN1(0, "exp", 0, sexp_exp), _FN1(0, "log", 0, sexp_log), _FN1(0, "sin", 0, sexp_sin), @@ -129,14 +129,14 @@ _FN1(0, "floor", 0, sexp_floor), _FN1(0, "ceiling", 0, sexp_ceiling), _FN2(0, 0, "expt", 0, sexp_expt), #endif -#if USE_TYPE_DEFS +#if SEXP_USE_TYPE_DEFS _FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type), _FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate), _FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor), _FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter), _FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter), #endif -#if USE_DEBUG +#if SEXP_USE_DEBUG _FN2OPTP(SEXP_PROCEDURE, SEXP_OPORT, "disasm", (sexp)"*current-error-port*", sexp_disasm), #endif #if PLAN9 diff --git a/opt/debug.c b/opt/debug.c index 4d0631f2..16419d3a 100644 --- a/opt/debug.c +++ b/opt/debug.c @@ -57,45 +57,45 @@ static sexp disasm (sexp ctx, sexp bc, sexp out, int depth) { 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_TYPEP: - case OP_FCALL0: - case OP_FCALL1: - case OP_FCALL2: - case OP_FCALL3: - case OP_FCALL4: - case OP_FCALL5: - case OP_FCALL6: + case SEXP_OP_STACK_REF: + case SEXP_OP_LOCAL_REF: + case SEXP_OP_LOCAL_SET: + case SEXP_OP_CLOSURE_REF: + case SEXP_OP_JUMP: + case SEXP_OP_JUMP_UNLESS: + case SEXP_OP_TYPEP: + case SEXP_OP_FCALL0: + case SEXP_OP_FCALL1: + case SEXP_OP_FCALL2: + case SEXP_OP_FCALL3: + case SEXP_OP_FCALL4: + case SEXP_OP_FCALL5: + case SEXP_OP_FCALL6: sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); ip += sizeof(sexp); break; - case OP_SLOT_REF: - case OP_SLOT_SET: - case OP_MAKE: + case SEXP_OP_SLOT_REF: + case SEXP_OP_SLOT_SET: + case SEXP_OP_MAKE: ip += sizeof(sexp)*2; break; - case OP_GLOBAL_REF: - case OP_GLOBAL_KNOWN_REF: - case OP_TAIL_CALL: - case OP_CALL: - case OP_PUSH: + case SEXP_OP_GLOBAL_REF: + case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_TAIL_CALL: + case SEXP_OP_CALL: + case SEXP_OP_PUSH: tmp = ((sexp*)ip)[0]; - if (((opcode == OP_GLOBAL_REF) || (opcode == OP_GLOBAL_KNOWN_REF)) + if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF)) && sexp_pairp(tmp)) tmp = sexp_car(tmp); - else if ((opcode == OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) + else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) sexp_write_char(ctx, '\'', out); sexp_write(ctx, tmp, out); ip += sizeof(sexp); break; } sexp_write_char(ctx, '\n', out); - if ((opcode == OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) + if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) disasm(ctx, tmp, out, depth+1); if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) @@ -107,7 +107,7 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { return disasm(ctx, bc, out, 0); } -#if USE_DEBUG_VM +#if SEXP_USE_DEBUG_VM static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { int i; if (! sexp_oport(out)) out = sexp_current_error_port(ctx); diff --git a/opt/plan9.c b/opt/plan9.c index 68346ab8..b103912a 100644 --- a/opt/plan9.c +++ b/opt/plan9.c @@ -186,7 +186,7 @@ void sexp_run_9p_handler (Req *r, sexp handler) { sexp_gc_var(ctx, args, s_args); sexp_gc_preserve(ctx, ptr, s_ptr); sexp_gc_preserve(ctx, args, s_args); - ptr = sexp_make_cpointer(ctx, r); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); args = sexp_cons(ctx, ptr, SEXP_NULL); sexp_apply(ctx, handler, args); sexp_gc_release(ctx, ptr, s_ptr); @@ -216,11 +216,11 @@ char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) { sexp_gc_var(ctx, args, s_args); sexp_gc_preserve(ctx, ptr, s_ptr); sexp_gc_preserve(ctx, args, s_args); - ptr = sexp_make_cpointer(ctx, qid); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0); args = sexp_cons(ctx, ptr, SEXP_NULL); ptr = sexp_c_string(ctx, name, -1); args = sexp_cons(ctx, ptr, args); - ptr = sexp_make_cpointer(ctx, fid); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); args = sexp_cons(ctx, ptr, args); res = sexp_apply(ctx, s->walk1, args); sexp_gc_release(ctx, ptr, s_ptr); @@ -234,9 +234,9 @@ char* sexp_9p_clone (Fid *oldfid, Fid *newfid) { sexp_gc_var(ctx, args, s_args); sexp_gc_preserve(ctx, ptr, s_ptr); sexp_gc_preserve(ctx, args, s_args); - ptr = sexp_make_cpointer(ctx, oldfid); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0); args = sexp_cons(ctx, ptr, SEXP_NULL); - ptr = sexp_make_cpointer(ctx, newfid); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0); args = sexp_cons(ctx, ptr, args); res = sexp_apply(ctx, s->clone, args); sexp_gc_release(ctx, ptr, s_ptr); @@ -250,7 +250,7 @@ void sexp_9p_destroyfid (Fid *fid) { sexp_gc_var(ctx, args, s_args); sexp_gc_preserve(ctx, ptr, s_ptr); sexp_gc_preserve(ctx, args, s_args); - ptr = sexp_make_cpointer(ctx, fid); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); args = sexp_cons(ctx, ptr, SEXP_NULL); sexp_apply(ctx, s->destroyfid, args); sexp_gc_release(ctx, ptr, s_ptr); @@ -263,7 +263,7 @@ void sexp_9p_destroyreq (Req *r) { sexp_gc_var(ctx, args, s_args); sexp_gc_preserve(ctx, ptr, s_ptr); sexp_gc_preserve(ctx, args, s_args); - ptr = sexp_make_cpointer(ctx, r); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); args = sexp_cons(ctx, ptr, SEXP_NULL); sexp_apply(ctx, s->destroyreq, args); sexp_gc_release(ctx, ptr, s_ptr); @@ -276,7 +276,7 @@ void sexp_9p_end (Srv *srv) { sexp_gc_var(ctx, args, s_args); sexp_gc_preserve(ctx, ptr, s_ptr); sexp_gc_preserve(ctx, args, s_args); - ptr = sexp_make_cpointer(ctx, srv); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0); args = sexp_cons(ctx, ptr, SEXP_NULL); sexp_apply(ctx, s->end, args); sexp_gc_release(ctx, ptr, s_ptr); @@ -331,11 +331,11 @@ sexp sexp_9p_req_path (sexp ctx, sexp req) { #endif sexp sexp_9p_req_fid (sexp ctx, sexp req) { - return sexp_make_cpointer(ctx, ((Req*)sexp_cpointer_value(req))->fid); + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0); } sexp sexp_9p_req_newfid (sexp ctx, sexp req) { - return sexp_make_cpointer(ctx, ((Req*)sexp_cpointer_value(req))->newfid); + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0); } sexp sexp_9p_respond (sexp ctx, sexp req, sexp err) { diff --git a/opt/simplify.c b/opt/simplify.c index 4092f791..e01e4042 100644 --- a/opt/simplify.c +++ b/opt/simplify.c @@ -22,7 +22,7 @@ static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); app = sexp_nreverse(ctx, app); if (sexp_opcodep(sexp_car(app))) { - if (sexp_opcode_class(sexp_car(app)) == OPC_ARITHMETIC) { + if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) { for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { check = 0; diff --git a/sexp.c b/sexp.c index f6d9d529..aad2b3b0 100644 --- a/sexp.c +++ b/sexp.c @@ -10,7 +10,7 @@ struct sexp_huff_entry { unsigned short bits; }; -#if USE_HUFF_SYMS +#if SEXP_USE_HUFF_SYMS #include "opt/sexp-hufftabs.c" static struct sexp_huff_entry huff_table[] = { #include "opt/sexp-huff.c" @@ -43,7 +43,7 @@ static int is_separator(int c) { return 0>3; while (c) { @@ -1270,7 +1270,7 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { if ((digit < 0) || (digit >= base)) break; tmp = res * base + digit; -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS if ((tmp < res) || (tmp > SEXP_MAX_FIXNUM)) { sexp_push_char(ctx, c, in); return sexp_read_bignum(ctx, in, res, (negativep ? -1 : 1), base); @@ -1514,16 +1514,16 @@ sexp sexp_read_raw (sexp ctx, sexp in) { sexp_push_char(ctx, c2, in); res = sexp_read_number(ctx, in, 10); if ((c1 == '-') && ! sexp_exceptionp(res)) { -#if USE_FLONUMS +#if SEXP_USE_FLONUMS if (sexp_flonump(res)) -#if USE_IMMEDIATE_FLONUMS +#if SEXP_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 -#if USE_BIGNUMS +#if SEXP_USE_BIGNUMS if (sexp_bignump(res)) sexp_bignum_sign(res) = -sexp_bignum_sign(res); else @@ -1533,7 +1533,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } else { sexp_push_char(ctx, c2, in); res = sexp_read_symbol(ctx, in, c1, 1); -#if USE_INFINITIES +#if SEXP_USE_INFINITIES if (res == sexp_intern(ctx, "+inf.0")) res = sexp_make_flonum(ctx, 1.0/0.0); else if (res == sexp_intern(ctx, "-inf.0")) @@ -1591,21 +1591,21 @@ sexp sexp_write_to_string(sexp ctx, sexp obj) { } void sexp_init(void) { -#if USE_GLOBAL_SYMBOLS +#if SEXP_USE_GLOBAL_SYMBOLS int i; #endif if (! sexp_initialized_p) { sexp_initialized_p = 1; -#if USE_BOEHM +#if SEXP_USE_BOEHM GC_init(); -#if USE_GLOBAL_SYMBOLS +#if SEXP_USE_GLOBAL_SYMBOLS GC_add_roots((char*)&sexp_symbol_table, ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); #endif -#elif ! USE_MALLOC +#elif ! SEXP_USE_MALLOC sexp_gc_init(); #endif -#if USE_GLOBAL_SYMBOLS +#if SEXP_USE_GLOBAL_SYMBOLS for (i=0; i Date: Fri, 18 Dec 2009 17:31:10 +0900 Subject: [PATCH 261/535] moving library initialization logic from main.c to eval.c. main is just minimal option parsing plus a simple repl now. still need to switch to using a module path instead of a single module dir. --- Makefile | 2 +- README | 6 +- eval.c | 164 +++++++++++++++++++++++++++++++++---------- include/chibi/eval.h | 7 ++ include/chibi/sexp.h | 4 ++ init.scm | 2 - main.c | 123 +++++--------------------------- mkfile | 2 +- 8 files changed, 162 insertions(+), 148 deletions(-) diff --git a/Makefile b/Makefile index 87ed11d0..2f9e2f79 100644 --- a/Makefile +++ b/Makefile @@ -91,7 +91,7 @@ INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h include/chibi/install.h: Makefile echo '#define sexp_so_extension "'$(SO)'"' > $@ - echo '#define sexp_module_dir "'$(MODDIR)'"' >> $@ + echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@ echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile diff --git a/README b/README index 4357c8b3..7c399df0 100644 --- a/README +++ b/README @@ -44,7 +44,11 @@ The essential functions to remember are: #include sexp_make_eval_context(NULL, NULL, NULL) - returns a new context with a fresh stack and standard environment + returns a new context with a fresh stack and primitive environment + + sexp_load_standard_env(context, env, version) + loads the init.scm file in primitive environment env + (version should be SEXP_FIVE) sexp_destroy_context(context) free a context and all associated memory diff --git a/eval.c b/eval.c index 883d7d6d..4dc50e71 100644 --- a/eval.c +++ b/eval.c @@ -7,6 +7,7 @@ /************************************************************************/ static int scheme_initialized_p = 0; +char *sexp_module_dir = NULL; #if SEXP_USE_DEBUG #include "opt/debug.c" @@ -18,8 +19,6 @@ static int scheme_initialized_p = 0; 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); static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) { sexp exn; @@ -135,7 +134,7 @@ static int sexp_param_index (sexp lambda, sexp name) { static void shrink_bcode (sexp ctx, sexp_uint_t i) { sexp tmp; if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) { - tmp = sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE); + tmp = sexp_alloc_bytecode(ctx, i); sexp_bytecode_name(tmp) = SEXP_FALSE; sexp_bytecode_length(tmp) = i; sexp_bytecode_literals(tmp) @@ -151,10 +150,7 @@ static void expand_bcode (sexp ctx, sexp_uint_t size) { sexp tmp; 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(ctx))*2, - SEXP_BYTECODE); + tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2); sexp_bytecode_name(tmp) = SEXP_FALSE; sexp_bytecode_length(tmp) = sexp_bytecode_length(sexp_context_bc(ctx))*2; @@ -298,9 +294,7 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env) { sexp_gc_var1(res); if (ctx) sexp_gc_preserve1(ctx, res); res = sexp_make_context(ctx); - sexp_context_bc(res) - = sexp_alloc_tagged(res, sexp_sizeof(bytecode)+SEXP_INIT_BCODE_SIZE, - SEXP_BYTECODE); + sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE); sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE; sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; @@ -311,8 +305,7 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env) { } sexp_context_stack(res) = stack; if (! ctx) sexp_init_eval_context_globals(res); - sexp_context_env(res) - = (env ? env : sexp_make_standard_env(res, sexp_make_fixnum(5))); + sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_FIVE)); if (ctx) sexp_gc_release1(ctx); return res; } @@ -2204,20 +2197,7 @@ static sexp sexp_apply_optimization (sexp ctx, sexp proc, sexp ast) { #include "opt/simplify.c" #endif -/*********************** standard environment *************************/ - -static struct sexp_struct core_forms[] = { - {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE, "define"}}}, - {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SET, "set!"}}}, - {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LAMBDA, "lambda"}}}, - {.tag=SEXP_CORE, .value={.core={SEXP_CORE_IF, "if"}}}, - {.tag=SEXP_CORE, .value={.core={SEXP_CORE_BEGIN, "begin"}}}, - {.tag=SEXP_CORE, .value={.core={SEXP_CORE_QUOTE, "quote"}}}, - {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}}}, - {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}}}, - {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LET_SYNTAX, "let-syntax"}}}, - {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}}}, -}; +/***************************** opcodes ********************************/ #include "opcodes.c" @@ -2342,6 +2322,21 @@ sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index) { #endif +/*********************** standard environment *************************/ + +static struct sexp_struct core_forms[] = { + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE, "define"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SET, "set!"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LAMBDA, "lambda"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_IF, "if"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_BEGIN, "begin"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_QUOTE, "quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LET_SYNTAX, "let-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}}}, +}; + sexp sexp_make_env (sexp ctx) { sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); sexp_env_lambda(e) = NULL; @@ -2350,7 +2345,7 @@ sexp sexp_make_env (sexp ctx) { return e; } -static sexp sexp_make_null_env (sexp ctx, sexp version) { +sexp sexp_make_null_env (sexp ctx, sexp version) { sexp_uint_t i; sexp e = sexp_make_env(ctx); for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) @@ -2359,21 +2354,88 @@ static sexp sexp_make_null_env (sexp ctx, sexp version) { return e; } -static sexp sexp_make_standard_env (sexp ctx, sexp version) { - sexp_uint_t i; - sexp cell, sym; - sexp_gc_var4(e, op, tmp, err_handler); - sexp_gc_preserve4(ctx, e, op, tmp, err_handler); +sexp sexp_make_primitive_env (sexp ctx, sexp version) { + int i; + sexp_gc_var3(e, op, sym); + sexp_gc_preserve3(ctx, e, op, sym); e = sexp_make_null_env(ctx, version); for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { op = sexp_copy_opcode(ctx, &opcodes[i]); if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { sym = sexp_intern(ctx, (char*)sexp_opcode_data(op)); - cell = sexp_env_cell_create(ctx, e, sym, SEXP_VOID); - sexp_opcode_data(op) = cell; + sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID); } sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); } + sexp_gc_release3(ctx); + return e; +} + +#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 + +sexp 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 (! sexp_module_dir) { +#ifndef PLAN9 + sexp_module_dir = getenv("CHIBI_MODULE_DIR"); + if (! sexp_module_dir) +#endif + sexp_module_dir = sexp_module_dir; + } + mlen = strlen(sexp_module_dir); + flen = strlen(file); + path = (char*) malloc(mlen+flen+2); + memcpy(path, sexp_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; +} + +#define sexp_file_not_found "couldn't find file to load in ./ or module dir" + +sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { + sexp res = SEXP_VOID; + sexp_gc_var2(path, irr); + sexp_gc_preserve2(ctx, path, irr); + path = sexp_find_module_file(ctx, file); + if (! sexp_stringp(path)) { + path = sexp_c_string(ctx, sexp_module_dir, -1); + irr = sexp_cons(ctx, path, SEXP_NULL); + path = sexp_c_string(ctx, file, -1); + irr = sexp_cons(ctx, path, irr); + res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, irr); + } else { + res = sexp_load(ctx, path, env); + } + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { + sexp_gc_var3(op, tmp, sym); + sexp_gc_preserve3(ctx, op, tmp, sym); /* add io port and interaction env parameters */ sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), sexp_make_input_port(ctx, stdin, SEXP_FALSE)); @@ -2382,8 +2444,8 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), sexp_make_output_port(ctx, stderr, SEXP_FALSE)); sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); - sexp_env_define(ctx, e, sexp_intern(ctx, "*module-directory*"), - sexp_c_string(ctx, sexp_module_dir, -1)); + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*module-directory*"), + sexp_c_string(ctx, sexp_default_module_dir, -1)); #if SEXP_USE_DL sexp_env_define(ctx, e, sexp_intern(ctx, "*shared-object-extension*"), sexp_c_string(ctx, sexp_so_extension, -1)); @@ -2398,8 +2460,34 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); #endif - sexp_gc_release4(ctx); - return e; + /* load init.scm */ + tmp = sexp_load_module_file(ctx, sexp_init_file, e); + /* load and bind config env */ +#if SEXP_USE_MODULES + if (! sexp_exceptionp(tmp)) { + sym = sexp_intern(ctx, "*config-env*"); + if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { + tmp = sexp_make_env(ctx); + if (! sexp_exceptionp(tmp)) { + sexp_env_copy(ctx, tmp, e, SEXP_FALSE); + sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; + sexp_env_define(ctx, tmp, sym, tmp); + } + } + sexp_env_define(ctx, e, sym, tmp); + } +#endif + sexp_gc_release3(ctx); + return sexp_exceptionp(tmp) ? tmp : e; +} + +sexp sexp_make_standard_env (sexp ctx, sexp version) { + sexp_gc_var1(env); + sexp_gc_preserve1(ctx, env); + env = sexp_make_primitive_env(ctx, version); + if (! sexp_exceptionp(env)) sexp_load_standard_env(ctx, env, version); + sexp_gc_release1(ctx); + return env; } sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) { diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 633771c3..342607eb 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -15,6 +15,8 @@ #define sexp_init_file "init.scm" #define sexp_config_file "config.scm" +SEXP_API char *sexp_module_dir; + enum sexp_core_form_names { SEXP_CORE_DEFINE = 1, SEXP_CORE_SET, @@ -129,6 +131,11 @@ SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); SEXP_API sexp sexp_make_env (sexp context); +SEXP_API sexp sexp_make_null_env (sexp context, sexp version); +SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version); +SEXP_API sexp sexp_make_standard_env (sexp context, sexp version); +SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version); +SEXP_API sexp sexp_load_module_file (sexp ctx, char *file, sexp env); SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls); SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index ba8c0bf9..dc9448f7 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -357,6 +357,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double)) #define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) +#define sexp_alloc_bytecode(ctx, i) sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE) #if SEXP_USE_BIGNUMS #include "chibi/bignum.h" @@ -460,6 +461,8 @@ sexp sexp_make_flonum(sexp ctx, double f); #define SEXP_ONE sexp_make_fixnum(1) #define SEXP_TWO sexp_make_fixnum(2) #define SEXP_THREE sexp_make_fixnum(3) +#define SEXP_FOUR sexp_make_fixnum(4) +#define SEXP_FIVE sexp_make_fixnum(5) #define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) @@ -682,6 +685,7 @@ enum sexp_context_globals { SEXP_G_OOM_ERROR, /* out of memory exception object */ SEXP_G_OOS_ERROR, /* out of stack exception object */ SEXP_G_OPTIMIZATIONS, + SEXP_G_CONFIG_ENV, SEXP_G_QUOTE_SYMBOL, SEXP_G_QUASIQUOTE_SYMBOL, SEXP_G_UNQUOTE_SYMBOL, diff --git a/init.scm b/init.scm index 64e3a05a..845fb3c3 100644 --- a/init.scm +++ b/init.scm @@ -552,8 +552,6 @@ (current-output-port old-out) res))) -(define (command-line-arguments) *command-line-arguments*) - ;; values (define *values-tag* (list 'values)) diff --git a/main.c b/main.c index 55f1d7bf..8da4643f 100644 --- a/main.c +++ b/main.c @@ -2,95 +2,12 @@ /* 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; +#define sexp_argv_symbol "*command-line-arguments*" +#define sexp_argv_proc "(define (command-line-arguments) "sexp_argv_symbol")" -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; -} - -sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { - sexp res = SEXP_VOID; - sexp_gc_var2(path, irr); - sexp_gc_preserve2(ctx, path, irr); - path = find_module_file(ctx, file); - if (! sexp_stringp(path)) { - path = sexp_c_string(ctx, chibi_module_dir, -1); - irr = sexp_cons(ctx, path, SEXP_NULL); - path = sexp_c_string(ctx, file, -1); - irr = sexp_cons(ctx, path, irr); - res = sexp_user_exception(ctx, - SEXP_FALSE, - "couldn't find file to load in ./ or module dir", - irr); - } else { - res = sexp_load(ctx, path, env); - } - sexp_gc_release2(ctx); - return res; -} - -sexp sexp_init_environments (sexp ctx) { - sexp res, env; - sexp_gc_var1(confenv); - env = sexp_context_env(ctx); - sexp_env_define(ctx, env, sexp_intern(ctx, "*command-line-arguments*"), SEXP_NULL); - res = sexp_load_module_file(ctx, sexp_init_file, env); -#if SEXP_USE_MODULES - if (! sexp_exceptionp(res)) { - res = SEXP_UNDEF; - sexp_gc_preserve1(ctx, confenv); - confenv = sexp_make_env(ctx); - sexp_env_copy(ctx, confenv, env, SEXP_FALSE); - sexp_load_module_file(ctx, sexp_config_file, confenv); - sexp_env_define(ctx, env, sexp_intern(ctx, "*config-env*"), confenv); - sexp_env_define(ctx, confenv, sexp_intern(ctx, "*config-env*"), confenv); - sexp_gc_release1(ctx); - } -#endif - return res; -} - -void repl (sexp ctx) { +static void repl (sexp ctx) { sexp in, out, err; sexp_gc_var4(obj, tmp, res, env); sexp_gc_preserve4(ctx, obj, tmp, res, env); @@ -128,11 +45,11 @@ void repl (sexp ctx) { sexp_gc_release4(ctx); } -sexp check_exception (sexp ctx, sexp res) { +static sexp check_exception (sexp ctx, sexp res) { + sexp err; if (res && sexp_exceptionp(res)) { - sexp_print_exception(ctx, res, - sexp_eval_string(ctx, "(current-error-port)", - sexp_context_env(ctx))); + err = sexp_current_error_port(ctx); + if (sexp_oportp(err)) sexp_print_exception(ctx, res, err); exit_failure(); } return res; @@ -155,15 +72,10 @@ void run_main (int argc, char **argv) { case 'e': case 'p': if (! init_loaded++) - sexp_init_environments(ctx); - res = sexp_read_from_string(ctx, argv[i+1]); - if (! sexp_exceptionp(res)) - res = sexp_eval(ctx, res, env); - if (sexp_exceptionp(res)) { - sexp_print_exception(ctx, res, out); - quit = 1; - break; - } else if (argv[i][1] == 'p') { + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); + check_exception(ctx, sexp_read_from_string(ctx, argv[i+1])); + check_exception(ctx, sexp_eval(ctx, res, env)); + if (argv[i][1] == 'p') { sexp_write(ctx, res, out); sexp_write_char(ctx, '\n', out); } @@ -172,14 +84,14 @@ void run_main (int argc, char **argv) { break; case 'l': if (! init_loaded++) - sexp_init_environments(ctx); - sexp_load_module_file(ctx, argv[++i], env); + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); + check_exception(ctx, sexp_load_module_file(ctx, argv[++i], env)); break; case 'q': init_loaded = 1; break; case 'm': - chibi_module_dir = argv[++i]; + sexp_module_dir = argv[++i]; break; case 's': for (argc=argc-1; argc>i+1; argc--) @@ -193,11 +105,12 @@ void run_main (int argc, char **argv) { if (! quit) { if (! init_loaded) - res = check_exception(ctx, sexp_init_environments(ctx)); - sexp_env_define(ctx, env, sexp_intern(ctx, "*command-line-arguments*"), args); + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); + sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol), args); + sexp_eval_string(ctx, sexp_argv_proc, env); if (i < argc) for ( ; i < argc; i++) - res = check_exception(ctx, sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env)); + check_exception(ctx, sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env)); else repl(ctx); } diff --git a/mkfile b/mkfile index 30f5ad0f..d99032c7 100644 --- a/mkfile +++ b/mkfile @@ -13,7 +13,7 @@ HFILES=include/chibi/sexp.h include/chibi/eval.h include/chibi/config.h include/ include/chibi/install.h + echo '#define sexp_default_module_dir "'$MODDIR'"' > include/chibi/install.h echo '#define sexp_platform "plan9"' >> include/chibi/install.h install:V: $BIN/$TARG From b0bcf1a0e61b772f716b14482c38c33dfa9cdd93 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 18 Dec 2009 17:58:02 +0900 Subject: [PATCH 262/535] oops, broke module loading with that last patch :) --- eval.c | 3 ++- main.c | 12 ++++++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/eval.c b/eval.c index 4dc50e71..f9ed2efe 100644 --- a/eval.c +++ b/eval.c @@ -2469,8 +2469,9 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { tmp = sexp_make_env(ctx); if (! sexp_exceptionp(tmp)) { - sexp_env_copy(ctx, tmp, e, SEXP_FALSE); sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; + sexp_env_copy(ctx, tmp, e, SEXP_FALSE); + sexp_load_module_file(ctx, sexp_config_file, tmp); sexp_env_define(ctx, tmp, sym, tmp); } } diff --git a/main.c b/main.c index 8da4643f..03bd3b34 100644 --- a/main.c +++ b/main.c @@ -49,7 +49,9 @@ static sexp check_exception (sexp ctx, sexp res) { sexp err; if (res && sexp_exceptionp(res)) { err = sexp_current_error_port(ctx); - if (sexp_oportp(err)) sexp_print_exception(ctx, res, err); + if (! sexp_oportp(err)) + err = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_print_exception(ctx, res, err); exit_failure(); } return res; @@ -63,7 +65,7 @@ void run_main (int argc, char **argv) { ctx = sexp_make_eval_context(NULL, NULL, NULL); sexp_gc_preserve2(ctx, str, args); env = sexp_context_env(ctx); - out = sexp_eval_string(ctx, "(current-output-port)", env); + out = SEXP_FALSE; args = SEXP_NULL; /* parse options */ @@ -73,9 +75,11 @@ void run_main (int argc, char **argv) { case 'p': if (! init_loaded++) check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); - check_exception(ctx, sexp_read_from_string(ctx, argv[i+1])); - check_exception(ctx, sexp_eval(ctx, res, env)); + res = check_exception(ctx, sexp_read_from_string(ctx, argv[i+1])); + res = check_exception(ctx, sexp_eval(ctx, res, env)); if (argv[i][1] == 'p') { + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", env); sexp_write(ctx, res, out); sexp_write_char(ctx, '\n', out); } From 828c6cc35a0ca0aa8291e706ba58a11219e6056b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 18 Dec 2009 21:26:59 +0900 Subject: [PATCH 263/535] adding support for module search paths You want to use the CHIBI_MODULE_PATH environment variable now, not CHIBI_MODULE_DIR, and can use : separators as expected. The default main now also accepts -I and -A to prepend or append module directories. The default path is ".:./lib:$PREFIX/share/chibi". The first two may be removed in a future version. --- config.scm | 11 +--- eval.c | 144 ++++++++++++++++++++++++++++--------------- include/chibi/eval.h | 4 +- include/chibi/sexp.h | 3 + main.c | 49 +++++++++++---- opcodes.c | 5 ++ 6 files changed, 143 insertions(+), 73 deletions(-) diff --git a/config.scm b/config.scm index 141e95f3..0e26ab90 100644 --- a/config.scm +++ b/config.scm @@ -4,7 +4,6 @@ (define *modules* '()) (define *this-module* '()) -(define *load-path* (list "./lib" (string-append *module-directory* "/lib"))) (define (make-module exports env meta) (vector exports env meta)) (define (module-exports mod) (vector-ref mod 0)) @@ -12,12 +11,6 @@ (define (module-meta-data mod) (vector-ref mod 2)) (define (module-env-set! mod env) (vector-set! mod 1 env)) -(define (find-module-file name file) - (let lp ((ls *load-path*)) - (and (pair? ls) - (let ((path (string-append (car ls) "/" file))) - (if (file-exists? path) path (lp (cdr ls))))))) - (define (module-name->strings ls res) (if (null? ls) res @@ -36,7 +29,7 @@ (define (load-module-definition name) (let* ((file (module-name->file name)) - (path (find-module-file name file))) + (path (find-module-file file))) (if path (load path *config-env*)))) (define (find-module name) @@ -109,7 +102,7 @@ dir f (if (eq? (car x) 'include) "" *shared-object-extension*)))) (cond - ((find-module-file name f) => (lambda (x) (load x env))) + ((find-module-file f) => (lambda (x) (load x env))) (else (error "couldn't find include" f))))) (cdr x))) ((body) diff --git a/eval.c b/eval.c index f9ed2efe..6d16a352 100644 --- a/eval.c +++ b/eval.c @@ -7,7 +7,6 @@ /************************************************************************/ static int scheme_initialized_p = 0; -char *sexp_module_dir = NULL; #if SEXP_USE_DEBUG #include "opt/debug.c" @@ -19,6 +18,8 @@ char *sexp_module_dir = NULL; static sexp analyze (sexp ctx, sexp x); static void generate (sexp ctx, sexp x); +static sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env); +static sexp sexp_find_module_file_op (sexp ctx, sexp file); static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) { sexp exn; @@ -273,20 +274,41 @@ static sexp sexp_make_lit (sexp ctx, sexp value) { #define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) +static void sexp_add_path (sexp ctx, char *str) { + char *colon; + if (str && *str) { + colon = strchr(str, ':'); + if (colon) + sexp_add_path(ctx, colon+1); + else + colon = str + strlen(str); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), SEXP_VOID); + sexp_car(sexp_global(ctx, SEXP_G_MODULE_PATH)) + = sexp_c_string(ctx, str, colon-str); + } +} + void sexp_init_eval_context_globals (sexp ctx) { - sexp_gc_var2(bc, vec); + sexp_gc_var2(tmp, vec); ctx = sexp_make_child_context(ctx, NULL); - sexp_gc_preserve2(ctx, bc, vec); + sexp_gc_preserve2(ctx, tmp, vec); emit(ctx, SEXP_OP_RESUMECC); sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); ctx = sexp_make_child_context(ctx, NULL); emit(ctx, SEXP_OP_DONE); - bc = finalize_bytecode(ctx); + tmp = finalize_bytecode(ctx); vec = sexp_make_vector(ctx, 0, SEXP_VOID); sexp_global(ctx, SEXP_G_FINAL_RESUMER) - = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, bc, vec); + = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) = sexp_intern(ctx, "final-resumer"); + sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL; + sexp_add_path(ctx, sexp_default_module_dir); + sexp_add_path(ctx, getenv(SEXP_MODULE_PATH_VAR)); + tmp = sexp_c_string(ctx, "./lib", 5); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); + tmp = sexp_c_string(ctx, ".", 1); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); sexp_gc_release2(ctx); } @@ -2371,68 +2393,90 @@ sexp sexp_make_primitive_env (sexp ctx, sexp version) { return e; } +sexp sexp_find_module_file (sexp ctx, char *file) { + sexp res=SEXP_FALSE, ls; + char *dir, *path; + sexp_uint_t slash, dirlen, filelen, len; #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 - -sexp sexp_find_module_file (sexp ctx, char *file) { - sexp res; - int mlen, flen; - char *path; -#ifdef PLAN9 unsigned char buf[128]; #else +#define file_exists_p(path, buf) (! stat(path, buf)) struct stat buf_str; struct stat *buf = &buf_str; #endif - if (file_exists_p(file, buf)) - return sexp_c_string(ctx, file, -1); - if (! sexp_module_dir) { -#ifndef PLAN9 - sexp_module_dir = getenv("CHIBI_MODULE_DIR"); - if (! sexp_module_dir) -#endif - sexp_module_dir = sexp_module_dir; + filelen = strlen(file); + + ls = sexp_global(ctx, SEXP_G_MODULE_PATH); + for ( ; sexp_pairp(ls) && sexp_not(res); ls=sexp_cdr(ls)) { + dir = sexp_string_data(sexp_car(ls)); + dirlen = sexp_string_length(sexp_car(ls)); + slash = dir[dirlen-1] == '/'; + len = dirlen+filelen+2-slash; + path = (char*) malloc(len); + memcpy(path, dir, dirlen); + if (! slash) path[dirlen] = '/'; + memcpy(path+len-filelen-1, file, filelen); + path[len-1] = '\0'; + if (file_exists_p(path, buf)) + res = sexp_c_string(ctx, path, len-1); + free(path); } - mlen = strlen(sexp_module_dir); - flen = strlen(file); - path = (char*) malloc(mlen+flen+2); - memcpy(path, sexp_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; } -#define sexp_file_not_found "couldn't find file to load in ./ or module dir" +static sexp sexp_find_module_file_op (sexp ctx, sexp file) { + if (! sexp_stringp(file)) + return sexp_type_exception(ctx, "not a string", file); + else + return sexp_find_module_file(ctx, sexp_string_data(file)); +} + +#define sexp_file_not_found "couldn't find file in module path" sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { - sexp res = SEXP_VOID; - sexp_gc_var2(path, irr); - sexp_gc_preserve2(ctx, path, irr); + sexp res; + sexp_gc_var1(path); + sexp_gc_preserve1(ctx, path); path = sexp_find_module_file(ctx, file); - if (! sexp_stringp(path)) { - path = sexp_c_string(ctx, sexp_module_dir, -1); - irr = sexp_cons(ctx, path, SEXP_NULL); - path = sexp_c_string(ctx, file, -1); - irr = sexp_cons(ctx, path, irr); - res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, irr); - } else { + if (sexp_stringp(path)) { res = sexp_load(ctx, path, env); + } else { + path = sexp_c_string(ctx, file, -1); + res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path); } - sexp_gc_release2(ctx); + sexp_gc_release1(ctx); return res; } +sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env) { + if (! sexp_stringp(file)) + return sexp_type_exception(ctx, "not a string", file); + else if (! sexp_envp(env)) + return sexp_type_exception(ctx, "not an environment", env); + return sexp_load_module_file(ctx, sexp_string_data(file), env); +} + +sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp) { + sexp ls; + if (! sexp_stringp(dir)) + return sexp_type_exception(ctx, "not a string", dir); + if (sexp_truep(appendp)) { + if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { + for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) + ; + sexp_cdr(ls) = sexp_list1(ctx, dir); + } else { + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir); + } + } else { + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir); + } + return SEXP_VOID; +} + sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { sexp_gc_var3(op, tmp, sym); sexp_gc_preserve3(ctx, op, tmp, sym); @@ -2444,8 +2488,6 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), sexp_make_output_port(ctx, stderr, SEXP_FALSE)); sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); - sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*module-directory*"), - sexp_c_string(ctx, sexp_default_module_dir, -1)); #if SEXP_USE_DL sexp_env_define(ctx, e, sexp_intern(ctx, "*shared-object-extension*"), sexp_c_string(ctx, sexp_so_extension, -1)); @@ -2471,7 +2513,9 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { if (! sexp_exceptionp(tmp)) { sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; sexp_env_copy(ctx, tmp, e, SEXP_FALSE); - sexp_load_module_file(ctx, sexp_config_file, tmp); + op = sexp_load_module_file(ctx, sexp_config_file, tmp); + if (sexp_exceptionp(op)) + sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); sexp_env_define(ctx, tmp, sym, tmp); } } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 342607eb..a2afa062 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -15,8 +15,6 @@ #define sexp_init_file "init.scm" #define sexp_config_file "config.scm" -SEXP_API char *sexp_module_dir; - enum sexp_core_form_names { SEXP_CORE_DEFINE = 1, SEXP_CORE_SET, @@ -135,7 +133,9 @@ SEXP_API sexp sexp_make_null_env (sexp context, sexp version); SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version); SEXP_API sexp sexp_make_standard_env (sexp context, sexp version); SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version); +SEXP_API sexp sexp_find_module_file (sexp ctx, char *file); SEXP_API sexp sexp_load_module_file (sexp ctx, char *file, sexp env); +SEXP_API sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp); SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls); SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index dc9448f7..8283d601 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -5,6 +5,8 @@ #ifndef SEXP_H #define SEXP_H +#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" + #include "chibi/config.h" #include "chibi/install.h" @@ -686,6 +688,7 @@ enum sexp_context_globals { SEXP_G_OOS_ERROR, /* out of stack exception object */ SEXP_G_OPTIMIZATIONS, SEXP_G_CONFIG_ENV, + SEXP_G_MODULE_PATH, SEXP_G_QUOTE_SYMBOL, SEXP_G_QUASIQUOTE_SYMBOL, SEXP_G_UNQUOTE_SYMBOL, diff --git a/main.c b/main.c index 03bd3b34..85ee9ba1 100644 --- a/main.c +++ b/main.c @@ -7,6 +7,9 @@ #define sexp_argv_symbol "*command-line-arguments*" #define sexp_argv_proc "(define (command-line-arguments) "sexp_argv_symbol")" +#define sexp_import_prefix "(import (" +#define sexp_import_suffix "))" + static void repl (sexp ctx) { sexp in, out, err; sexp_gc_var4(obj, tmp, res, env); @@ -57,9 +60,12 @@ static sexp check_exception (sexp ctx, sexp res) { return res; } +#define sexp_load_init() if (! init_loaded++) check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)) + void run_main (int argc, char **argv) { + char *arg, *impmod, *p; sexp env, out=NULL, res=SEXP_VOID, ctx; - sexp_sint_t i, quit=0, init_loaded=0; + sexp_sint_t i, len, quit=0, print=0, init_loaded=0; sexp_gc_var2(str, args); ctx = sexp_make_eval_context(NULL, NULL, NULL); @@ -73,29 +79,49 @@ void run_main (int argc, char **argv) { switch (argv[i][1]) { case 'e': case 'p': - if (! init_loaded++) - check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); - res = check_exception(ctx, sexp_read_from_string(ctx, argv[i+1])); + print = (argv[i][1] == 'p'); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + sexp_load_init(); + res = check_exception(ctx, sexp_read_from_string(ctx, arg)); res = check_exception(ctx, sexp_eval(ctx, res, env)); - if (argv[i][1] == 'p') { + if (print) { if (! sexp_oportp(out)) out = sexp_eval_string(ctx, "(current-output-port)", env); sexp_write(ctx, res, out); sexp_write_char(ctx, '\n', out); } - quit=1; + quit = 1; i++; break; case 'l': - if (! init_loaded++) - check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + sexp_load_init(); check_exception(ctx, sexp_load_module_file(ctx, argv[++i], env)); break; + case 'u': + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + sexp_load_init(); + len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); + impmod = (char*) malloc(len+1); + strcpy(impmod, sexp_import_prefix); + strcpy(impmod+strlen(sexp_import_prefix), arg); + strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix); + impmod[len] = '\0'; + for (p=impmod; *p; p++) + if (*p == '.') *p=' '; + check_exception(ctx, sexp_eval_string(ctx, impmod, env)); + free(impmod); + break; case 'q': init_loaded = 1; break; - case 'm': - sexp_module_dir = argv[++i]; + case 'A': + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + sexp_add_module_directory(ctx, str=sexp_c_string(ctx,arg,-1), SEXP_TRUE); + break; + case 'I': + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + sexp_add_module_directory(ctx, str=sexp_c_string(ctx,arg,-1), SEXP_FALSE); break; case 's': for (argc=argc-1; argc>i+1; argc--) @@ -108,8 +134,7 @@ void run_main (int argc, char **argv) { } if (! quit) { - if (! init_loaded) - check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); + sexp_load_init(); sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol), args); sexp_eval_string(ctx, sexp_argv_proc, env); if (i < argc) diff --git a/opcodes.c b/opcodes.c index 12949b3d..c65ef3d5 100644 --- a/opcodes.c +++ b/opcodes.c @@ -143,5 +143,10 @@ _FN2OPTP(SEXP_PROCEDURE, SEXP_OPORT, "disasm", (sexp)"*current-error-port*", sex #include "opt/plan9-opcodes.c" #endif _FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), +#if SEXP_USE_MODULES +_FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), +_FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), +_FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory), +#endif }; From 69166bb523aa3af836f92b1efed725b46577eed5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 18 Dec 2009 21:31:03 +0900 Subject: [PATCH 264/535] moving init.scm and config.scm to the module directory --- Makefile | 2 +- config.scm => lib/config.scm | 0 init.scm => lib/init.scm | 0 mkfile | 2 +- 4 files changed, 2 insertions(+), 2 deletions(-) rename config.scm => lib/config.scm (100%) rename init.scm => lib/init.scm (100%) diff --git a/Makefile b/Makefile index 2f9e2f79..f9d7e3aa 100644 --- a/Makefile +++ b/Makefile @@ -153,7 +153,7 @@ install: chibi-scheme$(EXE) mkdir -p $(DESTDIR)$(BINDIR) cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ mkdir -p $(DESTDIR)$(MODDIR) - cp init.scm config.scm $(DESTDIR)$(MODDIR)/ + cp lib/init.scm lib/config.scm $(DESTDIR)$(MODDIR)/ cp -r lib/ $(DESTDIR)$(MODDIR)/ mkdir -p $(DESTDIR)$(INCDIR) cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ diff --git a/config.scm b/lib/config.scm similarity index 100% rename from config.scm rename to lib/config.scm diff --git a/init.scm b/lib/init.scm similarity index 100% rename from init.scm rename to lib/init.scm diff --git a/mkfile b/mkfile index d99032c7..b5b413fc 100644 --- a/mkfile +++ b/mkfile @@ -18,7 +18,7 @@ include/chibi/install.h: mkfile install:V: $BIN/$TARG test -d $MODDIR || mkdir -p $MODDIR - cp init.scm $MODDIR/ + cp -r lib/* $MODDIR/ test:V: ./$O.out tests/r5rs-tests.scm From 427eb51ad6981e9d0788ba5c314240a0dc881bcd Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 18 Dec 2009 23:34:24 +0900 Subject: [PATCH 265/535] removing unneeded make-syntactic-closure from rsc-macro-transformer --- lib/init.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/init.scm b/lib/init.scm index 845fb3c3..67659303 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -99,7 +99,7 @@ (define rsc-macro-transformer (lambda (f) (lambda (expr use-env mac-env) - (make-syntactic-closure use-env '() (f expr mac-env))))) + (f expr mac-env)))) (define er-macro-transformer (lambda (f) From c895db6c48ddc8ef5aa7de47b08542eea2d12241 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 20 Dec 2009 13:27:30 +0900 Subject: [PATCH 266/535] config env doesn't copy the core env, it just links to it as a parent --- eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/eval.c b/eval.c index 6d16a352..3674419f 100644 --- a/eval.c +++ b/eval.c @@ -2512,7 +2512,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { tmp = sexp_make_env(ctx); if (! sexp_exceptionp(tmp)) { sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; - sexp_env_copy(ctx, tmp, e, SEXP_FALSE); + sexp_env_parent(tmp) = e; op = sexp_load_module_file(ctx, sexp_config_file, tmp); if (sexp_exceptionp(op)) sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); From ffdce3639b440f217cbeebc106b636f13b36dfdc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 20 Dec 2009 16:08:19 +0900 Subject: [PATCH 267/535] adding import-immutable to minimize heap usage --- Makefile | 2 +- eval.c | 110 +++++++---- include/chibi/config.h | 7 + include/chibi/eval.h | 4 +- include/chibi/sexp.h | 9 + lib/chibi/loop.module | 2 +- lib/chibi/macroexpand.module | 2 +- lib/chibi/match.module | 2 +- lib/chibi/net.module | 4 +- lib/chibi/pathname.module | 2 +- lib/chibi/posix.module | 6 +- lib/chibi/posix.scm | 11 +- lib/chibi/posix.stub | 26 +-- lib/chibi/uri.module | 4 +- lib/config.scm | 86 +++------ lib/init.scm | 3 +- lib/srfi/1.module | 2 +- lib/srfi/11.module | 2 +- lib/srfi/16.module | 2 +- lib/srfi/2.module | 2 +- lib/srfi/26.module | 2 +- lib/srfi/27.module | 2 +- lib/srfi/33.module | 2 +- lib/srfi/6.module | 2 +- lib/srfi/69.module | 4 +- lib/srfi/8.module | 2 +- lib/srfi/9.module | 2 +- opcodes.c | 3 +- tools/genstubs.scm | 362 +++++++++++++++++++++++++++++++---- 29 files changed, 491 insertions(+), 178 deletions(-) diff --git a/Makefile b/Makefile index f9d7e3aa..3aa63400 100644 --- a/Makefile +++ b/Makefile @@ -112,7 +112,7 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO) chibi-scheme-static$(EXE): main.o eval.o sexp.o $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) -%.c: %.stub chibi-scheme$(EXE) $(GENSTUBS) +%.c: %.stub $(GENSTUBS) LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) $(GENSTUBS) $< lib/%$(SO): lib/%.c $(INCLUDES) diff --git a/eval.c b/eval.c index 3674419f..a46389bd 100644 --- a/eval.c +++ b/eval.c @@ -36,56 +36,83 @@ static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) { /********************** environment utilities ***************************/ -sexp sexp_env_cell (sexp e, sexp key) { +static sexp sexp_env_cell_loc (sexp env, sexp key, sexp *varenv) { sexp ls; do { - for (ls=sexp_env_bindings(e); sexp_pairp(ls); ls=sexp_cdr(ls)) - if (sexp_caar(ls) == key) + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (sexp_caar(ls) == key) { + if (varenv) *varenv = env; return sexp_car(ls); - e = sexp_env_parent(e); - } while (e); + } + env = sexp_env_parent(env); + } while (env); return NULL; } -static sexp sexp_env_cell_create (sexp ctx, sexp e, sexp key, sexp value) { +sexp sexp_env_cell (sexp env, sexp key) { + return sexp_env_cell_loc(env, key, NULL); +} + +static sexp sexp_env_cell_create_loc (sexp ctx, sexp env, sexp key, + sexp value, sexp *varenv) { sexp_gc_var1(cell); - cell = sexp_env_cell(e, key); + cell = sexp_env_cell_loc(env, key, varenv); if (! cell) { sexp_gc_preserve1(ctx, 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)); + while (sexp_env_lambda(env) || sexp_env_syntactic_p(env)) + env = sexp_env_parent(env); + sexp_env_bindings(env) = sexp_cons(ctx, cell, sexp_env_bindings(env)); + if (varenv) *varenv = env; sexp_gc_release1(ctx); } return cell; } -sexp sexp_env_global_ref (sexp e, sexp key, sexp dflt) { +static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, sexp value) { + return sexp_env_cell_create_loc(ctx, env, key, value, NULL); +} + +sexp sexp_env_global_ref (sexp env, sexp key, sexp dflt) { sexp cell; - while (sexp_env_parent(e)) - e = sexp_env_parent(e); - cell = sexp_env_cell(e, key); + while (sexp_env_parent(env)) + env = sexp_env_parent(env); + cell = sexp_env_cell(env, key); return (cell ? sexp_cdr(cell) : dflt); } -void sexp_env_define (sexp ctx, sexp e, sexp key, sexp value) { - sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e)); +sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { + sexp cell = sexp_assq(ctx, key, sexp_env_bindings(env)), res=SEXP_VOID; sexp_gc_var1(tmp); - if (sexp_immutablep(e)) { - fprintf(stderr, "ERROR: immutable environment\n"); + if (sexp_immutablep(env)) { + res = sexp_type_exception(ctx, "immutable binding", key); } else { sexp_gc_preserve1(ctx, tmp); - if (sexp_truep(cell)) - sexp_cdr(cell) = value; - else { + if (sexp_truep(cell)) { + if (sexp_immutablep(cell)) + res = sexp_type_exception(ctx, "immutable binding", key); + else + sexp_cdr(cell) = value; + } else { tmp = sexp_cons(ctx, key, value); - sexp_push(ctx, sexp_env_bindings(e), tmp); + sexp_push(ctx, sexp_env_bindings(env), tmp); } sexp_gc_release1(ctx); } + return res; +} + +sexp sexp_env_exports (sexp ctx, sexp env) { + sexp ls; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(ctx, res, sexp_caar(ls)); + sexp_gc_release1(ctx); + return res; } sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { @@ -430,11 +457,11 @@ static sexp analyze_seq (sexp ctx, sexp ls) { return res; } -static sexp analyze_var_ref (sexp ctx, sexp x) { +static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) { sexp env = sexp_context_env(ctx), res; sexp_gc_var1(cell); sexp_gc_preserve1(ctx, cell); - cell = sexp_env_cell(env, x); + cell = sexp_env_cell_loc(env, x, varenv); if (! cell) { if (sexp_synclop(x)) { if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_context_fv(ctx))) @@ -442,7 +469,7 @@ static sexp analyze_var_ref (sexp ctx, sexp x) { env = sexp_synclo_env(x); x = sexp_synclo_expr(x); } - cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF); + cell = sexp_env_cell_create_loc(ctx, env, x, SEXP_UNDEF, varenv); } if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) res = sexp_compile_error(ctx, "invalid use of syntax as value", x); @@ -453,14 +480,14 @@ static sexp analyze_var_ref (sexp ctx, sexp x) { } static sexp analyze_set (sexp ctx, sexp x) { - sexp res; + sexp res, varenv; sexp_gc_var2(ref, value); sexp_gc_preserve2(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)); + ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv); 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)); @@ -468,6 +495,9 @@ static sexp analyze_set (sexp ctx, sexp x) { res = ref; else if (sexp_exceptionp(value)) res = value; + else if (sexp_immutablep(sexp_ref_cell(ref)) + || (varenv && sexp_immutablep(varenv))) + res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x)); else res = sexp_make_set(ctx, ref, value); } @@ -511,7 +541,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { } if (sexp_exceptionp(value)) sexp_return(res, value); sexp_push(ctx2, defs, - sexp_make_set(ctx2, analyze_var_ref(ctx2, name), value)); + sexp_make_set(ctx2, analyze_var_ref(ctx2, name, NULL), value)); } if (sexp_pairp(defs)) { if (! sexp_seqp(body)) { @@ -546,7 +576,7 @@ static sexp analyze_if (sexp ctx, sexp x) { } static sexp analyze_define (sexp ctx, sexp x) { - sexp name, res; + sexp name, res, varenv; sexp_gc_var4(ref, value, tmp, env); sexp_gc_preserve4(ctx, ref, value, tmp, env); env = sexp_context_env(ctx); @@ -574,11 +604,13 @@ static sexp analyze_define (sexp ctx, sexp x) { value = analyze_lambda(ctx, tmp); } else value = analyze(ctx, sexp_caddr(x)); - ref = analyze_var_ref(ctx, name); + ref = analyze_var_ref(ctx, name, &varenv); if (sexp_exceptionp(ref)) res = ref; else if (sexp_exceptionp(value)) res = value; + else if (varenv && sexp_immutablep(varenv)) + res = sexp_compile_error(ctx, "immutable binding", name); else res = sexp_make_set(ctx, ref, value); } @@ -736,15 +768,13 @@ static sexp analyze (sexp ctx, sexp object) { res = sexp_compile_error(ctx, "invalid operand in application", x); } } else if (sexp_idp(x)) { - res = analyze_var_ref(ctx, x); + res = analyze_var_ref(ctx, x, NULL); } else if (sexp_synclop(x)) { tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); sexp_context_env(tmp) = sexp_synclo_env(x); sexp_context_fv(tmp) = sexp_append2(tmp, sexp_synclo_free_vars(x), sexp_context_fv(tmp)); - if (sexp_pairp(sexp_synclo_free_vars(x))) - sexp_debug(ctx, "free vars: ", sexp_context_fv(tmp)); x = sexp_synclo_expr(x); res = analyze(tmp, x); } else { @@ -2535,13 +2565,21 @@ sexp sexp_make_standard_env (sexp ctx, sexp version) { return env; } -sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) { +sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls, sexp immutp) { sexp oldname, newname, value, out; if (! sexp_envp(to)) to = sexp_context_env(ctx); if (! sexp_envp(from)) from = sexp_context_env(ctx); if (sexp_not(ls)) { - for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls)) - sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls)); + if (sexp_truep(immutp)) { + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_parent(to) = value; + sexp_immutablep(value) = 1; + sexp_env_bindings(value) = sexp_env_bindings(from); + } else { + for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls)); + } } else { for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { if (sexp_pairp(sexp_car(ls))) { diff --git a/include/chibi/config.h b/include/chibi/config.h index 028ea0ec..cec2b00c 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -52,6 +52,9 @@ /* and are thus thread-safe and independant. */ /* #define SEXP_USE_GLOBAL_HEAP 1 */ +/* uncomment this to make type definitions common to all contexts */ +/* #define SEXP_USE_GLOBAL_TYPES 1 */ + /* uncomment this to make the symbol table common to all contexts */ /* Will still be restricted to all contexts sharing the same */ /* heap, of course. */ @@ -194,6 +197,10 @@ #endif #endif +#ifndef SEXP_USE_GLOBAL_TYPES +#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS) +#endif + #ifndef SEXP_USE_GLOBAL_SYMBOLS #if SEXP_USE_BOEHM || SEXP_USE_MALLOC #define SEXP_USE_GLOBAL_SYMBOLS 1 diff --git a/include/chibi/eval.h b/include/chibi/eval.h index a2afa062..23428d21 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -137,8 +137,8 @@ SEXP_API sexp sexp_find_module_file (sexp ctx, char *file); SEXP_API sexp sexp_load_module_file (sexp ctx, char *file, sexp env); SEXP_API sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp); SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); -SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls); -SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val); +SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls, sexp immutp); +SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_env_cell (sexp env, sexp sym); SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 8283d601..03a2e631 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -644,6 +644,12 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) #endif +#if SEXP_USE_GLOBAL_TYPES +#define sexp_context_types(ctx) sexp_type_specs +#else +#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#endif + #define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) #define sexp_type_tag(x) ((x)->value.type.tag) @@ -683,6 +689,9 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); enum sexp_context_globals { #if ! SEXP_USE_GLOBAL_SYMBOLS SEXP_G_SYMBOLS, +#endif +#if ! SEXP_USE_GLOBAL_TYPES + SEXP_G_TYPES, #endif SEXP_G_OOM_ERROR, /* out of memory exception object */ SEXP_G_OOS_ERROR, /* out of stack exception object */ diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module index 17c8ac2d..5b76daf8 100644 --- a/lib/chibi/loop.module +++ b/lib/chibi/loop.module @@ -4,6 +4,6 @@ listing listing-reverse appending appending-reverse summing multiplying in-string in-string-reverse in-vector in-vector-reverse) - (import (scheme)) + (import-immutable (scheme)) (include "loop/loop.scm")) diff --git a/lib/chibi/macroexpand.module b/lib/chibi/macroexpand.module index 9aac5dbc..47b0e7d4 100644 --- a/lib/chibi/macroexpand.module +++ b/lib/chibi/macroexpand.module @@ -1,6 +1,6 @@ (define-module (chibi macroexpand) - (import (scheme)) + (import-immutable (scheme)) (import (chibi ast)) (export macroexpand) (include "macroexpand.scm")) diff --git a/lib/chibi/match.module b/lib/chibi/match.module index afce8975..1366176a 100644 --- a/lib/chibi/match.module +++ b/lib/chibi/match.module @@ -1,6 +1,6 @@ (define-module (chibi match) (export match match-lambda match-lambda* match-let match-letrec match-let*) - (import (scheme)) + (import-immutable (scheme)) (include "match/match.scm")) diff --git a/lib/chibi/net.module b/lib/chibi/net.module index d17c1791..14f3801f 100644 --- a/lib/chibi/net.module +++ b/lib/chibi/net.module @@ -1,9 +1,9 @@ (define-module (chibi net) - (export sockaddr? addressinfo? get-address-info socket connect with-net-io + (export sockaddr? address-info? get-address-info socket connect with-net-io address-info-family address-info-socket-type address-info-protocol address-info-address address-info-address-length address-info-next) - (import (scheme)) + (import-immutable (scheme)) (import (chibi posix)) (include-shared "net") (include "net.scm")) diff --git a/lib/chibi/pathname.module b/lib/chibi/pathname.module index 2fb46eef..765ee189 100644 --- a/lib/chibi/pathname.module +++ b/lib/chibi/pathname.module @@ -3,5 +3,5 @@ (export path-strip-directory path-directory path-extension-pos path-extension path-strip-extension path-replace-extension path-absolute? path-relative? path-normalize make-path) - (import (scheme)) + (import-immutable (scheme)) (include "pathname.scm")) diff --git a/lib/chibi/posix.module b/lib/chibi/posix.module index 7a05181a..aba6b7ff 100644 --- a/lib/chibi/posix.module +++ b/lib/chibi/posix.module @@ -1,12 +1,12 @@ (define-module (chibi posix) - (export open-input-fd open-output-fd - delete-file link-file symbolic-link rename-file + (export open-input-fd open-output-fd pipe + delete-file link-file symbolic-link-file rename-file directory-files create-directory delete-directory current-seconds exit ) - (import (scheme)) + (import-immutable (scheme)) (include-shared "posix") (include "posix.scm")) diff --git a/lib/chibi/posix.scm b/lib/chibi/posix.scm index e2c6d56f..ed5fa780 100644 --- a/lib/chibi/posix.scm +++ b/lib/chibi/posix.scm @@ -1,7 +1,10 @@ -(define (directory-files path) - (let ((dir (opendir path))) - (let lp ((res '())) +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (let lp ((res knil)) (let ((file (readdir dir))) - (if file (lp (cons (dirent-name file) res)) res))))) + (if file (lp (kons (dirent-name file) res)) res))))) + +(define (directory-files dir) + (directory-fold dir cons '())) diff --git a/lib/chibi/posix.stub b/lib/chibi/posix.stub index b986952d..7c1a6c9f 100644 --- a/lib/chibi/posix.stub +++ b/lib/chibi/posix.stub @@ -10,29 +10,29 @@ (define-c-struct dirent (string d_name dirent-name)) -(define-c input-port (open-input-fd fdopen) (int (value "r"))) -(define-c output-port (open-output-fd fdopen) (int (value "w"))) +(define-c input-port (open-input-fd "fdopen") (int (value "r" string))) +(define-c output-port (open-output-fd "fdopen") (int (value "w" string))) -(define-c errno (delete-file unlink) (string)) -(define-c errno (link-file link) (string string)) -(define-c errno (symbolic-link-file symlink) (string string)) -(define-c errno (rename-file rename) (string string)) +(define-c errno (delete-file "unlink") (string)) +(define-c errno (link-file "link") (string string)) +(define-c errno (symbolic-link-file "symlink") (string string)) +(define-c errno (rename-file "rename") (string string)) -;; (define-c string (current-directory getcwd) ()) -(define-c errno (create-directory mkdir) (string int)) -(define-c errno (delete-directory rmdir) (string)) +;;(define-c string (current-directory "getcwd") ((value (array char)) int)) +(define-c errno (create-directory "mkdir") (string int)) +(define-c errno (delete-directory "rmdir") (string)) (define-c (free DIR) opendir (string)) (define-c dirent readdir (DIR)) -(define-c int (duplicate-fd dup) (int)) +(define-c int (duplicate-fd "dup") (int)) (define-c pid_t fork ()) ;; (define-c pid_t wait ((result pointer int))) (define-c void exit (int)) -;;(define-c int (execute execvp) (string (array string null))) +(define-c int (execute execvp) (string (array string null))) -;;(define-c errno pipe ((result (array int 2)))) +(define-c errno pipe ((result (array int 2)))) -(define-c time_t (current-seconds time) ((value NULL))) +(define-c time_t (current-seconds "time") ((value NULL))) diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module index 825ccd45..2456dd9f 100644 --- a/lib/chibi/uri.module +++ b/lib/chibi/uri.module @@ -5,6 +5,6 @@ uri-with-scheme uri-with-user uri-with-host uri-with-path uri-with-query uri-with-fragment uri-encode uri-decode uri-query->alist uri-alist->query) - (import (scheme) - (srfi 9)) + (import-immutable (scheme) + (srfi 9)) (include "uri.scm")) diff --git a/lib/config.scm b/lib/config.scm index 0e26ab90..51435a3a 100644 --- a/lib/config.scm +++ b/lib/config.scm @@ -2,15 +2,16 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; modules -(define *modules* '()) (define *this-module* '()) (define (make-module exports env meta) (vector exports env meta)) -(define (module-exports mod) (vector-ref mod 0)) (define (module-env mod) (vector-ref mod 1)) (define (module-meta-data mod) (vector-ref mod 2)) (define (module-env-set! mod env) (vector-set! mod 1 env)) +(define (module-exports mod) + (or (vector-ref mod 0) (env-exports (module-env mod)))) + (define (module-name->strings ls res) (if (null? ls) res @@ -55,13 +56,22 @@ ((not (and (pair? x) (list? x))) (error "invalid module syntax" x)) ((and (pair? (cdr x)) (pair? (cadr x))) - (if (memq (car x) '(only except renams)) + (if (memq (car x) '(only except rename)) (let* ((mod-name+imports (resolve-import (cadr x))) - (imp-ids (cdr mod-name+imports))) + (imp-ids (cdr mod-name+imports)) + (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x)))) + (begin + (set-cdr! mod-name+imports + (module-exports + (find-module (car mod-name+imports)))) + (cdr mod-name+imports)) + imp-ids))) (cons (car mod-name+imports) (case (car x) ((only) - (id-filter (lambda (i) (memq i (cddr x))) imp-ids)) + (if (not imp-ids) + (cddr x) + (id-filter (lambda (i) (memq i (cddr x))) imp-ids))) ((except) (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids)) ((rename) @@ -78,7 +88,7 @@ (if (pair? i) (cdr i) i))) (cdr mod-name+imports))))) ((find-module x) - => (lambda (mod) (cons x (module-exports mod)))) + => (lambda (mod) (cons x #f))) (else (error "couldn't find import" x)))) @@ -88,12 +98,13 @@ (for-each (lambda (x) (case (and (pair? x) (car x)) - ((import) + ((import import-immutable) (for-each - (lambda (x) - (let* ((mod2-name+imports (resolve-import x)) + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) (mod2 (load-module (car mod2-name+imports)))) - (%env-copy! env (module-env mod2) (cdr mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports) + (eq? (car x) 'import-immutable)))) (cdr x))) ((include include-shared) (for-each @@ -142,58 +153,15 @@ `(set! *this-module* (cons ',expr *this-module*)))))))) (define-config-primitive import) +(define-config-primitive import-immutable) (define-config-primitive export) (define-config-primitive include) (define-config-primitive include-shared) (define-config-primitive body) -(let ((exports - '(define set! let let* letrec lambda if cond case delay - and or begin do quote quasiquote - 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 exp log sin cos tan asin acos atan sqrt - expt 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 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 interaction-environment 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 - *current-input-port* *current-output-port* *current-error-port* - error current-error-port file-exists? string-concatenate - open-input-string open-output-string get-output-string - sc-macro-transformer rsc-macro-transformer er-macro-transformer - identifier? identifier=? identifier->symbol make-syntactic-closure - syntax-quote - register-simple-type make-constructor make-type-predicate - make-getter make-setter - ))) - (set! *modules* - (list (cons '(scheme) (make-module exports - (interaction-environment) - (list (cons 'export exports)))) - (cons '(srfi 0) (make-module (list 'cond-expand) - (interaction-environment) - (list (list 'export 'cond-expand))))))) +(define *modules* + (list (cons '(scheme) (make-module #f (interaction-environment) '())) + (cons '(srfi 0) (make-module (list 'cond-expand) + (interaction-environment) + (list (list 'export 'cond-expand)))))) diff --git a/lib/init.scm b/lib/init.scm index 67659303..24aa8b34 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -766,7 +766,8 @@ (vector-ref (eval '(load-module ',(car mod+imps)) *config-env*) 1) - ',(cdr mod+imps)) + ',(cdr mod+imps) + #f) res)) (error "couldn't find module" (car ls)))))))))) diff --git a/lib/srfi/1.module b/lib/srfi/1.module index 3d3da044..8d341b6b 100644 --- a/lib/srfi/1.module +++ b/lib/srfi/1.module @@ -18,7 +18,7 @@ lset<= lset= lset-adjoin lset-union lset-union! lset-intersection lset-intersection! lset-difference lset-difference! lset-xor lset-xor! lset-diff+intersection lset-diff+intersection!) - (import (scheme)) + (import-immutable (scheme)) (include "1/predicates.scm" "1/selectors.scm" "1/search.scm" diff --git a/lib/srfi/11.module b/lib/srfi/11.module index 386443a2..f3c91df8 100644 --- a/lib/srfi/11.module +++ b/lib/srfi/11.module @@ -1,7 +1,7 @@ (define-module (srfi 11) (export let-values let*-values) - (import (scheme)) + (import-immutable (scheme)) (body (define-syntax let*-values (syntax-rules () diff --git a/lib/srfi/16.module b/lib/srfi/16.module index 61837146..f931a376 100644 --- a/lib/srfi/16.module +++ b/lib/srfi/16.module @@ -1,7 +1,7 @@ (define-module (srfi 16) (export case-lambda) - (import (scheme)) + (import-immutable (scheme)) (body (define-syntax %case (syntax-rules () diff --git a/lib/srfi/2.module b/lib/srfi/2.module index b7addf06..4ceb8b6b 100644 --- a/lib/srfi/2.module +++ b/lib/srfi/2.module @@ -1,7 +1,7 @@ (define-module (srfi 2) (export and-let*) - (import (scheme)) + (import-immutable (scheme)) (body (define-syntax and-let* (syntax-rules () diff --git a/lib/srfi/26.module b/lib/srfi/26.module index 9ed9aeee..f97ab783 100644 --- a/lib/srfi/26.module +++ b/lib/srfi/26.module @@ -1,7 +1,7 @@ (define-module (srfi 26) (export cut cute) - (import (scheme)) + (import-immutable (scheme)) (body (define-syntax %cut (syntax-rules (<> <...>) diff --git a/lib/srfi/27.module b/lib/srfi/27.module index 198d444e..5c451629 100644 --- a/lib/srfi/27.module +++ b/lib/srfi/27.module @@ -5,7 +5,7 @@ random-source-state-ref random-source-state-set! random-source-randomize! random-source-pseudo-randomize! random-source-make-integers random-source-make-reals) - (import (scheme)) + (import-immutable (scheme)) (include-shared "27/rand") (include "27/constructors.scm")) diff --git a/lib/srfi/33.module b/lib/srfi/33.module index 81fa0a80..7eb86c1e 100644 --- a/lib/srfi/33.module +++ b/lib/srfi/33.module @@ -12,6 +12,6 @@ first-set-bit extract-bit-field test-bit-field? clear-bit-field replace-bit-field copy-bit-field) - (import (scheme)) + (import-immutable (scheme)) (include-shared "33/bit") (include "33/bitwise.scm")) diff --git a/lib/srfi/6.module b/lib/srfi/6.module index bbabf209..e589b6ff 100644 --- a/lib/srfi/6.module +++ b/lib/srfi/6.module @@ -1,5 +1,5 @@ (define-module (srfi 6) (export open-input-string open-output-string get-output-string) - (import (scheme))) + (import-immutable (scheme))) diff --git a/lib/srfi/69.module b/lib/srfi/69.module index fd28ecaa..037b6393 100644 --- a/lib/srfi/69.module +++ b/lib/srfi/69.module @@ -10,8 +10,8 @@ hash-table-walk hash-table-fold hash-table->alist hash-table-copy hash-table-merge! hash string-hash string-ci-hash hash-by-identity) - (import (scheme)) - (import (srfi 9)) + (import-immutable (scheme) + (srfi 9)) (include-shared "69/hash") (include "69/type.scm" "69/interface.scm")) diff --git a/lib/srfi/8.module b/lib/srfi/8.module index ebe02df7..64a3e6e2 100644 --- a/lib/srfi/8.module +++ b/lib/srfi/8.module @@ -1,7 +1,7 @@ (define-module (srfi 8) (export receive) - (import (scheme)) + (import-immutable (scheme)) (body (define-syntax receive (syntax-rules () diff --git a/lib/srfi/9.module b/lib/srfi/9.module index aca550a4..0516b201 100644 --- a/lib/srfi/9.module +++ b/lib/srfi/9.module @@ -1,7 +1,7 @@ (define-module (srfi 9) (export define-record-type) - (import (scheme)) + (import-immutable (scheme)) (body (define-syntax define-record-type (er-macro-transformer diff --git a/opcodes.c b/opcodes.c index c65ef3d5..470c694a 100644 --- a/opcodes.c +++ b/opcodes.c @@ -92,7 +92,7 @@ _FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), _FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), _FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval), _FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load), -_FN3(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), +_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), _FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), _FN5(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception), @@ -144,6 +144,7 @@ _FN2OPTP(SEXP_PROCEDURE, SEXP_OPORT, "disasm", (sexp)"*current-error-port*", sex #endif _FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), #if SEXP_USE_MODULES +_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports), _FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), _FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), _FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory), diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 3202e0eb..ae7c8201 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -1,8 +1,181 @@ #! chibi-scheme -s +;; Simple C FFI. "genstubs.scm file.stub" will read in the C function +;; FFI definitions from file.stub and output the appropriate C +;; wrappers into file.c. You can then compile that file with: +;; +;; cc -fPIC -shared file.c -lchibi-scheme +;; +;; (or using whatever flags are appropriate to generate shared libs on +;; your platform) and then the generated .so file can be loaded +;; directly with load, or portably using (include-shared "file") in a +;; module definition (note that include-shared uses no suffix). + +;; The goal of this interface is to make access to C types and +;; functions easy, without requiring the user to write any C code. +;; That means the stubber needs to be intelligent about various C +;; calling conventions and idioms, such as return values passed in +;; actual parameters. Writing C by hand is still possible, and +;; several of the core modules provide C interfaces directly without +;; using the stubber. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Struct Interface +;; +;; (define-c-struct struct-name +;; [predicate: predicate-name] +;; [constructor: constructor-name] +;; [finalizer: c_finalizer_name] +;; (type c_field_name getter-name setter-name) ...) +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Function Interface +;; +;; (define-c return-type name-spec (arg-type ...)) +;; +;; where name-space is either a symbol name, or a list of +;; (scheme-name c_name). If just a symbol, the C name is taken +;; to be the same with -'s replaced by _'s. +;; +;; arg-type is a type suitable for input validation and conversion. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Types +;; +;; Types +;; +;; Basic Types +;; void +;; boolean +;; char +;; +;; Integer Types: +;; short int long +;; unsigned-short unsigned-int unsigned-long size_t pid_t +;; time_t (in seconds, but using the chibi epoch of 2010/01/01) +;; errno (as a return type returns #f on error) +;; +;; Float Types: +;; float double long-double +;; +;; String Types: +;; string (a null-terminated char*) +;; +;; Port Types: +;; input-port output-port +;; +;; Struct Types: +;; +;; Struct types are by default just referred to by the bare +;; struct-name from define-c-struct, and it is assumed you want a +;; pointer to that type. To refer to the full struct, use the struct +;; modifier, as in (struct struct-name). + +;; Type modifiers +;; +;; Any type may also be written as a list of modifiers followed by the +;; type itself. The supported modifiers are: +;; +;; const: prepends the "const" C type modifier +;; * as a return or result parameter, makes non-immediates immutable +;; +;; free: it's Scheme's responsibility to "free" this resource +;; * as a return or result parameter, registers the freep flag +;; this causes the type finalizer to be run when GCed +;; +;; maybe-null: this pointer type may be NULL +;; * as a result parameter, NULL is translated to #f +;; normally this would just return a wrapped NULL pointer +;; * as an input parameter, #f is translated to NULL +;; normally this would be a type error +;; +;; pointer: create a pointer to this type +;; * as a return parameter, wraps the result in a vanilla cpointer +;; * as a result parameter, boxes then unboxes the value +;; +;; struct: treat this struct type as a struct, not a pointer +;; * as an input parameter, dereferences the pointer +;; * as a type field, indicates a nested struct +;; +;; link: add a gc link +;; * as a field getter, link to the parent object, so the +;; parent won't be GCed so long as we have a reference +;; to the child. this behavior is automatic for nested +;; structs. +;; +;; result: return a result in this parameter +;; * if there are multiple results (including the return type), +;; they are all returned in a list +;; * if there are any result parameters, a return type +;; of errno returns #f on failure, and as eliminated +;; from the list of results otherwise +;; +;; (value ): specify a fixed value +;; * as an input parameter, this parameter is not provided +;; in the Scheme API but always passed as +;; +;; (default ): specify a default value +;; * as the final input parameter, makes the Scheme parameter +;; optional, defaulting to +;; +;; (array []) an array type +;; * length must be specified for return and result parameters +;; * if specified, length can be any of +;; ** an integer, for a fixed size +;; ** the symbol null, indicating a NULL-terminated array + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define types '()) (define funcs '()) +(define (make-type type free? const? null? ptr? struct? link? result? array value default? i) + (vector type free? const? null? ptr? struct? link? result? array value default? i)) + +(define (with-parsed-type type proc . o) + (cond + ((vector? type) + (apply proc (vector->list type))) + (else + (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) + (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f) + (value #f) (default? #f)) + (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) + (case (and (pair? type) (car type)) + ((free) (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) + ((const) (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) + ((maybe-null) (lp (next) free? const? #t ptr? struct? link? result? array value default?)) + ((pointer) (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) + ((struct) (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) + ((link) (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) + ((result) (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) + ((array) (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) + ((value) (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) + ((default) (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) + (else (proc type free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) + +(define (parse-type type . o) + (with-parsed-type type make-type (and (pair? o) (car o)))) +(define (maybe-parse-type type) + (if (vector? type) type (parse-type type))) + +(define (type-base type) (vector-ref (maybe-parse-type type) 0)) +(define (type-free type) (vector-ref (maybe-parse-type type) 1)) +(define (type-const type) (vector-ref (maybe-parse-type type) 2)) +(define (type-null? type) (vector-ref (maybe-parse-type type) 3)) +(define (type-pointer? type) (vector-ref (maybe-parse-type type) 4)) +(define (type-struct? type) (vector-ref (maybe-parse-type type) 5)) +(define (type-link? type) (vector-ref (maybe-parse-type type) 6)) +(define (type-result? type) (vector-ref (maybe-parse-type type) 7)) +(define (type-array type) (vector-ref (maybe-parse-type type) 8)) +(define (type-value type) (vector-ref (maybe-parse-type type) 9)) +(define (type-default? type) (vector-ref (maybe-parse-type type) 10)) +(define (type-index type) (vector-ref (maybe-parse-type type) 11)) + (define (cat . args) (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) @@ -125,27 +298,10 @@ funcs)) #f))) -(define (with-parsed-type type proc) - (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) - (pointer? #f) (struct? #f) (link? #f) (result? #f)) - (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) - (case (and (pair? type) (car type)) - ((free) (lp (next) #t const? null-ptr? pointer? struct? link? result?)) - ((const) (lp (next) free? #t null-ptr? pointer? struct? link? result?)) - ((maybe-null) (lp (next) free? const? #t pointer? struct? link? result?)) - ((pointer) (lp (next) free? const? null-ptr? #t struct? link? result?)) - ((struct) (lp (next) free? const? null-ptr? pointer? #t link? result?)) - ((link) (lp (next) free? const? null-ptr? pointer? struct? #t result?)) - ((result) (lp (next) free? const? null-ptr? pointer? struct? link? #t)) - (else (proc type free? const? null-ptr? pointer? struct? link? result?))))) - -(define (get-base-type type) - (with-parsed-type type (lambda (x . args) x))) - (define (c->scheme-converter type val . o) (with-parsed-type type - (lambda (type free? const? null-ptr? pointer? struct? link? result?) + (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond ((eq? type 'void) (cat "((" val "), SEXP_VOID)")) @@ -174,9 +330,9 @@ (define (scheme->c-converter type val) (with-parsed-type type - (lambda (type free? const? null-ptr? pointer? struct? link? result?) + (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond - ((eq? 'sexp type) + ((eq? type 'sexp) (cat val)) ((eq? type 'time_t) (cat "sexp_uint_value(sexp_unshift_epoch(" val "))")) @@ -200,7 +356,7 @@ (define (type-predicate type) (with-parsed-type type - (lambda (type free? const? null-ptr? pointer? struct? link? result?) + (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond ((int-type? type) "sexp_exact_integerp") ((float-type? type) "sexp_flonump") @@ -210,7 +366,7 @@ (define (type-name type) (with-parsed-type type - (lambda (type free? const? null-ptr? pointer? struct? link? result?) + (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond ((int-type? type) "integer") ((float-type? type) "flonum") @@ -219,19 +375,19 @@ (define (type-c-name type) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (let ((struct? (assq base-type types))) (string-append (if const? "const " "") (if struct? "struct " "") (string-replace (symbol->string base-type) #\- #\space) (if struct? "*" "") - (if pointer? "*" "")))))) + (if ptr? "*" "")))))) (define (check-type arg type) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type)) (cat (type-predicate type) "(" arg ")")) @@ -252,7 +408,7 @@ (define (validate-type arg type) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type)) (cat @@ -289,6 +445,109 @@ (lp (cdr ls) (cons (car ls) res))) (reverse res)))) +(define (with-parsed-func func proc) + (let* ((ret-type (parse-type (cadr func))) + (scheme-name (if (pair? (caddr func)) (caaddr func) (caddr func))) + (c-name (if (pair? (caddr func)) + (cadr (caddr func)) + (mangle scheme-name)))) + (let lp ((ls (cadddr func)) + (i 0) + (results '()) + (c-args '()) + (s-args '())) + (cond + ((null? ls) + (proc scheme-name c-name ret-type + (reverse results) (reverse c-args) (reverse s-args))) + (else + (let ((type (parse-type (car ls) i))) + (cond + ((type-result? type) + (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) + ((type-value type) + (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) + (else + (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) + ))))))) + +(define (write-parameters args) + (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) + +(define (write-locals func) + (with-parsed-func func + (lambda (scheme-name c-name ret-type results c-args scheme-args) + (cat " sexp res;\n")))) + +(define (write-validators args) + (for-each + (lambda (a) + (validate-type (string-append "arg" (number->string (type-index arg))) a)) + args)) + +(define (write-temporaries func) + #f) + +(define (write-call ret-type c-name c-args) + (cat (if (eq? 'errno (type-base ret-type)) " err = " " res = ")) + (c->scheme-converter + ret-type + (lambda () + (cat c-name "(") + (for-each + (lambda (arg) + (if (> (type-index arg) 0) (cat ", ")) + (cond + ((type-result? arg) + (cat (if (or (type-pointer? result) (type-array result)) "" "&") + "tmp")) + ((type-value arg) + => (lambda (x) (write x))) + (else + (scheme->c-converter arg (string-append "arg" (type-index arg)))))) + c-args) + (cat ");\n")))) + +(define (write-result result) + (if (type-array (car result)) + (cat " sexp_gc_preserve1(ctx, res);\n" + " res = SEXP_NULL;\n" + " for (i=" (type-array (car result)) "-1; i>=0; i--) {\n" + " sexp_push(ctx, res, SEXP_VOID);\n" + " sexp_car(res) = " + (lambda () (c->scheme-converter (car result) "tmp[i]")) ";\n" + " }\n" + " sexp_gc_release1(ctx);\n") + (c->scheme-converter (car result) "tmp"))) + +(define (write-results ret-type results) + (if (eq? 'errno (type-base ret-type)) + (cat " if (err) {\n" + " res = SEXP_FALSE;\n" + " } else {\n")) + (if (null? results) + (cat " res = SEXP_TRUE;\n") + (for-each write-result results)) + (if (eq? 'errno (type-base ret-type)) + (cat " }\n"))) + +(define (write-cleanup func) + #f) + +(define (write-func func) + (with-parsed-func func + (lambda (scheme-name c-name ret-type results c-args scheme-args) + (cat "static sexp " scheme-name + "(sexp ctx" (write-parameters scheme-args) ") {\n" + (write-locals func) + (write-validators scheme-args) + (write-temporaries func) + (write-call ret-type c-name c-args) + (write-result ret-type results) + (write-cleanup func) + " return res;\n" + "}\n\n")))) + (define (write-func func) (let ((ret-type (cadr func)) (result (get-func-result func)) @@ -298,9 +557,19 @@ (cond ((pair? ls) (cat ", sexp arg" i) (lp (cdr ls) (+ i 1))))) - (cat ") {\n sexp res;\n") + (cat ") {\n " + (if (and result (type-array result)) "sexp_gc_var1(res)" "sexp res") + ";\n") (if (eq? 'errno ret-type) (cat " int err;\n")) - (if result (cat " " (type-c-name result) " tmp;\n")) + (if (type-array result) (cat " int i;\n")) + (if result + (cat " " (type-c-name result) (if (type-pointer? result) "*" "") + " tmp" + (if (type-array result) + (with-output-to-string + (lambda () (cat "[" (type-array result) "]"))) + "") + ";\n")) (let lp ((ls args) (i 0)) (cond ((pair? ls) (validate-type (string-append "arg" (number->string i)) (car ls)) @@ -314,7 +583,11 @@ (cond ((pair? ls) (cat (cond ((eq? (car ls) result) - "&tmp") + (lambda () (cat (if (or (type-pointer? result) + (type-array result)) + "" + "&") + "tmp"))) ((and (pair? (car ls)) (memq 'value (car ls))) => (lambda (x) (write (cadr x)) "")) (else @@ -328,9 +601,22 @@ (cat ";\n") (if (eq? 'errno ret-type) (if result - (cat " res = (err ? SEXP_FALSE : " - (lambda () (c->scheme-converter result "tmp")) - ");\n") + (if (type-array result) + (cat " if (err) {\n" + " res = SEXP_FALSE;\n" + " } else {\n" + " sexp_gc_preserve1(ctx, res);\n" + " res = SEXP_NULL;\n" + " for (i=" (type-array result) "-1; i>=0; i--) {\n" + " sexp_push(ctx, res, SEXP_VOID);\n" + " sexp_car(res) = " + (lambda () (c->scheme-converter result "tmp[i]")) ";\n" + " }\n" + " sexp_gc_release1(ctx);\n" + " }\n") + (cat " res = (err ? SEXP_FALSE : " + (lambda () (c->scheme-converter result "tmp")) + ");\n")) (cat " res = sexp_make_boolean(! err);\n"))) (cat " return res;\n" "}\n\n"))) @@ -345,7 +631,7 @@ (type (cdr type))) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" " " (type-id-name name) " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, " @@ -364,12 +650,12 @@ (define (type-getter-name type name field) (string-append "sexp_" (x->string (type-name name)) - "_get_" (x->string (get-base-type (cadr field))))) + "_get_" (x->string (type-base (cadr field))))) (define (write-type-getter type name field) (with-parsed-type (car field) - (lambda (field-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (field-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cat "static sexp " (type-getter-name type name field) " (sexp ctx, sexp x) {\n" (lambda () (validate-type "x" name)) @@ -387,12 +673,12 @@ (define (type-setter-name type name field) (string-append "sexp_" (x->string (type-name name)) - "_set_" (x->string (get-base-type (car field))))) + "_set_" (x->string (type-base (car field))))) (define (write-type-setter type name field) (with-parsed-type (car field) - (lambda (field-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (field-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cat "static sexp " (type-setter-name type name field) " (sexp ctx, sexp x, sexp v) {\n" (lambda () (validate-type "x" name)) @@ -413,7 +699,7 @@ (type (cdr type))) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond ((memq 'finalizer: base-type) => (lambda (x) From e93c1b14838a000da7ed4357d7cd322736ca14b6 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 21 Dec 2009 16:17:37 +0900 Subject: [PATCH 268/535] adding heap-dump utility for outputting the contents of the heap --- lib/chibi/heap-stats.c | 63 +++++++++++++++++++++++++++++++++++-- lib/chibi/heap-stats.module | 2 +- 2 files changed, 61 insertions(+), 4 deletions(-) diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c index f2f22df1..8b928fe4 100644 --- a/lib/chibi/heap-stats.c +++ b/lib/chibi/heap-stats.c @@ -1,6 +1,8 @@ #include +#define SEXP_HEAP_VECTOR_DEPTH 1 + #if SEXP_64_BIT #define sexp_heap_align(n) sexp_align(n, 5) #else @@ -10,15 +12,55 @@ extern sexp sexp_gc (sexp ctx, size_t *sum_freed); extern sexp_uint_t sexp_allocated_bytes (sexp x); -static sexp sexp_heap_stats (sexp ctx) { +static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { + int i; + if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x) + || sexp_flonump(x) || sexp_bignump(x)) { + sexp_write(ctx, x, out); + } else if (depth <= 0) { + goto print_name; + } else if (sexp_synclop(x)) { + sexp_write_string(ctx, "#", out); + } else if (sexp_pairp(x)) { + sexp_write_char(ctx, '(', out); + sexp_print_simple(ctx, sexp_car(x), out, depth-1); + sexp_write_string(ctx, " . ", out); + sexp_print_simple(ctx, sexp_cdr(x), out, depth-1); + sexp_write_char(ctx, ')', out); + } else if (sexp_vectorp(x)) { + sexp_write_string(ctx, "#(", out); + for (i=0; i0) + sexp_write_char(ctx, ' ', out); + sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); + } + if (i", out); + } +} + +static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { size_t freed; sexp_uint_t stats[256], hi_type=0, i; sexp_heap h = sexp_context_heap(ctx); - sexp p; + sexp p, out=SEXP_FALSE; sexp_free_list q, r; char *end; sexp_gc_var3(res, tmp, name); + if (printp) + out = sexp_env_global_ref(sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + SEXP_FALSE); + /* run gc once to remove unused variables */ sexp_gc(ctx, &freed); @@ -38,7 +80,11 @@ static sexp sexp_heap_stats (sexp ctx) { p = (sexp) (((char*)p) + r->size); continue; } - /* otherwise increment the stat and continue */ + /* otherwise maybe print, then increment the stat and continue */ + if (sexp_oportp(out)) { + sexp_print_simple(ctx, p, out, depth); + sexp_write_char(ctx, '\n', out); + } stats[sexp_pointer_tag(p)]++; if (sexp_pointer_tag(p) > hi_type) hi_type = sexp_pointer_tag(p); @@ -59,8 +105,19 @@ static sexp sexp_heap_stats (sexp ctx) { return res; } +static sexp sexp_heap_stats (sexp ctx) { + return sexp_heap_walk(ctx, 0, 0); +} + +static sexp sexp_heap_dump (sexp ctx, sexp depth) { + if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) + return sexp_type_exception(ctx, "bad heap-dump depth", depth); + return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); +} + sexp sexp_init_library (sexp ctx, sexp env) { sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats); + sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE); return SEXP_VOID; } diff --git a/lib/chibi/heap-stats.module b/lib/chibi/heap-stats.module index 24be3e9b..af84ca44 100644 --- a/lib/chibi/heap-stats.module +++ b/lib/chibi/heap-stats.module @@ -1,5 +1,5 @@ (define-module (chibi heap-stats) - (export heap-stats) + (export heap-stats heap-dump) (include-shared "heap-stats")) From 6da435d21cb220a6d9bd0c2aab0e3ff8969965d3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 22 Dec 2009 22:33:53 +0900 Subject: [PATCH 269/535] at great pains, the stubber can generate (ugly) code for getcwd --- include/chibi/sexp.h | 8 +- lib/chibi/posix.module | 2 +- lib/chibi/posix.stub | 8 +- sexp.c | 13 +- tools/genstubs.scm | 1183 ++++++++++++++++++++++++---------------- 5 files changed, 731 insertions(+), 483 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 03a2e631..30c542bd 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -823,11 +823,9 @@ SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots); SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp obj); #define sexp_register_c_type(ctx, name, finalizer) \ - sexp_register_type(ctx, name, sexp_make_fixnum(0), sexp_make_fixnum(0), \ - sexp_make_fixnum(0), sexp_make_fixnum(0), \ - sexp_make_fixnum(0), \ - sexp_make_fixnum(sexp_sizeof(cpointer)), \ - sexp_make_fixnum(0), sexp_make_fixnum(0), finalizer) + sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ + SEXP_ZERO, SEXP_ZERO, finalizer) #endif #define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) diff --git a/lib/chibi/posix.module b/lib/chibi/posix.module index aba6b7ff..af726ff4 100644 --- a/lib/chibi/posix.module +++ b/lib/chibi/posix.module @@ -4,7 +4,7 @@ delete-file link-file symbolic-link-file rename-file directory-files create-directory delete-directory current-seconds - exit + waitpid exit ) (import-immutable (scheme)) (include-shared "posix") diff --git a/lib/chibi/posix.stub b/lib/chibi/posix.stub index 7c1a6c9f..03d4f981 100644 --- a/lib/chibi/posix.stub +++ b/lib/chibi/posix.stub @@ -1,5 +1,6 @@ (c-system-include "sys/types.h") +(c-system-include "sys/wait.h") (c-system-include "time.h") (c-system-include "unistd.h") (c-system-include "dirent.h") @@ -18,7 +19,8 @@ (define-c errno (symbolic-link-file "symlink") (string string)) (define-c errno (rename-file "rename") (string string)) -;;(define-c string (current-directory "getcwd") ((value (array char)) int)) +(define-c non-null-string (current-directory "getcwd") + ((result (array char (auto-expand arg1))) (value 256 int))) (define-c errno (create-directory "mkdir") (string int)) (define-c errno (delete-directory "rmdir") (string)) @@ -28,9 +30,9 @@ (define-c int (duplicate-fd "dup") (int)) (define-c pid_t fork ()) -;; (define-c pid_t wait ((result pointer int))) +(define-c pid_t waitpid (int (result int) int)) (define-c void exit (int)) -(define-c int (execute execvp) (string (array string null))) +(define-c int (execute execvp) (string (array string))) (define-c errno pipe ((result (array int 2)))) diff --git a/sexp.c b/sexp.c index aad2b3b0..61b9a417 100644 --- a/sexp.c +++ b/sexp.c @@ -837,8 +837,12 @@ sexp sexp_get_output_string (sexp ctx, sexp port) { #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); + FILE *in; + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "open-input-string: not a string", str); + in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + res = sexp_make_input_port(ctx, in, SEXP_FALSE); sexp_port_cookie(res) = str; /* for gc preservation */ return res; } @@ -916,7 +920,10 @@ sexp sexp_buffered_flush (sexp ctx, sexp p) { } sexp sexp_make_input_string_port (sexp ctx, sexp str) { - sexp res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "open-input-string: not a string", str); + res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); if (sexp_exceptionp(res)) return res; sexp_port_cookie(res) = str; sexp_port_buf(res) = sexp_string_data(str); diff --git a/tools/genstubs.scm b/tools/genstubs.scm index ae7c8201..baa3b741 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -1,5 +1,8 @@ #! chibi-scheme -s +;; Note: this evolved as a throw-away script to provide certain core +;; modules, and so is a mess. Tread carefully. + ;; Simple C FFI. "genstubs.scm file.stub" will read in the C function ;; FFI definitions from file.stub and output the appropriate C ;; wrappers into file.c. You can then compile that file with: @@ -52,10 +55,11 @@ ;; void ;; boolean ;; char +;; sexp (no conversions) ;; ;; Integer Types: -;; short int long -;; unsigned-short unsigned-int unsigned-long size_t pid_t +;; signed-char short int long +;; unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t ;; time_t (in seconds, but using the chibi epoch of 2010/01/01) ;; errno (as a return type returns #f on error) ;; @@ -63,7 +67,9 @@ ;; float double long-double ;; ;; String Types: -;; string (a null-terminated char*) +;; string - a null-terminated char* +;; env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme +;; in addition you can use (array char) as a string ;; ;; Port Types: ;; input-port output-port @@ -129,52 +135,137 @@ ;; ** the symbol null, indicating a NULL-terminated array ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; globals -(define types '()) -(define funcs '()) +(define *types* '()) +(define *funcs* '()) -(define (make-type type free? const? null? ptr? struct? link? result? array value default? i) - (vector type free? const? null? ptr? struct? link? result? array value default? i)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type objects -(define (with-parsed-type type proc . o) +(define (parse-type type . o) (cond ((vector? type) - (apply proc (vector->list type))) + type) (else (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f) (value #f) (default? #f)) (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) (case (and (pair? type) (car type)) - ((free) (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) - ((const) (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) - ((maybe-null) (lp (next) free? const? #t ptr? struct? link? result? array value default?)) - ((pointer) (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) - ((struct) (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) - ((link) (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) - ((result) (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) - ((array) (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) - ((value) (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) - ((default) (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) - (else (proc type free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) + ((free) + (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) + ((const) + (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) + ((maybe-null) + (lp (next) free? const? #t ptr? struct? link? result? array value default?)) + ((pointer) + (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) + ((struct) + (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) + ((link) + (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) + ((result) + (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) + ((array) + (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) + ((value) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) + ((default) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) + (else + (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) -(define (parse-type type . o) - (with-parsed-type type make-type (and (pair? o) (car o)))) -(define (maybe-parse-type type) - (if (vector? type) type (parse-type type))) +(define (type-base type) (vector-ref type 0)) +(define (type-free? type) (vector-ref type 1)) +(define (type-const? type) (vector-ref type 2)) +(define (type-null? type) (vector-ref type 3)) +(define (type-pointer? type) (vector-ref type 4)) +(define (type-struct? type) (vector-ref type 5)) +(define (type-link? type) (vector-ref type 6)) +(define (type-result? type) (vector-ref type 7)) +(define (type-array type) (vector-ref type 8)) +(define (type-value type) (vector-ref type 9)) +(define (type-default? type) (vector-ref type 10)) +(define (type-index type) (vector-ref type 11)) -(define (type-base type) (vector-ref (maybe-parse-type type) 0)) -(define (type-free type) (vector-ref (maybe-parse-type type) 1)) -(define (type-const type) (vector-ref (maybe-parse-type type) 2)) -(define (type-null? type) (vector-ref (maybe-parse-type type) 3)) -(define (type-pointer? type) (vector-ref (maybe-parse-type type) 4)) -(define (type-struct? type) (vector-ref (maybe-parse-type type) 5)) -(define (type-link? type) (vector-ref (maybe-parse-type type) 6)) -(define (type-result? type) (vector-ref (maybe-parse-type type) 7)) -(define (type-array type) (vector-ref (maybe-parse-type type) 8)) -(define (type-value type) (vector-ref (maybe-parse-type type) 9)) -(define (type-default? type) (vector-ref (maybe-parse-type type) 10)) -(define (type-index type) (vector-ref (maybe-parse-type type) 11)) +(define (type-auto-expand? type) + (and (pair? (type-array type)) + (memq 'auto-expand (type-array type)))) + +(define (type-index-string type) + (if (integer? (type-index type)) + (number->string (type-index type)) + "")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type predicates + +(define (signed-int-type? type) + (memq type '(signed-char short int long))) + +(define (unsigned-int-type? type) + (memq type '(unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t))) + +(define (int-type? type) + (or (signed-int-type? type) (unsigned-int-type? type))) + +(define (float-type? type) + (memq type '(float double long-double long-long-double))) + +(define (string-type? type) + (memq type '(char* string env-string non-null-string))) + +(define (error-type? type) + (memq type '(errno non-null-string))) + +(define (array-type? type) + (and (type-array type) (not (eq? 'char (type-base type))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; function objects + +(define (parse-func func) + (let* ((ret-type (parse-type (car func))) + (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) + (c-name (if (pair? (cadr func)) + (cadadr func) + (mangle scheme-name))) + (stub-name (if (and (pair? (cadr func)) (pair? (cddadr func))) + (car (cddadr func)) + (generate-stub-name scheme-name)))) + (let lp ((ls (caddr func)) + (i 0) + (results '()) + (c-args '()) + (s-args '())) + (cond + ((null? ls) + (if (>= i 6) + (error "FFI currently only supports up to 6 scheme args" func)) + (vector scheme-name c-name stub-name ret-type + (reverse results) (reverse c-args) (reverse s-args))) + (else + (let ((type (parse-type (car ls) i))) + (cond + ((type-result? type) + (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) + ((type-value type) + (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) + (else + (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) + ))))))) + +(define (func-scheme-name func) (vector-ref func 0)) +(define (func-c-name func) (vector-ref func 1)) +(define (func-stub-name func) (vector-ref func 2)) +(define (func-ret-type func) (vector-ref func 3)) +(define (func-results func) (vector-ref func 4)) +(define (func-c-args func) (vector-ref func 5)) +(define (func-scheme-args func) (vector-ref func 6)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities (define (cat . args) (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) @@ -185,6 +276,16 @@ ((number? x) (number->string x)) (else (error "non-stringable object" x)))) +(define (filter pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (cons (car ls) (filter pred (cdr ls)))) + (else (filter pred (cdr ls))))) + +(define (remove pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (filter pred (cdr ls))) + (else (cons (car ls) (filter pred (cdr ls)))))) + (define (strip-extension path) (let lp ((i (- (string-length path) 1))) (cond ((<= i 0) path) @@ -207,11 +308,6 @@ (else (lp from (+ i 1) res)))))) -(define (mangle x) - (string-replace - (string-replace (string-replace (x->string x) #\- "_") #\? "_p") - #\! "_x")) - (define (string-scan c str . o) (let ((limit (string-length str))) (let lp ((i (if (pair? o) (car o) 0))) @@ -250,32 +346,22 @@ (else (if (consonant-exception? str) "an " "a "))) full-str))) -(define (func-name func) - (caddr func)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; naming -(define (func-scheme-name x) - (if (pair? x) (car x) x)) +(define (mangle x) + (string-replace + (string-replace (string-replace (x->string x) #\- "_") #\? "_p") + #\! "_x")) -(define (func-c-name x) - (if (pair? x) (cadr x) x)) - -(define (stub-name sym) +(define (generate-stub-name sym) (string-append "sexp_" (mangle sym) "_stub")) (define (type-id-name sym) (string-append "sexp_" (mangle sym) "_type_id")) -(define (signed-int-type? type) - (memq type '(short int long))) - -(define (unsigned-int-type? type) - (memq type '(unsigned-short unsigned-int unsigned-long size_t pid_t))) - -(define (int-type? type) - (or (signed-int-type? type) (unsigned-int-type? type))) - -(define (float-type? type) - (memq type '(float double long-double))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; .stub file interface (define (c-declare . args) (apply cat args) @@ -287,479 +373,632 @@ (define-syntax define-c-struct (er-macro-transformer (lambda (expr rename compare) - (set! types (cons (cdr expr) types)) + (set! *types* + (cons (map (lambda (x) + (if (pair? x) + (cons (parse-type (car x)) (cdr x)) + x)) + (cdr expr)) + *types*)) `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) (define-syntax define-c (er-macro-transformer (lambda (expr rename compare) - (set! funcs (cons (cons (stub-name (func-scheme-name (caddr expr))) - (cdr expr)) - funcs)) + (set! *funcs* (cons (parse-func (cdr expr)) *funcs*)) #f))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; C code generation + (define (c->scheme-converter type val . o) - (with-parsed-type - type - (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i) - (cond - ((eq? type 'void) - (cat "((" val "), SEXP_VOID)")) - ((memq type '(sexp errno)) - (cat val)) - ((eq? type 'time_t) - (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) - ((int-type? type) - (cat "sexp_make_integer(ctx, " val ")")) - ((eq? 'string type) - (cat "sexp_c_string(ctx, " val ", -1)")) - ((eq? 'input-port type) - (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)")) - ((eq? 'output-port type) - (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) - (else - (let ((ctype (assq type types))) - (cond - (ctype - (cat "sexp_make_cpointer(ctx, " (type-id-name type) ", " - val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " - (if free? 1 0) ")")) - (else - (error "unknown type" type))))))))) + (let ((base (type-base type))) + (cond + ((eq? base 'void) + (cat "((" val "), SEXP_VOID)")) + ((or (eq? base 'sexp) (error-type? base)) + (cat val)) + ((eq? base 'time_t) + (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) + ((int-type? base) + (cat "sexp_make_integer(ctx, " val ")")) + ((eq? base 'char) + (if (type-array type) + (cat "sexp_c_string(ctx, " val ", -1)") + (cat "sexp_make_character(ctx, " val ")"))) + ((eq? 'env-string base) + (cat "(p=strchr(" val ", '=') ? " + "sexp_cons(ctx, str=sexp_c_string(ctx, " val ", p - " val "), str=sexp_c_string(ctx, p, -1))" + " : sexp_cons(ctx, str=" val ", SEXP_FALSE)")) + ((string-type? base) + (cat "sexp_c_string(ctx, " val ", -1)")) + ((eq? 'input-port base) + (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)")) + ((eq? 'output-port base) + (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) + (else + (let ((ctype (assq base *types*))) + (cond + (ctype + (cat "sexp_make_cpointer(ctx, " (type-id-name base) ", " + val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " + (if (type-free? type) 1 0) ")")) + (else + (error "unknown type" base)))))))) (define (scheme->c-converter type val) - (with-parsed-type - type - (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i) - (cond - ((eq? type 'sexp) - (cat val)) - ((eq? type 'time_t) - (cat "sexp_uint_value(sexp_unshift_epoch(" val "))")) - ((signed-int-type? type) - (cat "sexp_sint_value(" val ")")) - ((unsigned-int-type? type) - (cat "sexp_uint_value(" val ")")) - ((eq? 'string type) - (cat "sexp_string_data(" val ")")) - (else - (let ((ctype (assq type types))) - (cond - (ctype - (cat (if null-ptr? - "sexp_cpointer_maybe_null_value" - "sexp_cpointer_value") - "(" val ")")) - (else - (error "unknown type" type))))))))) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'sexp) + (cat val)) + ((eq? base 'time_t) + (cat "sexp_uint_value(sexp_unshift_epoch(" val "))")) + ((signed-int-type? base) + (cat "sexp_sint_value(" val ")")) + ((unsigned-int-type? base) + (cat "sexp_uint_value(" val ")")) + ((eq? base 'char) + (cat "sexp_unbox_character(" val ")")) + ((eq? base 'env-string) + (cat "sexp_concat_env_string(" val ")")) + ((string-type? base) + (cat "sexp_string_data(" val ")")) + (else + (let ((ctype (assq base *types*))) + (cond + (ctype + (cat (if (type-null? type) + "sexp_cpointer_maybe_null_value" + "sexp_cpointer_value") + "(" val ")")) + (else + (error "unknown type" base)))))))) (define (type-predicate type) - (with-parsed-type - type - (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i) - (cond - ((int-type? type) "sexp_exact_integerp") - ((float-type? type) "sexp_flonump") - ((eq? 'string type) "sexp_stringp") - (else #f))))) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "sexp_exact_integerp") + ((float-type? base) "sexp_flonump") + ((string-type? base) "sexp_stringp") + ((eq? base 'char) "sexp_charp") + (else #f)))) (define (type-name type) - (with-parsed-type - type - (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i) - (cond - ((int-type? type) "integer") - ((float-type? type) "flonum") - (else type))))) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "integer") + ((float-type? base) "flonum") + (else base)))) + +(define (base-type-c-name base) + (case base + ((string env-string non-null-string) "char*") + (else (symbol->string base)))) (define (type-c-name type) - (with-parsed-type - type - (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) - (let ((struct? (assq base-type types))) - (string-append - (if const? "const " "") - (if struct? "struct " "") - (string-replace (symbol->string base-type) #\- #\space) - (if struct? "*" "") - (if ptr? "*" "")))))) + (let* ((type (parse-type type)) + (base (type-base type)) + (struct? (assq base *types*))) + (string-append + (if (type-const? type) "const " "") + (if struct? "struct " "") + (string-replace (base-type-c-name base) #\- " ") + (if struct? "*" "") + (if (type-pointer? type) "*" "")))) (define (check-type arg type) - (with-parsed-type - type - (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) - (cond - ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type)) - (cat (type-predicate type) "(" arg ")")) - (else - (cond - ((assq base-type types) - (cat - (if null-ptr? "(" "") - "(sexp_pointerp(" arg ")" - " && (sexp_pointer_tag(" arg ") == " (type-id-name base-type) "))" - (lambda () (if null-ptr? (cat " || sexp_not(" arg "))"))))) - (else - (display "WARNING: don't know how to check: " (current-error-port)) - (write type (current-error-port)) - (newline (current-error-port)) - (cat "1")))))))) - -(define (validate-type arg type) - (with-parsed-type - type - (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) - (cond - ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type)) - (cat - " if (! " (lambda () (check-type arg type)) ")\n" - " return sexp_type_exception(ctx, \"not " - (definite-article (type-name type)) "\", " - arg ");\n")) - (else - (cond - ((assq base-type types) - (cat - " if (! " (lambda () (check-type arg type)) ")\n" - " return sexp_type_exception(ctx, \"not " - (definite-article type) "\", " arg ");\n")) - (else - (display "WARNING: don't know how to validate: " (current-error-port)) - (write type (current-error-port)) - (newline (current-error-port)) - (write type)))))))) - -(define (get-func-result func) - (let lp ((ls (cadddr func))) - (and (pair? ls) - (if (memq 'result (car ls)) - (car ls) - (lp (cdr ls)))))) - -(define (get-func-args func) - (let lp ((ls (cadddr func)) (res '())) - (if (pair? ls) - (if (and (pair? (car ls)) - (or (memq 'result (car ls)) (memq 'value (car ls)))) - (lp (cdr ls) res) - (lp (cdr ls) (cons (car ls) res))) - (reverse res)))) - -(define (with-parsed-func func proc) - (let* ((ret-type (parse-type (cadr func))) - (scheme-name (if (pair? (caddr func)) (caaddr func) (caddr func))) - (c-name (if (pair? (caddr func)) - (cadr (caddr func)) - (mangle scheme-name)))) - (let lp ((ls (cadddr func)) - (i 0) - (results '()) - (c-args '()) - (s-args '())) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'env-string) + (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg + ")) && sexp_stringp(sexp_cdr(" arg ")))")) + ((or (int-type? base) (float-type? base) (string-type? base)) + (cat (type-predicate type) "(" arg ")")) + (else (cond - ((null? ls) - (proc scheme-name c-name ret-type - (reverse results) (reverse c-args) (reverse s-args))) + ((assq base *types*) + (cat + (if (type-null? type) "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " (type-id-name base) "))" + (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) (else - (let ((type (parse-type (car ls) i))) - (cond - ((type-result? type) - (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) - ((type-value type) - (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) - (else - (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) - ))))))) + (display "WARNING: don't know how to check: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (cat "1"))))))) + +(define (write-validator arg type) + (let* ((type (parse-type type)) + (array (type-array type)) + (base-type (type-base type))) + (cond + (array + (cond + ((number? array) + (cat " if (!sexp_listp(ctx, " arg ")" + " || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n" + " return sexp_type_exception(ctx, \"not a list\", " arg ");\n"))) + (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" + " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" + " return sexp_type_exception(ctx, \"not a list of " + (type-name type) "s\", " arg ");\n") + (if (not (number? array)) + (cat " if (! sexp_nullp(res))\n" + " return sexp_type_exception(ctx, \"not a list of " + (type-name type) "s\", " arg ");\n"))) + ((or (int-type? base-type) + (float-type? base-type) + (string-type? base-type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, \"not " + (definite-article (type-name type)) "\", " + arg ");\n")) + (else + (cond + ((assq base-type *types*) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, \"not " + (definite-article (type-name type)) "\", " arg ");\n")) + (else + (if (not (eq? 'sexp (type-base type))) + (display "WARNING: don't know how to validate: " (current-error-port))) + (write type (current-error-port)) + (newline (current-error-port)) + (write type))))))) (define (write-parameters args) (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) +(define (get-array-length func x) + (let ((len (if (pair? (type-array x)) + (car (reverse (type-array x))) + (type-array x)))) + (if (number? len) + len + (and (symbol? len) + (let* ((str (symbol->string len)) + (len (string-length str))) + (and (> len 3) + (string=? "arg" (substring str 0 3)) + (let ((i (string->number (substring str 3 len)))) + (if i + (let ((y (list-ref (func-c-args func) i))) + (or (type-value y) y)))))))))) + (define (write-locals func) - (with-parsed-func func - (lambda (scheme-name c-name ret-type results c-args scheme-args) - (cat " sexp res;\n")))) + (define (arg-res x) + (string-append "res" (type-index-string x))) + (let* ((ret-type (func-ret-type func)) + (results (func-results func)) + (scheme-args (func-scheme-args func)) + (return-res? (not (error-type? (type-base ret-type)))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons ret-type results))) + (gc-vars (map arg-res results)) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (sexps (if preserve-res? '() '("res"))) + (num-gc-vars (length gc-vars)) + (ints (if (or return-res? (eq? 'non-null-string (type-base ret-type))) + '() + '("err"))) + (ints (if (or (array-type? ret-type) + (any array-type? results) + (any array-type? scheme-args)) + (cons "i" ints) + ints))) + (if(eq? 'non-null-string (type-base ret-type)) + (cat " char *err;\n")) + (cond + ((pair? ints) + (cat " int " (car ints)) + (for-each (lambda (x) (display ", ") (display x)) (cdr ints)) + (cat ";\n"))) + (if (any (lambda (a) (eq? 'env-string (type-base a))) + (cons ret-type results)) + (cat " char *p;\n")) + (for-each + (lambda (x) + (let ((len (get-array-length func x))) + (cat " " (type-c-name (type-base x)) " ") + (if (or (type-pointer? x) (and (type-array x) (not (number? len)))) + (cat "*")) + (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) + (if (number? len) + (cat "[" len "]")) + (cat ";\n") + (if (or (vector? len) (type-auto-expand? x)) + (cat " int len" (type-index x) ";\n")) + (if (type-auto-expand? x) + (cat " " (type-c-name (type-base x)) + " *tmp" (type-index-string x) ";\n")))) + (append (if (type-array ret-type) (list ret-type) '()) + results + (remove type-result? (filter type-array scheme-args)))) + (cond + ((pair? sexps) + (cat " sexp " (car sexps)) + (for-each (lambda (x) (display ", ") (display x)) (cdr sexps)) + (cat ";\n"))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_var" num-gc-vars "(") + (display (car gc-vars)) + (for-each (lambda (x) (display ", ") (display x)) (cdr gc-vars)) + (cat ");\n") + (cat " sexp_gc_preserve" num-gc-vars "(ctx") + (for-each (lambda (x) (display ", ") (display x)) gc-vars) + (cat ");\n"))))) (define (write-validators args) (for-each (lambda (a) - (validate-type (string-append "arg" (number->string (type-index arg))) a)) + (write-validator (string-append "arg" (type-index-string a)) a)) args)) (define (write-temporaries func) - #f) + (for-each + (lambda (a) + (let ((len (and (type-array a) (get-array-length func a)))) + (cond + ((and (type-array a) (or (vector? len) (type-auto-expand? a))) + (cat " len" (type-index a) " = " + (lambda () + (if (number? len) (cat len) (scheme->c-converter 'int len))) + ";\n" + " tmp" (type-index a) " = buf" (type-index a) ";\n")))) + (cond + ((and (not (type-result? a)) (type-array a)) + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) + " = (" (type-c-name (type-base a)) "*) malloc(" + "(sexp_unbox_fixnum(sexp_length(ctx, arg" (type-index a) + "))+1) * sizeof(tmp" (type-index a) "[0]));\n")) + (cat " for (i=0, res=arg" (type-index a) + "; sexp_pairp(res); res=sexp_cdr(res), i++) {\n" + " tmp" (type-index a) "[i] = " + (lambda () (scheme->c-converter (type-base a) "sexp_car(res)")) + ";\n" + " }\n") + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) "[i] = NULL;\n"))))) + (func-c-args func))) -(define (write-call ret-type c-name c-args) - (cat (if (eq? 'errno (type-base ret-type)) " err = " " res = ")) - (c->scheme-converter - ret-type - (lambda () - (cat c-name "(") - (for-each - (lambda (arg) - (if (> (type-index arg) 0) (cat ", ")) - (cond - ((type-result? arg) - (cat (if (or (type-pointer? result) (type-array result)) "" "&") - "tmp")) - ((type-value arg) - => (lambda (x) (write x))) - (else - (scheme->c-converter arg (string-append "arg" (type-index arg)))))) - c-args) - (cat ");\n")))) - -(define (write-result result) - (if (type-array (car result)) - (cat " sexp_gc_preserve1(ctx, res);\n" - " res = SEXP_NULL;\n" - " for (i=" (type-array (car result)) "-1; i>=0; i--) {\n" - " sexp_push(ctx, res, SEXP_VOID);\n" - " sexp_car(res) = " - (lambda () (c->scheme-converter (car result) "tmp[i]")) ";\n" - " }\n" - " sexp_gc_release1(ctx);\n") - (c->scheme-converter (car result) "tmp"))) - -(define (write-results ret-type results) - (if (eq? 'errno (type-base ret-type)) - (cat " if (err) {\n" - " res = SEXP_FALSE;\n" - " } else {\n")) - (if (null? results) - (cat " res = SEXP_TRUE;\n") - (for-each write-result results)) - (if (eq? 'errno (type-base ret-type)) - (cat " }\n"))) - -(define (write-cleanup func) - #f) - -(define (write-func func) - (with-parsed-func func - (lambda (scheme-name c-name ret-type results c-args scheme-args) - (cat "static sexp " scheme-name - "(sexp ctx" (write-parameters scheme-args) ") {\n" - (write-locals func) - (write-validators scheme-args) - (write-temporaries func) - (write-call ret-type c-name c-args) - (write-result ret-type results) - (write-cleanup func) - " return res;\n" - "}\n\n")))) - -(define (write-func func) - (let ((ret-type (cadr func)) - (result (get-func-result func)) - (args (get-func-args func))) - (cat "static sexp " (car func) "(sexp ctx") - (let lp ((ls args) (i 0)) - (cond ((pair? ls) - (cat ", sexp arg" i) - (lp (cdr ls) (+ i 1))))) - (cat ") {\n " - (if (and result (type-array result)) "sexp_gc_var1(res)" "sexp res") - ";\n") - (if (eq? 'errno ret-type) (cat " int err;\n")) - (if (type-array result) (cat " int i;\n")) - (if result - (cat " " (type-c-name result) (if (type-pointer? result) "*" "") - " tmp" - (if (type-array result) - (with-output-to-string - (lambda () (cat "[" (type-array result) "]"))) - "") - ";\n")) - (let lp ((ls args) (i 0)) - (cond ((pair? ls) - (validate-type (string-append "arg" (number->string i)) (car ls)) - (lp (cdr ls) (+ i 1))))) - (cat (if (eq? 'errno ret-type) " err = " " res = ")) - (c->scheme-converter +(define (write-call func) + (let ((ret-type (func-ret-type func)) + (c-name (func-c-name func)) + (c-args (func-c-args func))) + (if (any type-auto-expand? (func-c-args func)) + (cat " loop:\n")) + (cat (cond ((error-type? (type-base ret-type)) " err = ") + ((type-array ret-type) " tmp = ") + (else " res = "))) + ((if (type-array ret-type) + (lambda (t f) (f)) + c->scheme-converter) ret-type (lambda () - (cat (func-c-name (func-name func)) "(") - (let lp ((ls (cadddr func)) (i 0)) - (cond ((pair? ls) - (cat (cond - ((eq? (car ls) result) - (lambda () (cat (if (or (type-pointer? result) - (type-array result)) - "" - "&") - "tmp"))) - ((and (pair? (car ls)) (memq 'value (car ls))) - => (lambda (x) (write (cadr x)) "")) - (else - (lambda () - (scheme->c-converter - (car ls) - (string-append "arg" (number->string i)))))) - (if (pair? (cdr ls)) ", " "")) - (lp (cdr ls) (+ i 1))))) + (cat c-name "(") + (for-each + (lambda (arg) + (if (> (type-index arg) 0) (cat ", ")) + (cond + ((or (type-result? arg) (type-array arg)) + (cat (if (or (type-pointer? arg) (type-array arg)) "" "&") + "tmp" (type-index arg))) + ((type-value arg) + => (lambda (x) + (cond + ((any (lambda (y) + (and (type-array y) + (eq? x (get-array-length func y)))) + (func-c-args func)) + => (lambda (y) (cat "len" (type-index y)))) + (else (write x))))) + (else + (scheme->c-converter + arg + (string-append "arg" (type-index-string arg)))))) + c-args) (cat ")"))) (cat ";\n") - (if (eq? 'errno ret-type) - (if result - (if (type-array result) - (cat " if (err) {\n" - " res = SEXP_FALSE;\n" - " } else {\n" - " sexp_gc_preserve1(ctx, res);\n" - " res = SEXP_NULL;\n" - " for (i=" (type-array result) "-1; i>=0; i--) {\n" - " sexp_push(ctx, res, SEXP_VOID);\n" - " sexp_car(res) = " - (lambda () (c->scheme-converter result "tmp[i]")) ";\n" - " }\n" - " sexp_gc_release1(ctx);\n" - " }\n") - (cat " res = (err ? SEXP_FALSE : " - (lambda () (c->scheme-converter result "tmp")) - ");\n")) - (cat " res = sexp_make_boolean(! err);\n"))) - (cat " return res;\n" - "}\n\n"))) + (if (type-array ret-type) + (write-result ret-type)))) + +(define (write-result result) + (let ((res (string-append "res" (type-index-string result))) + (tmp (string-append "tmp" (type-index-string result)))) + (cond + ((and (type-array result) (eq? 'char (type-base result))) + (cat " " res " = " (lambda () (c->scheme-converter result tmp)) ";\n")) + ((type-array result) + (cat " " res " = SEXP_NULL;\n") + (let ((auto-expand? + (and (pair? (type-array result)) + (memq 'auto-expand (type-array result)))) + (len (if (pair? (type-array result)) + (car (reverse (type-array result))) + (type-array result)))) + (cond + ((eq? 'null len) + (cat " for (i=0; " tmp "[i]; i++) {\n" + " sexp_push(ctx, " res ", " + (if (eq? 'string (type-base result)) + "str=" + (lambda () (cat "SEXP_VOID);\n sexp_car(" res ") = "))) + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ");\n" + " }\n" + " " res " = sexp_nreverse(ctx, " res ");\n")) + (else + (cat " for (i=" len "-1; i>=0; i--) {\n" + " sexp_push(ctx, " res ", SEXP_VOID);\n" + " sexp_car(" res ") = " + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ";\n" + " }\n"))))) + (else + (cat " " res " = ") + (c->scheme-converter + result + (string-append "tmp" (type-index-string result))) + (cat ";\n"))))) + +(define (write-results func) + (let ((error-res? (error-type? (type-base (func-ret-type func)))) + (results (func-results func))) + (if error-res? + (cat " if (" + (if (eq? 'non-null-string (type-base (func-ret-type func))) "!" "") + "err) {\n" + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (lambda () + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")) + (cat " len" i " *= 2;\n" + " tmp" i + " = malloc(len" i "*sizeof(tmp" i "[0]));\n" + " goto loop;\n"))))) + (else + " res = SEXP_FALSE;\n")) + " } else {\n")) + (if (null? results) + (if error-res? + (cat " res = SEXP_TRUE;\n")) + (for-each write-result results)) + (cond + ((> (length results) (if error-res? 1 0)) + (if error-res? + (cat " res = SEXP_NULL;\n") + (cat " res = sexp_cons(ctx, res, SEXP_NULL);\n")) + (for-each + (lambda (x) + (if error-res? + (cat " sexp_push(ctx, res, res" (type-index x) ");\n") + (cat " sexp_push(ctx, res, sexp_car(res));\n" + " sexp_cadr(res) = res" (type-index x) ";\n"))) + (reverse results))) + ((pair? results) + (cat " res = res" (type-index (car results)) ";\n"))) + (if error-res? + (cat " }\n")))) + +(define (write-free type) + (if (type-array type) + (cat " free(tmp" (type-index-string type) ");\n"))) + +(define (write-cleanup func) + (for-each write-free (func-scheme-args func)) + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n"))))) + (else + " res = SEXP_FALSE;\n")) + (let* ((results (func-results func)) + (return-res? (not (error-type? (type-base (func-ret-type func))))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons (func-ret-type func) + (func-results func)))) + (gc-vars results) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (num-gc-vars (length gc-vars))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_release" num-gc-vars "(ctx);\n"))))) + +(define (write-func func) + (cat "static sexp " (func-stub-name func) + " (sexp ctx" (write-parameters (func-scheme-args func)) ") {\n") + (write-locals func) + (write-validators (func-scheme-args func)) + (write-temporaries func) + (write-call func) + (write-results func) + (write-cleanup func) + (cat " return res;\n" + "}\n\n")) (define (write-func-binding func) (cat " sexp_define_foreign(ctx, env, " - (lambda () (write (symbol->string (func-scheme-name (func-name func))))) - ", " (length (get-func-args func)) ", " (car func) ");\n")) + (lambda () (write (symbol->string (func-scheme-name func)))) + ", " (length (func-scheme-args func)) ", " + (func-stub-name func) ");\n")) (define (write-type type) (let ((name (car type)) (type (cdr type))) - (with-parsed-type - type - (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) - (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" - " " (type-id-name name) - " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, " - (cond ((memq 'finalizer: base-type) - => (lambda (x) (stub-name (cadr x)))) - (else "sexp_finalize_c_type")) - "));\n") - (cond - ((memq 'predicate: base-type) - => (lambda (x) - (let ((pred (cadr x))) - (cat " tmp = sexp_make_type_predicate(ctx, name, " - "sexp_make_fixnum(" (type-id-name name) "));\n" - " name = sexp_intern(ctx, \"" pred "\");\n" - " sexp_env_define(ctx, env, name, tmp);\n"))))))))) + (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" + " " (type-id-name name) + " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, " + (cond ((memq 'finalizer: type) + => (lambda (x) (generate-stub-name (cadr x)))) + (else "sexp_finalize_c_type")) + "));\n") + (cond + ((memq 'predicate: type) + => (lambda (x) + (let ((pred (cadr x))) + (cat " tmp = sexp_make_type_predicate(ctx, name, " + "sexp_make_fixnum(" (type-id-name name) "));\n" + " name = sexp_intern(ctx, \"" pred "\");\n" + " sexp_env_define(ctx, env, name, tmp);\n"))))))) (define (type-getter-name type name field) - (string-append "sexp_" (x->string (type-name name)) - "_get_" (x->string (type-base (cadr field))))) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_get_" (x->string (type-base (parse-type (cadr field)))))) (define (write-type-getter type name field) - (with-parsed-type - (car field) - (lambda (field-type free? const? null-ptr? ptr? struct? link? result? array value default? i) - (cat "static sexp " (type-getter-name type name field) - " (sexp ctx, sexp x) {\n" - (lambda () (validate-type "x" name)) - " return " - (lambda () - (c->scheme-converter - field-type - (string-append "((struct " (mangle name) "*)" - "sexp_cpointer_value(x))" - (if struct? "." "->") - (x->string (cadr field))) - (and (or struct? link?) "x"))) - ";\n" - "}\n\n")))) + (cat "static sexp " (type-getter-name type name field) + " (sexp ctx, sexp x) {\n" + (lambda () (write-validator "x" name)) + " return " + (lambda () + (c->scheme-converter + (car field) + (string-append "((struct " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (x->string (cadr field))) + (and (or (type-struct? (car field)) (type-link? (car field))) "x"))) + ";\n" + "}\n\n")) (define (type-setter-name type name field) - (string-append "sexp_" (x->string (type-name name)) - "_set_" (x->string (type-base (car field))))) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_set_" (x->string (type-base (parse-type (car field)))))) (define (write-type-setter type name field) - (with-parsed-type - (car field) - (lambda (field-type free? const? null-ptr? ptr? struct? link? result? array value default? i) - (cat "static sexp " (type-setter-name type name field) - " (sexp ctx, sexp x, sexp v) {\n" - (lambda () (validate-type "x" name)) - (lambda () (validate-type "v" (car field))) - " " - (lambda () (c->scheme-converter - field-type - (string-append "((struct " (mangle name) "*)" - "sexp_cpointer_value(x))" - (if struct? "." "->") - (x->string (cadr field))))) - " = v;\n" - " return SEXP_VOID;" - "}\n\n")))) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx, sexp x, sexp v) {\n" + (lambda () (write-validator "x" name)) + (lambda () (write-validator "v" (car field))) + " " + (lambda () (c->scheme-converter + (car field) + (string-append "((struct " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (x->string (cadr field))))) + " = v;\n" + " return SEXP_VOID;" + "}\n\n")) (define (write-type-funcs type) (let ((name (car type)) (type (cdr type))) - (with-parsed-type - type - (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) + ;; maybe write finalizer + (cond + ((memq 'finalizer: type) + => (lambda (x) + (cat "static sexp " (generate-stub-name (cadr x)) + " (sexp ctx, sexp x) {\n" + " if (sexp_cpointer_freep(x))\n" + " " (cadr x) "(sexp_cpointer_value(x));\n" + " return SEXP_VOID;\n" + "}\n\n")))) + ;; maybe write constructor + (cond + ((memq 'constructor: type) + => (lambda (x) + (let ((make (caadr x)) + (args (cdadr x))) + (cat "static sexp " (generate-stub-name make) + " (sexp ctx" + (lambda () (for-each (lambda (x) (cat ", sexp " x)) args)) + ") {\n" + " struct " (type-name name) " *r;\n" + " sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + (type-id-name name) + ");\n" + " sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " r = sexp_cpointer_value(res);\n" + " return res;\n" + "}\n\n") + (set! *funcs* + (cons (parse-func `(void ,make ,args)) *funcs*)))))) + ;; write field accessors + (for-each + (lambda (field) (cond - ((memq 'finalizer: base-type) - => (lambda (x) - (cat "static sexp " (stub-name (cadr x)) - " (sexp ctx, sexp x) {\n" - " if (sexp_cpointer_freep(x))\n" - " " (cadr x) "(sexp_cpointer_value(x));\n" - " return SEXP_VOID;\n" - "}\n\n")))) - (cond - ((memq 'constructor: base-type) - => (lambda (x) - (let ((make (caadr x)) - (args (cdadr x))) - (cat "static sexp " (stub-name make) - " (sexp ctx" - (lambda () (for-each (lambda (x) (cat ", sexp " x)) args)) - ") {\n" - " struct " (type-name name) " *r;\n" - " sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " - (type-id-name name) - ");\n" - " sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" - " r = sexp_cpointer_value(res);\n" - " return res;\n" - "}\n\n") - (set! funcs - (cons (list (stub-name make) 'void make args) funcs)))))) - (for-each - (lambda (field) - (cond - ((and (pair? field) (pair? (cdr field))) - (cond - ((and (pair? (cddr field)) (caddr field)) - (write-type-getter type name field) - (set! funcs - (cons (list (type-getter-name type name field) - (car field) (caddr field) (list name)) - funcs)))) - (cond - ((and (pair? (cddr field)) - (pair? (cdddr field)) - (car (cdddr field))) - (write-type-setter type name field) - (set! funcs - (cons (list (type-setter-name type name field) - (car field) (cadddr field) - (list name (car field))) - funcs))))))) - base-type))))) + ((and (pair? field) (pair? (cdr field))) + (cond + ((and (pair? (cddr field)) (caddr field)) + (write-type-getter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(caddr field) + #f + ,(type-getter-name type name field)) + (,name))) + *funcs*)))) + (cond + ((and (pair? (cddr field)) + (pair? (cdddr field)) + (car (cdddr field))) + (write-type-setter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(car (cdddr field)) + #f + ,(type-setter-name type name field)) + (,name ,(car field)))) + *funcs*))))))) + type))) + +(define (write-utilities) + (define (input-env-string? x) + (and (eq? 'env-string (type-base x)) (not (type-result? x)))) + (cond + ((any (lambda (f) + (or (any input-env-string? (func-results f)) + (any input-env-string? (func-scheme-args f)))) + *funcs*) + (cat "static char* sexp_concat_env_string (sexp x) {\n" + " int klen=sexp_string_length(sexp_car(x)), vlen=sexp_string_length(sexp_cdr(x));\n" + " char *res = (char*) malloc(klen+vlen+2);\n" + " strncpy(res, sexp_string_data(sexp_car(x)), klen);\n" + " res[sexp_string_length(sexp_car(x))] = '=';\n" + " strncpy(res+sexp_string_length(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n" + " res[len-1] = '\\0';\n" + " return res;\n" + "}\n\n")))) (define (write-init) (newline) - (for-each write-func funcs) - (for-each write-type-funcs types) + (write-utilities) + (for-each write-func *funcs*) + (for-each write-type-funcs *types*) (cat "sexp sexp_init_library (sexp ctx, sexp env) {\n" " sexp_gc_var2(name, tmp);\n" " sexp_gc_preserve2(ctx, name, tmp);\n") - (for-each write-type types) - (for-each write-func-binding funcs) + (for-each write-type *types*) + (for-each write-func-binding *funcs*) (cat " sexp_gc_release2(ctx);\n" " return SEXP_VOID;\n" "}\n\n")) @@ -770,6 +1009,9 @@ (load file) (write-init)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main + (define (main args) (case (length args) ((1) @@ -783,4 +1025,3 @@ (error "usage: genstubs []")))) (main (command-line-arguments)) - From cb1859c683624d39be56da3168b4085b86debdeb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 22 Dec 2009 22:55:46 +0900 Subject: [PATCH 270/535] allowing link on input parameters for use with functions like readdir --- lib/chibi/posix.stub | 2 +- tools/genstubs.scm | 8 ++++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/lib/chibi/posix.stub b/lib/chibi/posix.stub index 03d4f981..25dd5dbd 100644 --- a/lib/chibi/posix.stub +++ b/lib/chibi/posix.stub @@ -25,7 +25,7 @@ (define-c errno (delete-directory "rmdir") (string)) (define-c (free DIR) opendir (string)) -(define-c dirent readdir (DIR)) +(define-c dirent readdir ((link DIR))) (define-c int (duplicate-fd "dup") (int)) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index baa3b741..9f33ef91 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -683,7 +683,7 @@ ((type-array ret-type) " tmp = ") (else " res = "))) ((if (type-array ret-type) - (lambda (t f) (f)) + (lambda (t f x) (f)) c->scheme-converter) ret-type (lambda () @@ -709,7 +709,11 @@ arg (string-append "arg" (type-index-string arg)))))) c-args) - (cat ")"))) + (cat ")")) + (cond + ((any type-link? (func-c-args func)) + => (lambda (a) (string-append "arg" (type-index-string a)))) + (else #f))) (cat ";\n") (if (type-array ret-type) (write-result ret-type)))) From bfbc9313ed707cc6ce790f725c28506c58567b75 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 24 Dec 2009 14:53:30 +0900 Subject: [PATCH 271/535] fixing import bug (was ignoring exports list except when using only/except/rename/prefix modifiers) --- eval.c | 15 +++++++++------ include/chibi/eval.h | 1 + lib/config.scm | 5 +++-- lib/init.scm | 8 ++++++-- 4 files changed, 19 insertions(+), 10 deletions(-) diff --git a/eval.c b/eval.c index a46389bd..4ec24ffc 100644 --- a/eval.c +++ b/eval.c @@ -75,14 +75,17 @@ static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, sexp value) { return sexp_env_cell_create_loc(ctx, env, key, value, NULL); } -sexp sexp_env_global_ref (sexp env, sexp key, sexp dflt) { - sexp cell; - while (sexp_env_parent(env)) - env = sexp_env_parent(env); - cell = sexp_env_cell(env, key); +sexp sexp_env_ref (sexp env, sexp key, sexp dflt) { + sexp cell = sexp_env_cell(env, key); return (cell ? sexp_cdr(cell) : dflt); } +sexp sexp_env_global_ref (sexp env, sexp key, sexp dflt) { + while (sexp_env_lambda(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); + return sexp_env_ref(env, key, dflt); +} + sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { sexp cell = sexp_assq(ctx, key, sexp_env_bindings(env)), res=SEXP_VOID; sexp_gc_var1(tmp); @@ -2587,7 +2590,7 @@ sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls, sexp immutp) { } else { newname = oldname = sexp_car(ls); } - value = sexp_env_global_ref(from, oldname, SEXP_UNDEF); + value = sexp_env_ref(from, oldname, SEXP_UNDEF); if (value != SEXP_UNDEF) { sexp_env_define(ctx, to, newname, value); #if SEXP_USE_WARN_UNDEFS diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 23428d21..22b5f340 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -140,6 +140,7 @@ SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls, sexp immutp); SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_env_cell (sexp env, sexp sym); +SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); diff --git a/lib/config.scm b/lib/config.scm index 51435a3a..461a6351 100644 --- a/lib/config.scm +++ b/lib/config.scm @@ -5,12 +5,13 @@ (define *this-module* '()) (define (make-module exports env meta) (vector exports env meta)) +(define (%module-exports mod) (vector-ref mod 0)) (define (module-env mod) (vector-ref mod 1)) (define (module-meta-data mod) (vector-ref mod 2)) (define (module-env-set! mod env) (vector-set! mod 1 env)) (define (module-exports mod) - (or (vector-ref mod 0) (env-exports (module-env mod)))) + (or (%module-exports mod) (env-exports (module-env mod)))) (define (module-name->strings ls res) (if (null? ls) @@ -88,7 +89,7 @@ (if (pair? i) (cdr i) i))) (cdr mod-name+imports))))) ((find-module x) - => (lambda (mod) (cons x #f))) + => (lambda (mod) (cons x (%module-exports mod)))) (else (error "couldn't find import" x)))) diff --git a/lib/init.scm b/lib/init.scm index 24aa8b34..ff7b4ece 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -783,10 +783,14 @@ ((or) (any check (cdr x))) ((not) (not (check (cadr x)))) (else (error "cond-expand: bad feature" x))) - (memq (identifier->symbol x) (cons 'else *features*)))) + (memq (identifier->symbol x) *features*))) (let expand ((ls (cdr expr))) - (cond ((null? ls) (error "cond-expand: no expansions" (cdr expr))) + (cond ((null? ls) (error "cond-expand: no expansions" expr)) ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) + ((eq? 'else (identifier->symbol (caar ls))) + (if (pair? (cdr ls)) + (error "cond-expand: else in non-final position") + `(,(rename 'begin) ,@(cdar ls)))) ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) (else (expand (cdr ls)))))))) From 77f2990f28439f525eb117aad93045ade0010f77 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 25 Dec 2009 21:11:56 +0900 Subject: [PATCH 272/535] factoring (chibi posix) into filesystem, process and time modules. the time module is garbage, because libc time handling is garbage. the signal handling is still experimental, use at your own risk. still need a host module for user/group and other host information. --- Makefile | 3 +- include/chibi/sexp.h | 1 + lib/chibi/filesystem.module | 22 ++++ lib/chibi/filesystem.scm | 39 +++++++ lib/chibi/filesystem.stub | 88 +++++++++++++++ lib/chibi/posix.module | 12 -- lib/chibi/posix.scm | 10 -- lib/chibi/posix.stub | 40 ------- lib/chibi/process.module | 17 +++ lib/chibi/process.stub | 69 ++++++++++++ lib/chibi/time.module | 11 ++ lib/chibi/time.stub | 45 ++++++++ lib/srfi/1.module | 2 +- tools/genstubs.scm | 219 +++++++++++++++++++++++++++--------- 14 files changed, 461 insertions(+), 117 deletions(-) create mode 100644 lib/chibi/filesystem.module create mode 100644 lib/chibi/filesystem.scm create mode 100644 lib/chibi/filesystem.stub delete mode 100644 lib/chibi/posix.module delete mode 100644 lib/chibi/posix.scm delete mode 100644 lib/chibi/posix.stub create mode 100644 lib/chibi/process.module create mode 100644 lib/chibi/process.stub create mode 100644 lib/chibi/time.module create mode 100644 lib/chibi/time.stub diff --git a/Makefile b/Makefile index 3aa63400..a10c3e0e 100644 --- a/Makefile +++ b/Makefile @@ -83,7 +83,8 @@ all: chibi-scheme$(EXE) libs COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ lib/chibi/ast$(SO) lib/chibi/net$(SO) \ - lib/chibi/posix$(SO) lib/chibi/heap-stats$(SO) + lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \ + lib/chibi/time$(SO) lib/chibi/heap-stats$(SO) libs: $(COMPILED_LIBS) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 30c542bd..73c78efb 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -696,6 +696,7 @@ enum sexp_context_globals { SEXP_G_OOM_ERROR, /* out of memory exception object */ SEXP_G_OOS_ERROR, /* out of stack exception object */ SEXP_G_OPTIMIZATIONS, + SEXP_G_SIGNAL_HANDLERS, SEXP_G_CONFIG_ENV, SEXP_G_MODULE_PATH, SEXP_G_QUOTE_SYMBOL, diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module new file mode 100644 index 00000000..fe0fbdcf --- /dev/null +++ b/lib/chibi/filesystem.module @@ -0,0 +1,22 @@ + +(define-module (chibi filesystem) + (export open-input-file-descriptor open-output-file-descriptor + duplicate-file-descriptor duplicate-file-descriptor-to + close-file-descriptor renumber-file-descriptor + delete-file link-file symbolic-link-file rename-file + directory-files create-directory delete-directory + file-status + file-device file-inode + file-mode file-num-links + file-owner file-group + file-represented-device file-size + file-block-size file-num-blocks + file-access-time file-modification-time file-change-time + file-regular? file-directory? file-character? + file-block? file-fifo? file-link? + file-socket? + ) + (import-immutable (scheme)) + (include-shared "filesystem") + (include "filesystem.scm")) + diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm new file mode 100644 index 00000000..b3995221 --- /dev/null +++ b/lib/chibi/filesystem.scm @@ -0,0 +1,39 @@ + +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (let lp ((res knil)) + (let ((file (readdir dir))) + (if file (lp (kons (dirent-name file) res)) res))))) + +(define (directory-files dir) + (directory-fold dir cons '())) + +(define (renumber-file-descriptor old new) + (and (duplicate-file-descriptor-to old new) + (close-file-descriptor old))) + +(define (file-status file) + (if (string? file) (stat file) (fstat file))) + +(define (file-device x) (stat-dev (if (stat? x) x (file-status x)))) +(define (file-inode x) (stat-ino (if (stat? x) x (file-status x)))) +(define (file-mode x) (stat-mode (if (stat? x) x (file-status x)))) +(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x)))) +(define (file-owner x) (stat-uid (if (stat? x) x (file-status x)))) +(define (file-group x) (stat-gid (if (stat? x) x (file-status x)))) +(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x)))) +(define (file-size x) (stat-size (if (stat? x) x (file-status x)))) +(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x)))) +(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x)))) +(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x)))) +(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x)))) +(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x)))) + +(define (file-regular? x) (S_ISREG (file-mode x))) +(define (file-directory? x) (S_ISDIR (file-mode x))) +(define (file-character? x) (S_ISCHR (file-mode x))) +(define (file-block? x) (S_ISBLK (file-mode x))) +(define (file-fifo? x) (S_ISFIFO (file-mode x))) +(define (file-link? x) (S_ISLNK (file-mode x))) +(define (file-socket? x) (S_ISSOCK (file-mode x))) + diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub new file mode 100644 index 00000000..ebd2f7be --- /dev/null +++ b/lib/chibi/filesystem.stub @@ -0,0 +1,88 @@ + +(c-system-include "sys/types.h") +(c-system-include "unistd.h") +(c-system-include "dirent.h") + +(define-c-struct DIR + finalizer: closedir) + +(define-c-struct dirent + (string d_name dirent-name)) + +(define-c-struct stat + predicate: stat? + (dev_t st_dev stat-dev) + (ino_t st_ino stat-ino) + (mode_t st_mode stat-mode) + (nlink_t st_nlink stat-nlinks) + (uid_t st_uid stat-uid) + (gid_t st_gid stat-gid) + (dev_t st_rdev stat-rdev) + (off_t st_size stat-size) + (blksize_t st_blksize stat-blksize) + (blkcnt_t st_blocks stat-blocks) + (time_t st_atime stat-atime) + (time_t st_mtime stat-mtime) + (time_t st_ctime stat-ctime)) + +(define-c boolean S_ISREG (mode_t)) +(define-c boolean S_ISDIR (mode_t)) +(define-c boolean S_ISCHR (mode_t)) +(define-c boolean S_ISBLK (mode_t)) +(define-c boolean S_ISFIFO (mode_t)) +(define-c boolean S_ISLNK (mode_t)) +(define-c boolean S_ISSOCK (mode_t)) + +;;(define-c-const int ("S_IFMT")) +(define-c-const int (file/socket "S_IFSOCK")) +(define-c-const int (file/link "S_IFLNK")) +(define-c-const int (file/regular "S_IFREG")) +(define-c-const int (file/block "S_IFBLK")) +(define-c-const int (file/directory "S_IFDIR")) +(define-c-const int (file/character "S_IFCHR")) +(define-c-const int (file/fifo "S_IFIFO")) +(define-c-const int (file/suid "S_ISUID")) +(define-c-const int (file/sgid "S_ISGID")) +(define-c-const int (file/sticky "S_ISVTX")) +;;(define-c-const int ("S_IRWXU")) +(define-c-const int (perm/user-read "S_IRUSR")) +(define-c-const int (perm/user-write "S_IWUSR")) +(define-c-const int (perm/user-execute "S_IXUSR")) +;;(define-c-const int ("S_IRWXG")) +(define-c-const int (perm/group-read "S_IRGRP")) +(define-c-const int (perm/group-write "S_IWGRP")) +(define-c-const int (perm/group-execute "S_IXGRP")) +;;(define-c-const int ("S_IRWXO")) +(define-c-const int (perm/others-read "S_IROTH")) +(define-c-const int (perm/others-write "S_IWOTH")) +(define-c-const int (perm/others-execute "S_IXOTH")) + +(define-c errno stat (string (result stat))) +(define-c errno fstat (int (result stat))) +(define-c errno (file-link-status "lstat") (string (result stat))) + +(define-c input-port (open-input-file-descriptor "fdopen") + (int (value "r" string))) +(define-c output-port (open-output-file-descriptor "fdopen") + (int (value "w" string))) + +(define-c errno (delete-file "unlink") (string)) +(define-c errno (link-file "link") (string string)) +(define-c errno (symbolic-link-file "symlink") (string string)) +(define-c errno (rename-file "rename") (string string)) + +(define-c non-null-string (current-directory "getcwd") + ((result (array char (auto-expand arg1))) (value 256 int))) + +(define-c errno (create-directory "mkdir") (string int)) +(define-c errno (delete-directory "rmdir") (string)) + +(define-c (free DIR) opendir (string)) +(define-c dirent readdir ((link DIR))) + +(define-c int (duplicate-file-descriptor "dup") (int)) +(define-c errno (duplicate-file-descriptor-to "dup2") (int int)) +(define-c errno (close-file-descriptor "close") (int)) + +(define-c errno (open-pipe "pipe") ((result (array int 2)))) +(define-c errno (make-fifo "mkfifo") (string (default #o644 int))) diff --git a/lib/chibi/posix.module b/lib/chibi/posix.module deleted file mode 100644 index af726ff4..00000000 --- a/lib/chibi/posix.module +++ /dev/null @@ -1,12 +0,0 @@ - -(define-module (chibi posix) - (export open-input-fd open-output-fd pipe - delete-file link-file symbolic-link-file rename-file - directory-files create-directory delete-directory - current-seconds - waitpid exit - ) - (import-immutable (scheme)) - (include-shared "posix") - (include "posix.scm")) - diff --git a/lib/chibi/posix.scm b/lib/chibi/posix.scm deleted file mode 100644 index ed5fa780..00000000 --- a/lib/chibi/posix.scm +++ /dev/null @@ -1,10 +0,0 @@ - -(define (directory-fold dir kons knil) - (let ((dir (opendir dir))) - (let lp ((res knil)) - (let ((file (readdir dir))) - (if file (lp (kons (dirent-name file) res)) res))))) - -(define (directory-files dir) - (directory-fold dir cons '())) - diff --git a/lib/chibi/posix.stub b/lib/chibi/posix.stub deleted file mode 100644 index 25dd5dbd..00000000 --- a/lib/chibi/posix.stub +++ /dev/null @@ -1,40 +0,0 @@ - -(c-system-include "sys/types.h") -(c-system-include "sys/wait.h") -(c-system-include "time.h") -(c-system-include "unistd.h") -(c-system-include "dirent.h") - -(define-c-struct DIR - finalizer: closedir) - -(define-c-struct dirent - (string d_name dirent-name)) - -(define-c input-port (open-input-fd "fdopen") (int (value "r" string))) -(define-c output-port (open-output-fd "fdopen") (int (value "w" string))) - -(define-c errno (delete-file "unlink") (string)) -(define-c errno (link-file "link") (string string)) -(define-c errno (symbolic-link-file "symlink") (string string)) -(define-c errno (rename-file "rename") (string string)) - -(define-c non-null-string (current-directory "getcwd") - ((result (array char (auto-expand arg1))) (value 256 int))) -(define-c errno (create-directory "mkdir") (string int)) -(define-c errno (delete-directory "rmdir") (string)) - -(define-c (free DIR) opendir (string)) -(define-c dirent readdir ((link DIR))) - -(define-c int (duplicate-fd "dup") (int)) - -(define-c pid_t fork ()) -(define-c pid_t waitpid (int (result int) int)) -(define-c void exit (int)) -(define-c int (execute execvp) (string (array string))) - -(define-c errno pipe ((result (array int 2)))) - -(define-c time_t (current-seconds "time") ((value NULL))) - diff --git a/lib/chibi/process.module b/lib/chibi/process.module new file mode 100644 index 00000000..3e3f2cdb --- /dev/null +++ b/lib/chibi/process.module @@ -0,0 +1,17 @@ + +(define-module (chibi process) + (export exit sleep fork kill execute waitpid + set-signal-action! make-signal-set signal-set-contains? + signal-set-fill! signal-set-add! signal-set-delete! + current-signal-mask + signal-mask-block! signal-mask-unblock! signal-mask-set! + signal/hang-up signal/interrupt signal/quit + signal/illegal signal/abort signal/fpe + signal/kill signal/segv signal/pipe + signal/alarm signal/term signal/user1 + signal/user2 signal/child signal/continue + signal/stop signal/tty-stop signal/tty-input + signal/tty-output) + (import-immutable (scheme)) + (include-shared "process")) + diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub new file mode 100644 index 00000000..baa5a7a5 --- /dev/null +++ b/lib/chibi/process.stub @@ -0,0 +1,69 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/wait.h") +(c-system-include "signal.h") +(c-system-include "unistd.h") + +(define-c-struct siginfo + predicate: signal-info? + (int si_signo signal-number) + (int si_errno signal-error-number) + (int si_code signal-code) + (pid_t si_pid signal-pid) + (uid_t si_uid signal-uid) + (int si_status signal-status) + (clock_t si_utime signal-user-time) + (clock_t si_stime signal-system-time)) + +(define-c-type sigset_t + predicate: signal-set?) + +(define-c-const int (signal/hang-up "SIGHUP")) +(define-c-const int (signal/interrupt "SIGINT")) +(define-c-const int (signal/quit "SIGQUIT")) +(define-c-const int (signal/illegal "SIGILL")) +(define-c-const int (signal/abort "SIGABRT")) +(define-c-const int (signal/fpe "SIGFPE")) +(define-c-const int (signal/kill "SIGKILL")) +(define-c-const int (signal/segv "SIGSEGV")) +(define-c-const int (signal/pipe "SIGPIPE")) +(define-c-const int (signal/alarm "SIGALRM")) +(define-c-const int (signal/term "SIGTERM")) +(define-c-const int (signal/user1"SIGUSR1")) +(define-c-const int (signal/user2 "SIGUSR2")) +(define-c-const int (signal/child "SIGCHLD")) +(define-c-const int (signal/continue "SIGCONT")) +(define-c-const int (signal/stop "SIGSTOP")) +(define-c-const int (signal/tty-stop "SIGTSTP")) +(define-c-const int (signal/tty-input "SIGTTIN")) +(define-c-const int (signal/tty-output "SIGTTOU")) + +(c-include "signal.c") + +(define-c sexp (set-signal-action! "sexp_set_signal_action") + ((value ctx sexp) sexp sexp)) + +(define-c errno (make-signal-set "sigemptyset") ((result sigset_t))) +(define-c errno (signal-set-fill! "sigfillset") (sigset_t)) +(define-c errno (signal-set-add! "sigaddset") (sigset_t int)) +(define-c errno (signal-set-delete! "sigaddset") (sigset_t int)) +(define-c boolean (signal-set-contains? "sigismember") (sigset_t int)) + +(define-c errno (signal-mask-block! "sigprocmask") + ((value SIG_BLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-unblock! "sigprocmask") + ((value SIG_UNBLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-set! "sigprocmask") + ((value SIG_SETMASK int) sigset_t (value NULL sigset_t))) +(define-c errno (current-signal-mask "sigprocmask") + ((value SIG_BLOCK int) (value NULL sigset_t) (result sigset_t))) + +(define-c pid_t fork ()) +;;(define-c pid_t wait ((result int))) +(define-c pid_t waitpid (int (result int) int)) +(define-c errno kill (int int)) +;;(define-c errno raise (int)) +(define-c unsigned-int sleep (unsigned-int)) +(define-c void exit (int)) +(define-c int (execute execvp) (string (array string))) + diff --git a/lib/chibi/time.module b/lib/chibi/time.module new file mode 100644 index 00000000..84f2b800 --- /dev/null +++ b/lib/chibi/time.module @@ -0,0 +1,11 @@ + +(define-module (chibi time) + (export current-seconds get-time-of-day set-time-of-day! + seconds->time seconds->string time->seconds time->string + timeval-seconds timeval-microseconds + timezone-offset timezone-dst-time + time-second time-minute time-hour time-day time-month time-year + time-day-of-week time-day-of-year time-dst?) + (import-immutable (scheme)) + (include-shared "time")) + diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub new file mode 100644 index 00000000..b2d444a8 --- /dev/null +++ b/lib/chibi/time.stub @@ -0,0 +1,45 @@ + +(c-system-include "time.h") +(c-system-include "sys/time.h") + +(define-c-struct tm + (int tm_sec time-second) + (int tm_min time-minute) + (int tm_hour time-hour) + (int tm_mday time-day) + (int tm_mon time-month) + (int tm_year time-year) + (int tm_wday time-day-of-week) + (int tm_yday time-day-of-year) + (int tm_isdst time-dst?)) + +(define-c-struct timeval + predicate: timeval? + (time_t tv_sec timeval-seconds) + (int tv_usec timeval-microseconds)) + +(define-c-struct timezone + predicate: timezone? + (int tz_minuteswest timezone-offset) + (int tz_dsttime timezone-dst-time)) + +(define-c time_t (current-seconds "time") ((value NULL))) + +(define-c errno (get-time-of-day "gettimeofday") + ((result timeval) (result timezone))) + +(define-c errno (set-time-of-day! "settimeofday") + ((maybe-null timeval) (maybe-null default NULL timezone))) + +(define-c non-null-pointer (seconds->time "localtime_r") + ((pointer time_t) (result tm))) + +(define-c time_t (time->seconds "mktime") + (tm)) + +(define-c non-null-string (seconds->string "ctime_r") + ((pointer time_t) (result (array char 64)))) + +(define-c non-null-string (time->string "asctime_r") + (tm (result (array char 64)))) + diff --git a/lib/srfi/1.module b/lib/srfi/1.module index 8d341b6b..3d3da044 100644 --- a/lib/srfi/1.module +++ b/lib/srfi/1.module @@ -18,7 +18,7 @@ lset<= lset= lset-adjoin lset-union lset-union! lset-intersection lset-intersection! lset-difference lset-difference! lset-xor lset-xor! lset-diff+intersection lset-diff+intersection!) - (import-immutable (scheme)) + (import (scheme)) (include "1/predicates.scm" "1/selectors.scm" "1/search.scm" diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 9f33ef91..c679c30c 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -139,6 +139,7 @@ (define *types* '()) (define *funcs* '()) +(define *consts* '()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; type objects @@ -202,10 +203,12 @@ ;; type predicates (define (signed-int-type? type) - (memq type '(signed-char short int long))) + (memq type '(signed-char short int long boolean))) (define (unsigned-int-type? type) - (memq type '(unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t))) + (memq type '(unsigned-char unsigned-short unsigned-int unsigned-long + size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t + uid_t gid_t pid_t blksize_t blkcnt_t sigval_t))) (define (int-type? type) (or (signed-int-type? type) (unsigned-int-type? type))) @@ -214,14 +217,23 @@ (memq type '(float double long-double long-long-double))) (define (string-type? type) - (memq type '(char* string env-string non-null-string))) + (or (memq type '(char* string env-string non-null-string)) + (and (vector? type) + (type-array type) + (not (type-pointer? type)) + (eq? 'char (type-base type))))) (define (error-type? type) - (memq type '(errno non-null-string))) + (memq type '(errno non-null-string non-null-pointer))) (define (array-type? type) (and (type-array type) (not (eq? 'char (type-base type))))) +(define (basic-type? type) + (let ((type (parse-type type))) + (and (not (type-array type)) + (not (assq (type-base type) *types*))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; function objects @@ -250,7 +262,7 @@ (cond ((type-result? type) (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) - ((type-value type) + ((and (type-value type) (not (type-default? type))) (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) (else (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) @@ -303,10 +315,8 @@ (define (collect) (if (= i from) res (cons (substring str from i) res))) (cond ((>= i len) (string-concatenate-reverse (collect))) - ((eqv? c (string-ref str i)) - (lp (+ i 1) (+ i 1) (cons r (collect)))) - (else - (lp from (+ i 1) res)))))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) (define (string-scan c str . o) (let ((limit (string-length str))) @@ -349,9 +359,21 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; naming +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + (define (mangle x) (string-replace - (string-replace (string-replace (x->string x) #\- "_") #\? "_p") + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") #\! "_x")) (define (generate-stub-name sym) @@ -367,20 +389,38 @@ (apply cat args) (newline)) +(define (c-include header) + (cat "\n#include \"" header "\"\n")) + (define (c-system-include header) (cat "\n#include <" header ">\n")) +(define (parse-struct-like ls) + (map (lambda (x) (if (pair? x) (cons (parse-type (car x)) (cdr x)) x)) ls)) + +(define-syntax define-struct-like + (er-macro-transformer + (lambda (expr rename compare) + (set! *types* + `((,(cadr expr) + ,@(parse-struct-like (cddr expr))) + ,@*types*)) + `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) + (define-syntax define-c-struct (er-macro-transformer (lambda (expr rename compare) - (set! *types* - (cons (map (lambda (x) - (if (pair? x) - (cons (parse-type (car x)) (cdr x)) - x)) - (cdr expr)) - *types*)) - `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) + `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr))))) + +(define-syntax define-c-class + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) + +(define-syntax define-c-type + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) ,@(cddr expr))))) (define-syntax define-c (er-macro-transformer @@ -388,6 +428,12 @@ (set! *funcs* (cons (parse-func (cdr expr)) *funcs*)) #f))) +(define-syntax define-c-const + (er-macro-transformer + (lambda (expr rename compare) + (set! *consts* + (cons (cons (parse-type (cadr expr)) (cddr expr)) *consts*))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; C code generation @@ -398,6 +444,8 @@ (cat "((" val "), SEXP_VOID)")) ((or (eq? base 'sexp) (error-type? base)) (cat val)) + ((eq? base 'boolean) + (cat "sexp_make_boolean(" val ")")) ((eq? base 'time_t) (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) ((int-type? base) @@ -422,7 +470,11 @@ (ctype (cat "sexp_make_cpointer(ctx, " (type-id-name base) ", " val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " - (if (type-free? type) 1 0) ")")) + (if (or (type-free? type) + (and (type-result? type) (not (basic-type? type)))) + 1 + 0) + ")")) (else (error "unknown type" base)))))))) @@ -432,8 +484,10 @@ (cond ((eq? base 'sexp) (cat val)) + ((eq? base 'boolean) + (cat "sexp_truep(" val ")")) ((eq? base 'time_t) - (cat "sexp_uint_value(sexp_unshift_epoch(" val "))")) + (cat "sexp_unshift_epoch(sexp_uint_value(" val "))")) ((signed-int-type? base) (cat "sexp_sint_value(" val ")")) ((unsigned-int-type? base) @@ -462,6 +516,7 @@ ((float-type? base) "sexp_flonump") ((string-type? base) "sexp_stringp") ((eq? base 'char) "sexp_charp") + ((eq? base 'boolean) "sexp_booleanp") (else #f)))) (define (type-name type) @@ -469,6 +524,7 @@ (cond ((int-type? base) "integer") ((float-type? base) "flonum") + ((eq? 'boolean base) "int") (else base)))) (define (base-type-c-name base) @@ -479,12 +535,15 @@ (define (type-c-name type) (let* ((type (parse-type type)) (base (type-base type)) - (struct? (assq base *types*))) + (type-spec (assq base *types*)) + (struct-type + (cond ((and type-spec (memq 'type: type-spec)) => cadr) + (else #f)))) (string-append (if (type-const? type) "const " "") - (if struct? "struct " "") + (if struct-type (string-append (symbol->string struct-type) " ") "") (string-replace (base-type-c-name base) #\- " ") - (if struct? "*" "") + (if type-spec "*" "") (if (type-pointer? type) "*" "")))) (define (check-type arg type) @@ -515,7 +574,7 @@ (array (type-array type)) (base-type (type-base type))) (cond - (array + ((and array (not (string-type? type))) (cond ((number? array) (cat " if (!sexp_listp(ctx, " arg ")" @@ -544,9 +603,11 @@ " if (! " (lambda () (check-type arg type)) ")\n" " return sexp_type_exception(ctx, \"not " (definite-article (type-name type)) "\", " arg ");\n")) + ((eq? 'sexp base-type)) + ((string-type? type) + (write-validator arg 'string)) (else - (if (not (eq? 'sexp (type-base type))) - (display "WARNING: don't know how to validate: " (current-error-port))) + (display "WARNING: don't know how to validate: " (current-error-port)) (write type (current-error-port)) (newline (current-error-port)) (write type))))))) @@ -588,7 +649,9 @@ (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) (sexps (if preserve-res? '() '("res"))) (num-gc-vars (length gc-vars)) - (ints (if (or return-res? (eq? 'non-null-string (type-base ret-type))) + (ints (if (or return-res? + (memq (type-base ret-type) + '(non-null-string non-null-pointer))) '() '("err"))) (ints (if (or (array-type? ret-type) @@ -596,8 +659,9 @@ (any array-type? scheme-args)) (cons "i" ints) ints))) - (if(eq? 'non-null-string (type-base ret-type)) - (cat " char *err;\n")) + (case (type-base ret-type) + ((non-null-string) (cat " char *err;\n")) + ((non-null-pointer) (cat " void *err;\n"))) (cond ((pair? ints) (cat " int " (car ints)) @@ -624,6 +688,13 @@ (append (if (type-array ret-type) (list ret-type) '()) results (remove type-result? (filter type-array scheme-args)))) + (for-each + (lambda (arg) + (cond + ((and (type-pointer? arg) (basic-type? arg)) + (cat " " (type-c-name (type-base arg)) + " tmp" (type-index arg) ";\n")))) + scheme-args) (cond ((pair? sexps) (cat " sexp " (car sexps)) @@ -657,7 +728,7 @@ ";\n" " tmp" (type-index a) " = buf" (type-index a) ";\n")))) (cond - ((and (not (type-result? a)) (type-array a)) + ((and (not (type-result? a)) (type-array a) (not (string-type? a))) (if (not (number? (type-array a))) (cat " tmp" (type-index a) " = (" (type-c-name (type-base a)) "*) malloc(" @@ -670,9 +741,45 @@ ";\n" " }\n") (if (not (number? (type-array a))) - (cat " tmp" (type-index a) "[i] = NULL;\n"))))) + (cat " tmp" (type-index a) "[i] = NULL;\n"))) + ((and (type-result? a) (not (basic-type? a)) + (not (type-free? a)) (not (type-auto-expand? a)) + (or (not (type-array a)) + (not (integer? (get-array-length func a))))) + (cat " tmp" (type-index a) " = malloc(sizeof(tmp" (type-index a) + "[0]));\n")) + ((and (type-pointer? a) (basic-type? a)) + (cat " tmp" (type-index a) " = " + (lambda () + (scheme->c-converter + a + (string-append "arg" (type-index-string a)))) + ";\n")))) (func-c-args func))) +(define (write-actual-parameter func arg) + (cond + ((and (not (type-default? arg)) (type-value arg)) + => (lambda (x) + (cond + ((any (lambda (y) + (and (type-array y) + (eq? x (get-array-length func y)))) + (func-c-args func)) + => (lambda (y) (cat "len" (type-index y)))) + (else (write x))))) + ((or (type-result? arg) (type-array arg)) + (cat (if (or (type-pointer? arg) (type-free? arg) (basic-type? arg)) + "&" + "") + "tmp" (type-index arg))) + ((and (type-pointer? arg) (basic-type? arg)) + (cat "&tmp" (type-index arg))) + (else + (scheme->c-converter + arg + (string-append "arg" (type-index-string arg)))))) + (define (write-call func) (let ((ret-type (func-ret-type func)) (c-name (func-c-name func)) @@ -691,23 +798,7 @@ (for-each (lambda (arg) (if (> (type-index arg) 0) (cat ", ")) - (cond - ((or (type-result? arg) (type-array arg)) - (cat (if (or (type-pointer? arg) (type-array arg)) "" "&") - "tmp" (type-index arg))) - ((type-value arg) - => (lambda (x) - (cond - ((any (lambda (y) - (and (type-array y) - (eq? x (get-array-length func y)))) - (func-c-args func)) - => (lambda (y) (cat "len" (type-index y)))) - (else (write x))))) - (else - (scheme->c-converter - arg - (string-append "arg" (type-index-string arg)))))) + (write-actual-parameter func arg)) c-args) (cat ")")) (cond @@ -762,7 +853,10 @@ (results (func-results func))) (if error-res? (cat " if (" - (if (eq? 'non-null-string (type-base (func-ret-type func))) "!" "") + (if (memq (type-base (func-ret-type func)) + '(non-null-string non-null-pointer)) + "!" + "") "err) {\n" (cond ((any type-auto-expand? (func-c-args func)) @@ -847,10 +941,21 @@ "}\n\n")) (define (write-func-binding func) - (cat " sexp_define_foreign(ctx, env, " - (lambda () (write (symbol->string (func-scheme-name func)))) - ", " (length (func-scheme-args func)) ", " - (func-stub-name func) ");\n")) + (let ((default (and (pair? (func-scheme-args func)) + (type-default? (car (reverse (func-scheme-args func)))) + (car (reverse (func-scheme-args func)))))) + (cat (if default + " sexp_define_foreign_opt(ctx, env, " + " sexp_define_foreign(ctx, env, ") + (lambda () (write (symbol->string (func-scheme-name func)))) + ", " (length (func-scheme-args func)) ", " + (func-stub-name func) + (if default ", " "") + (if default + (lambda () + (c->scheme-converter default (type-value default))) + "") + ");\n"))) (define (write-type type) (let ((name (car type)) @@ -975,6 +1080,13 @@ *funcs*))))))) type))) +(define (write-const const) + (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) + (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) + (cat " name = sexp_intern(ctx, \"" scheme-name "\");\n" + " sexp_env_define(ctx, env, name, tmp=" + (lambda () (c->scheme-converter (car const) c-name)) ");\n"))) + (define (write-utilities) (define (input-env-string? x) (and (eq? 'env-string (type-base x)) (not (type-result? x)))) @@ -1001,6 +1113,7 @@ (cat "sexp sexp_init_library (sexp ctx, sexp env) {\n" " sexp_gc_var2(name, tmp);\n" " sexp_gc_preserve2(ctx, name, tmp);\n") + (for-each write-const *consts*) (for-each write-type *types*) (for-each write-func-binding *funcs*) (cat " sexp_gc_release2(ctx);\n" From 4e5889a6f4f4f330ca90531e096270ed7631a72b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 25 Dec 2009 23:32:38 +0900 Subject: [PATCH 273/535] forgot to add signal.c used by process.stub --- lib/chibi/signal.c | 59 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) create mode 100644 lib/chibi/signal.c diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c new file mode 100644 index 00000000..6def22ef --- /dev/null +++ b/lib/chibi/signal.c @@ -0,0 +1,59 @@ + +#define SEXP_MAX_SIGNUM 32 + +static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM]; + +static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { + sexp ctx, sigctx, handler; + sexp_gc_var1(args); + ctx = sexp_signal_contexts[signum]; + if (ctx) { + handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), + sexp_make_fixnum(signum)); + if (sexp_truep(handler)) { + sigctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve1(sigctx, args); + args = sexp_cons(sigctx, SEXP_FALSE, SEXP_NULL); + sexp_car(args) + = sexp_make_cpointer(sigctx, sexp_siginfo_type_id, info, SEXP_FALSE, 0); + args = sexp_cons(sigctx, SEXP_FALSE, args); + sexp_car(args) = sexp_make_fixnum(signum); + sexp_apply(sigctx, handler, args); + sexp_gc_release1(sigctx); + } + } +} + +static struct sigaction call_sigaction = { + .sa_sigaction = sexp_call_sigaction, + .sa_flags = SA_SIGINFO | SA_NODEFER +}; + +static struct sigaction call_sigdefault = {.sa_handler = SIG_DFL}; +static struct sigaction call_sigignore = {.sa_handler = SIG_IGN}; + +static sexp sexp_set_signal_action (sexp ctx, sexp signum, sexp newaction) { + int res; + sexp oldaction; + if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0 + && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) + return sexp_type_exception(ctx, "not a valid signal number", signum); + if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) + || sexp_booleanp(newaction))) + return sexp_type_exception(ctx, "not a procedure", newaction); + if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS))) + sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS) + = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE); + oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); + res = sigaction(sexp_unbox_fixnum(signum), + (sexp_booleanp(newaction) ? + (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore) + : &call_sigaction), + NULL); + if (res) + return sexp_user_exception(ctx, SEXP_FALSE, "couldn't set signal", signum); + sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction); + sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx; + return oldaction; +} + From a1941ff08a60c79452725695a8f4959eac98370a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Dec 2009 00:50:45 +0900 Subject: [PATCH 274/535] somewhat reluctantly adding dynamic-wind --- lib/init.scm | 46 ++++++++++++++++++++++++++++++++++++++++++++ opcodes.c | 2 +- tests/r5rs-tests.scm | 23 ++++++++++++++++++++++ 3 files changed, 70 insertions(+), 1 deletion(-) diff --git a/lib/init.scm b/lib/init.scm index ff7b4ece..75217d71 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -89,6 +89,12 @@ (define (every pred ls) (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t)) +(define (delq x ls) + (if (pair? ls) + (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls)))) + '())) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; syntax (define sc-macro-transformer @@ -284,6 +290,9 @@ (lambda (expr rename compare) `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr)))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; promises + (define (make-promise thunk) (lambda () (let ((computed? #f) (result #f)) @@ -295,6 +304,9 @@ (define (force x) (if (procedure? x) (x) x)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exceptions + (define (error msg . args) (raise (make-exception 'user msg args #f #f))) @@ -305,6 +317,9 @@ (current-exception-handler orig-handler) res))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; library functions + ;; booleans (define (not x) (if x #f #t)) @@ -552,6 +567,7 @@ (current-output-port old-out) res))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; values (define *values-tag* (list 'values)) @@ -567,6 +583,32 @@ (apply consumer (cdr res)) (consumer res)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dynamic-wind + +(define *dk* (list #f)) + +(define (dynamic-wind before thunk after) + (let ((dk *dk*)) + (set-dk! (cons (cons before after) dk)) + (let ((res (thunk))) (set-dk! dk) res))) + +(define (set-dk! dk) + (if (not (eq? dk *dk*)) + (begin + (set-dk! (cdr dk)) + (let ((before (car (car dk))) (dk dk)) + (set-car! *dk* (cons (cdr (car dk)) before)) + (set-cdr! *dk* dk) + (set-car! dk #f) + (set-cdr! dk '()) + (set! *dk* dk) + (before))))) + +(define (call-with-current-continuation proc) + (let ((dk *dk*)) + (%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; syntax-rules @@ -748,6 +790,9 @@ (list (list _error "no expansion for" (list (rename 'strip-syntactic-closures) _expr))))))))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + (define *config-env* #f) (define-syntax import @@ -771,6 +816,7 @@ res)) (error "couldn't find module" (car ls)))))))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SRFI-0 (define-syntax cond-expand diff --git a/opcodes.c b/opcodes.c index 470c694a..5d3a36cc 100644 --- a/opcodes.c +++ b/opcodes.c @@ -63,7 +63,7 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0), _OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "%call/cc", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), _OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), _OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 1a2091d6..cf6bc8ab 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -436,6 +436,29 @@ (test '(2 3) ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) +(test '(a b c) + (let* ((path '()) + (add (lambda (s) (set! path (cons s path))))) + (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) + (reverse path))) + +(test '(connect talk1 disconnect connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test-report) From 09b7b7de69970685ec6f0e55be073ac8fbbf3c1d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Dec 2009 01:10:27 +0900 Subject: [PATCH 275/535] can't have a null timeval in settimeofday --- lib/chibi/time.stub | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub index b2d444a8..bb5cd644 100644 --- a/lib/chibi/time.stub +++ b/lib/chibi/time.stub @@ -29,7 +29,7 @@ ((result timeval) (result timezone))) (define-c errno (set-time-of-day! "settimeofday") - ((maybe-null timeval) (maybe-null default NULL timezone))) + (timeval (maybe-null default NULL timezone))) (define-c non-null-pointer (seconds->time "localtime_r") ((pointer time_t) (result tm))) From fea2428eb63bafd77ffd7ab08bac5f0321739822 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Dec 2009 01:48:12 +0900 Subject: [PATCH 276/535] auto-expanding hash-tables --- Makefile | 3 +++ lib/srfi/69/hash.c | 62 +++++++++++++++++++++++++++++++++++----------- 2 files changed, 51 insertions(+), 14 deletions(-) diff --git a/Makefile b/Makefile index a10c3e0e..6b2ce258 100644 --- a/Makefile +++ b/Makefile @@ -141,6 +141,9 @@ test-basic: chibi-scheme$(EXE) test-numbers: all LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/numeric-tests.scm +test-hash: all + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/hash-tests.scm + test-match: all LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/match-tests.scm diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c index e5d4c293..9ab056e4 100644 --- a/lib/srfi/69/hash.c +++ b/lib/srfi/69/hash.c @@ -21,6 +21,10 @@ static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { } static sexp sexp_string_hash (sexp ctx, sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string-hash: not a string", str); + else if (! sexp_integerp(bound)) + return sexp_type_exception(ctx, "string-hash: not an integer", bound); return sexp_make_fixnum(string_hash(sexp_string_data(str), sexp_unbox_fixnum(bound))); } @@ -32,6 +36,10 @@ static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { } static sexp sexp_string_ci_hash (sexp ctx, sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string-ci-hash: not a string", str); + else if (! sexp_integerp(bound)) + return sexp_type_exception(ctx, "string-ci-hash: not an integer", bound); return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), sexp_unbox_fixnum(bound))); } @@ -83,18 +91,21 @@ static sexp_uint_t hash (sexp obj, sexp_uint_t bound) { } static sexp sexp_hash (sexp ctx, sexp obj, sexp bound) { + if (! sexp_exact_integerp(bound)) + return sexp_type_exception(ctx, "hash: not an integer", bound); return sexp_make_fixnum(hash(obj, sexp_unbox_fixnum(bound))); } static sexp sexp_hash_by_identity (sexp ctx, sexp obj, sexp bound) { + if (! sexp_exact_integerp(bound)) + return sexp_type_exception(ctx, "hash-by-identity: not an integer", bound); return sexp_make_fixnum((sexp_uint_t)obj % sexp_unbox_fixnum(bound)); } -static sexp sexp_get_bucket (sexp ctx, sexp ht, sexp obj) { +static sexp sexp_get_bucket (sexp ctx, sexp buckets, sexp hash_fn, sexp obj) { sexp_gc_var1(args); - sexp buckets = sexp_hash_table_buckets(ht), hash_fn, res; + sexp res; sexp_uint_t len = sexp_vector_length(buckets); - hash_fn = sexp_hash_table_hash_fn(ht); if (hash_fn == sexp_make_fixnum(1)) res = sexp_hash_by_identity(ctx, obj, sexp_make_fixnum(len)); else if (hash_fn == sexp_make_fixnum(2)) @@ -150,25 +161,47 @@ static sexp sexp_scan_bucket (sexp ctx, sexp ls, sexp obj, sexp eq_fn) { return res; } -/* static sexp sexp_regrow_hash_table (sexp ctx, sexp ht) { */ -/* } */ +static void sexp_regrow_hash_table (sexp ctx, sexp ht, sexp oldbuckets, sexp hash_fn) { + sexp ls, *oldvec, *newvec; + int i, j, oldsize=sexp_vector_length(oldbuckets), newsize=oldsize*2; + sexp_gc_var1(newbuckets); + sexp_gc_preserve1(ctx, newbuckets); + newbuckets = sexp_make_vector(ctx, sexp_make_fixnum(newsize), SEXP_NULL); + if (newbuckets) { + oldvec = sexp_vector_data(oldbuckets); + newvec = sexp_vector_data(newbuckets); + for (i=0; i Date: Sat, 26 Dec 2009 02:07:18 +0900 Subject: [PATCH 277/535] adding (... ...) escapes and SRFI-46 ellipse specifiers to syntax-rules --- TODO | 28 ++++++++++++++++----- lib/init.scm | 58 +++++++++++++++++++++++++------------------- tests/r5rs-tests.scm | 6 +++++ 3 files changed, 61 insertions(+), 31 deletions(-) diff --git a/TODO b/TODO index 0468bee3..8cb51490 100644 --- a/TODO +++ b/TODO @@ -39,9 +39,10 @@ - State "DONE" [2009-12-08 Tue 14:41] ** DONE macroexpand utility - State "DONE" [2009-12-08 Tue 14:41] -** TODO compiler macros ** TODO SRFI-46 basic syntax-rules extensions -** TODO (... ...) support +** DONE (... ...) support + - State "DONE" [2009-12-26 Sat 02:06] +** TODO compiler macros ** TODO syntax-rules common pattern reduction ** TODO syntax-rules loop optimization @@ -61,6 +62,9 @@ - State "DONE" [2009-07-07 Tue 14:42] ** TODO unicode ** TODO threads +** DONE dynamic-wind + - State "DONE" [2009-12-26 Sat 01:51] + Adapted a version from Scheme48. ** DONE recursive disasm - State "DONE" [2009-12-18 Fri 14:15] @@ -69,13 +73,16 @@ - State "DONE" [2009-12-08 Tue 14:45] ** DONE opcode generation interface - State "DONE" [2009-11-15 Sun 14:45] -** TODO stub generator +** DONE stub generator + - State "DONE" [2009-12-26 Sat 01:50] *** DONE define-c-struct - State "DONE" [2009-11-29 Sun 14:48] *** DONE define-c - State "DONE" [2009-11-29 Sun 14:48] -*** TODO array return types -*** TODO pre-buffered string types (like getcwd) +*** DONE array return types + - State "DONE" [2009-12-26 Sat 01:49] +*** DONE pre-buffered string types (like getcwd) + - State "DONE" [2009-12-26 Sat 01:49] * module system ** DONE scheme48-like config language @@ -85,7 +92,8 @@ ** DONE only/except/rename/prefix modifiers - State "DONE" [2009-12-16 Wed 18:57] ** TODO scheme-complete.el support -** TODO access individual modules from repl +** DONE access individual modules from repl + - State "DONE" [2009-12-26 Sat 01:49] * core modules ** DONE SRFI-0 cond-expand @@ -100,6 +108,14 @@ - State "DONE" [2009-12-08 Tue 14:54] ** TODO network interface ** TODO posix interface + Splitting this into several parts. +*** DONE filesystem interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE process interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE time interface + - State "DONE" [2009-12-26 Sat 01:50] +*** TODO host system interface ** DONE pathname library - State "DONE" [2009-12-16 Wed 18:58] ** DONE uri library diff --git a/lib/init.scm b/lib/init.scm index 75217d71..3c4f9491 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -615,8 +615,7 @@ (define-syntax syntax-rules (er-macro-transformer (lambda (expr rename compare) - (let ((lits (cadr expr)) - (forms (cddr expr)) + (let ((ellipse-specified? (identifier? (cadr expr))) (count 0) (_er-macro-transformer (rename 'er-macro-transformer)) (_lambda (rename 'lambda)) (_let (rename 'let)) @@ -634,6 +633,9 @@ (_error (rename 'error)) (_vector->list (rename 'vector->list)) (_list->vector (rename 'list->vector))) + (define ellipse (rename (if ellipse-specified? (cadr expr) '...))) + (define lits (if ellipse-specified? (caddr expr) (cadr expr))) + (define forms (if ellipse-specified? (cdddr expr) (cddr expr))) (define (next-v) (set! count (+ count 1)) (rename (string->symbol (string-append "v." (number->string count))))) @@ -708,8 +710,9 @@ (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-escape? x) (and (pair? x) (compare ellipse (car x)))) (define (ellipse? x) - (and (pair? x) (pair? (cdr x)) (compare (rename '...) (cadr x)))) + (and (pair? x) (pair? (cdr x)) (compare ellipse (cadr x)))) (define (ellipse-depth x) (if (ellipse? x) (+ 1 (ellipse-depth (cdr x))) @@ -753,28 +756,33 @@ (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)))) + (cond + ((ellipse-escape? t) + (if (pair? (cdr t)) + (if (pair? (cddr t)) (cddr t) (cadr t)) + (cdr t))) + ((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))))))) + (else (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)))) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index cf6bc8ab..c657be99 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -459,6 +459,12 @@ (c 'talk2) (reverse path))))) +(test 2 (let-syntax + ((foo (syntax-rules ::: () + ((foo ... args :::) + (args ::: ...))))) + (foo 3 - 5))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test-report) From 7392e082cc3c8b49cafeccdde4ad6077c810e83a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Dec 2009 08:07:28 +0900 Subject: [PATCH 278/535] adding srfi-46 support --- TODO | 5 +++-- lib/config.scm | 5 ++++- lib/init.scm | 27 +++++++++++++++++++++++++-- tests/r5rs-tests.scm | 7 +++++++ 4 files changed, 39 insertions(+), 5 deletions(-) diff --git a/TODO b/TODO index 8cb51490..8c59ef19 100644 --- a/TODO +++ b/TODO @@ -30,7 +30,7 @@ ** TODO unsafe operations Possibly, don't want to make things too complicated or unstable. ** TODO plugin infrastructure -** TODO type inference with warning +** TODO type inference with warnings * macros ** DONE hygiene @@ -39,7 +39,8 @@ - State "DONE" [2009-12-08 Tue 14:41] ** DONE macroexpand utility - State "DONE" [2009-12-08 Tue 14:41] -** TODO SRFI-46 basic syntax-rules extensions +** DONE SRFI-46 basic syntax-rules extensions + - State "DONE" [2009-12-26 Sat 07:59] ** DONE (... ...) support - State "DONE" [2009-12-26 Sat 02:06] ** TODO compiler macros diff --git a/lib/config.scm b/lib/config.scm index 461a6351..0993a3e3 100644 --- a/lib/config.scm +++ b/lib/config.scm @@ -164,5 +164,8 @@ (list (cons '(scheme) (make-module #f (interaction-environment) '())) (cons '(srfi 0) (make-module (list 'cond-expand) (interaction-environment) - (list (list 'export 'cond-expand)))))) + (list (list 'export 'cond-expand)))) + (cons '(srfi 46) (make-module (list 'syntax-rules) + (interaction-environment) + (list (list 'export 'syntax-rules)))))) diff --git a/lib/init.scm b/lib/init.scm index 3c4f9491..8bcc7491 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -630,7 +630,9 @@ (_append (rename 'append)) (_map (rename 'map)) (_vector? (rename 'vector?)) (_list? (rename 'list?)) (_lp (rename 'lp)) (_reverse (rename 'reverse)) - (_error (rename 'error)) + (_len (rename'len)) (_length (rename 'length)) + (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error)) + (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) (_vector->list (rename 'vector->list)) (_list->vector (rename 'list->vector))) (define ellipse (rename (if ellipse-specified? (cadr expr) '...))) @@ -658,7 +660,28 @@ ((ellipse? p) (cond ((not (null? (cddr p))) - (error "non-trailing ellipse")) + (cond + ((not (list? (cddr p))) + (error "dotted ellipse" p)) + ((any (lambda (x) (and (identifier? x) (compare x ellipse))) + (cddr p)) + (error "multiple ellipses" p)) + (else + (let ((len (length (cdr (cdr p))))) + `(,_let ((,_len (,_length ,v))) + (,_and (,_>= ,_len ,len) + (,_let ,_lp ((,_ls ,v) + (,_i (,_- ,_len ,len)) + (,_res (,_quote ()))) + (,_if (,_>= 0 ,_i) + ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p))) + `(,_append ,_ls (,_reverse ,_res)) + dim + vars + k) + (,_lp (,_cdr ,_ls) + (,_- ,_i 1) + (,_cons (,_car ,_ls) ,_res)))))))))) ((identifier? (car p)) (list _and (list _list? v) (list _let (list (list (car p) v)) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index c657be99..c35d71df 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -465,6 +465,13 @@ (args ::: ...))))) (foo 3 - 5))) +(test '(5 4 1 2 3) + (let-syntax + ((foo (syntax-rules () + ((foo args ... penultimate ultimate) + (list ultimate penultimate args ...))))) + (foo 1 2 3 4 5))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test-report) From 8596e1812abc6d70721cf7157adce5e95d14113d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Dec 2009 08:25:57 +0900 Subject: [PATCH 279/535] recursive evals now share the same stack. since in a minimal chibi heap the stack accounts for a large amount of the space, this makes a big difference - you can now load (chibi match) in a 2MB heap on a 64-bit system and it won't grow the heap. --- TODO | 7 ++----- eval.c | 7 ++++++- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/TODO b/TODO index 8c59ef19..854cceb3 100644 --- a/TODO +++ b/TODO @@ -9,11 +9,8 @@ - State "DONE" [2009-04-09 Thu 14:45] ** TODO native x86 backend ** TODO fasl/image files -** TODO shared stack on EVAL - Arguably a bug, at the moment we create a new stack on every EVAL - (which includes every macro definition, and in particular every - call to let-syntax that a macro may expand into - I'm looking at - you, (chibi loop)). +** DONE shared stack on EVAL + - State "DONE" [2009-12-26 Sat 08:22] * compiler optimizations ** DONE constant folding diff --git a/eval.c b/eval.c index 4ec24ffc..7b7305fc 100644 --- a/eval.c +++ b/eval.c @@ -2653,13 +2653,18 @@ sexp sexp_compile (sexp ctx, sexp x) { } sexp sexp_eval (sexp ctx, sexp obj, sexp env) { + sexp_sint_t top; sexp ctx2; sexp_gc_var1(res); sexp_gc_preserve1(ctx, res); - ctx2 = sexp_make_eval_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); + top = sexp_context_top(ctx); + ctx2 = sexp_make_eval_context(ctx, + sexp_context_stack(ctx), + (env ? env : sexp_context_env(ctx))); res = sexp_compile(ctx2, obj); if (! sexp_exceptionp(res)) res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_context_top(ctx) = top; sexp_gc_release1(ctx); return res; } From e82b500b61c987b76ae2441510b67528f3aa2ad1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Dec 2009 09:01:45 +0900 Subject: [PATCH 280/535] adding explicit type-casts when using sexp_cpointer_value, not all compilers will allow implicit conversions from void*. also removing Linux-specific stime and utime from siginfo_t. --- lib/chibi/process.stub | 7 ++++--- lib/chibi/signal.c | 2 +- tools/genstubs.scm | 18 ++++++++++++------ 3 files changed, 17 insertions(+), 10 deletions(-) diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub index baa5a7a5..5c0f1a34 100644 --- a/lib/chibi/process.stub +++ b/lib/chibi/process.stub @@ -4,7 +4,7 @@ (c-system-include "signal.h") (c-system-include "unistd.h") -(define-c-struct siginfo +(define-c-type siginfo_t predicate: signal-info? (int si_signo signal-number) (int si_errno signal-error-number) @@ -12,8 +12,9 @@ (pid_t si_pid signal-pid) (uid_t si_uid signal-uid) (int si_status signal-status) - (clock_t si_utime signal-user-time) - (clock_t si_stime signal-system-time)) + ;;(clock_t si_utime signal-user-time) + ;;(clock_t si_stime signal-system-time) + ) (define-c-type sigset_t predicate: signal-set?) diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c index 6def22ef..930ef468 100644 --- a/lib/chibi/signal.c +++ b/lib/chibi/signal.c @@ -15,7 +15,7 @@ static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { sexp_gc_preserve1(sigctx, args); args = sexp_cons(sigctx, SEXP_FALSE, SEXP_NULL); sexp_car(args) - = sexp_make_cpointer(sigctx, sexp_siginfo_type_id, info, SEXP_FALSE, 0); + = sexp_make_cpointer(sigctx, sexp_siginfo_t_type_id, info, SEXP_FALSE, 0); args = sexp_cons(sigctx, SEXP_FALSE, args); sexp_car(args) = sexp_make_fixnum(signum); sexp_apply(sigctx, handler, args); diff --git a/tools/genstubs.scm b/tools/genstubs.scm index c679c30c..a6a9fc98 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -502,7 +502,8 @@ (let ((ctype (assq base *types*))) (cond (ctype - (cat (if (type-null? type) + (cat "(" (type-c-name type) ")" + (if (type-null? type) "sexp_cpointer_maybe_null_value" "sexp_cpointer_value") "(" val ")")) @@ -532,13 +533,16 @@ ((string env-string non-null-string) "char*") (else (symbol->string base)))) +(define (type-struct-type type) + (let ((type-spec (assq (if (vector? type) (type-base type) type) *types*))) + (cond ((and type-spec (memq 'type: type-spec)) => cadr) + (else #f)))) + (define (type-c-name type) (let* ((type (parse-type type)) (base (type-base type)) (type-spec (assq base *types*)) - (struct-type - (cond ((and type-spec (memq 'type: type-spec)) => cadr) - (else #f)))) + (struct-type (type-struct-type type))) (string-append (if (type-const? type) "const " "") (if struct-type (string-append (symbol->string struct-type) " ") "") @@ -988,7 +992,8 @@ (lambda () (c->scheme-converter (car field) - (string-append "((struct " (mangle name) "*)" + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" "sexp_cpointer_value(x))" (if (type-struct? (car field)) "." "->") (x->string (cadr field))) @@ -1008,7 +1013,8 @@ " " (lambda () (c->scheme-converter (car field) - (string-append "((struct " (mangle name) "*)" + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" "sexp_cpointer_value(x))" (if (type-struct? (car field)) "." "->") (x->string (cadr field))))) From 55710f48be449ac605a45fdb6dcd90110f35bc5b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Dec 2009 09:09:04 +0900 Subject: [PATCH 281/535] DIR isn't a struct --- lib/chibi/filesystem.stub | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub index ebd2f7be..69b50a31 100644 --- a/lib/chibi/filesystem.stub +++ b/lib/chibi/filesystem.stub @@ -3,7 +3,7 @@ (c-system-include "unistd.h") (c-system-include "dirent.h") -(define-c-struct DIR +(define-c-type DIR finalizer: closedir) (define-c-struct dirent From 7eae77d0f93340c760e636aeda4f8dad3d19c88f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Dec 2009 16:21:37 +0900 Subject: [PATCH 282/535] converting make-exception to a primitive opcode instead of a foreign function, since foreign functions will always raise any exception they return (hence the double catch in issue #15). also restoring the original exception handler when an exception is raised in with-exception-handler, so that exceptions within the handler itself don't cause an infinite loop. this may change, as with-exception-handler is meant to be a low-level tool on which to build either guard or condition-case, but until then the restoring is necessary. --- eval.c | 4 ++++ include/chibi/eval.h | 1 + lib/init.scm | 5 ++++- opcodes.c | 2 +- opt/debug.c | 4 ++-- 5 files changed, 12 insertions(+), 4 deletions(-) diff --git a/eval.c b/eval.c index 7b7305fc..26f212a3 100644 --- a/eval.c +++ b/eval.c @@ -1581,6 +1581,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); top--; break; + case SEXP_OP_MAKE_EXCEPTION: + _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + break; case SEXP_OP_AND: _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); top--; diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 22b5f340..8ba7b442 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -76,6 +76,7 @@ enum sexp_opcode_names { SEXP_OP_STRING_LENGTH, SEXP_OP_MAKE_PROCEDURE, SEXP_OP_MAKE_VECTOR, + SEXP_OP_MAKE_EXCEPTION, SEXP_OP_AND, SEXP_OP_NULLP, SEXP_OP_FIXNUMP, diff --git a/lib/init.scm b/lib/init.scm index 8bcc7491..aed24843 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -312,7 +312,10 @@ (define (with-exception-handler handler thunk) (let ((orig-handler (current-exception-handler))) - (current-exception-handler handler) + (current-exception-handler + (lambda (exn) + (current-exception-handler orig-handler) + (handler exn))) (let ((res (thunk))) (current-exception-handler orig-handler) res))) diff --git a/opcodes.c b/opcodes.c index 5d3a36cc..8f9825d9 100644 --- a/opcodes.c +++ b/opcodes.c @@ -48,6 +48,7 @@ _OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), @@ -95,7 +96,6 @@ _FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_ _FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), _FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), -_FN5(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), diff --git a/opt/debug.c b/opt/debug.c index 16419d3a..561cd52f 100644 --- a/opt/debug.c +++ b/opt/debug.c @@ -11,8 +11,8 @@ static const char* reverse_opcode_names[] = "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?", + "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", + "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE", From e9d6f1857a6b15c049923024e76ef32d84f3229e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Dec 2009 23:46:54 +0900 Subject: [PATCH 283/535] types are now context-group local by default. --- Makefile | 7 ++- TODO | 2 + eval.c | 23 ++++++-- gc.c | 22 ++++---- include/chibi/config.h | 3 ++ include/chibi/sexp.h | 49 ++++++++++------- lib/chibi/filesystem.module | 5 ++ lib/chibi/filesystem.stub | 27 ++++++++++ lib/chibi/heap-stats.c | 4 +- lib/chibi/net.module | 2 +- lib/chibi/net.scm | 4 +- lib/chibi/net.stub | 1 - lib/chibi/process.module | 2 +- lib/chibi/process.stub | 4 +- lib/srfi/1/search.scm | 5 +- lib/srfi/69/hash.c | 12 ++--- sexp.c | 105 +++++++++++++++++++++--------------- tests/r5rs-tests.scm | 20 ++++--- tools/genstubs.scm | 10 +++- 19 files changed, 196 insertions(+), 111 deletions(-) diff --git a/Makefile b/Makefile index 6b2ce258..01e3647c 100644 --- a/Makefile +++ b/Makefile @@ -81,10 +81,9 @@ endif all: chibi-scheme$(EXE) libs COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ - lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ - lib/chibi/ast$(SO) lib/chibi/net$(SO) \ - lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \ - lib/chibi/time$(SO) lib/chibi/heap-stats$(SO) + lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) lib/chibi/ast$(SO) \ + lib/chibi/net$(SO) lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \ + lib/chibi/time$(SO) lib/chibi/system$(SO) lib/chibi/heap-stats$(SO) libs: $(COMPILED_LIBS) diff --git a/TODO b/TODO index 854cceb3..93f7c837 100644 --- a/TODO +++ b/TODO @@ -60,6 +60,7 @@ - State "DONE" [2009-07-07 Tue 14:42] ** TODO unicode ** TODO threads +** TODO virtual ports ** DONE dynamic-wind - State "DONE" [2009-12-26 Sat 01:51] Adapted a version from Scheme48. @@ -138,6 +139,7 @@ ** TODO overall cleanup ** TODO user documentation ** TODO thorough source documentation +** TODO full test suite for libraries * distribution ** TODO packaging format diff --git a/eval.c b/eval.c index 26f212a3..4546318f 100644 --- a/eval.c +++ b/eval.c @@ -1609,13 +1609,13 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case SEXP_OP_SLOT_REF: if (! sexp_check_tag(_ARG1, _UWORD0)) - sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(_UWORD0), -1), _ARG1)); + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); ip += sizeof(sexp)*2; break; case SEXP_OP_SLOT_SET: if (! sexp_check_tag(_ARG1, _UWORD0)) - sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(_UWORD0), -1), _ARG1)); + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); else if (sexp_immutablep(_ARG1)) sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); sexp_slot_set(_ARG1, _UWORD1, _ARG2); @@ -2154,12 +2154,27 @@ 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) +static sexp sexp_sqrt (sexp ctx, sexp z) { + double d, r; + if (sexp_flonump(z)) + d = sexp_flonum_value(z); + else if (sexp_fixnump(z)) + d = (double)sexp_unbox_fixnum(z); + maybe_convert_bignum(z) /* XXXX add bignum sqrt */ + else + return sexp_type_exception(ctx, "not a number", z); + r = sqrt(d); + if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) + return sexp_make_fixnum(round(r)); + else + return sexp_make_flonum(ctx, r); +} + #endif static sexp sexp_expt (sexp ctx, sexp x, sexp e) { @@ -2354,7 +2369,7 @@ sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { sexp_uint_t type_size; if (! sexp_fixnump(type)) return sexp_type_exception(ctx, "make-constructor: bad type", type); - type_size = sexp_type_size_base(&(sexp_type_specs[sexp_unbox_fixnum(type)])); + type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, diff --git a/gc.c b/gc.c index e53b83af..79ff4b87 100644 --- a/gc.c +++ b/gc.c @@ -44,17 +44,17 @@ static sexp_heap sexp_heap_last (sexp_heap h) { return h; } -sexp_uint_t sexp_allocated_bytes (sexp x) { +sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) { sexp_uint_t res; sexp t; - if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_num_types)) + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) return sexp_heap_align(1); - t = &(sexp_type_specs[sexp_pointer_tag(x)]); + t = sexp_object_type(ctx, x); res = sexp_type_size_of_object(t, x); return res; } -void sexp_mark (sexp x) { +void sexp_mark (sexp ctx, sexp x) { sexp_sint_t i, len; sexp t, *p; struct sexp_gc_var_t *saves; @@ -64,13 +64,13 @@ void sexp_mark (sexp x) { 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)]); + if (saves->var) sexp_mark(ctx, *(saves->var)); + t = sexp_object_type(ctx, x); p = (sexp*) (((char*)x) + sexp_type_field_base(t)); len = sexp_type_num_slots_of_object(t, x) - 1; if (len >= 0) { for (i=0; isize); continue; } - size = sexp_heap_align(sexp_allocated_bytes(p)); + size = sexp_heap_align(sexp_allocated_bytes(ctx, p)); if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { /* free p */ - finalizer = sexp_type_finalize(sexp_object_type(p)); + finalizer = sexp_type_finalize(sexp_object_type(ctx, p)); if (finalizer) finalizer(ctx, p); sum_freed += size; if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) { @@ -159,9 +159,9 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) { #if SEXP_USE_GLOBAL_SYMBOLS int i; for (i=0; iimmutablep) #define sexp_freep(x) ((x)->freep) -#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag])) -#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x))) -#define sexp_type_name_by_index(x) (sexp_type_name(&(sexp_type_specs[(x)]))) - -#define sexp_type_size_of_object(t, x) \ - (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \ - * sexp_type_size_scale(t) \ - + sexp_type_size_base(t)) -#define sexp_type_num_slots_of_object(t, x) \ - (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ - * sexp_type_field_len_scale(t) \ - + sexp_type_field_len_base(t)) -#define sexp_type_num_eq_slots_of_object(t, x) \ - (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ - * sexp_type_field_len_scale(t) \ - + sexp_type_field_eq_len_base(t)) - #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) #define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) @@ -645,11 +628,37 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #endif #if SEXP_USE_GLOBAL_TYPES -#define sexp_context_types(ctx) sexp_type_specs +SEXP_API struct sexp_struct *sexp_type_specs; +#define sexp_context_types(ctx) sexp_type_specs +#define sexp_type_by_index(ctx,i) (&(sexp_context_types(ctx)[i])) +#define sexp_context_num_types(ctx) sexp_num_types +#define sexp_context_type_array_size(ctx) sexp_type_array_size #else -#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#define sexp_type_by_index(ctx,i) (sexp_context_types(ctx)[i]) +#define sexp_context_num_types(ctx) \ + sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES)) +#define sexp_context_type_array_size(ctx) \ + sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES)) #endif +#define sexp_object_type(ctx,x) (sexp_type_by_index(ctx, ((x)->tag))) +#define sexp_object_type_name(ctx,x) (sexp_type_name(sexp_object_type(ctx, x))) +#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i))) + +#define sexp_type_size_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \ + * sexp_type_size_scale(t) \ + + sexp_type_size_base(t)) +#define sexp_type_num_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_len_base(t)) +#define sexp_type_num_eq_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_eq_len_base(t)) + #define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) #define sexp_type_tag(x) ((x)->value.type.tag) @@ -692,6 +701,7 @@ enum sexp_context_globals { #endif #if ! SEXP_USE_GLOBAL_TYPES SEXP_G_TYPES, + SEXP_G_NUM_TYPES, #endif SEXP_G_OOM_ERROR, /* out of memory exception object */ SEXP_G_OOS_ERROR, /* out of stack exception object */ @@ -768,7 +778,6 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); #define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) -SEXP_API struct sexp_struct *sexp_type_specs; SEXP_API sexp sexp_make_context(sexp ctx); 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); diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module index fe0fbdcf..82a8ebda 100644 --- a/lib/chibi/filesystem.module +++ b/lib/chibi/filesystem.module @@ -15,6 +15,11 @@ file-regular? file-directory? file-character? file-block? file-fifo? file-link? file-socket? + get-file-descriptor-flags set-file-descriptor-flags! + get-file-descriptor-status set-file-descriptor-status! + open/read open/write open/read-write + open/create open/exclusive open/truncate + open/append open/non-block ) (import-immutable (scheme)) (include-shared "filesystem") diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub index 69b50a31..8c42466f 100644 --- a/lib/chibi/filesystem.stub +++ b/lib/chibi/filesystem.stub @@ -2,6 +2,7 @@ (c-system-include "sys/types.h") (c-system-include "unistd.h") (c-system-include "dirent.h") +(c-system-include "fcntl.h") (define-c-type DIR finalizer: closedir) @@ -86,3 +87,29 @@ (define-c errno (open-pipe "pipe") ((result (array int 2)))) (define-c errno (make-fifo "mkfifo") (string (default #o644 int))) + +(define-c int (get-file-descriptor-flags "fcntl") + (int (value F_GETFD int))) +(define-c errno (set-file-descriptor-flags! "fcntl") + (int (value F_SETFD int) long)) + +(define-c int (get-file-descriptor-status "fcntl") + (int (value F_GETFL int))) +(define-c errno (set-file-descriptor-status! "fcntl") + (int (value F_SETFL int) long)) + +;; (define-c int (get-file-descriptor-lock "fcntl") +;; (int (value F_GETLK int) flock)) +;; (define-c errno (set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLK int) flock)) +;; (define-c errno (try-set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLKW int) flock)) + +(define-c-const int (open/read "O_RDONLY")) +(define-c-const int (open/write "O_WRONLY")) +(define-c-const int (open/read-write "O_RDWR")) +(define-c-const int (open/create "O_CREAT")) +(define-c-const int (open/exclusive "O_EXCL")) +(define-c-const int (open/truncate "O_TRUNC")) +(define-c-const int (open/append "O_APPEND")) +(define-c-const int (open/non-block "O_NONBLOCK")) diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c index 8b928fe4..381d0b31 100644 --- a/lib/chibi/heap-stats.c +++ b/lib/chibi/heap-stats.c @@ -42,7 +42,7 @@ static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { } else { print_name: sexp_write_string(ctx, "#<", out); - sexp_write_string(ctx, sexp_object_type_name(x), out); + sexp_write_string(ctx, sexp_object_type_name(ctx, x), out); sexp_write_string(ctx, ">", out); } } @@ -97,7 +97,7 @@ static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { res = SEXP_NULL; for (i=hi_type; i>0; i--) if (stats[i]) { - name = sexp_intern(ctx, sexp_type_name_by_index(i)); + name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i)); tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); res = sexp_cons(ctx, tmp, res); } diff --git a/lib/chibi/net.module b/lib/chibi/net.module index 14f3801f..41cdafe4 100644 --- a/lib/chibi/net.module +++ b/lib/chibi/net.module @@ -4,7 +4,7 @@ address-info-family address-info-socket-type address-info-protocol address-info-address address-info-address-length address-info-next) (import-immutable (scheme)) - (import (chibi posix)) + (import (chibi filesystem)) (include-shared "net") (include "net.scm")) diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm index a6fd78e0..0ac1adca 100644 --- a/lib/chibi/net.scm +++ b/lib/chibi/net.scm @@ -13,8 +13,8 @@ (address-info-address addr) (address-info-address-length addr))) (lp (address-info-next addr)) - (let ((in (open-input-fd sock)) - (out (open-output-fd sock))) + (let ((in (open-input-file-descriptor sock)) + (out (open-output-file-descriptor sock))) (let ((res (proc in out))) (close-input-port in) res)))))))) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub index 8e595f8f..0d72bc90 100644 --- a/lib/chibi/net.stub +++ b/lib/chibi/net.stub @@ -23,4 +23,3 @@ (define-c int listen (int int)) (define-c int socket (int int int)) (define-c int connect (int sockaddr int)) - diff --git a/lib/chibi/process.module b/lib/chibi/process.module index 3e3f2cdb..fe03c2e5 100644 --- a/lib/chibi/process.module +++ b/lib/chibi/process.module @@ -1,6 +1,6 @@ (define-module (chibi process) - (export exit sleep fork kill execute waitpid + (export exit sleep alarm fork kill execute waitpid set-signal-action! make-signal-set signal-set-contains? signal-set-fill! signal-set-add! signal-set-delete! current-signal-mask diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub index 5c0f1a34..7dbca7eb 100644 --- a/lib/chibi/process.stub +++ b/lib/chibi/process.stub @@ -59,12 +59,14 @@ (define-c errno (current-signal-mask "sigprocmask") ((value SIG_BLOCK int) (value NULL sigset_t) (result sigset_t))) +(define-c unsigned-int alarm (unsigned-int)) +(define-c unsigned-int sleep (unsigned-int)) + (define-c pid_t fork ()) ;;(define-c pid_t wait ((result int))) (define-c pid_t waitpid (int (result int) int)) (define-c errno kill (int int)) ;;(define-c errno raise (int)) -(define-c unsigned-int sleep (unsigned-int)) (define-c void exit (int)) (define-c int (execute execvp) (string (array string))) diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm index 335faf4c..4ab9eb7d 100644 --- a/lib/srfi/1/search.scm +++ b/lib/srfi/1/search.scm @@ -30,10 +30,11 @@ (define (any pred ls . lists) (if (null? lists) - (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) #t (lp (cdr ls))))) + (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls))))) (let lp ((lists (cons ls lists))) (and (every pair? lists) - (if (apply pred (map car lists)) #t (lp (map cdr lists))))))) + (let ((args (map car lists))) + (if (apply pred args) args (lp (map cdr lists)))))))) (define (every pred ls . lists) (if (null? lists) diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c index 9ab056e4..51da2b62 100644 --- a/lib/srfi/69/hash.c +++ b/lib/srfi/69/hash.c @@ -44,7 +44,7 @@ static sexp sexp_string_ci_hash (sexp ctx, sexp str, sexp bound) { sexp_unbox_fixnum(bound))); } -static sexp_uint_t hash_one (sexp obj, sexp_uint_t bound, sexp_sint_t depth) { +static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) { sexp_uint_t acc = FNV_OFFSET_BASIS, size; sexp_sint_t i, len; sexp t, *p; @@ -57,7 +57,7 @@ static sexp_uint_t hash_one (sexp obj, sexp_uint_t bound, sexp_sint_t depth) { #endif if (sexp_pointerp(obj)) { if (depth) { - t = &(sexp_type_specs[sexp_pointer_tag(obj)]); + t = sexp_object_type(ctx, obj); p = (sexp*) (((char*)obj) + sexp_type_field_base(t)); p0 = ((char*)obj) + offsetof(struct sexp_struct, value); if ((sexp)p == obj) p=(sexp*)p0; @@ -72,7 +72,7 @@ static sexp_uint_t hash_one (sexp obj, sexp_uint_t bound, sexp_sint_t depth) { depth--; for (i=0; i= SEXP_MAXIMUM_TYPES) { - fprintf(stderr, "chibi: exceeded maximum type limit\n"); - res = SEXP_FALSE; +#if SEXP_USE_GLOBAL_TYPES + struct sexp_struct *new, *tmp; +#else + sexp *v1, *v2; +#endif + sexp res, type; + sexp_uint_t i, len, num_types=sexp_context_num_types(ctx), + type_array_size=sexp_context_type_array_size(ctx); + if (num_types >= SEXP_MAXIMUM_TYPES) { + res = sexp_user_exception(ctx, SEXP_FALSE, "register-type: exceeded maximum type limit", name); } else if (! sexp_stringp(name)) { res = sexp_type_exception(ctx, "register-type: not a string", name); } else { - if (sexp_num_types >= sexp_type_array_size) { - len = sexp_type_array_size*2; + if (num_types >= type_array_size) { + len = type_array_size*2; if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES; +#if SEXP_USE_GLOBAL_TYPES new = malloc(len * sizeof(_sexp_type_specs[0])); - for (i=0; i sexp_num_types) free(tmp); + if (type_array_size > num_types) free(tmp); sexp_type_array_size = len; +#else + res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID); + v1 = sexp_vector_data(res); + v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)); + for (i=0; i', out); break; diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index c35d71df..85b3a801 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -168,6 +168,10 @@ (test #t (equal? 2 2)) +(test #f (eqv? 2 2.0)) + +(test #f (equal? 2.0 2)) + (test #t (equal? (make-vector 5 'a) (make-vector 5 'a))) (test 4 (max 3 4)) @@ -212,21 +216,21 @@ (test 288 (lcm 32 -36)) -(test -5 (floor -4.3)) +(test #t (= -5 (floor -4.3))) -(test -4 (ceiling -4.3)) +(test #t (= -4 (ceiling -4.3))) -(test -4 (truncate -4.3)) +(test #t (= -4 (truncate -4.3))) -(test -4 (round -4.3)) +(test #t (= -4 (round -4.3))) -(test 3 (floor 3.5)) +(test #t (= 3 (floor 3.5))) -(test 4 (ceiling 3.5)) +(test #t (= 4 (ceiling 3.5))) -(test 3 (truncate 3.5)) +(test #t (= 3 (truncate 3.5))) -(test 4 (round 3.5)) +(test #t (= 4 (round 3.5))) (test 100 (string->number "100")) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index a6a9fc98..bb55fcfd 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -238,6 +238,10 @@ ;; function objects (define (parse-func func) + (if (not (and (= 3 (length func)) + (or (identifier? (cadr func)) (list (cadr func))) + (list (caddr func)))) + (error "bad function definition" func)) (let* ((ret-type (parse-type (car func))) (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) (c-name (if (pair? (cadr func)) @@ -678,7 +682,7 @@ (lambda (x) (let ((len (get-array-length func x))) (cat " " (type-c-name (type-base x)) " ") - (if (or (type-pointer? x) (and (type-array x) (not (number? len)))) + (if (and (type-array x) (not (number? len))) (cat "*")) (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) (if (number? len) @@ -747,7 +751,8 @@ (if (not (number? (type-array a))) (cat " tmp" (type-index a) "[i] = NULL;\n"))) ((and (type-result? a) (not (basic-type? a)) - (not (type-free? a)) (not (type-auto-expand? a)) + (not (type-free? a)) (not (type-pointer? a)) + (not (type-auto-expand? a)) (or (not (type-array a)) (not (integer? (get-array-length func a))))) (cat " tmp" (type-index a) " = malloc(sizeof(tmp" (type-index a) @@ -768,6 +773,7 @@ (cond ((any (lambda (y) (and (type-array y) + (type-auto-expand? y) (eq? x (get-array-length func y)))) (func-c-args func)) => (lambda (y) (cat "len" (type-index y)))) From 2534e81d5b40a532210479c09f38de5a998c4bc1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Dec 2009 23:48:43 +0900 Subject: [PATCH 284/535] adding initial host system module --- lib/chibi/system.module | 15 +++++++++++++++ lib/chibi/system.stub | 34 ++++++++++++++++++++++++++++++++++ 2 files changed, 49 insertions(+) create mode 100644 lib/chibi/system.module create mode 100644 lib/chibi/system.stub diff --git a/lib/chibi/system.module b/lib/chibi/system.module new file mode 100644 index 00000000..adc26ddc --- /dev/null +++ b/lib/chibi/system.module @@ -0,0 +1,15 @@ + +(define-module (chibi system) + (export user-information user-name user-password + user-id user-group-id user-gecos user-home user-shell + current-user-id current-group-id + current-effective-user-id current-effective-group-id + set-current-user-id! set-current-effective-user-id! + set-current-group-id! set-current-effective-group-id! + current-session-id create-session + set-root-directory!) + (import-immutable (scheme)) + (include-shared "system") + ;;(include "system.scm") + ) + diff --git a/lib/chibi/system.stub b/lib/chibi/system.stub new file mode 100644 index 00000000..7d4a836f --- /dev/null +++ b/lib/chibi/system.stub @@ -0,0 +1,34 @@ + +(c-system-include "unistd.h") +(c-system-include "pwd.h") +(c-system-include "sys/types.h") + +(define-c-struct passwd + predicate: user? + (string pw_name user-name) + (string pw_passwd user-password) + (uid_t pw_uid user-id) + (gid_t pw_gid user-group-id) + (string pw_gecos user-gecos) + (string pw_dir user-home) + (string pw_shell user-shell)) + +(define-c uid_t (current-user-id "getuid") ()) +(define-c gid_t (current-group-id "getgid") ()) +(define-c uid_t (current-effective-user-id "geteuid") ()) +(define-c gid_t (current-effective-group-id "getegid") ()) + +(define-c errno (set-current-user-id! "setuid") (uid_t)) +(define-c errno (set-current-effective-user-id! "seteuid") (uid_t)) +(define-c errno (set-current-group-id! "setgid") (gid_t)) +(define-c errno (set-current-effective-group-id! "setegid") (gid_t)) + +(define-c pid_t (current-session-id "getsid") ((default 0 pid_t))) +(define-c pid_t (create-session "setsid") ()) + +(define-c errno (set-root-directory! "chroot") (string)) + +;; (define-c errno getpwuid_r +;; (uid_t (result passwd) (result (array char arg3)) +;; (value 256 int) (result pointer passwd))) + From 23411056c2f636dc82cfb36fd86b061a8df667be Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 27 Dec 2009 00:28:20 +0900 Subject: [PATCH 285/535] resetting current-exception-handler after handler is done --- lib/init.scm | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lib/init.scm b/lib/init.scm index aed24843..88fb43b4 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -311,11 +311,13 @@ (raise (make-exception 'user msg args #f #f))) (define (with-exception-handler handler thunk) - (let ((orig-handler (current-exception-handler))) - (current-exception-handler - (lambda (exn) - (current-exception-handler orig-handler) - (handler exn))) + (letrec ((orig-handler (current-exception-handler)) + (self (lambda (exn) + (current-exception-handler orig-handler) + (let ((res (handler exn))) + (current-exception-handler self) + res)))) + (current-exception-handler self) (let ((res (thunk))) (current-exception-handler orig-handler) res))) From 3c2615e2a7b4fdd4ae7221b7bd98ce7245273725 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 27 Dec 2009 00:45:28 +0900 Subject: [PATCH 286/535] moving file-exists? to (chibi filesystem) --- eval.c | 9 --------- lib/chibi/filesystem.module | 2 +- lib/chibi/filesystem.scm | 1 + opcodes.c | 1 - opt/plan9-opcodes.c | 1 + 5 files changed, 3 insertions(+), 11 deletions(-) diff --git a/eval.c b/eval.c index 4546318f..0c87270d 100644 --- a/eval.c +++ b/eval.c @@ -2038,15 +2038,6 @@ static sexp sexp_close_port (sexp ctx, sexp port) { return SEXP_VOID; } -#ifndef PLAN9 -static sexp sexp_file_exists_p (sexp ctx, sexp path) { - struct stat buf; - if (! sexp_stringp(path)) - return sexp_type_exception(ctx, "not a string", path); - return (stat(sexp_string_data(path), &buf) ? SEXP_FALSE : SEXP_TRUE); -} -#endif - 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)) diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module index 82a8ebda..38a8fab1 100644 --- a/lib/chibi/filesystem.module +++ b/lib/chibi/filesystem.module @@ -14,7 +14,7 @@ file-access-time file-modification-time file-change-time file-regular? file-directory? file-character? file-block? file-fifo? file-link? - file-socket? + file-socket? file-exists? get-file-descriptor-flags set-file-descriptor-flags! get-file-descriptor-status set-file-descriptor-status! open/read open/write open/read-write diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm index b3995221..d1fe36ba 100644 --- a/lib/chibi/filesystem.scm +++ b/lib/chibi/filesystem.scm @@ -37,3 +37,4 @@ (define (file-link? x) (S_ISLNK (file-mode x))) (define (file-socket? x) (S_ISSOCK (file-mode x))) +(define (file-exists? x) (and (file-status file) #t)) diff --git a/opcodes.c b/opcodes.c index 8f9825d9..5b943e6f 100644 --- a/opcodes.c +++ b/opcodes.c @@ -142,7 +142,6 @@ _FN2OPTP(SEXP_PROCEDURE, SEXP_OPORT, "disasm", (sexp)"*current-error-port*", sex #if PLAN9 #include "opt/plan9-opcodes.c" #endif -_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), #if SEXP_USE_MODULES _FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports), _FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), diff --git a/opt/plan9-opcodes.c b/opt/plan9-opcodes.c index e64dd8a8..9f7cac33 100644 --- a/opt/plan9-opcodes.c +++ b/opt/plan9-opcodes.c @@ -16,3 +16,4 @@ _FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), _FN0("wait", 0, sexp_wait), _FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), _FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), +_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), From 02a763007df4545d2601f9661cabf1499b1836e7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 27 Dec 2009 01:17:32 +0900 Subject: [PATCH 287/535] moving disasm to (chibi disasm) module --- Makefile | 3 ++- README | 5 ++++- eval.c | 18 ++++++++++-------- include/chibi/config.h | 6 ------ opt/debug.c => lib/chibi/disasm.c | 30 ++++++++++++++++++------------ lib/chibi/disasm.module | 4 ++++ lib/chibi/filesystem.scm | 2 +- opcodes.c | 3 --- 8 files changed, 39 insertions(+), 32 deletions(-) rename opt/debug.c => lib/chibi/disasm.c (83%) create mode 100644 lib/chibi/disasm.module diff --git a/Makefile b/Makefile index 01e3647c..89fce44a 100644 --- a/Makefile +++ b/Makefile @@ -83,7 +83,8 @@ all: chibi-scheme$(EXE) libs COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) lib/chibi/ast$(SO) \ lib/chibi/net$(SO) lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \ - lib/chibi/time$(SO) lib/chibi/system$(SO) lib/chibi/heap-stats$(SO) + lib/chibi/time$(SO) lib/chibi/system$(SO) lib/chibi/heap-stats$(SO) \ + lib/chibi/disasm$(SO) libs: $(COMPILED_LIBS) diff --git a/README b/README index 7c399df0..cfbdc524 100644 --- a/README +++ b/README @@ -72,7 +72,10 @@ The essential functions to remember are: A minimal module system is provided by default. Currently you can load the following SRFIs with (import (srfi N)): - 1, 2, 6, 8, 9, 11, 16, 26, 69 + 0, 1, 2, 6, 8, 9, 11, 16, 26, 27, 33, 46, 62, 69, 98 + +although 0, 46 and 62 are built into the default environment so +there's no need to import them. LOAD is extended to accept an optional environment argument, like EVAL. You can also LOAD shared libraries in addition to Scheme source diff --git a/eval.c b/eval.c index 0c87270d..e5cf340c 100644 --- a/eval.c +++ b/eval.c @@ -8,12 +8,16 @@ static int scheme_initialized_p = 0; -#if SEXP_USE_DEBUG -#include "opt/debug.c" -#else -#define print_stack(...) -#define print_bytecode(...) -#define sexp_disasm(...) +#if SEXP_USE_DEBUG_VM +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { + int i; + if (! sexp_oport(out)) out = sexp_current_error_port(ctx); + for (i=0; i Date: Sun, 27 Dec 2009 07:29:44 +0900 Subject: [PATCH 288/535] removing opt/debug.c from the eval.o dependencies --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 89fce44a..489beabb 100644 --- a/Makefile +++ b/Makefile @@ -98,7 +98,7 @@ include/chibi/install.h: Makefile sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< -eval.o: eval.c opcodes.c opt/debug.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile +eval.o: eval.c opcodes.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile From f645ecbb54278e80fd768d2e2b97aa2083cde2aa Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 27 Dec 2009 13:34:53 +0900 Subject: [PATCH 289/535] updating the sexp_allocated_bytes signature to use the context for context-local types --- lib/chibi/heap-stats.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c index 381d0b31..fcea809b 100644 --- a/lib/chibi/heap-stats.c +++ b/lib/chibi/heap-stats.c @@ -10,7 +10,7 @@ #endif extern sexp sexp_gc (sexp ctx, size_t *sum_freed); -extern sexp_uint_t sexp_allocated_bytes (sexp x); +extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { int i; @@ -88,7 +88,7 @@ static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { stats[sexp_pointer_tag(p)]++; if (sexp_pointer_tag(p) > hi_type) hi_type = sexp_pointer_tag(p); - p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(p))); + p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p))); } } From 5f7201ab045b5d70cdd786426546c96b4c86f28e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 27 Dec 2009 13:37:25 +0900 Subject: [PATCH 290/535] immediate flonums now work on 64-bit machines. we pack a 32-bit float so there's no funky rounding issues as on 32-bit machines. this reduces heap usage, and avoids allocations during flonum arithmetic. --- include/chibi/sexp.h | 8 +++++++- opcodes.c | 4 ++++ opt/bignum.c | 3 +++ sexp.c | 20 ++++++++++++++++++-- 4 files changed, 32 insertions(+), 3 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 9f1b775f..a73f3e98 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -391,11 +391,17 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #if SEXP_USE_IMMEDIATE_FLONUMS union sexp_flonum_conv { float flonum; - sexp_uint_t bits; + unsigned int bits; }; #define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x); +#if SEXP_64_BIT +SEXP_API float sexp_flonum_value (sexp x); +SEXP_API sexp sexp_make_flonum(sexp ctx, float f); +#else #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) +#endif #else #define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) #define sexp_flonum_value(f) ((f)->value.flonum) diff --git a/opcodes.c b/opcodes.c index a2af3017..c6f5445d 100644 --- a/opcodes.c +++ b/opcodes.c @@ -57,7 +57,11 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0 _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), +#if SEXP_USE_IMMEDIATE_FLONUMS +_FN1(0, "flonum?", 0, sexp_flonum_predicate), +#else _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), +#endif _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0), diff --git a/opt/bignum.c b/opt/bignum.c index 49cfb314..90f71661 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -465,6 +465,9 @@ static int sexp_number_types[] = static int sexp_number_type (sexp a) { return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] +#if SEXP_USE_IMMEDIATE_FLONUMS + : sexp_flonump(a) ? 2 +#endif : sexp_fixnump(a); } diff --git a/sexp.c b/sexp.c index 0bcc3a57..b12900b3 100644 --- a/sexp.c +++ b/sexp.c @@ -574,12 +574,28 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) { /********************* strings, symbols, vectors **********************/ #if ! SEXP_USE_IMMEDIATE_FLONUMS -sexp sexp_make_flonum(sexp ctx, double f) { +sexp sexp_make_flonum (sexp ctx, double f) { sexp x = sexp_alloc_type(ctx, flonum, SEXP_FLONUM); if (sexp_exceptionp(x)) return x; sexp_flonum_value(x) = f; return x; } +#else +sexp sexp_flonum_predicate (sexp ctx, sexp x) { + return sexp_make_boolean(sexp_flonump(x)); +} +#if SEXP_64_BIT +float sexp_flonum_value (sexp x) { + union sexp_flonum_conv r; + r.bits = (sexp_uint_t)x >> 32; + return r.flonum; +} +sexp sexp_make_flonum (sexp ctx, float f) { + union sexp_flonum_conv x; + x.flonum = f; + return (sexp)(((sexp_uint_t)(x.bits) << 32) + SEXP_IFLONUM_TAG); +} +#endif #endif sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { @@ -1111,7 +1127,7 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) { } else #endif { - i = sprintf(numbuf, "%.15g", f); + i = sprintf(numbuf, "%.8g", f); if (f == trunc(f) && ! strchr(numbuf, '.')) { numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; } From 461fec8e6d1ccb6b2dcf8db015a3e8ffd6517028 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 27 Dec 2009 15:44:28 +0900 Subject: [PATCH 291/535] adding build-tests script to verify different build options. --- Makefile | 3 +++ eval.c | 32 ++++++++++++++++++++------------ gc.c | 2 +- include/chibi/sexp.h | 3 +++ lib/chibi/ast.c | 3 --- lib/chibi/heap-stats.c | 3 +++ lib/srfi/27/rand.c | 5 ++++- lib/srfi/33/bit.c | 29 +++++++++++++++++++++++++---- opcodes.c | 2 +- sexp.c | 15 +++++++++++---- tests/build/build-opts.txt | 20 ++++++++++++++++++++ tests/build/build-tests.sh | 37 +++++++++++++++++++++++++++++++++++++ tests/r5rs-tests.scm | 22 ++++++++++++---------- 13 files changed, 140 insertions(+), 36 deletions(-) create mode 100644 tests/build/build-opts.txt create mode 100755 tests/build/build-tests.sh diff --git a/Makefile b/Makefile index 489beabb..0b6575ff 100644 --- a/Makefile +++ b/Makefile @@ -138,6 +138,9 @@ test-basic: chibi-scheme$(EXE) fi; \ done +test-build: + ./tests/build/build-tests.sh + test-numbers: all LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/numeric-tests.scm diff --git a/eval.c b/eval.c index e5cf340c..0eab33aa 100644 --- a/eval.c +++ b/eval.c @@ -22,8 +22,11 @@ static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) static sexp analyze (sexp ctx, sexp x); static void generate (sexp ctx, sexp x); + +#if SEXP_USE_MODULES static sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env); static sexp sexp_find_module_file_op (sexp ctx, sexp file); +#endif static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) { sexp exn; @@ -2179,7 +2182,7 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ else if (x == SEXP_ONE) - res = sexp_make_flonum(ctx, 1); /* 1.0 */ + res = SEXP_ONE; /* 1.0 */ else if (sexp_flonump(x)) res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); else @@ -2195,7 +2198,7 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { x1 = sexp_flonum_value(x); #endif else - return sexp_type_exception(ctx, "not a number", x); + return sexp_type_exception(ctx, "expt: not a number", x); if (sexp_fixnump(e)) e1 = sexp_unbox_fixnum(e); #if SEXP_USE_FLONUMS @@ -2203,11 +2206,13 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { e1 = sexp_flonum_value(e); #endif else - return sexp_type_exception(ctx, "not a number", e); + return sexp_type_exception(ctx, "expt: not a number", e); f = pow(x1, e1); + if ((f > SEXP_MAX_FIXNUM) || (f < SEXP_MIN_FIXNUM) #if SEXP_USE_FLONUMS - if ((f > SEXP_MAX_FIXNUM) || (! sexp_fixnump(x)) || (! sexp_fixnump(e))) { + || (! sexp_fixnump(x)) || (! sexp_fixnump(e)) #endif + ) { #if SEXP_USE_BIGNUMS if (sexp_fixnump(x) && sexp_fixnump(e)) res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); @@ -2215,8 +2220,10 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { #endif #if SEXP_USE_FLONUMS res = sexp_make_flonum(ctx, f); - } else +#else + res = sexp_make_fixnum((sexp_sint_t)round(f)); #endif + } else res = sexp_make_fixnum((sexp_sint_t)round(f)); #if SEXP_USE_BIGNUMS } @@ -2472,13 +2479,6 @@ sexp sexp_find_module_file (sexp ctx, char *file) { return res; } -static sexp sexp_find_module_file_op (sexp ctx, sexp file) { - if (! sexp_stringp(file)) - return sexp_type_exception(ctx, "not a string", file); - else - return sexp_find_module_file(ctx, sexp_string_data(file)); -} - #define sexp_file_not_found "couldn't find file in module path" sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { @@ -2496,6 +2496,13 @@ sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { return res; } +#if SEXP_USE_MODULES +static sexp sexp_find_module_file_op (sexp ctx, sexp file) { + if (! sexp_stringp(file)) + return sexp_type_exception(ctx, "not a string", file); + else + return sexp_find_module_file(ctx, sexp_string_data(file)); +} sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env) { if (! sexp_stringp(file)) return sexp_type_exception(ctx, "not a string", file); @@ -2503,6 +2510,7 @@ sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env) { return sexp_type_exception(ctx, "not an environment", env); return sexp_load_module_file(ctx, sexp_string_data(file), env); } +#endif sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp) { sexp ls; diff --git a/gc.c b/gc.c index 79ff4b87..7a5b409c 100644 --- a/gc.c +++ b/gc.c @@ -32,7 +32,7 @@ #endif #if SEXP_USE_GLOBAL_HEAP -static sexp_heap sexp_global_heap; +sexp_heap sexp_global_heap; #endif #if SEXP_USE_DEBUG_GC diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index a73f3e98..918debbe 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -622,6 +622,9 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) #if SEXP_USE_GLOBAL_HEAP +#if ! SEXP_USE_BOEHM +SEXP_API sexp_heap sexp_global_heap; +#endif #define sexp_context_heap(ctx) sexp_global_heap #else #define sexp_context_heap(ctx) ((ctx)->value.context.heap) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index b21604eb..dd85692c 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -44,8 +44,6 @@ static sexp sexp_get_opcode_name (sexp ctx, sexp op) { } sexp sexp_init_library (sexp ctx, sexp env) { - sexp_gc_var2(name, op); - sexp_gc_preserve2(ctx, name, op); sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); @@ -74,7 +72,6 @@ sexp sexp_init_library (sexp ctx, sexp env) { sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); - sexp_gc_release2(ctx); return SEXP_VOID; } diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c index fcea809b..583277a7 100644 --- a/lib/chibi/heap-stats.c +++ b/lib/chibi/heap-stats.c @@ -12,6 +12,9 @@ extern sexp sexp_gc (sexp ctx, size_t *sum_freed); extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); +#if SEXP_USE_GLOBAL_HEAP +#endif + static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { int i; if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x) diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index d89227cc..bff675c1 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -36,7 +36,10 @@ static sexp default_random_source; static sexp sexp_rs_random_integer (sexp ctx, sexp rs, sexp bound) { sexp res; - int32_t n, hi, mod, len, i, *data; + int32_t n; +#if SEXP_USE_BIGNUMS + int32_t hi, mod, len, i, *data; +#endif if (! sexp_random_source_p(rs)) res = sexp_type_exception(ctx, "not a random-source", rs); if (sexp_fixnump(bound)) { diff --git a/lib/srfi/33/bit.c b/lib/srfi/33/bit.c index 396dbc6f..63cdc163 100644 --- a/lib/srfi/33/bit.c +++ b/lib/srfi/33/bit.c @@ -4,11 +4,15 @@ #if SEXP_USE_BIGNUMS #include +#else +#define sexp_bignum_normalize(x) x #endif static sexp sexp_bit_and (sexp ctx, sexp x, sexp y) { sexp res; +#if SEXP_USE_BIGNUMS sexp_sint_t len, i; +#endif if (sexp_fixnump(x)) { if (sexp_fixnump(y)) res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); @@ -42,7 +46,9 @@ static sexp sexp_bit_and (sexp ctx, sexp x, sexp y) { static sexp sexp_bit_ior (sexp ctx, sexp x, sexp y) { sexp res; +#if SEXP_USE_BIGNUMS sexp_sint_t len, i; +#endif if (sexp_fixnump(x)) { if (sexp_fixnump(y)) res = (sexp) ((sexp_uint_t)x | (sexp_uint_t)y); @@ -80,7 +86,9 @@ static sexp sexp_bit_ior (sexp ctx, sexp x, sexp y) { static sexp sexp_bit_xor (sexp ctx, sexp x, sexp y) { sexp res; +#if SEXP_USE_BIGNUMS sexp_sint_t len, i; +#endif if (sexp_fixnump(x)) { if (sexp_fixnump(y)) res = sexp_make_fixnum(sexp_unbox_fixnum(x) ^ sexp_unbox_fixnum(y)); @@ -119,9 +127,14 @@ static sexp sexp_bit_xor (sexp ctx, sexp x, sexp y) { /* should probably split into left and right shifts, that's a better */ /* interface anyway */ static sexp sexp_arithmetic_shift (sexp ctx, sexp i, sexp count) { - sexp_gc_var1(res); - sexp_sint_t c, len, offset, bit_shift, j; sexp_uint_t tmp; + sexp_sint_t c; +#if SEXP_USE_BIGNUMS + sexp_sint_t len, offset, bit_shift, j; + sexp_gc_var1(res); +#else + sexp res; +#endif if (! sexp_fixnump(count)) return sexp_type_exception(ctx, "arithmetic-shift: not an integer", count); c = sexp_unbox_fixnum(count); @@ -194,7 +207,10 @@ static sexp_uint_t bit_count (sexp_uint_t i) { static sexp sexp_bit_count (sexp ctx, sexp x) { sexp res; - sexp_sint_t count, i; + sexp_sint_t i; +#if SEXP_USE_BIGNUMS + sexp_uint_t count; +#endif if (sexp_fixnump(x)) { i = sexp_unbox_fixnum(x); res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); @@ -229,7 +245,10 @@ static sexp_uint_t integer_log2 (sexp_uint_t x) { } static sexp sexp_integer_length (sexp ctx, sexp x) { - sexp_sint_t hi, tmp; + sexp_sint_t tmp; +#if SEXP_USE_BIGNUMS + sexp_sint_t hi; +#endif if (sexp_fixnump(x)) { tmp = sexp_unbox_fixnum(x); return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp)); @@ -245,7 +264,9 @@ static sexp sexp_integer_length (sexp ctx, sexp x) { } static sexp sexp_bit_set_p (sexp ctx, sexp i, sexp x) { +#if SEXP_USE_BIGNUMS sexp_uint_t pos; +#endif if (! sexp_fixnump(i)) return sexp_type_exception(ctx, "bit-set?: not an integer", i); if (sexp_fixnump(x)) { diff --git a/opcodes.c b/opcodes.c index c6f5445d..d3c77865 100644 --- a/opcodes.c +++ b/opcodes.c @@ -131,8 +131,8 @@ _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 +_FN2(0, 0, "expt", 0, sexp_expt), #if SEXP_USE_TYPE_DEFS _FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type), _FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate), diff --git a/sexp.c b/sexp.c index b12900b3..bcdb619f 100644 --- a/sexp.c +++ b/sexp.c @@ -678,9 +678,13 @@ static sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) { #endif sexp sexp_intern(sexp ctx, char *str) { +#if SEXP_USE_HUFF_SYMS struct sexp_huff_entry he; - sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket; - char c, *p=str; + sexp_uint_t space=3, newbits; + char c; +#endif + sexp_uint_t len, res=FNV_OFFSET_BASIS, bucket; + char *p=str; sexp ls; sexp_gc_var1(sym); @@ -696,9 +700,9 @@ sexp sexp_intern(sexp ctx, char *str) { space += newbits; } return (sexp) (res + SEXP_ISYMBOL_TAG); -#endif normal_intern: +#endif #if SEXP_USE_HASH_SYMS bucket = (sexp_string_hash(p, res) % SEXP_SYMBOL_TABLE_SIZE); #else @@ -1013,7 +1017,10 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { } sexp sexp_write (sexp ctx, sexp obj, sexp out) { - unsigned long len, c, res; +#if SEXP_USE_HUFF_SYMS + unsigned long res, c; +#endif + unsigned long len; long i=0; double f; sexp x, *elts; diff --git a/tests/build/build-opts.txt b/tests/build/build-opts.txt new file mode 100644 index 00000000..01d2a81d --- /dev/null +++ b/tests/build/build-opts.txt @@ -0,0 +1,20 @@ +CPPFLAGS=-DSEXP_USE_MODULES=0 +CPPFLAGS=-DSEXP_USE_DL=0 +CPPFLAGS=-DSEXP_USE_SIMPLIFY=0 +CPPFLAGS=-DSEXP_USE_TYPE_DEFS=0 +SEXP_USE_BOEHM=1 +CPPFLAGS=-DSEXP_USE_DEBUG_GC=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_HEAP=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_TYPES=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_SYMBOLS=1 +CPPFLAGS=-DSEXP_USE_FLONUMS=0 +CPPFLAGS=-DSEXP_USE_IMMEDIATE_FLONUMS=1 +CPPFLAGS=-DSEXP_USE_BIGNUMS=0 +CPPFLAGS=-DSEXP_USE_MATH=0 +CPPFLAGS=-DSEXP_WARN_UNDEFS=0 +CPPFLAGS=-DSEXP_USE_HUFF_SYMS=0 +CPPFLAGS=-DSEXP_USE_HASH_SYMS=0 +CPPFLAGS=-DSEXP_USE_STRING_STREAMS=0 +CPPFLAGS=-DSEXP_USE_AUTOCLOSE_PORTS=0 +CPPFLAGS=-DSEXP_USE_2010_EPOCH=0 +CPPFLAGS=-DSEXP_USE_CHECK_STACK=0 diff --git a/tests/build/build-tests.sh b/tests/build/build-tests.sh new file mode 100755 index 00000000..b3bd46ec --- /dev/null +++ b/tests/build/build-tests.sh @@ -0,0 +1,37 @@ +#! /bin/bash + +# test basic build options + +# for bootstrapping reasons this is a shell script, instead of a +# scheme script using (chibi process) + +# we just check each build against r5rs-tests.scm - +# some of the libraries will fail to build (notably +# if modules or user-defined types are disabled). + +BUILDDIR=tests/build +FAILURES=0 +i=0 + +for opts in `cat ${BUILDDIR}/build-opts.txt`; do + make cleaner 2>&1 >/dev/null + if make $opts 2>&1 >${BUILDDIR}/build${i}-make.out; then + if make test 2>&1 | tee ${BUILDDIR}/build${i}-test.out | grep -q -E 'FAIL|ERROR'; then + echo "[FAIL] ${i}: tests failed with $opts" + FAILURES=$((FAILURES + 1)) + else + echo "[PASS] ${i}: tests passed with $opts" + fi + else + echo "[FAIL] ${i}: couldn't build with $opts" + FAILURES=$((FAILURES + 1)) + fi + i=$((i+1)) +done + +if (( FAILURES == 0 )); then + echo "build-tests: all tests passed" +else + echo "build-tests: ${FAILURES} tests failed" +fi + diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 85b3a801..e91bd57e 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -120,8 +120,8 @@ (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 '(10 5 4 16 9 8) + `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 8)) (test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) @@ -216,21 +216,23 @@ (test 288 (lcm 32 -36)) -(test #t (= -5 (floor -4.3))) +;;;; these will fail when compiled either without flonums or trig funcs -(test #t (= -4 (ceiling -4.3))) +;; (test #t (= -5 (floor -4.3))) -(test #t (= -4 (truncate -4.3))) +;; (test #t (= -4 (ceiling -4.3))) -(test #t (= -4 (round -4.3))) +;; (test #t (= -4 (truncate -4.3))) -(test #t (= 3 (floor 3.5))) +;; (test #t (= -4 (round -4.3))) -(test #t (= 4 (ceiling 3.5))) +;; (test #t (= 3 (floor 3.5))) -(test #t (= 3 (truncate 3.5))) +;; (test #t (= 4 (ceiling 3.5))) -(test #t (= 4 (round 3.5))) +;; (test #t (= 3 (truncate 3.5))) + +;; (test #t (= 4 (round 3.5))) (test 100 (string->number "100")) From 482e0d79a91010afcc9abc20b5014c93afcbd1c4 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 27 Dec 2009 16:08:27 +0900 Subject: [PATCH 292/535] #t and #f are case-insensitive tokens --- sexp.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/sexp.c b/sexp.c index bcdb619f..2df64934 100644 --- a/sexp.c +++ b/sexp.c @@ -1464,11 +1464,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) { if (sexp_fixnump(res)) res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res)); break; - case 'f': - case 't': + case 'f': case 'F': + case 't': case 'T': c2 = sexp_read_char(ctx, in); if (c2 == EOF || is_separator(c2)) { - res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); + res = (tolower(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)); From 6fa8474c42cf1e974c84d117c61d49a31497f5dc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 27 Dec 2009 16:15:28 +0900 Subject: [PATCH 293/535] don't check for bits over 32 on 32-bit machines in integer_log2 (removes shift width warning) --- lib/srfi/33/bit.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/srfi/33/bit.c b/lib/srfi/33/bit.c index 63cdc163..cbfc940e 100644 --- a/lib/srfi/33/bit.c +++ b/lib/srfi/33/bit.c @@ -236,9 +236,12 @@ static const char log_table_256[256] = static sexp_uint_t integer_log2 (sexp_uint_t x) { sexp_uint_t t, tt; +#if SEXP_64_BIT if ((tt = x >> 32)) return integer_log2(tt) + 32; - else if ((tt = x >> 16)) + else +#endif + if ((tt = x >> 16)) return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt]; else return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; From 84404ac54aab30e1d1e6c2c01a7fc3d379f46331 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 27 Dec 2009 16:38:37 +0900 Subject: [PATCH 294/535] adding sexp_load_standard_parameters to fix -q option to main --- eval.c | 10 +++++++--- include/chibi/eval.h | 1 + main.c | 1 + 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/eval.c b/eval.c index 0eab33aa..22f13c1a 100644 --- a/eval.c +++ b/eval.c @@ -2530,9 +2530,7 @@ sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp) { return SEXP_VOID; } -sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { - sexp_gc_var3(op, tmp, sym); - sexp_gc_preserve3(ctx, op, tmp, sym); +sexp sexp_load_standard_parameters (sexp ctx, sexp e) { /* add io port and interaction env parameters */ sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), sexp_make_input_port(ctx, stdin, SEXP_FALSE)); @@ -2541,6 +2539,12 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), sexp_make_output_port(ctx, stderr, SEXP_FALSE)); sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); +} + +sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { + sexp_gc_var3(op, tmp, sym); + sexp_gc_preserve3(ctx, op, tmp, sym); + sexp_load_standard_parameters(ctx, e); #if SEXP_USE_DL sexp_env_define(ctx, e, sexp_intern(ctx, "*shared-object-extension*"), sexp_c_string(ctx, sexp_so_extension, -1)); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 8ba7b442..297f2b70 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -133,6 +133,7 @@ SEXP_API sexp sexp_make_env (sexp context); SEXP_API sexp sexp_make_null_env (sexp context, sexp version); SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version); SEXP_API sexp sexp_make_standard_env (sexp context, sexp version); +SEXP_API sexp sexp_load_standard_parameters (sexp context, sexp env); SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version); SEXP_API sexp sexp_find_module_file (sexp ctx, char *file); SEXP_API sexp sexp_load_module_file (sexp ctx, char *file, sexp env); diff --git a/main.c b/main.c index 85ee9ba1..55fa6dba 100644 --- a/main.c +++ b/main.c @@ -113,6 +113,7 @@ void run_main (int argc, char **argv) { free(impmod); break; case 'q': + sexp_load_standard_parameters(ctx, env); init_loaded = 1; break; case 'A': From f2fb277eab9396672e0f38f418c788628afad536 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 27 Dec 2009 16:39:32 +0900 Subject: [PATCH 295/535] forgot the return value --- eval.c | 1 + 1 file changed, 1 insertion(+) diff --git a/eval.c b/eval.c index 22f13c1a..36e26ab8 100644 --- a/eval.c +++ b/eval.c @@ -2539,6 +2539,7 @@ sexp sexp_load_standard_parameters (sexp ctx, sexp e) { sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), sexp_make_output_port(ctx, stderr, SEXP_FALSE)); sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); + return SEXP_VOID; } sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { From 667e8959e04bd6dc66bb1bfeb6ca1912a8685e43 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 27 Dec 2009 22:37:55 +0900 Subject: [PATCH 296/535] port size should be size_t --- include/chibi/sexp.h | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 918debbe..d161de9d 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -185,7 +185,8 @@ struct sexp_struct { FILE *stream; char *buf; char openp, sourcep; - sexp_uint_t offset, line, size; + sexp_uint_t offset, line; + size_t size; sexp name; sexp cookie; } port; From 17e4f63f94e9e34ce19f93baea7932be3e2d4a9c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 27 Dec 2009 23:19:19 +0900 Subject: [PATCH 297/535] fixing a simple offby1 error in intern previously hidden by the prevalence of huffman-coded symbols. --- sexp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/sexp.c b/sexp.c index 2df64934..a0657df8 100644 --- a/sexp.c +++ b/sexp.c @@ -708,7 +708,7 @@ sexp sexp_intern(sexp ctx, char *str) { #else bucket = 0; #endif - len = strlen(str); + len = strlen(str) + 1; /* include the trailing NULL in the comparison */ for (ls=sexp_context_symbols(ctx)[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); @@ -717,7 +717,7 @@ sexp sexp_intern(sexp ctx, char *str) { sexp_gc_preserve1(ctx, sym); sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); if (sexp_exceptionp(sym)) return sym; - sexp_symbol_string(sym) = sexp_c_string(ctx, str, len); + sexp_symbol_string(sym) = sexp_c_string(ctx, str, len-1); sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); sexp_gc_release1(ctx); return sym; From 1fda388db962f8e05e89b5670c6c739bf433bcd1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 00:06:46 +0900 Subject: [PATCH 298/535] fixing vm <, >, = comparator cases when both flonums and bignums are disabled --- eval.c | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/eval.c b/eval.c index 36e26ab8..9958998f 100644 --- a/eval.c +++ b/eval.c @@ -1845,14 +1845,14 @@ sexp sexp_vm (sexp ctx, sexp proc) { } #else #if SEXP_USE_FLONUMS - } else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + } else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) { i = sexp_flonum_value(_ARG1) < sexp_flonum_value(_ARG2); - else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) - i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_fixnum(_ARG2); - else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + } else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { i = (double)sexp_unbox_fixnum(_ARG1) < sexp_flonum_value(_ARG2); #endif - else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + } else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); _ARG2 = sexp_make_boolean(i); #endif top--; @@ -1869,14 +1869,14 @@ sexp sexp_vm (sexp ctx, sexp proc) { } #else #if SEXP_USE_FLONUMS - } else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + } else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) { i = sexp_flonum_value(_ARG1) <= sexp_flonum_value(_ARG2); - else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + } else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) { i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_fixnum(_ARG2); - else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { i = (double)sexp_unbox_fixnum(_ARG1) <= sexp_flonum_value(_ARG2); #endif - else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + } else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); _ARG2 = sexp_make_boolean(i); #endif top--; @@ -1893,14 +1893,14 @@ sexp sexp_vm (sexp ctx, sexp proc) { } #else #if SEXP_USE_FLONUMS - } else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + } else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) { i = sexp_flonum_value(_ARG1) == sexp_flonum_value(_ARG2); - else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + } else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) { i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_fixnum(_ARG2); - else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { i = (double)sexp_unbox_fixnum(_ARG1) == sexp_flonum_value(_ARG2); #endif - else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + } else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); _ARG2 = sexp_make_boolean(i); #endif top--; From 4f45da310af3dadbdf41664ae2d75df44ea39421 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 00:06:59 +0900 Subject: [PATCH 299/535] removing flonums from basic tests --- tests/r5rs-tests.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index e91bd57e..1b22acd2 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -168,15 +168,15 @@ (test #t (equal? 2 2)) -(test #f (eqv? 2 2.0)) +;;(test #f (eqv? 2 2.0)) -(test #f (equal? 2.0 2)) +;;(test #f (equal? 2.0 2)) (test #t (equal? (make-vector 5 'a) (make-vector 5 'a))) (test 4 (max 3 4)) -(test 4 (max 3.9 4)) +;;(test 4 (max 3.9 4)) (test 7 (+ 3 4)) From 793d3931e36a0d6adc12de51d76b7d77b49df6c6 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 00:07:44 +0900 Subject: [PATCH 300/535] using faster symbolp test when immediate symbols are disabled --- include/chibi/sexp.h | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index d161de9d..13854cfd 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -433,7 +433,12 @@ sexp sexp_make_flonum(sexp ctx, double f); #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)) + +#if SEXP_USE_HUFF_SYMS #define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +#else +#define sexp_symbolp(x) (sexp_lsymbolp(x)) +#endif #define sexp_idp(x) \ (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x)))) From 93509206238a21a01654951c9c6ff6d6804f9f18 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 00:08:33 +0900 Subject: [PATCH 301/535] adding the SEXP_USE_NO_FEATURES build option --- include/chibi/config.h | 43 +++++++++++++++++++++----------------- tests/build/build-opts.txt | 1 + 2 files changed, 25 insertions(+), 19 deletions(-) diff --git a/include/chibi/config.h b/include/chibi/config.h index 865b455a..ce14091a 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -2,6 +2,11 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ +/* uncomment this to disable most features */ +/* Most features are enabled by default, but setting this */ +/* option will disable any not explicitly enabled. */ +/* #define SEXP_USE_NO_FEATURES 1 */ + /* uncomment this to disable the module system */ /* Currently this just loads the config.scm from main and */ /* sets up an (import (module name)) macro. */ @@ -150,12 +155,16 @@ #define _GNU_SOURCE #endif +#ifndef SEXP_USE_NO_FEATURES +#define SEXP_USE_NO_FEATURES 0 +#endif + #ifndef SEXP_USE_MODULES -#define SEXP_USE_MODULES 1 +#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_TYPE_DEFS -#define SEXP_USE_TYPE_DEFS 1 +#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_MAXIMUM_TYPES @@ -166,12 +175,12 @@ #ifdef PLAN9 #define SEXP_USE_DL 0 #else -#define SEXP_USE_DL 1 +#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES #endif #endif #ifndef SEXP_USE_SIMPLIFY -#define SEXP_USE_SIMPLIFY 1 +#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_BOEHM @@ -207,14 +216,14 @@ #endif #ifndef SEXP_USE_FLONUMS -#define SEXP_USE_FLONUMS 1 +#define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_INFINITIES #if defined(PLAN9) || ! SEXP_USE_FLONUMS #define SEXP_USE_INFINITIES 0 #else -#define SEXP_USE_INFINITIES 1 +#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES #endif #endif @@ -223,27 +232,23 @@ #endif #ifndef SEXP_USE_BIGNUMS -#define SEXP_USE_BIGNUMS 1 +#define SEXP_USE_BIGNUMS ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_MATH -#define SEXP_USE_MATH SEXP_USE_FLONUMS +#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_WARN_UNDEFS -#define SEXP_USE_WARN_UNDEFS 1 +#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_HUFF_SYMS -#define SEXP_USE_HUFF_SYMS 1 +#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_HASH_SYMS -#define SEXP_USE_HASH_SYMS 1 -#endif - -#ifndef SEXP_USE_DEBUG -#define SEXP_USE_DEBUG 1 +#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_DEBUG_VM @@ -251,15 +256,15 @@ #endif #ifndef SEXP_USE_STRING_STREAMS -#define SEXP_USE_STRING_STREAMS 1 +#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_AUTOCLOSE_PORTS -#define SEXP_USE_AUTOCLOSE_PORTS 1 +#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_2010_EPOCH -#define SEXP_USE_2010_EPOCH 1 +#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_EPOCH_OFFSET @@ -271,7 +276,7 @@ #endif #ifndef SEXP_USE_CHECK_STACK -#define SEXP_USE_CHECK_STACK 1 +#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES #endif #ifdef PLAN9 diff --git a/tests/build/build-opts.txt b/tests/build/build-opts.txt index 01d2a81d..e6bcd056 100644 --- a/tests/build/build-opts.txt +++ b/tests/build/build-opts.txt @@ -18,3 +18,4 @@ CPPFLAGS=-DSEXP_USE_STRING_STREAMS=0 CPPFLAGS=-DSEXP_USE_AUTOCLOSE_PORTS=0 CPPFLAGS=-DSEXP_USE_2010_EPOCH=0 CPPFLAGS=-DSEXP_USE_CHECK_STACK=0 +CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 From 2810fb8b1b56ab13434e1c422ec073dd46c31a20 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 13:09:43 +0900 Subject: [PATCH 302/535] sexp_make(_eval)_context now takes an extra parameter to specify the initial heap size (available as the -h option on the command line). --- eval.c | 28 +++++++++++++--------------- gc.c | 3 +++ include/chibi/config.h | 16 ---------------- include/chibi/eval.h | 2 +- include/chibi/sexp.h | 2 +- main.c | 41 +++++++++++++++++++++++++++++++++-------- opt/simplify.c | 2 +- sexp.c | 10 ++++++---- 8 files changed, 58 insertions(+), 46 deletions(-) diff --git a/eval.c b/eval.c index 9958998f..a8b7ed8e 100644 --- a/eval.c +++ b/eval.c @@ -62,8 +62,8 @@ sexp sexp_env_cell (sexp env, sexp key) { return sexp_env_cell_loc(env, key, NULL); } -static sexp sexp_env_cell_create_loc (sexp ctx, sexp env, sexp key, - sexp value, sexp *varenv) { +static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, + sexp value, sexp *varenv) { sexp_gc_var1(cell); cell = sexp_env_cell_loc(env, key, varenv); if (! cell) { @@ -78,10 +78,6 @@ static sexp sexp_env_cell_create_loc (sexp ctx, sexp env, sexp key, return cell; } -static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, sexp value) { - return sexp_env_cell_create_loc(ctx, env, key, value, NULL); -} - sexp sexp_env_ref (sexp env, sexp key, sexp dflt) { sexp cell = sexp_env_cell(env, key); return (cell ? sexp_cdr(cell) : dflt); @@ -348,10 +344,10 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_gc_release2(ctx); } -sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env) { +sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size) { sexp_gc_var1(res); if (ctx) sexp_gc_preserve1(ctx, res); - res = sexp_make_context(ctx); + res = sexp_make_context(ctx, size); sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE); sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE; @@ -371,7 +367,8 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env) { sexp sexp_make_child_context (sexp ctx, sexp lambda) { sexp res = sexp_make_eval_context(ctx, sexp_context_stack(ctx), - sexp_context_env(ctx)); + sexp_context_env(ctx), + 0); sexp_context_lambda(res) = lambda; sexp_context_top(res) = sexp_context_top(ctx); sexp_context_fv(res) = sexp_context_fv(ctx); @@ -478,7 +475,7 @@ static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) { env = sexp_synclo_env(x); x = sexp_synclo_expr(x); } - cell = sexp_env_cell_create_loc(ctx, env, x, SEXP_UNDEF, varenv); + cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF, varenv); } if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) res = sexp_compile_error(ctx, "invalid use of syntax as value", x); @@ -606,7 +603,7 @@ static sexp analyze_define (sexp ctx, sexp x) { res = SEXP_VOID; } else { if (sexp_synclop(name)) name = sexp_synclo_expr(name); - sexp_env_cell_create(ctx, env, name, SEXP_VOID); + sexp_env_cell_create(ctx, env, name, SEXP_VOID, NULL); if (sexp_pairp(sexp_cadr(x))) { tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); tmp = sexp_cons(ctx, SEXP_VOID, tmp); @@ -1041,7 +1038,7 @@ static void generate_lambda (sexp ctx, sexp lambda) { 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_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx)); + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); sexp_context_lambda(ctx2) = lambda; /* allocate space for local vars */ for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) @@ -2090,7 +2087,7 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { res = SEXP_VOID; in = sexp_open_input_file(ctx, source); out = sexp_current_error_port(ctx); - ctx2 = sexp_make_eval_context(ctx, NULL, env); + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0); sexp_context_parent(ctx2) = ctx; tmp = sexp_env_bindings(env); sexp_context_tailp(ctx2) = 0; @@ -2437,7 +2434,7 @@ sexp sexp_make_primitive_env (sexp ctx, sexp version) { op = sexp_copy_opcode(ctx, &opcodes[i]); if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { sym = sexp_intern(ctx, (char*)sexp_opcode_data(op)); - sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID); + sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); } sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); } @@ -2685,7 +2682,8 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) { top = sexp_context_top(ctx); ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), - (env ? env : sexp_context_env(ctx))); + (env ? env : sexp_context_env(ctx)), + 0); res = sexp_compile(ctx2, obj); if (! sexp_exceptionp(res)) res = sexp_apply(ctx2, res, SEXP_NULL); diff --git a/gc.c b/gc.c index 7a5b409c..1130c15b 100644 --- a/gc.c +++ b/gc.c @@ -16,6 +16,9 @@ #ifndef SEXP_MAXIMUM_HEAP_SIZE #define SEXP_MAXIMUM_HEAP_SIZE 0 #endif +#ifndef SEXP_MINIMUM_HEAP_SIZE +#define SEXP_MINIMUM_HEAP_SIZE 512*1024 +#endif /* if after GC more than this percentage of memory is still in use, */ /* and we've not exceeded the maximum size, grow the heap */ diff --git a/include/chibi/config.h b/include/chibi/config.h index ce14091a..a3301d22 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -280,26 +280,10 @@ #endif #ifdef PLAN9 - -#define errx(code, msg, ...) exits(msg) -#define exit_normally() exits(NULL) -#define exit_failure() exits("ERROR") #define strcasecmp cistrcmp #define strncasecmp cistrncmp #define round(x) floor((x)+0.5) #define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) - -#else - -#define exit_normally() exit(0) -#define exit_failure() exit(EXIT_FAILURE) -#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 #ifdef __MINGW32__ diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 297f2b70..60201c61 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -122,7 +122,7 @@ enum sexp_opcode_names { /**************************** prototypes ******************************/ SEXP_API void sexp_scheme_init (void); -SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env); +SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size); SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); SEXP_API sexp sexp_analyze (sexp context, sexp x); SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 13854cfd..44b7cc7a 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -793,7 +793,7 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); #define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) -SEXP_API sexp sexp_make_context(sexp ctx); +SEXP_API sexp sexp_make_context(sexp ctx, sexp_uint_t size); 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); diff --git a/main.c b/main.c index 55fa6dba..77d910b7 100644 --- a/main.c +++ b/main.c @@ -10,6 +10,12 @@ #define sexp_import_prefix "(import (" #define sexp_import_suffix "))" +#ifdef PLAN9 +#define exit_failure() exits("ERROR") +#else +#define exit_failure() exit(1) +#endif + static void repl (sexp ctx) { sexp in, out, err; sexp_gc_var4(obj, tmp, res, env); @@ -60,17 +66,20 @@ static sexp check_exception (sexp ctx, sexp res) { return res; } -#define sexp_load_init() if (! init_loaded++) check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)) +#define sexp_load_init() if (! init_loaded++) do { \ + ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \ + env = sexp_context_env(ctx); \ + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \ + sexp_gc_preserve2(ctx, str, args); \ + } while (0) void run_main (int argc, char **argv) { char *arg, *impmod, *p; - sexp env, out=NULL, res=SEXP_VOID, ctx; + sexp env, out=NULL, res=SEXP_VOID, ctx=NULL; sexp_sint_t i, len, quit=0, print=0, init_loaded=0; + sexp_uint_t heap_size=0; sexp_gc_var2(str, args); - ctx = sexp_make_eval_context(NULL, NULL, NULL); - sexp_gc_preserve2(ctx, str, args); - env = sexp_context_env(ctx); out = SEXP_FALSE; args = SEXP_NULL; @@ -113,8 +122,13 @@ void run_main (int argc, char **argv) { free(impmod); break; case 'q': - sexp_load_standard_parameters(ctx, env); - init_loaded = 1; + if (! ctx) { + ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); + env = sexp_context_env(ctx); + sexp_gc_preserve2(ctx, str, args); + } + if (! init_loaded++) + sexp_load_standard_parameters(ctx, env); break; case 'A': arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); @@ -129,8 +143,19 @@ void run_main (int argc, char **argv) { args = sexp_cons(ctx, str=sexp_c_string(ctx,argv[argc],-1), args); argc++; break; + case 'h': + heap_size = atol(argv[++i]); + len = strlen(argv[i]); + if (heap_size && isalpha(argv[i][len-1])) { + switch (tolower(argv[i][len-1])) { + case 'k': heap_size *= 1024; break; + case 'm': heap_size *= (1024*1024); break; + } + } + break; default: - errx(1, "unknown option: %s", argv[i]); + fprintf(stderr, "unknown option: %s\n", argv[i]); + exit_failure(); } } diff --git a/opt/simplify.c b/opt/simplify.c index e01e4042..d70de633 100644 --- a/opt/simplify.c +++ b/opt/simplify.c @@ -30,7 +30,7 @@ static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { } } if (check) { - ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx)); + ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0); generate(ctx2, app); app = finalize_bytecode(ctx2); if (! sexp_exceptionp(app)) { diff --git a/sexp.c b/sexp.c index a0657df8..51e97c19 100644 --- a/sexp.c +++ b/sexp.c @@ -242,9 +242,11 @@ void sexp_init_context_globals (sexp ctx) { } #if ! SEXP_USE_GLOBAL_HEAP -sexp sexp_bootstrap_context (void) { +sexp sexp_bootstrap_context (sexp_uint_t size) { sexp dummy_ctx, ctx; - sexp_heap heap = sexp_make_heap(sexp_heap_align(SEXP_INITIAL_HEAP_SIZE)); + sexp_heap heap; + if (size < SEXP_MINIMUM_HEAP_SIZE) size = SEXP_INITIAL_HEAP_SIZE; + heap = sexp_make_heap(sexp_heap_align(size)); dummy_ctx = (sexp) malloc(sexp_sizeof(context)); sexp_pointer_tag(dummy_ctx) = SEXP_CONTEXT; sexp_context_saves(dummy_ctx) = NULL; @@ -257,11 +259,11 @@ sexp sexp_bootstrap_context (void) { } #endif -sexp sexp_make_context (sexp ctx) { +sexp sexp_make_context (sexp ctx, sexp_uint_t size) { sexp_gc_var1(res); if (ctx) sexp_gc_preserve1(ctx, res); #if ! SEXP_USE_GLOBAL_HEAP - if (! ctx) res = sexp_bootstrap_context(); + if (! ctx) res = sexp_bootstrap_context(size); else #endif { From 007c3f07feed0cd652c6ccae1f3d2d2f36f3fd3f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 16:30:51 +0900 Subject: [PATCH 303/535] switching to SRFI-22 semantics. -s is no longer needed, only the first non-option argument is loaded (though you can use -- if the script name begins with a -). main is then called automatically if defined. -u was changed to -m. --- Makefile | 20 ++++----- README | 6 +-- main.c | 84 ++++++++++++++++++++++---------------- tests/build/build-tests.sh | 2 +- tools/genstubs.scm | 4 +- 5 files changed, 63 insertions(+), 53 deletions(-) diff --git a/Makefile b/Makefile index 0b6575ff..ebda90c0 100644 --- a/Makefile +++ b/Makefile @@ -81,10 +81,10 @@ endif all: chibi-scheme$(EXE) libs COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ - lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) lib/chibi/ast$(SO) \ - lib/chibi/net$(SO) lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \ - lib/chibi/time$(SO) lib/chibi/system$(SO) lib/chibi/heap-stats$(SO) \ - lib/chibi/disasm$(SO) + lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ + lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \ + lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \ + lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) libs: $(COMPILED_LIBS) @@ -114,7 +114,7 @@ chibi-scheme-static$(EXE): main.o eval.o sexp.o $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) %.c: %.stub $(GENSTUBS) - LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) $(GENSTUBS) $< + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) PATH=.:$(PATH) $(GENSTUBS) $< lib/%$(SO): lib/%.c $(INCLUDES) -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme @@ -141,19 +141,19 @@ test-basic: chibi-scheme$(EXE) test-build: ./tests/build/build-tests.sh -test-numbers: all +test-numbers: chibi-scheme$(EXE) LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/numeric-tests.scm -test-hash: all +test-hash: chibi-scheme$(EXE) LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/hash-tests.scm -test-match: all +test-match: chibi-scheme$(EXE) LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/match-tests.scm -test-loop: all +test-loop: chibi-scheme$(EXE) LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/loop-tests.scm -test: all +test: chibi-scheme$(EXE) LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/r5rs-tests.scm install: chibi-scheme$(EXE) diff --git a/README b/README index cfbdc524..4b723595 100644 --- a/README +++ b/README @@ -72,10 +72,10 @@ The essential functions to remember are: A minimal module system is provided by default. Currently you can load the following SRFIs with (import (srfi N)): - 0, 1, 2, 6, 8, 9, 11, 16, 26, 27, 33, 46, 62, 69, 98 + 0, 1, 2, 6, 8, 9, 11, 16, 22, 23, 26, 27, 33, 46, 62, 69, 98 -although 0, 46 and 62 are built into the default environment so -there's no need to import them. +although 0, 22, 23, 46 and 62 are built into the default environment +so there's no need to import them. LOAD is extended to accept an optional environment argument, like EVAL. You can also LOAD shared libraries in addition to Scheme source diff --git a/main.c b/main.c index 77d910b7..a8e52c8d 100644 --- a/main.c +++ b/main.c @@ -13,7 +13,7 @@ #ifdef PLAN9 #define exit_failure() exits("ERROR") #else -#define exit_failure() exit(1) +#define exit_failure() exit(70) #endif static void repl (sexp ctx) { @@ -66,21 +66,23 @@ static sexp check_exception (sexp ctx, sexp res) { return res; } -#define sexp_load_init() if (! init_loaded++) do { \ +#define init_context() if (! ctx) do { \ ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \ env = sexp_context_env(ctx); \ + sexp_gc_preserve2(ctx, tmp, args); \ + } while (0) + +#define load_init() if (! init_loaded++) do { \ + init_context(); \ check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \ - sexp_gc_preserve2(ctx, str, args); \ } while (0) void run_main (int argc, char **argv) { char *arg, *impmod, *p; - sexp env, out=NULL, res=SEXP_VOID, ctx=NULL; - sexp_sint_t i, len, quit=0, print=0, init_loaded=0; + sexp env, out=SEXP_FALSE, res=SEXP_VOID, ctx=NULL; + sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0; sexp_uint_t heap_size=0; - sexp_gc_var2(str, args); - - out = SEXP_FALSE; + sexp_gc_var2(tmp, args); args = SEXP_NULL; /* parse options */ @@ -88,9 +90,9 @@ void run_main (int argc, char **argv) { switch (argv[i][1]) { case 'e': case 'p': + load_init(); print = (argv[i][1] == 'p'); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); - sexp_load_init(); res = check_exception(ctx, sexp_read_from_string(ctx, arg)); res = check_exception(ctx, sexp_eval(ctx, res, env)); if (print) { @@ -103,13 +105,13 @@ void run_main (int argc, char **argv) { i++; break; case 'l': + load_init(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); - sexp_load_init(); check_exception(ctx, sexp_load_module_file(ctx, argv[++i], env)); break; - case 'u': + case 'm': + load_init(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); - sexp_load_init(); len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); impmod = (char*) malloc(len+1); strcpy(impmod, sexp_import_prefix); @@ -122,52 +124,63 @@ void run_main (int argc, char **argv) { free(impmod); break; case 'q': - if (! ctx) { - ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); - env = sexp_context_env(ctx); - sexp_gc_preserve2(ctx, str, args); - } - if (! init_loaded++) - sexp_load_standard_parameters(ctx, env); + init_context(); + if (! init_loaded++) sexp_load_standard_parameters(ctx, env); break; case 'A': + init_context(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); - sexp_add_module_directory(ctx, str=sexp_c_string(ctx,arg,-1), SEXP_TRUE); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); break; case 'I': + init_context(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); - sexp_add_module_directory(ctx, str=sexp_c_string(ctx,arg,-1), SEXP_FALSE); - break; - case 's': - for (argc=argc-1; argc>i+1; argc--) - args = sexp_cons(ctx, str=sexp_c_string(ctx,argv[argc],-1), args); - argc++; + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); break; + case '-': + i++; + goto done_options; case 'h': - heap_size = atol(argv[++i]); - len = strlen(argv[i]); - if (heap_size && isalpha(argv[i][len-1])) { - switch (tolower(argv[i][len-1])) { + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + heap_size = atol(arg); + len = strlen(arg); + if (heap_size && isalpha(arg[len-1])) { + switch (tolower(arg[len-1])) { case 'k': heap_size *= 1024; break; case 'm': heap_size *= (1024*1024); break; } } break; + case 'V': + printf("chibi-scheme 0.3\n"); + exit(0); default: fprintf(stderr, "unknown option: %s\n", argv[i]); exit_failure(); } } + done_options: if (! quit) { - sexp_load_init(); + load_init(); + if (i < argc) + for (j=argc-1; j>i; j--) + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); + else + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol), args); sexp_eval_string(ctx, sexp_argv_proc, env); - if (i < argc) - for ( ; i < argc; i++) - check_exception(ctx, sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env)); - else + if (i < argc) { /* script usage */ + check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); + tmp = sexp_intern(ctx, "main"); + tmp = sexp_env_ref(env, tmp, SEXP_FALSE); + if (sexp_procedurep(tmp)) { + args = sexp_list1(ctx, args); + check_exception(ctx, sexp_apply(ctx, tmp, args)); + } + } else { repl(ctx); + } } sexp_gc_release2(ctx); @@ -178,4 +191,3 @@ int main (int argc, char **argv) { run_main(argc, argv); return 0; } - diff --git a/tests/build/build-tests.sh b/tests/build/build-tests.sh index b3bd46ec..1d239629 100755 --- a/tests/build/build-tests.sh +++ b/tests/build/build-tests.sh @@ -15,7 +15,7 @@ i=0 for opts in `cat ${BUILDDIR}/build-opts.txt`; do make cleaner 2>&1 >/dev/null - if make $opts 2>&1 >${BUILDDIR}/build${i}-make.out; then + if make $opts chibi-scheme 2>&1 >${BUILDDIR}/build${i}-make.out; then if make test 2>&1 | tee ${BUILDDIR}/build${i}-test.out | grep -q -E 'FAIL|ERROR'; then echo "[FAIL] ${i}: tests failed with $opts" FAILURES=$((FAILURES + 1)) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index bb55fcfd..037e853e 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -1,4 +1,4 @@ -#! chibi-scheme -s +#! /usr/bin/env chibi-scheme ;; Note: this evolved as a throw-away script to provide certain core ;; modules, and so is a mess. Tread carefully. @@ -1152,5 +1152,3 @@ (with-output-to-file (cadr args) (lambda () (generate (car args)))))) (else (error "usage: genstubs []")))) - -(main (command-line-arguments)) From b66c116183f1de2ff3ffdbfd9d9568eec06b222a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 19:13:09 +0900 Subject: [PATCH 304/535] adding srfi-95 --- Makefile | 2 +- lib/srfi/95.module | 7 ++ lib/srfi/95/qsort.c | 167 +++++++++++++++++++++++++++++++++++++++++++ lib/srfi/95/sort.scm | 67 +++++++++++++++++ 4 files changed, 242 insertions(+), 1 deletion(-) create mode 100644 lib/srfi/95.module create mode 100644 lib/srfi/95/qsort.c create mode 100644 lib/srfi/95/sort.scm diff --git a/Makefile b/Makefile index ebda90c0..85904625 100644 --- a/Makefile +++ b/Makefile @@ -81,7 +81,7 @@ endif all: chibi-scheme$(EXE) libs COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ - lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ + lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \ lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \ lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \ lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) diff --git a/lib/srfi/95.module b/lib/srfi/95.module new file mode 100644 index 00000000..25e0d3ff --- /dev/null +++ b/lib/srfi/95.module @@ -0,0 +1,7 @@ + +(define-module (srfi 95) + (export sorted? merge merge! sort sort!) + (import-immutable (scheme)) + (include-shared "95/qsort") + (include "95/sort.scm")) + diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c new file mode 100644 index 00000000..ca2bb017 --- /dev/null +++ b/lib/srfi/95/qsort.c @@ -0,0 +1,167 @@ + +#include "chibi/eval.h" + +#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var) + +static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) { + sexp_sint_t i; + sexp ls, *data=sexp_vector_data(vec); + for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls)) + sexp_car(ls) = data[i]; + return seq; +} + +static sexp sexp_vector_nreverse (sexp ctx, sexp vec) { + int i, j; + sexp tmp, *data=sexp_vector_data(vec); + for (i=0, j=sexp_vector_length(vec)-1; i 2) { + sexp_qsort(ctx, vec, lo, j-1); + lo = j+1; + goto loop; + } + } +} + +static sexp sexp_qsort_less (sexp ctx, sexp *vec, + sexp_sint_t lo, sexp_sint_t hi, + sexp less, sexp key) { + sexp_sint_t mid, i, j; + sexp tmp, res, args1; + sexp_gc_var3(a, b, args2); + sexp_gc_preserve3(ctx, a, b, args2); + args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID); + args1 = sexp_cdr(args2); + loop: + if (lo >= hi) { + res = SEXP_VOID; + } else { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + sexp_car(args1) = tmp; + b = sexp_apply(ctx, key, args1); + for (i=j=lo; i < hi; i++) { + sexp_car(args1) = vec[i]; + a = sexp_apply(ctx, key, args1); + sexp_car(args2) = a; + sexp_car(args1) = b; + res = sexp_apply(ctx, less, args2); + if (sexp_exceptionp(res)) + goto done; + else if (sexp_truep(res)) + swap(res, vec[i], vec[j]), j++; + } + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + res = sexp_qsort_less(ctx, vec, lo, j-1, less, key); + if (sexp_exceptionp(res)) + goto done; + lo = j+1; + goto loop; + } + } + done: + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_sort_x (sexp ctx, sexp seq, sexp less, sexp key) { + sexp_sint_t len; + sexp res, *data; + sexp_gc_var1(vec); + + if (sexp_nullp(seq)) return seq; + + sexp_gc_preserve1(ctx, vec); + + vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); + + if (! sexp_vectorp(vec)) { + res = sexp_type_exception(ctx, "sort: not a vector", vec); + } else { + data = sexp_vector_data(vec); + len = sexp_vector_length(vec); + if (sexp_not(key) && sexp_basic_comparator(less)) { + sexp_qsort(ctx, data, 0, len-1); + if (sexp_opcodep(less) && sexp_opcode_inverse(less)) + sexp_vector_nreverse(ctx, vec); + } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { + res = sexp_type_exception(ctx, "sort: not a procedure", less); + } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { + res = sexp_type_exception(ctx, "sort: not a procedure", less); + } else { + res = sexp_qsort_less(ctx, data, 0, len-1, less, key); + } + } + + if (sexp_pairp(seq)) + res = sexp_vector_copy_to_list(ctx, vec, seq); + else if (! sexp_exceptionp(res)) + res = vec; + + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE); + return SEXP_VOID; +} diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm new file mode 100644 index 00000000..0659c3c9 --- /dev/null +++ b/lib/srfi/95/sort.scm @@ -0,0 +1,67 @@ + +(define (copy seq) + (if (vector? seq) + (let* ((len (vector-length seq)) + (res (make-vector len))) + (do ((i (- len 1) (- i 1))) + ((< i 0) res) + (vector-set! res i (vector-ref seq i)))) + (map (lambda (x) x) seq))) + +(define (sort seq . o) + (let ((less (and (pair? o) (car o))) + (key (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (sort! (copy seq) less key))) + +(define (sorted? seq less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (cond + ((vector? seq) + (let ((len (- (vector-length seq) 1))) + (let lp ((i 0)) + (cond + ((>= i len) #t) + ((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f) + (else (lp (+ i 1))))))) + ((null? seq) + #f) + (else + (let lp ((ls1 seq) (ls2 (cdr seq))) + (cond ((null? ls2) #t) + ((less (key (car ls2)) (key (car ls1))) #f) + (else (lp ls2 (cdr ls2))))))))) + +(define (merge! ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (define (lp prev ls1 ls2 a b less key) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))) + (else + (set-cdr! prev ls2) + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))))) + (cond + ((null? ls1) ls2) + ((null? ls2) ls1) + (else + (let ((a (key (car ls1))) + (b (key (car ls2)))) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)) + ls1) + (else + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)) + ls2))))))) + +(define (merge ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (merge! (copy ls1) (copy ls2) less key))) From 02e1bb820d1004f02bc8ce921487f1f01e1103ee Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 19:29:43 +0900 Subject: [PATCH 305/535] adding a manpage --- Makefile | 4 ++ doc/chibi-scheme.1 | 133 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 137 insertions(+) create mode 100644 doc/chibi-scheme.1 diff --git a/Makefile b/Makefile index 85904625..fee25951 100644 --- a/Makefile +++ b/Makefile @@ -13,11 +13,13 @@ SOLIBDIR ?= $(PREFIX)/lib INCDIR ?= $(PREFIX)/include/chibi MODDIR ?= $(PREFIX)/share/chibi LIBDIR ?= $(PREFIX)/lib/chibi +MANDIR ?= $(PREFIX)/share/man/man1 DESTDIR ?= GENSTUBS ?= ./tools/genstubs.scm +######################################################################## # system configuration - if not using GNU make, set PLATFORM and the # following flags as necessary. @@ -169,6 +171,8 @@ install: chibi-scheme$(EXE) cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ + mkdir -p $(DESTDIR)$(MANDIR) + cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/ if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi uninstall: diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1 new file mode 100644 index 00000000..f20c50e5 --- /dev/null +++ b/doc/chibi-scheme.1 @@ -0,0 +1,133 @@ +.TH "chibi-scheme" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-scheme \- a tiny Scheme interpreter + +.SH SYNOPSIS +.B chibi-scheme +[-qV] +[-I +.I path +] +[-A +.I path +] +[-u +.I module +] +[-l +.I file +] +[-e +.I expr +] +[-p +.I expr +] +[--] +[ +.I script argument ... +] +.br +.sp 0.3 + +.SH DESCRIPTION +.I chibi-scheme +is a sample interactive Scheme interpreter for the +.I chibi-scheme +library. It serves as an example of how to embed +.I chibi-scheme +in applications, and can be useful on its own for writing +scripts and interactive development. + +When +.I script +is given, the script will be loaded with SRFI-22 semantics, +calling the procedure +.I main +(if defined) with a single parameter as a list of the +command-line arguments beginning with the script name. + +Otherwise, if no script is given and no -e or -p options +are given an interactive repl is entered, reading, evaluating, +then printing expressions until EOF is reached. The repl +provided is very minimal - if you want readline +completion you may want to wrap it with the +.I rlwrap(1) +program. Signals aren't caught either - to enable handling keyboard +interrupts you can use the (chibi process) module. + +.SH OPTIONS +.TP 5 +.BI -V +Prints the version information and exits. +.TP +.BI -q +Don't load the initialization file. The resulting +environment will only contain the core syntactic forms +and primitives coded in C. +.TP +.BI -h size +Specifies the initial size of the heap, in bytes. +.I size +can be any integer value, optionally suffixed by +"K" for kilobytes, or "M" for megabytes. +.I -h +must be specified before any options which load or +evaluate Scheme code. +.TP +.BI -I path +Inserts +.I path +on front of the load path list. +.TP +.BI -A path +Appends +.I path +to the load path list. +.TP +.BI -m module +Imports +.I module +as though "(import +.I module +)" were evaluated. However, to reduce the need for shell +escapes, modules are written in a dot notation, so that the module +.I (foo bar) +is written as +.I foo.bar +.TP +.BI -l file +Loads the Scheme source from the file +.I file +searched for in the default load path. +.TP +.BI -e expr +Evaluates the Scheme expression +.I expr. +.TP +.BI -p expr +Evaluates the Scheme expression +.I expr +then prints the result to stdout. + +.SH ENVIRONMENT +.TP +.B CHIBI_MODULE_PATH +.TQ +A colon separated list of directories to search for module +files, inserted before the system default load paths. + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +More detailed information can be found in the README file +included in the distribution. + +The chibi-scheme home-page: +.br +http://code.google.com/p/chibi-scheme/ From ad068bc1f86ccc88351e459cd83b4f35c6fa81cf Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 21:05:25 +0900 Subject: [PATCH 306/535] adding srfi-39 --- lib/srfi/39.module | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 lib/srfi/39.module diff --git a/lib/srfi/39.module b/lib/srfi/39.module new file mode 100644 index 00000000..11b9ed9f --- /dev/null +++ b/lib/srfi/39.module @@ -0,0 +1,25 @@ + +(define-module (srfi 39) + (export make-parameter parameterize) + (import-immutable (scheme)) + (body + (define (make-parameter value . o) + (if (pair? o) + (let ((converter (car o))) + (lambda args + (if (null? args) + value + (set! value (converter (car args)))))) + (lambda args (if (null? args) value (set! value (car args)))))) + (define-syntax parameterize + (syntax-rules () + ((parameterize ("step") ((param value tmp1 tmp2) ...) () body) + (let ((tmp1 value) ...) + (let ((tmp2 (param)) ...) + (dynamic-wind (lambda () (param tmp1) ...) + (lambda () . body) + (lambda () (param tmp2) ...))))) + ((parameterize ("step") args ((param value) . rest) body) + (parameterize ("step") ((param value tmp1 tmp2) . args) rest body)) + ((parameterize ((param value) ...) . body) + (parameterize ("step") () ((param value) ...) body)))))) From f141b22cb30cf52343233756afd90cfb099352e4 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 22:53:20 +0900 Subject: [PATCH 307/535] adding extended documentation to README, updating version and copyright information. --- COPYING | 24 +++ README | 380 ++++++++++++++++++++++++++++++----- VERSION | 2 +- lib/chibi/ast.c | 3 + lib/chibi/disasm.c | 2 +- lib/chibi/filesystem.scm | 3 + lib/chibi/heap-stats.c | 3 + lib/chibi/macroexpand.scm | 6 + lib/chibi/net.scm | 3 + lib/chibi/pathname.scm | 3 + lib/chibi/signal.c | 3 + lib/chibi/uri.scm | 3 + lib/config.scm | 3 + lib/init.scm | 3 + lib/srfi/1/alists.scm | 3 + lib/srfi/1/constructors.scm | 3 + lib/srfi/1/deletion.scm | 3 + lib/srfi/1/fold.scm | 3 + lib/srfi/1/lset.scm | 3 + lib/srfi/1/misc.scm | 3 + lib/srfi/1/predicates.scm | 3 + lib/srfi/1/search.scm | 3 + lib/srfi/1/selectors.scm | 3 + lib/srfi/27/constructors.scm | 3 + lib/srfi/27/rand.c | 3 + lib/srfi/33/bit.c | 3 + lib/srfi/33/bitwise.scm | 3 + lib/srfi/69/hash.c | 3 + lib/srfi/69/interface.scm | 5 + lib/srfi/69/type.scm | 3 + lib/srfi/95/qsort.c | 3 + lib/srfi/95/sort.scm | 3 + lib/srfi/98/env.c | 3 + opt/simplify.c | 3 + 34 files changed, 453 insertions(+), 50 deletions(-) create mode 100644 COPYING diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..1fcee28e --- /dev/null +++ b/COPYING @@ -0,0 +1,24 @@ +Copyright (c) 2009 Alex Shinn +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README index 4b723595..d1476de2 100644 --- a/README +++ b/README @@ -15,6 +15,9 @@ 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. +------------------------------------------------------------------------ +INSTALLING + 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 @@ -24,7 +27,7 @@ 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 + make CFLAGS=-Os CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 to optimize for size, or @@ -36,46 +39,25 @@ 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 + make SEXP_USE_BOEHM=1 -See the file main.c for an example of using chibi-scheme as a library. -The essential functions to remember are: +------------------------------------------------------------------------ +CHIBI-SCHEME LANGUAGE - #include +The default language is mostly compatible with the R5RS, with all +differences made by design, not through difficulty of implementation. +The following procedures are omitted: - sexp_make_eval_context(NULL, NULL, NULL) - returns a new context with a fresh stack and primitive environment + transcript-on and transcript-off (because they're silly) + rationalize (pending the addition of rational numbers) - sexp_load_standard_env(context, env, version) - loads the init.scm file in primitive environment env - (version should be SEXP_FIVE) +Apart from this, chibi-scheme is case-sensitive, unlike the R5RS. +The default configuration includes fixnums, flonums and bignums +but no exact rationals or complex numbers. - sexp_destroy_context(context) - free a context and all associated memory - - sexp_eval(context, expr, env) - evaluates an s-expression in an environment - env can be NULL to use the context's default env - - sexp_eval_string(context, str) - reads an s-expression from str and evaluates it - - sexp_load(context, file, env) - read and eval all top-level forms from file - - sexp_context_env(context) - a macro returning the environment associated with a context - - sexp_env_define(context, env, symbol, value) - define a variable in an environment - -A minimal module system is provided by default. Currently you can -load the following SRFIs with (import (srfi N)): - - 0, 1, 2, 6, 8, 9, 11, 16, 22, 23, 26, 27, 33, 46, 62, 69, 98 - -although 0, 22, 23, 46 and 62 are built into the default environment -so there's no need to import them. +Full continuations are supported, but currently continuations don't +take C code into account. The only higher-order C functions in the +standard environment are LOAD and EVAL. LOAD is extended to accept an optional environment argument, like EVAL. You can also LOAD shared libraries in addition to Scheme source @@ -84,23 +66,23 @@ called with the following signature: sexp_init_library(sexp context, sexp environment) -To define new primitive functions from C, use sexp_define_foreign, -which takes a Scheme environment, a name, a number of arguments the C -function takes (not counting the context argument), and a C function. +SYNTAX-RULES macros are provided by default, with the extensions from +SRFI-46. In addition, low-level hygienic macros are provided with +a syntactic-closures interface, including SC-MACRO-TRANSFORMER, +RSC-MACRO-TRANSFORMER, and ER-MACRO-TRANSFORMER. A good introduction +to syntactic-closures can be found at: - /* sexp_define_foreign(context, env, name, num_args, f) */ + http://community.schemewiki.org/?syntactic-closures - sexp add (sexp context, sexp x, sexp y) { - return sexp_fx_add(x, y); - } +IDENTIFIER?, IDENTIFIER->SYMBOL, IDENTIFIER=?, and +MAKE-SYNTACTIC-CLOSURE and STRIP-SYNTACTIC-CLOSURES are provided. - sexp_define_foreign(context, env, "add", 2, add); +SRFI-0's COND-EXPAND is provided, with the feature `chibi'. -You can also define functions with a single optional argument: +STRING-CONCATENATE concatenates a list of strings. - sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); - -See the SRFI-69 implementation for more detailed examples of this. +------------------------------------------------------------------------ +TYPES You can define new data types with SRFI-9. This is just syntactic sugar for the following more primitive type constructors: @@ -120,3 +102,305 @@ sugar for the following more primitive type constructors: (make-setter ) => ; takes 2 args, sets the field located at the index +------------------------------------------------------------------------ +MODULE SYSTEM + +A configurable module system, in the style of the Scheme48 module +system, is provided by default. + +Modules names are hierarchical lists of symbols or numbers. The +definition of the module (foo bar baz) is searched for in the file +foo/bar/baz.module. This file should contain an expression of the +form: + + (define-module (foo bar baz) + ...) + +where can be any of + + (export ...) - specify an export list + (import ...) - specify one or more imports + (import-immutable ...) - specify an immutable import + (body ...) - inline Scheme code + (include ...) - load one or more files + (include-shared ...) - dynamic load a library + + can either be a module name or any of + + (only ...) + (except ...) + (rename ( ) ...) + (prefix ) + +The can be composed and perform basic selection and renaming of +individual identifiers from the given module. + +Files are loaded relative to the .module file, and are written with +their extension (so you can use whatever suffix you prefer - .scm, +.ss, .sls, etc.). + +Shared modules, on the other hand, should be specified _without_ the +extension - the correct suffix will be added portably (e.g. .so for +Unix and .dylib for OS X). + +You may also use COND-EXPAND and arbitrary macro expansions in a +module definition to generate . + +------------------------------------------------------------------------ +MODULES + +The default environment is (scheme) - you almost always want to import +this. + +Currently you can load the following SRFIs with (import (srfi N)): + + 0, 1, 2, 6, 8, 9, 11, 16, 22, 23, 26, 27, 33, 39, 46, 62, 69, 95, 98 + +although 0, 22, 23, 46 and 62 are built into the default environment +so there's no need to import them. + +Included non-standard modules are put in the (chibi) module namespace. +The following additional modules are available: + + (chibi net) - networking interface + (chibi filesystem) - local filesystem and file descriptor interface + (chibi process) - processes and signals + (chibi system) - host system and user information + (chibi time) - time and date library + (chibi match) - pattern-matching library + (chibi loop) - extensible loop syntax + (chibi pathname) - pathname manipulation utilities + (chibi uri) - URI parsing and construction utilities + (chibi macroexpand) - macro expansion utility + (chibi ast) - interface to the internal Abstract Syntax Tree + (chibi disasm) - disassembly utility for the chibi VM + (chibi heap-stats) - debugging tool to analyze or dump the heap + +------------------------------------------------------------------------ +C INTERFACE + +See the file main.c for an example of using chibi-scheme as a library. + +The basic usage involves creating a context for evaluation and loading +or evaluating Scheme source with it. Begin by including the eval.h +header file: + + #include + +then call + + sexp_scheme_init(); + +with no parameters to initialize any globals (this actually does +nothing in the standard configuration but is a good idea to call +anyway). + +Then you can use the following to create and manipulate contexts: + + sexp_make_eval_context(context, stack, environment, heap_size) + Creates a new context with the given stack and environment. + If context is non-NULL, this will be the "parent" context and + the two contexts will share a heap. Otherwise, a new heap + will be allocated with heap_size, or a default size if heap_size + is zero. stack and environment may both also be NULL (and _must_ + be NULL if context is NULL) and will be given standard defaults. + + Thus the to create your first context you generally call: + + sexp_make_eval_context(NULL, NULL, NULL, 0) + + You can create as many contexts as you want, and other than those + sharing a heap they are all independent and thread-safe. + + sexp_load_standard_env(context, env, version) + Loads the init.scm file in the environment env. Version refers + to the RnRS version number and should always be SEXP_FIVE. The + environment created with sexp_make_eval_context only contains + core syntactic forms and C primitives (thus for example it has + CAR but not CADR or LIST), so to get a full featured + environment, plus a module system with which to load additional + modules, you want to use this. + + sexp_destroy_context(context) + Signals that you no longer need context, or any other context + sharing the heap. It will thus free() the context and heap and + all associated memory. Does nothing if using the Boehm GC. + +Environments can be handled with the following: + + sexp_context_env(context) + A macro returning the default environment associated with context. + + sexp_env_define(context, env, symbol, value) + Define a variable in an environment. + + sexp_env_ref(env, symbol, dflt) + Fetch the binding for symbol from the environment env, + returning the default dflt if the symbol is unbound. + +You can evaluate code with the following utility: + + sexp_eval(context, expr, env) + Evaluates an s-expression in an environment. + env can be NULL to use the context's default env. + + sexp_eval_string(context, str, env) + Reads an s-expression from str and evaluates it in env. + + sexp_load(context, file, env) + Read and eval all top-level forms from file in environment env. + As described in LOAD above, file may be a shared library. + +To define new primitive functions from C, use sexp_define_foreign, +which takes a Scheme environment, a name, a number of arguments the C +function takes (not counting the context argument), and a C function. + + /* sexp_define_foreign(context, env, name, num_args, f) */ + + sexp add (sexp context, sexp x, sexp y) { + return sexp_fx_add(x, y); + } + + sexp_define_foreign(context, env, "add", 2, add); + +You can also define functions with a single optional argument: + + sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); + +See the SRFI-69 implementation for more detailed examples of this. + +------------------------------------------------------------------------ +FFI + +Simple C FFI. "genstubs.scm file.stub" will read in the C function +FFI definitions from file.stub and output the appropriate C +wrappers into file.c. You can then compile that file with: + + cc -fPIC -shared file.c -lchibi-scheme + +(or using whatever flags are appropriate to generate shared libs on +your platform) and then the generated .so file can be loaded +directly with LOAD, or portably using (include-shared "file") in a +module definition (note that include-shared uses no suffix). + +The goal of this interface is to make access to C types and +functions easy, without requiring the user to write any C code. +That means the stubber needs to be intelligent about various C +calling conventions and idioms, such as return values passed in +actual parameters. Writing C by hand is still possible, and +several of the core modules provide C interfaces directly without +using the stubber. + +================================ + +Struct Interface + +(define-c-struct struct-name + [predicate: predicate-name] + [constructor: constructor-name] + [finalizer: c_finalizer_name] + (type c_field_name getter-name setter-name) ...) + + +================================ + + +Function Interface + +(define-c return-type name-spec (arg-type ...)) + +where name-space is either a symbol name, or a list of +(scheme-name c_name). If just a symbol, the C name is taken +to be the same with -'s replaced by _'s. + +arg-type is a type suitable for input validation and conversion. + +================================ + + +Types + +Types + +Basic Types + void + boolean + char + sexp (no conversions) + +Integer Types: + signed-char short int long + unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t + time_t (in seconds, but using the chibi epoch of 2010/01/01) + errno (as a return type returns #f on error) + +Float Types: + float double long-double + +String Types: + string - a null-terminated char* + env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme + in addition you can use (array char) as a string + +Port Types: + input-port output-port + +Struct Types: + +Struct types are by default just referred to by the bare +struct-name from define-c-struct, and it is assumed you want a +pointer to that type. To refer to the full struct, use the struct +modifier, as in (struct struct-name). + +Type modifiers + +Any type may also be written as a list of modifiers followed by the +type itself. The supported modifiers are: + +const: prepends the "const" C type modifier + * as a return or result parameter, makes non-immediates immutable + +free: it's Scheme's responsibility to "free" this resource + * as a return or result parameter, registers the freep flag + this causes the type finalizer to be run when GCed + +maybe-null: this pointer type may be NULL + * as a result parameter, NULL is translated to #f + normally this would just return a wrapped NULL pointer + * as an input parameter, #f is translated to NULL + normally this would be a type error + +pointer: create a pointer to this type + * as a return parameter, wraps the result in a vanilla cpointer + * as a result parameter, boxes then unboxes the value + +struct: treat this struct type as a struct, not a pointer + * as an input parameter, dereferences the pointer + * as a type field, indicates a nested struct + +link: add a gc link + * as a field getter, link to the parent object, so the + parent won't be GCed so long as we have a reference + to the child. this behavior is automatic for nested + structs. + +result: return a result in this parameter + * if there are multiple results (including the return type), + they are all returned in a list + * if there are any result parameters, a return type + of errno returns #f on failure, and as eliminated + from the list of results otherwise + +(value ): specify a fixed value + * as an input parameter, this parameter is not provided + in the Scheme API but always passed as + +(default ): specify a default value + * as the final input parameter, makes the Scheme parameter + optional, defaulting to + +(array []) an array type + * length must be specified for return and result parameters + * if specified, length can be any of + ** an integer, for a fixed size + ** the symbol null, indicating a NULL-terminated array diff --git a/VERSION b/VERSION index 3b04cfb6..be586341 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.2 +0.3 diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index dd85692c..19721c10 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -1,3 +1,6 @@ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index f2a50b7d..2aac1943 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -1,4 +1,4 @@ -/* debug.c -- optional debugging utilities */ +/* disasm.c -- optional debugging utilities */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm index 27af77e0..aa3fc69f 100644 --- a/lib/chibi/filesystem.scm +++ b/lib/chibi/filesystem.scm @@ -1,3 +1,6 @@ +;; filesystem.scm -- additional filesystem utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (directory-fold dir kons knil) (let ((dir (opendir dir))) diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c index 583277a7..34e415c1 100644 --- a/lib/chibi/heap-stats.c +++ b/lib/chibi/heap-stats.c @@ -1,3 +1,6 @@ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm index f1322c06..a040855a 100644 --- a/lib/chibi/macroexpand.scm +++ b/lib/chibi/macroexpand.scm @@ -1,3 +1,9 @@ +;; macroexpand.scm -- macro expansion utility +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; This actually analyzes the expression then reverse-engineers an +;; sexp from the result, generating a minimal amount of renames. (define (macroexpand x) (ast->sexp (analyze x))) diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm index 0ac1adca..85ed756a 100644 --- a/lib/chibi/net.scm +++ b/lib/chibi/net.scm @@ -1,3 +1,6 @@ +;; net.scm -- the high-level network interface +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (with-net-io host service proc) (let lp ((addr (get-address-info host service #f))) diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm index b8b28b4b..de27ad61 100644 --- a/lib/chibi/pathname.scm +++ b/lib/chibi/pathname.scm @@ -1,3 +1,6 @@ +;; pathname.scm -- a general, non-host-specific path lib +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (string-scan c str . o) (let ((limit (string-length str))) diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c index 930ef468..463e481d 100644 --- a/lib/chibi/signal.c +++ b/lib/chibi/signal.c @@ -1,3 +1,6 @@ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #define SEXP_MAX_SIGNUM 32 diff --git a/lib/chibi/uri.scm b/lib/chibi/uri.scm index 4386837a..41507961 100644 --- a/lib/chibi/uri.scm +++ b/lib/chibi/uri.scm @@ -1,3 +1,6 @@ +;; uri.scm -- URI parsing library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; URI representation diff --git a/lib/config.scm b/lib/config.scm index 0993a3e3..1254360d 100644 --- a/lib/config.scm +++ b/lib/config.scm @@ -1,3 +1,6 @@ +;; config.scm -- configuration module +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; modules diff --git a/lib/init.scm b/lib/init.scm index 88fb43b4..cd50ad37 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -1,3 +1,6 @@ +;; init.scm -- R5RS library procedures +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt ;; provide c[ad]{2,4}r diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm index b5032796..a35db42c 100644 --- a/lib/srfi/1/alists.scm +++ b/lib/srfi/1/alists.scm @@ -1,3 +1,6 @@ +;; alist.scm -- association list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (alist-cons key value ls) (cons (cons key value) ls)) diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm index 836f48b5..e205cee0 100644 --- a/lib/srfi/1/constructors.scm +++ b/lib/srfi/1/constructors.scm @@ -1,3 +1,6 @@ +;; constructors.scm -- list construction utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (xcons a b) (cons b a)) diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm index 721ae8c3..70ee5cc5 100644 --- a/lib/srfi/1/deletion.scm +++ b/lib/srfi/1/deletion.scm @@ -1,3 +1,6 @@ +;; deletion.scm -- list deletion utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (delete x ls . o) (let ((eq (if (pair? o) (car o) equal?))) diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm index 5253dec6..892b075c 100644 --- a/lib/srfi/1/fold.scm +++ b/lib/srfi/1/fold.scm @@ -1,3 +1,6 @@ +;; fold.scm -- list fold/reduce utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (fold kons knil ls . lists) (if (null? lists) diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm index dd1a0964..f2ffc4ae 100644 --- a/lib/srfi/1/lset.scm +++ b/lib/srfi/1/lset.scm @@ -1,3 +1,6 @@ +;; lset.scm -- list set library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (lset<= eq . sets) (if (null? sets) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm index c40afa1d..1e7568df 100644 --- a/lib/srfi/1/misc.scm +++ b/lib/srfi/1/misc.scm @@ -1,3 +1,6 @@ +;; misc.scm -- miscellaneous list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (map-onto proc ls init) (let lp ((ls ls) (res init)) diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm index 70144660..be84e085 100644 --- a/lib/srfi/1/predicates.scm +++ b/lib/srfi/1/predicates.scm @@ -1,3 +1,6 @@ +;; predicates.scm -- list prediates +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (proper-list? x) (cond ((null? x) #t) diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm index 4ab9eb7d..ea31d931 100644 --- a/lib/srfi/1/search.scm +++ b/lib/srfi/1/search.scm @@ -1,3 +1,6 @@ +;; search.scm -- list searching and splitting +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (find pred ls) (cond ((find-tail pred ls) => car) (else #f))) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm index c6608d50..74ef7119 100644 --- a/lib/srfi/1/selectors.scm +++ b/lib/srfi/1/selectors.scm @@ -1,3 +1,6 @@ +;; selectors.scm -- extended list selectors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define first car) (define second cadr) diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm index 473ad2a2..dbd0a8c6 100644 --- a/lib/srfi/27/constructors.scm +++ b/lib/srfi/27/constructors.scm @@ -1,3 +1,6 @@ +;; constructors.scm -- random function constructors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (random-source-make-integers rs) (lambda (n) (%random-integer rs n))) diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index bff675c1..d5d3d984 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -1,3 +1,6 @@ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include #include diff --git a/lib/srfi/33/bit.c b/lib/srfi/33/bit.c index cbfc940e..38aa4652 100644 --- a/lib/srfi/33/bit.c +++ b/lib/srfi/33/bit.c @@ -1,3 +1,6 @@ +/* bit.c -- bitwise operators */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include #include diff --git a/lib/srfi/33/bitwise.scm b/lib/srfi/33/bitwise.scm index 7beaf316..d0ac59f1 100644 --- a/lib/srfi/33/bitwise.scm +++ b/lib/srfi/33/bitwise.scm @@ -1,3 +1,6 @@ +;; bitwise.scm -- high-level bitwise functions +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (bitwise-not i) (- (+ i 1))) diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c index 51da2b62..e38c23c0 100644 --- a/lib/srfi/69/hash.c +++ b/lib/srfi/69/hash.c @@ -1,3 +1,6 @@ +/* hash.c -- type-general hashing */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include diff --git a/lib/srfi/69/interface.scm b/lib/srfi/69/interface.scm index 548d1eae..edd752f1 100644 --- a/lib/srfi/69/interface.scm +++ b/lib/srfi/69/interface.scm @@ -1,3 +1,8 @@ +;; interface.scm -- hash-table interface +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; the non-exported hash-table-cell is the heart of the implemenation (define (make-hash-table . o) (let ((eq-fn (if (pair? o) (car o) equal?)) diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm index 849d6a14..1fca9953 100644 --- a/lib/srfi/69/type.scm +++ b/lib/srfi/69/type.scm @@ -1,3 +1,6 @@ +;; types.scm -- the hash-table record type +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define-record-type hash-table (%make-hash-table buckets size hash-fn eq-fn) diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c index ca2bb017..6b304e54 100644 --- a/lib/srfi/95/qsort.c +++ b/lib/srfi/95/qsort.c @@ -1,3 +1,6 @@ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include "chibi/eval.h" diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm index 0659c3c9..38273199 100644 --- a/lib/srfi/95/sort.scm +++ b/lib/srfi/95/sort.scm @@ -1,3 +1,6 @@ +;; sort.scm -- SRFI-95 sorting utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (copy seq) (if (vector? seq) diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c index 4a180421..38f8b883 100644 --- a/lib/srfi/98/env.c +++ b/lib/srfi/98/env.c @@ -1,3 +1,6 @@ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #ifdef __APPLE__ #include diff --git a/opt/simplify.c b/opt/simplify.c index d70de633..d4ac576d 100644 --- a/opt/simplify.c +++ b/opt/simplify.c @@ -1,3 +1,6 @@ +/* simplify.c -- basic simplification pass */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda)) From 964011c39b0c44916c5db04421501d7f026c3edc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 22:59:57 +0900 Subject: [PATCH 308/535] fixing build for immediate flonums on 32-bit machines --- include/chibi/sexp.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 44b7cc7a..09254723 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -401,7 +401,7 @@ SEXP_API float sexp_flonum_value (sexp x); SEXP_API sexp sexp_make_flonum(sexp ctx, float f); #else #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) +#define sexp_flonum_value(x) (((union sexp_flonum_conv)(((unsigned int)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) #endif #else #define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) From 44a6c530d99c4b94914fed0acebc04ebe1d0c6d7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 23:18:04 +0900 Subject: [PATCH 309/535] EVAL save/restores the current exception handler. It doesn't really make sense for an exception to pass outside of EVAL. Fixes issue #17. --- .hgignore | 21 + COPYING | 24 + Makefile | 191 ++ README | 406 ++++ TODO | 148 ++ VERSION | 1 + doc/chibi-scheme.1 | 133 ++ eval.c | 2715 ++++++++++++++++++++++++ gc.c | 249 +++ include/chibi/bignum.h | 43 + include/chibi/config.h | 297 +++ include/chibi/eval.h | 163 ++ include/chibi/sexp.h | 860 ++++++++ lib/chibi/ast.c | 80 + lib/chibi/ast.module | 14 + lib/chibi/disasm.c | 127 ++ lib/chibi/disasm.module | 4 + lib/chibi/filesystem.module | 27 + lib/chibi/filesystem.scm | 43 + lib/chibi/filesystem.stub | 115 + lib/chibi/heap-stats.c | 129 ++ lib/chibi/heap-stats.module | 5 + lib/chibi/loop.module | 9 + lib/chibi/loop/loop.scm | 365 ++++ lib/chibi/macroexpand.module | 6 + lib/chibi/macroexpand.scm | 85 + lib/chibi/match.module | 6 + lib/chibi/match/match.scm | 670 ++++++ lib/chibi/net.module | 10 + lib/chibi/net.scm | 23 + lib/chibi/net.stub | 25 + lib/chibi/pathname.module | 7 + lib/chibi/pathname.scm | 180 ++ lib/chibi/process.module | 17 + lib/chibi/process.stub | 72 + lib/chibi/signal.c | 62 + lib/chibi/system.module | 15 + lib/chibi/system.stub | 34 + lib/chibi/time.module | 11 + lib/chibi/time.stub | 45 + lib/chibi/uri.module | 10 + lib/chibi/uri.scm | 306 +++ lib/config.scm | 174 ++ lib/init.scm | 881 ++++++++ lib/srfi/1.module | 31 + lib/srfi/1/alists.scm | 14 + lib/srfi/1/constructors.scm | 36 + lib/srfi/1/deletion.scm | 25 + lib/srfi/1/fold.scm | 115 + lib/srfi/1/lset.scm | 51 + lib/srfi/1/misc.scm | 54 + lib/srfi/1/predicates.scm | 42 + lib/srfi/1/search.scm | 54 + lib/srfi/1/selectors.scm | 59 + lib/srfi/11.module | 28 + lib/srfi/16.module | 24 + lib/srfi/2.module | 16 + lib/srfi/26.module | 24 + lib/srfi/27.module | 11 + lib/srfi/27/constructors.scm | 10 + lib/srfi/27/rand.c | 204 ++ lib/srfi/33.module | 17 + lib/srfi/33/bit.c | 303 +++ lib/srfi/33/bitwise.scm | 61 + lib/srfi/39.module | 25 + lib/srfi/6.module | 5 + lib/srfi/69.module | 17 + lib/srfi/69/hash.c | 242 +++ lib/srfi/69/interface.scm | 115 + lib/srfi/69/type.scm | 12 + lib/srfi/8.module | 10 + lib/srfi/9.module | 82 + lib/srfi/95.module | 7 + lib/srfi/95/qsort.c | 170 ++ lib/srfi/95/sort.scm | 70 + lib/srfi/98.module | 5 + lib/srfi/98/env.c | 48 + main.c | 193 ++ mkfile | 26 + opcodes.c | 153 ++ opt/bignum.c | 734 +++++++ opt/plan9-opcodes.c | 19 + opt/plan9.c | 351 +++ opt/sexp-huff.c | 128 ++ opt/sexp-hufftabs.c | 92 + opt/sexp-unhuff.c | 71 + opt/simplify.c | 135 ++ sexp.c | 1662 +++++++++++++++ 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 | 48 + tests/basic/test10-unhygiene.res | 6 + tests/basic/test10-unhygiene.scm | 49 + tests/build/build-opts.txt | 21 + tests/build/build-tests.sh | 37 + tests/loop-tests.scm | 202 ++ tests/match-tests.scm | 196 ++ tests/numeric-tests.scm | 150 ++ tests/r5rs-tests.scm | 483 +++++ tools/genstubs.scm | 1154 ++++++++++ 117 files changed, 16867 insertions(+) create mode 100644 .hgignore create mode 100644 COPYING create mode 100644 Makefile create mode 100644 README create mode 100644 TODO create mode 100644 VERSION create mode 100644 doc/chibi-scheme.1 create mode 100644 eval.c create mode 100644 gc.c create mode 100644 include/chibi/bignum.h create mode 100644 include/chibi/config.h create mode 100644 include/chibi/eval.h create mode 100644 include/chibi/sexp.h create mode 100644 lib/chibi/ast.c create mode 100644 lib/chibi/ast.module create mode 100644 lib/chibi/disasm.c create mode 100644 lib/chibi/disasm.module create mode 100644 lib/chibi/filesystem.module create mode 100644 lib/chibi/filesystem.scm create mode 100644 lib/chibi/filesystem.stub create mode 100644 lib/chibi/heap-stats.c create mode 100644 lib/chibi/heap-stats.module create mode 100644 lib/chibi/loop.module create mode 100644 lib/chibi/loop/loop.scm create mode 100644 lib/chibi/macroexpand.module create mode 100644 lib/chibi/macroexpand.scm create mode 100644 lib/chibi/match.module create mode 100644 lib/chibi/match/match.scm create mode 100644 lib/chibi/net.module create mode 100644 lib/chibi/net.scm create mode 100644 lib/chibi/net.stub create mode 100644 lib/chibi/pathname.module create mode 100644 lib/chibi/pathname.scm create mode 100644 lib/chibi/process.module create mode 100644 lib/chibi/process.stub create mode 100644 lib/chibi/signal.c create mode 100644 lib/chibi/system.module create mode 100644 lib/chibi/system.stub create mode 100644 lib/chibi/time.module create mode 100644 lib/chibi/time.stub create mode 100644 lib/chibi/uri.module create mode 100644 lib/chibi/uri.scm create mode 100644 lib/config.scm create mode 100644 lib/init.scm create mode 100644 lib/srfi/1.module create mode 100644 lib/srfi/1/alists.scm create mode 100644 lib/srfi/1/constructors.scm create mode 100644 lib/srfi/1/deletion.scm create mode 100644 lib/srfi/1/fold.scm create mode 100644 lib/srfi/1/lset.scm create mode 100644 lib/srfi/1/misc.scm create mode 100644 lib/srfi/1/predicates.scm create mode 100644 lib/srfi/1/search.scm create mode 100644 lib/srfi/1/selectors.scm create mode 100644 lib/srfi/11.module create mode 100644 lib/srfi/16.module create mode 100644 lib/srfi/2.module create mode 100644 lib/srfi/26.module create mode 100644 lib/srfi/27.module create mode 100644 lib/srfi/27/constructors.scm create mode 100644 lib/srfi/27/rand.c create mode 100644 lib/srfi/33.module create mode 100644 lib/srfi/33/bit.c create mode 100644 lib/srfi/33/bitwise.scm create mode 100644 lib/srfi/39.module create mode 100644 lib/srfi/6.module create mode 100644 lib/srfi/69.module create mode 100644 lib/srfi/69/hash.c create mode 100644 lib/srfi/69/interface.scm create mode 100644 lib/srfi/69/type.scm create mode 100644 lib/srfi/8.module create mode 100644 lib/srfi/9.module create mode 100644 lib/srfi/95.module create mode 100644 lib/srfi/95/qsort.c create mode 100644 lib/srfi/95/sort.scm create mode 100644 lib/srfi/98.module create mode 100644 lib/srfi/98/env.c create mode 100644 main.c create mode 100644 mkfile create mode 100644 opcodes.c create mode 100644 opt/bignum.c create mode 100644 opt/plan9-opcodes.c create mode 100644 opt/plan9.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 opt/simplify.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/build/build-opts.txt create mode 100755 tests/build/build-tests.sh create mode 100644 tests/loop-tests.scm create mode 100644 tests/match-tests.scm create mode 100644 tests/numeric-tests.scm create mode 100644 tests/r5rs-tests.scm create mode 100755 tools/genstubs.scm diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..babe41d2 --- /dev/null +++ b/.hgignore @@ -0,0 +1,21 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dylib +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +chibi-scheme +chibi-scheme-static +include/chibi/install.h diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..1fcee28e --- /dev/null +++ b/COPYING @@ -0,0 +1,24 @@ +Copyright (c) 2009 Alex Shinn +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..fee25951 --- /dev/null +++ b/Makefile @@ -0,0 +1,191 @@ +# -*- makefile-gmake -*- + +.PHONY: all libs doc dist clean cleaner test install uninstall +.PRECIOUS: %.c + +# install configuration + +CC ?= cc +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +SOLIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi +LIBDIR ?= $(PREFIX)/lib/chibi +MANDIR ?= $(PREFIX)/share/man/man1 + +DESTDIR ?= + +GENSTUBS ?= ./tools/genstubs.scm + +######################################################################## +# system configuration - if not using GNU make, set PLATFORM and the +# following flags as necessary. + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +PLATFORM=unix +endif +endif +endif + +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0 +else +ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL -DSEXP_USE_DEBUG=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static -DSEXP_USE_DL=0 +endif +endif + +ifeq ($(USE_BOEHM),1) +SEXP_USE_BOEHM = 1 +endif + +ifeq ($(SEXP_USE_BOEHM),1) +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DSEXP_USE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude +endif + +ifeq ($(SEXP_USE_DL),0) +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS) +else +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -ldl -lm +XCFLAGS := -Wall -g3 $(CFLAGS) +endif + +######################################################################## + +all: chibi-scheme$(EXE) libs + +COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ + lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \ + lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \ + lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \ + lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + +libs: $(COMPILED_LIBS) + +INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h + +include/chibi/install.h: Makefile + echo '#define sexp_so_extension "'$(SO)'"' > $@ + echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@ + echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ + +sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +eval.o: eval.c opcodes.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +main.o: main.c $(INCLUDES) include/chibi/eval.h 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) + +%.c: %.stub $(GENSTUBS) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) PATH=.:$(PATH) $(GENSTUBS) $< + +lib/%$(SO): lib/%.c $(INCLUDES) + -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +clean: + rm -f *.o *.i *.s *.8 + find lib -name \*$(SO) -exec rm -f '{}' \; + rm -f tests/basic/*.out tests/basic/*.err + +cleaner: clean + rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h + rm -rf *.dSYM + +test-basic: chibi-scheme$(EXE) + @for f in tests/basic/*.scm; do \ + ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + +test-build: + ./tests/build/build-tests.sh + +test-numbers: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/numeric-tests.scm + +test-hash: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/hash-tests.scm + +test-match: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/match-tests.scm + +test-loop: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/loop-tests.scm + +test: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/r5rs-tests.scm + +install: chibi-scheme$(EXE) + mkdir -p $(DESTDIR)$(BINDIR) + cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ + mkdir -p $(DESTDIR)$(MODDIR) + cp lib/init.scm lib/config.scm $(DESTDIR)$(MODDIR)/ + cp -r lib/ $(DESTDIR)$(MODDIR)/ + mkdir -p $(DESTDIR)$(INCDIR) + cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ + mkdir -p $(DESTDIR)$(LIBDIR) + mkdir -p $(DESTDIR)$(SOLIBDIR) + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ + mkdir -p $(DESTDIR)$(MANDIR) + cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/ + if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + +uninstall: + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE) + rm -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO) + rm -f $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a + cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -rf $(DESTDIR)$(MODDIR) + +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..d1476de2 --- /dev/null +++ b/README @@ -0,0 +1,406 @@ + + 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. + +------------------------------------------------------------------------ +INSTALLING + +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 CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 + +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 SEXP_USE_BOEHM=1 + +------------------------------------------------------------------------ +CHIBI-SCHEME LANGUAGE + +The default language is mostly compatible with the R5RS, with all +differences made by design, not through difficulty of implementation. +The following procedures are omitted: + + transcript-on and transcript-off (because they're silly) + rationalize (pending the addition of rational numbers) + +Apart from this, chibi-scheme is case-sensitive, unlike the R5RS. +The default configuration includes fixnums, flonums and bignums +but no exact rationals or complex numbers. + +Full continuations are supported, but currently continuations don't +take C code into account. The only higher-order C functions in the +standard environment are LOAD and EVAL. + +LOAD is extended to accept an optional environment argument, like +EVAL. You can also LOAD shared libraries in addition to Scheme source +files - in this case the function sexp_init_library is automatically +called with the following signature: + + sexp_init_library(sexp context, sexp environment) + +SYNTAX-RULES macros are provided by default, with the extensions from +SRFI-46. In addition, low-level hygienic macros are provided with +a syntactic-closures interface, including SC-MACRO-TRANSFORMER, +RSC-MACRO-TRANSFORMER, and ER-MACRO-TRANSFORMER. A good introduction +to syntactic-closures can be found at: + + http://community.schemewiki.org/?syntactic-closures + +IDENTIFIER?, IDENTIFIER->SYMBOL, IDENTIFIER=?, and +MAKE-SYNTACTIC-CLOSURE and STRIP-SYNTACTIC-CLOSURES are provided. + +SRFI-0's COND-EXPAND is provided, with the feature `chibi'. + +STRING-CONCATENATE concatenates a list of strings. + +------------------------------------------------------------------------ +TYPES + +You can define new data types with SRFI-9. This is just syntactic +sugar for the following more primitive type constructors: + +(register-simple-type ) + => ; a fixnum + +(make-type-predicate ) + => ; takes 1 arg, returns #t iff that arg is of the type + +(make-constructor ) + => ; takes 0 args, returns a newly allocated instance of type + +(make-getter ) + => ; takes 1 args, retrieves the field located at the index + +(make-setter ) + => ; takes 2 args, sets the field located at the index + +------------------------------------------------------------------------ +MODULE SYSTEM + +A configurable module system, in the style of the Scheme48 module +system, is provided by default. + +Modules names are hierarchical lists of symbols or numbers. The +definition of the module (foo bar baz) is searched for in the file +foo/bar/baz.module. This file should contain an expression of the +form: + + (define-module (foo bar baz) + ...) + +where can be any of + + (export ...) - specify an export list + (import ...) - specify one or more imports + (import-immutable ...) - specify an immutable import + (body ...) - inline Scheme code + (include ...) - load one or more files + (include-shared ...) - dynamic load a library + + can either be a module name or any of + + (only ...) + (except ...) + (rename ( ) ...) + (prefix ) + +The can be composed and perform basic selection and renaming of +individual identifiers from the given module. + +Files are loaded relative to the .module file, and are written with +their extension (so you can use whatever suffix you prefer - .scm, +.ss, .sls, etc.). + +Shared modules, on the other hand, should be specified _without_ the +extension - the correct suffix will be added portably (e.g. .so for +Unix and .dylib for OS X). + +You may also use COND-EXPAND and arbitrary macro expansions in a +module definition to generate . + +------------------------------------------------------------------------ +MODULES + +The default environment is (scheme) - you almost always want to import +this. + +Currently you can load the following SRFIs with (import (srfi N)): + + 0, 1, 2, 6, 8, 9, 11, 16, 22, 23, 26, 27, 33, 39, 46, 62, 69, 95, 98 + +although 0, 22, 23, 46 and 62 are built into the default environment +so there's no need to import them. + +Included non-standard modules are put in the (chibi) module namespace. +The following additional modules are available: + + (chibi net) - networking interface + (chibi filesystem) - local filesystem and file descriptor interface + (chibi process) - processes and signals + (chibi system) - host system and user information + (chibi time) - time and date library + (chibi match) - pattern-matching library + (chibi loop) - extensible loop syntax + (chibi pathname) - pathname manipulation utilities + (chibi uri) - URI parsing and construction utilities + (chibi macroexpand) - macro expansion utility + (chibi ast) - interface to the internal Abstract Syntax Tree + (chibi disasm) - disassembly utility for the chibi VM + (chibi heap-stats) - debugging tool to analyze or dump the heap + +------------------------------------------------------------------------ +C INTERFACE + +See the file main.c for an example of using chibi-scheme as a library. + +The basic usage involves creating a context for evaluation and loading +or evaluating Scheme source with it. Begin by including the eval.h +header file: + + #include + +then call + + sexp_scheme_init(); + +with no parameters to initialize any globals (this actually does +nothing in the standard configuration but is a good idea to call +anyway). + +Then you can use the following to create and manipulate contexts: + + sexp_make_eval_context(context, stack, environment, heap_size) + Creates a new context with the given stack and environment. + If context is non-NULL, this will be the "parent" context and + the two contexts will share a heap. Otherwise, a new heap + will be allocated with heap_size, or a default size if heap_size + is zero. stack and environment may both also be NULL (and _must_ + be NULL if context is NULL) and will be given standard defaults. + + Thus the to create your first context you generally call: + + sexp_make_eval_context(NULL, NULL, NULL, 0) + + You can create as many contexts as you want, and other than those + sharing a heap they are all independent and thread-safe. + + sexp_load_standard_env(context, env, version) + Loads the init.scm file in the environment env. Version refers + to the RnRS version number and should always be SEXP_FIVE. The + environment created with sexp_make_eval_context only contains + core syntactic forms and C primitives (thus for example it has + CAR but not CADR or LIST), so to get a full featured + environment, plus a module system with which to load additional + modules, you want to use this. + + sexp_destroy_context(context) + Signals that you no longer need context, or any other context + sharing the heap. It will thus free() the context and heap and + all associated memory. Does nothing if using the Boehm GC. + +Environments can be handled with the following: + + sexp_context_env(context) + A macro returning the default environment associated with context. + + sexp_env_define(context, env, symbol, value) + Define a variable in an environment. + + sexp_env_ref(env, symbol, dflt) + Fetch the binding for symbol from the environment env, + returning the default dflt if the symbol is unbound. + +You can evaluate code with the following utility: + + sexp_eval(context, expr, env) + Evaluates an s-expression in an environment. + env can be NULL to use the context's default env. + + sexp_eval_string(context, str, env) + Reads an s-expression from str and evaluates it in env. + + sexp_load(context, file, env) + Read and eval all top-level forms from file in environment env. + As described in LOAD above, file may be a shared library. + +To define new primitive functions from C, use sexp_define_foreign, +which takes a Scheme environment, a name, a number of arguments the C +function takes (not counting the context argument), and a C function. + + /* sexp_define_foreign(context, env, name, num_args, f) */ + + sexp add (sexp context, sexp x, sexp y) { + return sexp_fx_add(x, y); + } + + sexp_define_foreign(context, env, "add", 2, add); + +You can also define functions with a single optional argument: + + sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); + +See the SRFI-69 implementation for more detailed examples of this. + +------------------------------------------------------------------------ +FFI + +Simple C FFI. "genstubs.scm file.stub" will read in the C function +FFI definitions from file.stub and output the appropriate C +wrappers into file.c. You can then compile that file with: + + cc -fPIC -shared file.c -lchibi-scheme + +(or using whatever flags are appropriate to generate shared libs on +your platform) and then the generated .so file can be loaded +directly with LOAD, or portably using (include-shared "file") in a +module definition (note that include-shared uses no suffix). + +The goal of this interface is to make access to C types and +functions easy, without requiring the user to write any C code. +That means the stubber needs to be intelligent about various C +calling conventions and idioms, such as return values passed in +actual parameters. Writing C by hand is still possible, and +several of the core modules provide C interfaces directly without +using the stubber. + +================================ + +Struct Interface + +(define-c-struct struct-name + [predicate: predicate-name] + [constructor: constructor-name] + [finalizer: c_finalizer_name] + (type c_field_name getter-name setter-name) ...) + + +================================ + + +Function Interface + +(define-c return-type name-spec (arg-type ...)) + +where name-space is either a symbol name, or a list of +(scheme-name c_name). If just a symbol, the C name is taken +to be the same with -'s replaced by _'s. + +arg-type is a type suitable for input validation and conversion. + +================================ + + +Types + +Types + +Basic Types + void + boolean + char + sexp (no conversions) + +Integer Types: + signed-char short int long + unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t + time_t (in seconds, but using the chibi epoch of 2010/01/01) + errno (as a return type returns #f on error) + +Float Types: + float double long-double + +String Types: + string - a null-terminated char* + env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme + in addition you can use (array char) as a string + +Port Types: + input-port output-port + +Struct Types: + +Struct types are by default just referred to by the bare +struct-name from define-c-struct, and it is assumed you want a +pointer to that type. To refer to the full struct, use the struct +modifier, as in (struct struct-name). + +Type modifiers + +Any type may also be written as a list of modifiers followed by the +type itself. The supported modifiers are: + +const: prepends the "const" C type modifier + * as a return or result parameter, makes non-immediates immutable + +free: it's Scheme's responsibility to "free" this resource + * as a return or result parameter, registers the freep flag + this causes the type finalizer to be run when GCed + +maybe-null: this pointer type may be NULL + * as a result parameter, NULL is translated to #f + normally this would just return a wrapped NULL pointer + * as an input parameter, #f is translated to NULL + normally this would be a type error + +pointer: create a pointer to this type + * as a return parameter, wraps the result in a vanilla cpointer + * as a result parameter, boxes then unboxes the value + +struct: treat this struct type as a struct, not a pointer + * as an input parameter, dereferences the pointer + * as a type field, indicates a nested struct + +link: add a gc link + * as a field getter, link to the parent object, so the + parent won't be GCed so long as we have a reference + to the child. this behavior is automatic for nested + structs. + +result: return a result in this parameter + * if there are multiple results (including the return type), + they are all returned in a list + * if there are any result parameters, a return type + of errno returns #f on failure, and as eliminated + from the list of results otherwise + +(value ): specify a fixed value + * as an input parameter, this parameter is not provided + in the Scheme API but always passed as + +(default ): specify a default value + * as the final input parameter, makes the Scheme parameter + optional, defaulting to + +(array []) an array type + * length must be specified for return and result parameters + * if specified, length can be any of + ** an integer, for a fixed size + ** the symbol null, indicating a NULL-terminated array diff --git a/TODO b/TODO new file mode 100644 index 00000000..93f7c837 --- /dev/null +++ b/TODO @@ -0,0 +1,148 @@ +-*- org -*- + +* compiler +** DONE ast rewrite + - State "DONE" [2009-04-09 Thu 14:32] +** DONE call/cc support + - State "DONE" [2009-04-09 Thu 14:36] +** DONE exceptions + - State "DONE" [2009-04-09 Thu 14:45] +** TODO native x86 backend +** TODO fasl/image files +** DONE shared stack on EVAL + - State "DONE" [2009-12-26 Sat 08:22] + +* compiler optimizations +** DONE constant folding + - State "DONE" [2009-12-16 Wed 23:25] +** DONE simplification pass, dead-code elimination + - State "DONE" [2009-12-18 Fri 14:14] + This is important in particular for the output generated by + syntax-rules. +** TODO lambda lift + The current closure representation is not very efficient, so this + would help a lot. +** TODO inlining (and disabling primitive inlining) + Being able to redefine procedures is important though. +** TODO unsafe operations + Possibly, don't want to make things too complicated or unstable. +** TODO plugin infrastructure +** TODO type inference with warnings + +* macros +** DONE hygiene + - State "DONE" [2009-04-09 Thu 14:41] +** DONE hygienic nested let-syntax + - State "DONE" [2009-12-08 Tue 14:41] +** DONE macroexpand utility + - State "DONE" [2009-12-08 Tue 14:41] +** DONE SRFI-46 basic syntax-rules extensions + - State "DONE" [2009-12-26 Sat 07:59] +** DONE (... ...) support + - State "DONE" [2009-12-26 Sat 02:06] +** TODO compiler macros +** TODO syntax-rules common pattern reduction +** TODO syntax-rules loop optimization + +* garbage collection +** DONE precise gc rewrite + - State "DONE" [2009-06-22 Mon 14:27] +** DONE fix heap growing + - State "DONE" [2009-06-22 Mon 14:29] +** DONE separate gc heaps + - State "DONE" [2009-12-08 Tue 14:29] +** DONE add finalizers + - State "DONE" [2009-12-08 Tue 14:29] +** TODO support weak references + +* runtime +** DONE bignums + - State "DONE" [2009-07-07 Tue 14:42] +** TODO unicode +** TODO threads +** TODO virtual ports +** DONE dynamic-wind + - State "DONE" [2009-12-26 Sat 01:51] + Adapted a version from Scheme48. +** DONE recursive disasm + - State "DONE" [2009-12-18 Fri 14:15] + +* FFI +** DONE libdl support + - State "DONE" [2009-12-08 Tue 14:45] +** DONE opcode generation interface + - State "DONE" [2009-11-15 Sun 14:45] +** DONE stub generator + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE define-c-struct + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE define-c + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE array return types + - State "DONE" [2009-12-26 Sat 01:49] +*** DONE pre-buffered string types (like getcwd) + - State "DONE" [2009-12-26 Sat 01:49] + +* module system +** DONE scheme48-like config language + - State "DONE" [2009-10-13 Tue 14:38] +** DONE shared library includes + - State "DONE" [2009-12-08 Tue 14:39] +** DONE only/except/rename/prefix modifiers + - State "DONE" [2009-12-16 Wed 18:57] +** TODO scheme-complete.el support +** DONE access individual modules from repl + - State "DONE" [2009-12-26 Sat 01:49] + +* core modules +** DONE SRFI-0 cond-expand + - State "DONE" [2009-12-16 Wed 20:12] +** DONE SRFI-9 define-record-type + - State "DONE" [2009-12-08 Tue 14:50] +** DONE SRFI-69 hash-tables + - State "DONE" [2009-11-15 Sun 14:50] +** DONE match library + - State "DONE" [2009-12-08 Tue 14:54] +** DONE loop library + - State "DONE" [2009-12-08 Tue 14:54] +** TODO network interface +** TODO posix interface + Splitting this into several parts. +*** DONE filesystem interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE process interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE time interface + - State "DONE" [2009-12-26 Sat 01:50] +*** TODO host system interface +** DONE pathname library + - State "DONE" [2009-12-16 Wed 18:58] +** DONE uri library + - State "DONE" [2009-12-16 Wed 18:58] +** TODO http library +** TODO show (formatting) library +** TODO zip library +** TODO tar library +** TODO md5sum library + +* ports +** DONE basic mingw support + - State "DONE" [2009-06-22 Mon 14:36] +** DONE Plan 9 support + - State "DONE" [2009-08-10 Mon 14:37] +** DONE 64-bit support + - State "DONE" [2009-11-01 Sun 14:37] +** TODO iPhone support +** TODO bare-metal support + +* miscellaneous +** TODO overall cleanup +** TODO user documentation +** TODO thorough source documentation +** TODO full test suite for libraries + +* distribution +** TODO packaging format +** TODO code repository with fetch+install tool +** TODO translator to/from other implementations + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..be586341 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.3 diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1 new file mode 100644 index 00000000..f20c50e5 --- /dev/null +++ b/doc/chibi-scheme.1 @@ -0,0 +1,133 @@ +.TH "chibi-scheme" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-scheme \- a tiny Scheme interpreter + +.SH SYNOPSIS +.B chibi-scheme +[-qV] +[-I +.I path +] +[-A +.I path +] +[-u +.I module +] +[-l +.I file +] +[-e +.I expr +] +[-p +.I expr +] +[--] +[ +.I script argument ... +] +.br +.sp 0.3 + +.SH DESCRIPTION +.I chibi-scheme +is a sample interactive Scheme interpreter for the +.I chibi-scheme +library. It serves as an example of how to embed +.I chibi-scheme +in applications, and can be useful on its own for writing +scripts and interactive development. + +When +.I script +is given, the script will be loaded with SRFI-22 semantics, +calling the procedure +.I main +(if defined) with a single parameter as a list of the +command-line arguments beginning with the script name. + +Otherwise, if no script is given and no -e or -p options +are given an interactive repl is entered, reading, evaluating, +then printing expressions until EOF is reached. The repl +provided is very minimal - if you want readline +completion you may want to wrap it with the +.I rlwrap(1) +program. Signals aren't caught either - to enable handling keyboard +interrupts you can use the (chibi process) module. + +.SH OPTIONS +.TP 5 +.BI -V +Prints the version information and exits. +.TP +.BI -q +Don't load the initialization file. The resulting +environment will only contain the core syntactic forms +and primitives coded in C. +.TP +.BI -h size +Specifies the initial size of the heap, in bytes. +.I size +can be any integer value, optionally suffixed by +"K" for kilobytes, or "M" for megabytes. +.I -h +must be specified before any options which load or +evaluate Scheme code. +.TP +.BI -I path +Inserts +.I path +on front of the load path list. +.TP +.BI -A path +Appends +.I path +to the load path list. +.TP +.BI -m module +Imports +.I module +as though "(import +.I module +)" were evaluated. However, to reduce the need for shell +escapes, modules are written in a dot notation, so that the module +.I (foo bar) +is written as +.I foo.bar +.TP +.BI -l file +Loads the Scheme source from the file +.I file +searched for in the default load path. +.TP +.BI -e expr +Evaluates the Scheme expression +.I expr. +.TP +.BI -p expr +Evaluates the Scheme expression +.I expr +then prints the result to stdout. + +.SH ENVIRONMENT +.TP +.B CHIBI_MODULE_PATH +.TQ +A colon separated list of directories to search for module +files, inserted before the system default load paths. + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +More detailed information can be found in the README file +included in the distribution. + +The chibi-scheme home-page: +.br +http://code.google.com/p/chibi-scheme/ diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..c9a02bd5 --- /dev/null +++ b/eval.c @@ -0,0 +1,2715 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +#if SEXP_USE_DEBUG_VM +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { + int i; + if (! sexp_oport(out)) out = sexp_current_error_port(ctx); + 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, NULL); + } else if (sexp_synclop(x)) { + tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(tmp) = sexp_synclo_env(x); + sexp_context_fv(tmp) = sexp_append2(tmp, + sexp_synclo_free_vars(x), + sexp_context_fv(tmp)); + x = sexp_synclo_expr(x); + res = analyze(tmp, x); + } else { + res = x; + } + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res)) + && sexp_pairp(x)) + sexp_exception_source(res) = sexp_pair_source(x); + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} + +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 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, SEXP_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, SEXP_OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + emit(ctx, SEXP_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, SEXP_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, SEXP_OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, SEXP_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) + ? SEXP_OP_GLOBAL_REF : SEXP_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, SEXP_OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, SEXP_OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, SEXP_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_var1(ls); + sexp_gc_preserve1(ctx, ls); + + num_args = sexp_unbox_fixnum(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_data(op) + && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) + emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* push the arguments onto the stack in reverse order */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != SEXP_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 SEXP_OPC_ARITHMETIC: + if (num_args > 1) + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_INV: + emit(ctx, (num_args==1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + emit(ctx, SEXP_OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_FOREIGN: + emit(ctx, sexp_opcode_code(op)); + emit_word(ctx, (sexp_uint_t)op); + break; + case SEXP_OPC_TYPE_PREDICATE: + case SEXP_OPC_ACCESSOR: + case SEXP_OPC_CONSTRUCTOR: + emit(ctx, sexp_opcode_code(op)); + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE) { + if (sexp_opcode_data(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); + if (sexp_opcode_data2(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + } + break; + case SEXP_OPC_PARAMETER: + emit_push(ctx, sexp_opcode_data(op)); + emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + /* emit optional folding of operator */ + if ((num_args > 2) + && (sexp_opcode_class(op) == SEXP_OPC_ARITHMETIC + || sexp_opcode_class(op) == SEXP_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_release1(ctx); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, 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 ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); + + sexp_context_tailp(ctx) = tailp; + sexp_context_depth(ctx) -= len; + sexp_gc_release1(ctx); +} + +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_var2(tmp, bc); + sexp_gc_preserve2(ctx, tmp, 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_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); + 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, SEXP_OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, SEXP_OP_CONS); + emit(ctx2, SEXP_OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, SEXP_OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_fixnum((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_ZERO, 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, SEXP_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_fixnum(k)); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_VECTOR_SET); + emit(ctx, SEXP_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, SEXP_OP_MAKE_PROCEDURE); + } + sexp_gc_release2(ctx); +} + +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_var1(res); + if (sexp_nullp(fv2)) + return fv1; + sexp_gc_preserve1(ctx, res); + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, 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_release1(ctx); + return res; +} + +static sexp free_vars (sexp ctx, sexp x, sexp fv) { + sexp_gc_var2(fv1, fv2); + sexp_gc_preserve2(ctx, fv1, 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_release2(ctx); + return fv1; +} + +static sexp make_param_list (sexp ctx, sexp_uint_t i) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_fixnum(i), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ls, bc, res, env; + sexp_gc_var5(params, ref, refs, lambda, ctx2); + if (i == sexp_opcode_num_args(op)) { /* return before preserving */ + if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); + } else if (i < sexp_opcode_num_args(op)) { + return sexp_compile_error(ctx, "not enough args for opcode", op); + } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ + return sexp_compile_error(ctx, "too many args for opcode", op); + } + sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = sexp_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), sexp_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_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + sexp_gc_release5(ctx); + 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_fixnum(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= SEXP_INIT_STACK_SIZE) { + _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); + goto end_loop; + } +#endif + i = sexp_unbox_fixnum(_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_fixnum(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_fixnum(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_fixnum(i); + stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + stack[top+1] = self; + stack[top+2] = sexp_make_fixnum(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 SEXP_OP_FCALL0: + sexp_context_top(ctx) = top; + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx)); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL1: + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx, _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL2: + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL3: + sexp_context_top(ctx) = top; + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL4: + sexp_context_top(ctx) = top; + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL5: + sexp_context_top(ctx) = top; + _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL6: + sexp_context_top(ctx) = top; + _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_JUMP_UNLESS: + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case SEXP_OP_JUMP: + ip += _SWORD0; + break; + case SEXP_OP_PUSH: + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case SEXP_OP_DROP: + top--; + break; + case SEXP_OP_GLOBAL_REF: + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case SEXP_OP_GLOBAL_KNOWN_REF: + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_STACK_REF: /* `pick' in forth */ + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_REF: + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_SET: + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case SEXP_OP_CLOSURE_REF: + _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); + ip += sizeof(sexp); + break; + case SEXP_OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_VECTOR_LENGTH: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); + break; + case SEXP_OP_STRING_REF: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_string_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2)); + else if (! sexp_charp(_ARG3)) + sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_string_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_STRING_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); + break; + case SEXP_OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; + _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case SEXP_OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; + if (! sexp_fixnump(_ARG1)) + sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); + _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_MAKE_EXCEPTION: + _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + break; + case SEXP_OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case SEXP_OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case SEXP_OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case SEXP_OP_FIXNUMP: + _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; + case SEXP_OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case SEXP_OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case SEXP_OP_TYPEP: + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_MAKE: + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_REF: + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_SET: + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); + sexp_slot_set(_ARG1, _UWORD1, _ARG2); + _ARG2 = SEXP_VOID; + ip += sizeof(sexp)*2; + top--; + break; + case SEXP_OP_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case SEXP_OP_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case SEXP_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 SEXP_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 SEXP_OP_CONS: + sexp_context_top(ctx) = top; + _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_ADD: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(j); + } + else + _ARG2 = sexp_add(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_add(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) + sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_SUB: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(j); + } + else + _ARG2 = sexp_sub(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_sub(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) - sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_MUL: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); + if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(prod); + } + else + _ARG2 = sexp_mul(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_mul(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) * sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_DIV: + if (_ARG2 == SEXP_ZERO) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) + _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { +#if SEXP_USE_FLONUMS + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); + _ARG2 = sexp_fixnum_to_flonum(ctx, _ARG2); + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + if (sexp_flonum_value(_ARG2) == trunc(sexp_flonum_value(_ARG2))) + _ARG2 = sexp_make_fixnum(sexp_flonum_value(_ARG2)); +#else + _ARG2 = sexp_fx_div(_ARG1, _ARG2); +#endif + } +#if SEXP_USE_BIGNUMS + else + _ARG2 = sexp_div(ctx, _ARG1, _ARG2); +#else +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) / sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_QUOTIENT: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG2 = sexp_fx_div(_ARG1, _ARG2); + top--; + } +#if SEXP_USE_BIGNUMS + else { + _ARG2 = sexp_quotient(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case SEXP_OP_REMAINDER: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + tmp1 = sexp_fx_rem(_ARG1, _ARG2); + top--; + _ARG1 = tmp1; + } +#if SEXP_USE_BIGNUMS + else { + _ARG2 = sexp_remainder(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case SEXP_OP_NEGATIVE: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_make_fixnum(-sexp_unbox_fixnum(_ARG1)); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) { + _ARG1 = sexp_copy_bignum(ctx, NULL, _ARG1, 0); + sexp_bignum_sign(_ARG1) = -sexp_bignum_sign(_ARG1); + } +#endif +#if SEXP_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 SEXP_OP_INVERSE: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, 1/(double)sexp_unbox_fixnum(_ARG1)); +#if SEXP_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 SEXP_OP_LT: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) < 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) < sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_LE: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) <= 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) <= sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_EQN: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = _ARG1 == _ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) == 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) == sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case SEXP_OP_FIX2FLO: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); +#endif + else if (! sexp_flonump(_ARG1)) + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case SEXP_OP_FLO2FIX: + if (sexp_flonump(_ARG1)) { + if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { + sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_BIGNUMS + } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { + _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); +#endif + } else { + _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); + } + } else if (! sexp_fixnump(_ARG1) && ! sexp_bignump(_ARG1)) { + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + } + break; + case SEXP_OP_CHAR2INT: + if (! sexp_charp(_ARG1)) + sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); + break; + case SEXP_OP_INT2CHAR: + if (! sexp_fixnump(_ARG1)) + sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); + break; + case SEXP_OP_CHAR_UPCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_CHAR_DOWNCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_WRITE_CHAR: + if (! sexp_charp(_ARG1)) + sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_NEWLINE: + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case SEXP_OP_READ_CHAR: + i = sexp_read_char(ctx, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_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 SEXP_OP_RET: + i = sexp_unbox_fixnum(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_fixnum(stack[fp+1]); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_fixnum(stack[fp+3]); + break; + case SEXP_OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); + } + goto loop; + + end_loop: + sexp_gc_release3(ctx); + 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_stream(port)) + fclose(sexp_port_stream(port)); +#if ! SEXP_USE_STRING_STREAMS + if (sexp_port_buf(port) && sexp_oportp(port)) + free(sexp_port_buf(port)); +#endif + 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); + } +} + +#if SEXP_USE_DL +sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); + if (! handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = dlsym(handle, "sexp_init_library"); + if (! init) { + dlclose(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx, env); +} +#endif + +sexp sexp_load (sexp ctx, sexp source, sexp env) { +#if SEXP_USE_DL + char *suffix; +#endif + sexp tmp, out=SEXP_FALSE; + sexp_gc_var4(ctx2, x, in, res); + if (! sexp_stringp(source)) + return sexp_type_exception(ctx, "not a string", source); + if (! sexp_envp(env)) + return sexp_type_exception(ctx, "not an environment", env); +#if SEXP_USE_DL + suffix = sexp_string_data(source) + + sexp_string_length(source) - strlen(sexp_so_extension); + if (strcmp(suffix, sexp_so_extension) == 0) { + res = sexp_load_dl(ctx, source, env); + } else { +#endif + sexp_gc_preserve4(ctx, ctx2, x, in, res); + res = SEXP_VOID; + in = sexp_open_input_file(ctx, source); + out = sexp_current_error_port(ctx); + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0); + sexp_context_parent(ctx2) = ctx; + tmp = sexp_env_bindings(env); + sexp_context_tailp(ctx2) = 0; + if (sexp_exceptionp(in)) { + if (sexp_not(out)) out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) + 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, env); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); + } + sexp_gc_release4(ctx); +#if SEXP_USE_DL + } +#endif +#if SEXP_USE_WARN_UNDEFS + if (sexp_oportp(out) && ! sexp_exceptionp(res)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out); +#endif + return res; +} + +#if SEXP_USE_MATH + +#if SEXP_USE_BIGNUMS +#define maybe_convert_bignum(z) \ + else if (sexp_bignump(z)) d = sexp_bignum_to_double(z); +#else +#define maybe_convert_bignum(z) +#endif + +#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_fixnump(z)) \ + d = (double)sexp_unbox_fixnum(z); \ + maybe_convert_bignum(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_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +static sexp sexp_sqrt (sexp ctx, sexp z) { + double d, r; + if (sexp_flonump(z)) + d = sexp_flonum_value(z); + else if (sexp_fixnump(z)) + d = (double)sexp_unbox_fixnum(z); + maybe_convert_bignum(z) /* XXXX add bignum sqrt */ + else + return sexp_type_exception(ctx, "not a number", z); + r = sqrt(d); + if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) + return sexp_make_fixnum(round(r)); + else + return sexp_make_flonum(ctx, r); +} + +#endif + +static sexp sexp_expt (sexp ctx, sexp x, sexp e) { + long double f, x1, e1; + sexp res; +#if SEXP_USE_BIGNUMS + if (sexp_bignump(e)) { /* bignum exponent needs special handling */ + if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) + res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ + else if (x == SEXP_ONE) + res = SEXP_ONE; /* 1.0 */ + else if (sexp_flonump(x)) + res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); + else + res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */ + } else if (sexp_bignump(x)) { + res = sexp_bignum_expt(ctx, x, e); + } else { +#endif + if (sexp_fixnump(x)) + x1 = sexp_unbox_fixnum(x); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception(ctx, "expt: not a number", x); + if (sexp_fixnump(e)) + e1 = sexp_unbox_fixnum(e); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception(ctx, "expt: not a number", e); + f = pow(x1, e1); + if ((f > SEXP_MAX_FIXNUM) || (f < SEXP_MIN_FIXNUM) +#if SEXP_USE_FLONUMS + || (! sexp_fixnump(x)) || (! sexp_fixnump(e)) +#endif + ) { +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(x) && sexp_fixnump(e)) + res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); + else +#endif +#if SEXP_USE_FLONUMS + res = sexp_make_flonum(ctx, f); +#else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#endif + } else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#if SEXP_USE_BIGNUMS + } +#endif + 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)) + 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 = ((len1= SEXP_OPC_NUM_OP_CLASSES)) + res = sexp_type_exception(ctx, "make-opcode: bad opcode class", op_class); + else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) + || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) + res = sexp_type_exception(ctx, "make-opcode: bad opcode", code); + else if (! sexp_fixnump(num_args)) + res = sexp_type_exception(ctx, "make-opcode: bad num_args", num_args); + else if (! sexp_fixnump(flags)) + res = sexp_type_exception(ctx, "make-opcode: bad flags", flags); + else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_arg1_type(res) = sexp_unbox_fixnum(arg1t); + sexp_opcode_arg2_type(res) = sexp_unbox_fixnum(arg2t); + sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_data(res) = data; + sexp_opcode_data2(res) = data2; + sexp_opcode_func(res) = func; + sexp_opcode_name(res) = strdup(sexp_string_data(name)); + } + return res; +} + +sexp sexp_make_foreign (sexp ctx, char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res; + if (num_args > 6) { + res = sexp_type_exception(ctx, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); + } else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; + sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1; + if (flags & 1) num_args--; + sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; + sexp_opcode_name(res) = name; + sexp_opcode_data(res) = data; + sexp_opcode_func(res) = f; + } + return res; +} + +sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp_gc_var1(op); + sexp_gc_preserve1(ctx, op); + sexp res = SEXP_VOID; + op = sexp_make_foreign(ctx, name, num_args, flags, f, data); + if (sexp_exceptionp(op)) + res = op; + else + sexp_env_define(ctx, env, sexp_intern(ctx, name), op); + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_TYPE_DEFS + +sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { + if (! sexp_fixnump(type)) + return sexp_type_exception(ctx, "make-type-predicate: bad type", type); + return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), + sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); +} + +sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { + sexp_uint_t type_size; + if (! sexp_fixnump(type)) + return sexp_type_exception(ctx, "make-constructor: bad type", type); + type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); + return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), + sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, + sexp_make_fixnum(type_size), NULL); +} + +sexp sexp_make_accessor (sexp ctx, sexp name, sexp type, sexp index, sexp code) { + if (! sexp_fixnump(type)) + return sexp_type_exception(ctx, "make-accessor: bad type", type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, "make-accessor: bad index", index); + return + sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_ACCESSOR), code, + sexp_make_fixnum(sexp_unbox_fixnum(code)==SEXP_OP_SLOT_REF?1:2), + SEXP_ZERO, type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(SEXP_OP_SLOT_REF)); +} +sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index) { + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(SEXP_OP_SLOT_SET)); +} + +#endif + +/*********************** standard environment *************************/ + +static struct sexp_struct core_forms[] = { + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE, "define"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SET, "set!"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LAMBDA, "lambda"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_IF, "if"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_BEGIN, "begin"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_QUOTE, "quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LET_SYNTAX, "let-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}}}, +}; + +sexp sexp_make_env (sexp ctx) { + 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; + return e; +} + +sexp sexp_make_null_env (sexp ctx, sexp version) { + sexp_uint_t i; + sexp e = sexp_make_env(ctx); + for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i])), + sexp_copy_core(ctx, &core_forms[i])); + return e; +} + +sexp sexp_make_primitive_env (sexp ctx, sexp version) { + int i; + sexp_gc_var3(e, op, sym); + sexp_gc_preserve3(ctx, e, op, sym); + e = sexp_make_null_env(ctx, version); + for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { + op = sexp_copy_opcode(ctx, &opcodes[i]); + if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op)); + sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); + } + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); + } + sexp_gc_release3(ctx); + return e; +} + +sexp sexp_find_module_file (sexp ctx, char *file) { + sexp res=SEXP_FALSE, ls; + char *dir, *path; + sexp_uint_t slash, dirlen, filelen, len; +#ifdef PLAN9 +#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0) + unsigned char buf[128]; +#else +#define file_exists_p(path, buf) (! stat(path, buf)) + struct stat buf_str; + struct stat *buf = &buf_str; +#endif + + filelen = strlen(file); + + ls = sexp_global(ctx, SEXP_G_MODULE_PATH); + for ( ; sexp_pairp(ls) && sexp_not(res); ls=sexp_cdr(ls)) { + dir = sexp_string_data(sexp_car(ls)); + dirlen = sexp_string_length(sexp_car(ls)); + slash = dir[dirlen-1] == '/'; + len = dirlen+filelen+2-slash; + path = (char*) malloc(len); + memcpy(path, dir, dirlen); + if (! slash) path[dirlen] = '/'; + memcpy(path+len-filelen-1, file, filelen); + path[len-1] = '\0'; + if (file_exists_p(path, buf)) + res = sexp_c_string(ctx, path, len-1); + free(path); + } + + return res; +} + +#define sexp_file_not_found "couldn't find file in module path" + +sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { + sexp res; + sexp_gc_var1(path); + sexp_gc_preserve1(ctx, path); + path = sexp_find_module_file(ctx, file); + if (sexp_stringp(path)) { + res = sexp_load(ctx, path, env); + } else { + path = sexp_c_string(ctx, file, -1); + res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path); + } + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_MODULES +static sexp sexp_find_module_file_op (sexp ctx, sexp file) { + if (! sexp_stringp(file)) + return sexp_type_exception(ctx, "not a string", file); + else + return sexp_find_module_file(ctx, sexp_string_data(file)); +} +sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env) { + if (! sexp_stringp(file)) + return sexp_type_exception(ctx, "not a string", file); + else if (! sexp_envp(env)) + return sexp_type_exception(ctx, "not an environment", env); + return sexp_load_module_file(ctx, sexp_string_data(file), env); +} +#endif + +sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp) { + sexp ls; + if (! sexp_stringp(dir)) + return sexp_type_exception(ctx, "not a string", dir); + if (sexp_truep(appendp)) { + if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { + for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) + ; + sexp_cdr(ls) = sexp_list1(ctx, dir); + } else { + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir); + } + } else { + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir); + } + return SEXP_VOID; +} + +sexp sexp_load_standard_parameters (sexp ctx, sexp e) { + /* add io port and interaction env parameters */ + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), + sexp_make_input_port(ctx, stdin, SEXP_FALSE)); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + sexp_make_output_port(ctx, stdout, SEXP_FALSE)); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), + sexp_make_output_port(ctx, stderr, SEXP_FALSE)); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); + return SEXP_VOID; +} + +sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { + sexp_gc_var3(op, tmp, sym); + sexp_gc_preserve3(ctx, op, tmp, sym); + sexp_load_standard_parameters(ctx, e); +#if SEXP_USE_DL + sexp_env_define(ctx, e, sexp_intern(ctx, "*shared-object-extension*"), + sexp_c_string(ctx, sexp_so_extension, -1)); +#endif + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform)); + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp); + sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; +#if SEXP_USE_SIMPLIFY + op = sexp_make_foreign(ctx, "simplify", 1, 0, + (sexp_proc1)sexp_simplify, SEXP_VOID); + tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); +#endif + /* load init.scm */ + tmp = sexp_load_module_file(ctx, sexp_init_file, e); + /* load and bind config env */ +#if SEXP_USE_MODULES + if (! sexp_exceptionp(tmp)) { + sym = sexp_intern(ctx, "*config-env*"); + if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { + tmp = sexp_make_env(ctx); + if (! sexp_exceptionp(tmp)) { + sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; + sexp_env_parent(tmp) = e; + op = sexp_load_module_file(ctx, sexp_config_file, tmp); + if (sexp_exceptionp(op)) + sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); + sexp_env_define(ctx, tmp, sym, tmp); + } + } + sexp_env_define(ctx, e, sym, tmp); + } +#endif + sexp_gc_release3(ctx); + return sexp_exceptionp(tmp) ? tmp : e; +} + +sexp sexp_make_standard_env (sexp ctx, sexp version) { + sexp_gc_var1(env); + sexp_gc_preserve1(ctx, env); + env = sexp_make_primitive_env(ctx, version); + if (! sexp_exceptionp(env)) sexp_load_standard_env(ctx, env, version); + sexp_gc_release1(ctx); + return env; +} + +sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls, sexp immutp) { + sexp oldname, newname, value, out; + if (! sexp_envp(to)) to = sexp_context_env(ctx); + if (! sexp_envp(from)) from = sexp_context_env(ctx); + if (sexp_not(ls)) { + if (sexp_truep(immutp)) { + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_parent(to) = value; + sexp_immutablep(value) = 1; + sexp_env_bindings(value) = sexp_env_bindings(from); + } else { + for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls)); + } + } else { + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (sexp_pairp(sexp_car(ls))) { + newname = sexp_caar(ls); oldname = sexp_cdar(ls); + } else { + newname = oldname = sexp_car(ls); + } + value = sexp_env_ref(from, oldname, SEXP_UNDEF); + if (value != SEXP_UNDEF) { + sexp_env_define(ctx, to, newname, value); +#if SEXP_USE_WARN_UNDEFS + } else if (sexp_oportp(out=sexp_current_error_port(ctx))) { + sexp_write_string(ctx, "WARNING: importing undefined variable: ", out); + sexp_write(ctx, oldname, out); + sexp_write_char(ctx, '\n', out); +#endif + } + } + } + return SEXP_VOID; +} + +/************************** eval interface ****************************/ + +sexp sexp_apply (sexp ctx, sexp proc, sexp args) { + sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx), len, offset; + len = sexp_unbox_fixnum(sexp_length(ctx, args)); + if (sexp_opcodep(proc)) + proc = make_opcode_procedure(ctx, proc, len); + if (! sexp_procedurep(proc)) { + res = sexp_exceptionp(proc) ? proc : + sexp_type_exception(ctx, "apply: not a procedure", proc); + } else { + offset = top + len; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) + stack[--offset] = sexp_car(ls); + stack[top] = sexp_make_fixnum(len); + top++; + stack[top++] = SEXP_ZERO; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + stack[top++] = SEXP_ZERO; + sexp_context_top(ctx) = top; + res = sexp_vm(ctx, proc); + if (! res) res = SEXP_VOID; + } + return res; +} + +sexp sexp_compile (sexp ctx, sexp x) { + sexp_gc_var3(ast, vec, res); + sexp_gc_preserve3(ctx, ast, vec, res); + ast = sexp_analyze(ctx, x); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(res); res=sexp_cdr(res)) + ast = sexp_apply_optimization(ctx, sexp_cdar(res), ast); + free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + generate(ctx, ast); + res = finalize_bytecode(ctx); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec); + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_eval (sexp ctx, sexp obj, sexp env) { + sexp_sint_t top; + sexp ctx2; + sexp_gc_var2(res, err_handler); + sexp_gc_preserve2(ctx, res, err_handler); + top = sexp_context_top(ctx); + err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = SEXP_FALSE; + ctx2 = sexp_make_eval_context(ctx, + sexp_context_stack(ctx), + (env ? env : sexp_context_env(ctx)), + 0); + res = sexp_compile(ctx2, obj); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; + sexp_context_top(ctx) = top; + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_eval_string (sexp ctx, char *str, sexp env) { + sexp res; + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); + obj = sexp_read_from_string(ctx, str); + res = sexp_eval(ctx, obj, env); + sexp_gc_release1(ctx); + return res; +} + +void sexp_scheme_init (void) { + if (! scheme_initialized_p) { + scheme_initialized_p = 1; + sexp_init(); + } +} diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..1130c15b --- /dev/null +++ b/gc.c @@ -0,0 +1,249 @@ +/* gc.c -- simple mark&sweep garbage collector */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* These settings are configurable but only recommended for */ +/* experienced users, so they're not in config.h. */ + +/* the initial heap size in bytes */ +#ifndef SEXP_INITIAL_HEAP_SIZE +#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) +#endif + +/* the maximum heap size in bytes - if 0 there is no limit */ +#ifndef SEXP_MAXIMUM_HEAP_SIZE +#define SEXP_MAXIMUM_HEAP_SIZE 0 +#endif +#ifndef SEXP_MINIMUM_HEAP_SIZE +#define SEXP_MINIMUM_HEAP_SIZE 512*1024 +#endif + +/* if after GC more than this percentage of memory is still in use, */ +/* and we've not exceeded the maximum size, grow the heap */ +#ifndef SEXP_GROW_HEAP_RATIO +#define SEXP_GROW_HEAP_RATIO 0.75 +#endif + +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair)) + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +#if SEXP_USE_GLOBAL_HEAP +sexp_heap sexp_global_heap; +#endif + +#if SEXP_USE_DEBUG_GC +static sexp* stack_base; +#endif + +static sexp_heap sexp_heap_last (sexp_heap h) { + while (h->next) h = h->next; + return h; +} + +sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) { + sexp_uint_t res; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) + return sexp_heap_align(1); + t = sexp_object_type(ctx, x); + res = sexp_type_size_of_object(t, x); + return res; +} + +void sexp_mark (sexp ctx, sexp x) { + 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(ctx, *(saves->var)); + t = sexp_object_type(ctx, x); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len = sexp_type_num_slots_of_object(t, x) - 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(ctx, p)); + if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + /* free p */ + finalizer = sexp_type_finalize(sexp_object_type(ctx, p)); + if (finalizer) finalizer(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_fixnum(max_freed); +} + +sexp sexp_gc (sexp ctx, size_t *sum_freed) { + sexp res; +#if SEXP_USE_GLOBAL_SYMBOLS + int i; + 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(sexp_context_heap(ctx)); + 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=sexp_context_heap(ctx); 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_fixnum(sexp_gc(ctx, &sum_freed)); + h = sexp_heap_last(sexp_context_heap(ctx)); + if (((max_freed < size) + || ((h->size - sum_freed) > (h->size*SEXP_GROW_HEAP_RATIO))) + && ((! SEXP_MAXIMUM_HEAP_SIZE) || (h->size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); + if (! res) + res = sexp_global(ctx, SEXP_G_OOM_ERROR); + } + return res; +} + +void sexp_gc_init (void) { +#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_DEBUG_GC + sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); +#endif +#if SEXP_USE_GLOBAL_HEAP + sexp_global_heap = sexp_make_heap(size); +#endif +#if SEXP_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/bignum.h b/include/chibi/bignum.h new file mode 100644 index 00000000..580b0a7d --- /dev/null +++ b/include/chibi/bignum.h @@ -0,0 +1,43 @@ +/* bignum.h -- header for bignum utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_BIGNUM_H +#define SEXP_BIGNUM_H + +#if (SEXP_64_BIT) +typedef unsigned int uint128_t __attribute__((mode(TI))); +typedef int sint128_t __attribute__((mode(TI))); +typedef uint128_t sexp_luint_t; +typedef sint128_t sexp_lsint_t; +#else +typedef unsigned long long sexp_luint_t; +typedef long long sexp_lsint_t; +#endif + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b); +sexp sexp_compare (sexp ctx, sexp a, sexp b); +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len); +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len); +sexp sexp_bignum_normalize (sexp a); +sexp_uint_t sexp_bignum_hi (sexp a); +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a); +double sexp_bignum_to_double (sexp a); +sexp sexp_double_to_bignum (sexp ctx, double f); +sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b); +sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset); +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset); +sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_div (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_expt (sexp ctx, sexp n, sexp e); +sexp sexp_add (sexp ctx, sexp a, sexp b); +sexp sexp_sub (sexp ctx, sexp a, sexp b); +sexp sexp_mul (sexp ctx, sexp a, sexp b); +sexp sexp_div (sexp ctx, sexp a, sexp b); +sexp sexp_quotient (sexp ctx, sexp a, sexp b); +sexp sexp_remainder (sexp ctx, sexp a, sexp b); + +#endif /* ! SEXP_BIGNUM_H */ + diff --git a/include/chibi/config.h b/include/chibi/config.h new file mode 100644 index 00000000..a3301d22 --- /dev/null +++ b/include/chibi/config.h @@ -0,0 +1,297 @@ +/* config.h -- general configuration */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +/* uncomment this to disable most features */ +/* Most features are enabled by default, but setting this */ +/* option will disable any not explicitly enabled. */ +/* #define SEXP_USE_NO_FEATURES 1 */ + +/* uncomment this to disable the module system */ +/* Currently this just loads the config.scm from main and */ +/* sets up an (import (module name)) macro. */ +/* #define SEXP_USE_MODULES 0 */ + +/* uncomment this to disable dynamic loading */ +/* If enabled, you can LOAD .so files with a */ +/* sexp_init_library(ctx, env) function provided. */ +/* #define SEXP_USE_DL 0 */ + +/* uncomment this to disable a simplifying optimization pass */ +/* This performs some simple optimizations such as dead-code */ +/* elimination, constant-folding, and directly propagating */ +/* non-mutated let values bound to constants or non-mutated */ +/* references. More than performance, this is aimed at reducing the */ +/* size of the compiled code, especially as the result of macro */ +/* expansions, so it's a good idea to leave it enabled. */ +/* #define SEXP_USE_SIMPLIFY 0 */ + +/* uncomment this to disable dynamic type definitions */ +/* This enables register-simple-type and related */ +/* opcodes for defining types, needed by the default */ +/* implementation of (srfi 9). */ +/* #define SEXP_USE_TYPE_DEFS 0 */ + +/* uncomment this to use the Boehm conservative GC */ +/* Conservative GCs make it easier to write extensions, */ +/* since you don't have to keep track of intermediate */ +/* variables, but can leak memory. Boehm is also a */ +/* very large library to link in. You may want to */ +/* enable this when debugging your own extensions, or */ +/* if you suspect a bug in the native GC. */ +/* #define SEXP_USE_BOEHM 1 */ + +/* uncomment this to just malloc manually instead of any GC */ +/* Mostly for debugging purposes, this is the no GC option. */ +/* You can use just the read/write API and */ +/* explicitly free sexps, though. */ +/* #define SEXP_USE_MALLOC 1 */ + +/* uncomment this to add conservative checks to the native GC */ +/* Please mail the author if enabling this makes a bug */ +/* go away and you're not working on your own C extension. */ +/* #define SEXP_USE_DEBUG_GC 1 */ + +/* uncomment this to make the heap common to all contexts */ +/* By default separate contexts can have separate heaps, */ +/* and are thus thread-safe and independant. */ +/* #define SEXP_USE_GLOBAL_HEAP 1 */ + +/* uncomment this to make type definitions common to all contexts */ +/* By default types are only global if you don't allow user type */ +/* definitions, so new types will be local to a given set of */ +/* contexts sharing thei heap. */ +/* #define SEXP_USE_GLOBAL_TYPES 1 */ + +/* uncomment this to make the symbol table common to all contexts */ +/* Will still be restricted to all contexts sharing the same */ +/* heap, of course. */ +/* #define SEXP_USE_GLOBAL_SYMBOLS 1 */ + +/* uncomment this if you don't need flonum support */ +/* This is only for EVAL - you'll still be able to read */ +/* and write flonums directly through the sexp API. */ +/* #define SEXP_USE_FLONUMS 0 */ + +/* uncomment this to disable reading/writing IEEE infinities */ +/* By default you can read/write +inf.0, -inf.0 and +nan.0 */ +/* #define SEXP_USE_INFINITIES 0 */ + +/* uncomment this if you want immediate flonums */ +/* This is experimental, enable at your own risk. */ +/* #define SEXP_USE_IMMEDIATE_FLONUMS 1 */ + +/* uncomment this if you don't want bignum support */ +/* Bignums are implemented with a small, custom library */ +/* in opt/bignum.c. */ +/* #define SEXP_USE_BIGNUMS 0 */ + +/* uncomment this if you don't need extended math operations */ +/* This includes the trigonometric and expt functions. */ +/* Automatically disabled if you've disabled flonums. */ +/* #define SEXP_USE_MATH 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* This is something of a hack, but can be quite useful. */ +/* It's very fast and doesn't involve any separate analysis */ +/* passes. */ +/* #define SEXP_USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* By default (this may change) small symbols are represented */ +/* as immediates using a simple huffman encoding. This keeps */ +/* the symbol table small, and minimizes hashing when doing a */ +/* lot of reading. */ +/* #define SEXP_USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* You can trade off some space in exchange for longer read */ +/* times by disabling hashing and just putting all */ +/* non-immediate symbols in a single list. */ +/* #define SEXP_USE_HASH_SYMS 0 */ + +/* uncomment this to disable string ports */ +/* If disabled some basic functionality such as number->string */ +/* will not be available by default. */ +/* #define SEXP_USE_STRING_STREAMS 0 */ + +/* uncomment this to disable automatic closing of ports */ +/* If enabled, the underlying FILE* for file ports will be */ +/* automatically closed when they're garbage collected. Doesn't */ +/* apply to stdin/stdout/stderr. */ +/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */ + +/* uncomment this to use the normal 1970 unix epoch */ +/* By default chibi uses an datetime epoch starting at */ +/* 2010/01/01 00:00:00 in order to be able to represent */ +/* more common times as fixnums. */ +/* #define SEXP_USE_2010_EPOCH 0 */ + +/* uncomment this to disable stack overflow checks */ +/* By default stacks are fairly small, so it's good to leave */ +/* this enabled. */ +/* #define SEXP_USE_CHECK_STACK 0 */ + +/* #define SEXP_USE_DEBUG_VM 0 */ +/* Experts only. */ +/* For *very* verbose output on every VM operation. */ + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#ifndef SEXP_64_BIT +#if defined(__amd64) || defined(__x86_64) +#define SEXP_64_BIT 1 +#else +#define SEXP_64_BIT 0 +#endif +#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 SEXP_USE_NO_FEATURES +#define SEXP_USE_NO_FEATURES 0 +#endif + +#ifndef SEXP_USE_MODULES +#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_TYPE_DEFS +#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_MAXIMUM_TYPES +#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1) +#endif + +#ifndef SEXP_USE_DL +#ifdef PLAN9 +#define SEXP_USE_DL 0 +#else +#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 0 +#endif + +#ifndef SEXP_USE_MALLOC +#define SEXP_USE_MALLOC 0 +#endif + +#ifndef SEXP_USE_DEBUG_GC +#define SEXP_USE_DEBUG_GC 0 +#endif + +#ifndef SEXP_USE_GLOBAL_HEAP +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_HEAP 1 +#else +#define SEXP_USE_GLOBAL_HEAP 0 +#endif +#endif + +#ifndef SEXP_USE_GLOBAL_TYPES +#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS) +#endif + +#ifndef SEXP_USE_GLOBAL_SYMBOLS +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_SYMBOLS 1 +#else +#define SEXP_USE_GLOBAL_SYMBOLS 0 +#endif +#endif + +#ifndef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_INFINITIES +#if defined(PLAN9) || ! SEXP_USE_FLONUMS +#define SEXP_USE_INFINITIES 0 +#else +#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_IMMEDIATE_FLONUMS +#define SEXP_USE_IMMEDIATE_FLONUMS 0 +#endif + +#ifndef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MATH +#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_WARN_UNDEFS +#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HUFF_SYMS +#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HASH_SYMS +#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_DEBUG_VM +#define SEXP_USE_DEBUG_VM 0 +#endif + +#ifndef SEXP_USE_STRING_STREAMS +#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_AUTOCLOSE_PORTS +#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_2010_EPOCH +#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_EPOCH_OFFSET +#if SEXP_USE_2010_EPOCH +#define SEXP_EPOCH_OFFSET 1262271600 +#else +#define SEXP_EPOCH_OFFSET 0 +#endif +#endif + +#ifndef SEXP_USE_CHECK_STACK +#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES +#endif + +#ifdef PLAN9 +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#endif + +#ifdef __MINGW32__ +#ifdef BUILDING_DLL +#define SEXP_API __declspec(dllexport) +#else +#define SEXP_API __declspec(dllimport) +#endif +#else +#define SEXP_API +#endif diff --git a/include/chibi/eval.h b/include/chibi/eval.h new file mode 100644 index 00000000..60201c61 --- /dev/null +++ b/include/chibi/eval.h @@ -0,0 +1,163 @@ +/* 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 SEXP_INIT_BCODE_SIZE 128 +#define SEXP_INIT_STACK_SIZE 8192 + +#define sexp_init_file "init.scm" +#define sexp_config_file "config.scm" + +enum sexp_core_form_names { + SEXP_CORE_DEFINE = 1, + SEXP_CORE_SET, + SEXP_CORE_LAMBDA, + SEXP_CORE_IF, + SEXP_CORE_BEGIN, + SEXP_CORE_QUOTE, + SEXP_CORE_SYNTAX_QUOTE, + SEXP_CORE_DEFINE_SYNTAX, + SEXP_CORE_LET_SYNTAX, + SEXP_CORE_LETREC_SYNTAX +}; + +enum sexp_opcode_classes { + SEXP_OPC_GENERIC = 1, + SEXP_OPC_TYPE_PREDICATE, + SEXP_OPC_PREDICATE, + SEXP_OPC_ARITHMETIC, + SEXP_OPC_ARITHMETIC_INV, + SEXP_OPC_ARITHMETIC_CMP, + SEXP_OPC_IO, + SEXP_OPC_CONSTRUCTOR, + SEXP_OPC_ACCESSOR, + SEXP_OPC_PARAMETER, + SEXP_OPC_FOREIGN, + SEXP_OPC_NUM_OP_CLASSES +}; + +enum sexp_opcode_names { + SEXP_OP_NOOP, + SEXP_OP_RAISE, + SEXP_OP_RESUMECC, + SEXP_OP_CALLCC, + SEXP_OP_APPLY1, + SEXP_OP_TAIL_CALL, + SEXP_OP_CALL, + SEXP_OP_FCALL0, + SEXP_OP_FCALL1, + SEXP_OP_FCALL2, + SEXP_OP_FCALL3, + SEXP_OP_FCALL4, + SEXP_OP_FCALL5, + SEXP_OP_FCALL6, + SEXP_OP_JUMP_UNLESS, + SEXP_OP_JUMP, + SEXP_OP_PUSH, + SEXP_OP_DROP, + SEXP_OP_GLOBAL_REF, + SEXP_OP_GLOBAL_KNOWN_REF, + SEXP_OP_STACK_REF, + SEXP_OP_LOCAL_REF, + SEXP_OP_LOCAL_SET, + SEXP_OP_CLOSURE_REF, + SEXP_OP_VECTOR_REF, + SEXP_OP_VECTOR_SET, + SEXP_OP_VECTOR_LENGTH, + SEXP_OP_STRING_REF, + SEXP_OP_STRING_SET, + SEXP_OP_STRING_LENGTH, + SEXP_OP_MAKE_PROCEDURE, + SEXP_OP_MAKE_VECTOR, + SEXP_OP_MAKE_EXCEPTION, + SEXP_OP_AND, + SEXP_OP_NULLP, + SEXP_OP_FIXNUMP, + SEXP_OP_SYMBOLP, + SEXP_OP_CHARP, + SEXP_OP_EOFP, + SEXP_OP_TYPEP, + SEXP_OP_MAKE, + SEXP_OP_SLOT_REF, + SEXP_OP_SLOT_SET, + SEXP_OP_CAR, + SEXP_OP_CDR, + SEXP_OP_SET_CAR, + SEXP_OP_SET_CDR, + SEXP_OP_CONS, + SEXP_OP_ADD, + SEXP_OP_SUB, + SEXP_OP_MUL, + SEXP_OP_DIV, + SEXP_OP_QUOTIENT, + SEXP_OP_REMAINDER, + SEXP_OP_NEGATIVE, + SEXP_OP_INVERSE, + SEXP_OP_LT, + SEXP_OP_LE, + SEXP_OP_EQN, + SEXP_OP_EQ, + SEXP_OP_FIX2FLO, + SEXP_OP_FLO2FIX, + SEXP_OP_CHAR2INT, + SEXP_OP_INT2CHAR, + SEXP_OP_CHAR_UPCASE, + SEXP_OP_CHAR_DOWNCASE, + SEXP_OP_WRITE_CHAR, + SEXP_OP_NEWLINE, + SEXP_OP_READ_CHAR, + SEXP_OP_PEEK_CHAR, + SEXP_OP_RET, + SEXP_OP_DONE, + SEXP_OP_NUM_OPCODES +}; + +/**************************** prototypes ******************************/ + +SEXP_API void sexp_scheme_init (void); +SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size); +SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); +SEXP_API sexp sexp_analyze (sexp context, sexp x); +SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); +SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); +SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); +SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); +SEXP_API sexp sexp_make_env (sexp context); +SEXP_API sexp sexp_make_null_env (sexp context, sexp version); +SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version); +SEXP_API sexp sexp_make_standard_env (sexp context, sexp version); +SEXP_API sexp sexp_load_standard_parameters (sexp context, sexp env); +SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version); +SEXP_API sexp sexp_find_module_file (sexp ctx, char *file); +SEXP_API sexp sexp_load_module_file (sexp ctx, char *file, sexp env); +SEXP_API sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp); +SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); +SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls, sexp immutp); +SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val); +SEXP_API sexp sexp_env_cell (sexp env, sexp sym); +SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); +SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); +SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); +SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); +SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data); +SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, int flags, sexp_proc1 f, sexp data); + +#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL) +#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d) + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); +SEXP_API sexp sexp_make_constructor (sexp ctx, sexp name, sexp type); +SEXP_API sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index); +SEXP_API sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index); +#endif + +#endif /* ! SEXP_EVAL_H */ + diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h new file mode 100644 index 00000000..72fbe564 --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,860 @@ +/* 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 + +#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" + +#include "chibi/config.h" +#include "chibi/install.h" + +#include +#include + +#if SEXP_USE_DL +#include +#endif + +#ifdef PLAN9 +#include +#include +#include +#include +#include <9p.h> +typedef unsigned long size_t; +#else +#include +#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 + +#if SEXP_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_CPOINTER, + 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_CORE_TYPES +}; + +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +#if SEXP_64_BIT +typedef unsigned int sexp_tag_t; +#else +typedef unsigned short sexp_tag_t; +#endif +typedef struct sexp_struct *sexp; + +#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2)) +#define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type)) +#define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type)) + +#define SEXP_UINT_T_MAX ((sexp_uint_t)-1) +#define SEXP_UINT_T_MIN (0) +#define SEXP_SINT_T_MAX __MAX_SIGNED(sexp_sint_t) +#define SEXP_SINT_T_MIN __MIN_SIGNED(sexp_sint_t) + +#define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1) +#define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1) + +/* procedure types */ +typedef sexp (*sexp_proc0) (void); +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 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 free_list; + sexp_heap next; + char *data; +}; + +struct sexp_gc_var_t { + sexp *var; + /* char *name; */ + struct sexp_gc_var_t *next; +}; + +struct sexp_struct { + sexp_tag_t tag; + char gc_mark; + unsigned int immutablep:1; + unsigned int freep:1; + union { + /* basic types */ + double flonum; + struct { + sexp_tag_t tag; + short field_base, field_eq_len_base, field_len_base, field_len_off; + unsigned short field_len_scale; + short size_base, size_off; + unsigned short size_scale; + char *name; + sexp_proc2 finalize; + } 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; + char openp, sourcep; + sexp_uint_t offset, line; + size_t size; + 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; + struct { + sexp_uint_t length; + void *value; + sexp parent; + char body[]; + } cpointer; + /* runtime types */ + struct { + unsigned int syntacticp:1; + 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, data2, proc; + sexp_proc1 func; + } opcode; + struct { + char code; + char *name; + } core; + /* ast types */ + struct { + sexp name, params, body, defs, locals, flags, 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_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp_heap heap; + struct sexp_gc_var_t *saves; + sexp_uint_t pos, depth, tailp, tracep; + sexp bc, lambda, stack, env, fv, parent, globals; + } 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_offsetof_slot0 (offsetof(struct sexp_struct, value)) + +#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double)) + +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) +#define sexp_alloc_bytecode(ctx, i) sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE) + +#if SEXP_USE_BIGNUMS +#include "chibi/bignum.h" +#endif + +/***************************** 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_fixnump(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_flags(x) ((x)->flags) +#define sexp_immutablep(x) ((x)->immutablep) +#define sexp_freep(x) ((x)->freep) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) +#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) + +#if SEXP_USE_IMMEDIATE_FLONUMS +union sexp_flonum_conv { + float flonum; + unsigned int bits; +}; +#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x); +#if SEXP_64_BIT +SEXP_API float sexp_flonum_value (sexp x); +SEXP_API sexp sexp_make_flonum(sexp ctx, float f); +#else +#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)(((unsigned int)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) +#endif +#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_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) +#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER)) +#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)) + +#if SEXP_USE_HUFF_SYMS +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +#else +#define sexp_symbolp(x) (sexp_lsymbolp(x)) +#endif + +#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_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) + +#define SEXP_NEG_ONE sexp_make_fixnum(-1) +#define SEXP_ZERO sexp_make_fixnum(0) +#define SEXP_ONE sexp_make_fixnum(1) +#define SEXP_TWO sexp_make_fixnum(2) +#define SEXP_THREE sexp_make_fixnum(3) +#define SEXP_FOUR sexp_make_fixnum(4) +#define SEXP_FIVE sexp_make_fixnum(5) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) + +#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x))) +#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x)) +#else +#define _or_integer_flonump(x) +#endif + +#if SEXP_USE_BIGNUMS +SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); +#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) +#else +#define sexp_make_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_exact_integerp(x) sexp_fixnump(x) +#endif + +#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) +#else +#define sexp_fixnum_to_flonum(ctx, x) (x) +#endif + +#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS +#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0])) +#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0])) +#else +#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x)) +#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x)) +#endif + +#define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET) +#define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET) + +/*************************** 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_fixnum(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_fixnum(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_fixnum(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_fixnum(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(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_cpointer_freep(p) (sexp_freep(p)) +#define sexp_cpointer_length(p) ((p)->value.cpointer.length) +#define sexp_cpointer_body(p) ((p)->value.cpointer.body) +#define sexp_cpointer_parent(p) ((p)->value.cpointer.parent) +#define sexp_cpointer_value(p) ((p)->value.cpointer.value) +#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p)) + +#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_syntactic_p(x) ((x)->value.env.syntacticp) +#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_data(x) ((x)->value.opcode.data) +#define sexp_opcode_data2(x) ((x)->value.opcode.data2) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) +#define sexp_opcode_func(x) ((x)->value.opcode.func) + +#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_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) + +#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_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_globals(x) ((x)->value.context.globals) + +#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) + +#if SEXP_USE_GLOBAL_HEAP +#if ! SEXP_USE_BOEHM +SEXP_API sexp_heap sexp_global_heap; +#endif +#define sexp_context_heap(ctx) sexp_global_heap +#else +#define sexp_context_heap(ctx) ((ctx)->value.context.heap) +#endif + +#if SEXP_USE_GLOBAL_SYMBOLS +#define sexp_context_symbols(ctx) sexp_symbol_table +#else +#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) +#endif + +#if SEXP_USE_GLOBAL_TYPES +SEXP_API struct sexp_struct *sexp_type_specs; +#define sexp_context_types(ctx) sexp_type_specs +#define sexp_type_by_index(ctx,i) (&(sexp_context_types(ctx)[i])) +#define sexp_context_num_types(ctx) sexp_num_types +#define sexp_context_type_array_size(ctx) sexp_type_array_size +#else +#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#define sexp_type_by_index(ctx,i) (sexp_context_types(ctx)[i]) +#define sexp_context_num_types(ctx) \ + sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES)) +#define sexp_context_type_array_size(ctx) \ + sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES)) +#endif + +#define sexp_object_type(ctx,x) (sexp_type_by_index(ctx, ((x)->tag))) +#define sexp_object_type_name(ctx,x) (sexp_type_name(sexp_object_type(ctx, x))) +#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i))) + +#define sexp_type_size_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \ + * sexp_type_size_scale(t) \ + + sexp_type_size_base(t)) +#define sexp_type_num_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_len_base(t)) +#define sexp_type_num_eq_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_eq_len_base(t)) + +#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_eq_len_base(x) ((x)->value.type.field_eq_len_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_type_finalize(x) ((x)->value.type.finalize) + +#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_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b))) +#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b))) +#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1))) +#define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a)))) +#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) + +#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 *****************************/ + +enum sexp_context_globals { +#if ! SEXP_USE_GLOBAL_SYMBOLS + SEXP_G_SYMBOLS, +#endif +#if ! SEXP_USE_GLOBAL_TYPES + SEXP_G_TYPES, + SEXP_G_NUM_TYPES, +#endif + SEXP_G_OOM_ERROR, /* out of memory exception object */ + SEXP_G_OOS_ERROR, /* out of stack exception object */ + SEXP_G_OPTIMIZATIONS, + SEXP_G_SIGNAL_HANDLERS, + SEXP_G_CONFIG_ENV, + SEXP_G_MODULE_PATH, + SEXP_G_QUOTE_SYMBOL, + SEXP_G_QUASIQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SPLICING_SYMBOL, + SEXP_G_EMPTY_VECTOR, + SEXP_G_CUR_IN_SYMBOL, + SEXP_G_CUR_OUT_SYMBOL, + SEXP_G_CUR_ERR_SYMBOL, + SEXP_G_INTERACTION_ENV_SYMBOL, + SEXP_G_ERR_HANDLER, + SEXP_G_RESUMECC_BYTECODE, + SEXP_G_FINAL_RESUMER, + SEXP_G_NUM_GLOBALS +}; + +#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(ctx, (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 SEXP_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)) + +SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); +SEXP_API sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p); +SEXP_API sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p); +SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) + +SEXP_API sexp sexp_make_context(sexp ctx, sexp_uint_t size); +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_string_concatenate (sexp ctx, sexp str_ls); +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_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, sexp parent, int freep); +SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_flush_output(sexp ctx, 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_write_to_string(sexp ctx, sexp obj); +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 source); +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(void); + +#if SEXP_USE_GLOBAL_HEAP +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_destroy_context(sexp ctx); +#endif + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots); +SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); +SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp obj); +#define sexp_register_c_type(ctx, name, finalizer) \ + sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ + SEXP_ZERO, SEXP_ZERO, finalizer) +#endif + +#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) +#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))) + +#endif /* ! SEXP_H */ + diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c new file mode 100644 index 00000000..19721c10 --- /dev/null +++ b/lib/chibi/ast.c @@ -0,0 +1,80 @@ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +static void sexp_define_type_predicate (sexp ctx, sexp env, + char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname), op); + sexp_gc_release2(ctx); +} + +static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, + sexp_uint_t cindex, char* get, char *set) { + sexp type, index; + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + type = sexp_make_fixnum(ctype); + index = sexp_make_fixnum(cindex); + op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, get), op); + op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, set), op); + sexp_gc_release2(ctx); +} + +static sexp sexp_get_env_cell (sexp ctx, sexp env, sexp id) { + sexp cell = sexp_env_cell(env, id); + while ((! cell) && sexp_synclop(id)) { + env = sexp_synclo_env(id); + id = sexp_synclo_expr(id); + } + return cell ? cell : SEXP_FALSE; +} + +static sexp sexp_get_opcode_name (sexp ctx, sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, "not an opcode", op); + else if (! sexp_opcode_name(op)) + return SEXP_FALSE; + else + return sexp_intern(ctx, sexp_opcode_name(op)); +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); + sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); + sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); + sexp_define_type_predicate(ctx, env, "set?", SEXP_SET); + sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF); + sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ); + sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); + sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); + sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); + sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); + sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze); + sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); + sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); + sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + return SEXP_VOID; +} + diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module new file mode 100644 index 00000000..57068ece --- /dev/null +++ b/lib/chibi/ast.module @@ -0,0 +1,14 @@ + +(define-module (chibi ast) + (export analyze env-cell opcode-name + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + lambda-name lambda-params lambda-body lambda-defs + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + cnd-test cnd-pass cnd-fail + cnd-test-set! cnd-pass-set! cnd-fail-set! + set-var set-value set-var-set! set-value-set! + ref-name ref-cell ref-name-set! ref-cell-set! + seq-ls seq-ls-set! lit-value lit-value-set!) + (include-shared "ast")) + diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c new file mode 100644 index 00000000..2aac1943 --- /dev/null +++ b/lib/chibi/disasm.c @@ -0,0 +1,127 @@ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define SEXP_DISASM_MAX_DEPTH 8 +#define SEXP_DISASM_PAD_WIDTH 4 + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", + "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", + "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "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", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", + }; + +static sexp disasm (sexp ctx, sexp bc, sexp out, int depth) { + sexp tmp; + unsigned char *ip, opcode, i; + + if (sexp_procedurep(bc)) { + bc = sexp_procedure_code(bc); + } else if (sexp_opcodep(bc)) { + sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); + return SEXP_VOID; + } else if (! sexp_bytecodep(bc)) { + return sexp_type_exception(ctx, "not a procedure", bc); + } + if (! sexp_oportp(out)) { + return sexp_type_exception(ctx, "not an output-port", out); + } + + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + sexp_write_string(ctx, "-------------- ", out); + if (sexp_truep(sexp_bytecode_name(bc))) { + sexp_write(ctx, sexp_bytecode_name(bc), out); + sexp_write_char(ctx, ' ', out); + } + sexp_printf(ctx, out, "%p\n", bc); + + ip = sexp_bytecode_data(bc); + + loop: + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + 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 SEXP_OP_STACK_REF: + case SEXP_OP_LOCAL_REF: + case SEXP_OP_LOCAL_SET: + case SEXP_OP_CLOSURE_REF: + case SEXP_OP_JUMP: + case SEXP_OP_JUMP_UNLESS: + case SEXP_OP_TYPEP: + case SEXP_OP_FCALL0: + case SEXP_OP_FCALL1: + case SEXP_OP_FCALL2: + case SEXP_OP_FCALL3: + case SEXP_OP_FCALL4: + case SEXP_OP_FCALL5: + case SEXP_OP_FCALL6: + sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case SEXP_OP_SLOT_REF: + case SEXP_OP_SLOT_SET: + case SEXP_OP_MAKE: + ip += sizeof(sexp)*2; + break; + case SEXP_OP_GLOBAL_REF: + case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_TAIL_CALL: + case SEXP_OP_CALL: + case SEXP_OP_PUSH: + tmp = ((sexp*)ip)[0]; + if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF)) + && sexp_pairp(tmp)) + tmp = sexp_car(tmp); + else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) + sexp_write_char(ctx, '\'', out); + sexp_write(ctx, tmp, out); + ip += sizeof(sexp); + break; + } + sexp_write_char(ctx, '\n', out); + if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) + && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) + disasm(ctx, tmp, out, depth+1); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { + return disasm(ctx, bc, out, 0); +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_gc_var2(op, name); + sexp_gc_preserve2(ctx, op, name); + name = sexp_c_string(ctx, "disasm", -1); + op = sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_FOREIGN), + sexp_make_fixnum(SEXP_OP_FCALL2), SEXP_ONE, + SEXP_THREE, 0, 0, 0, 0, 0, (sexp_proc1)sexp_disasm); + name = sexp_intern(ctx, "*current-error-port*"); + sexp_opcode_data(op) = sexp_env_cell(sexp_context_env(ctx), name); + name = sexp_intern(ctx, "disasm"); + sexp_env_define(ctx, env, name, op); + sexp_gc_release2(ctx); + return SEXP_VOID; +} + diff --git a/lib/chibi/disasm.module b/lib/chibi/disasm.module new file mode 100644 index 00000000..46c6189c --- /dev/null +++ b/lib/chibi/disasm.module @@ -0,0 +1,4 @@ + +(define-module (chibi disasm) + (export disasm) + (include-shared "disasm")) diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module new file mode 100644 index 00000000..38a8fab1 --- /dev/null +++ b/lib/chibi/filesystem.module @@ -0,0 +1,27 @@ + +(define-module (chibi filesystem) + (export open-input-file-descriptor open-output-file-descriptor + duplicate-file-descriptor duplicate-file-descriptor-to + close-file-descriptor renumber-file-descriptor + delete-file link-file symbolic-link-file rename-file + directory-files create-directory delete-directory + file-status + file-device file-inode + file-mode file-num-links + file-owner file-group + file-represented-device file-size + file-block-size file-num-blocks + file-access-time file-modification-time file-change-time + file-regular? file-directory? file-character? + file-block? file-fifo? file-link? + file-socket? file-exists? + get-file-descriptor-flags set-file-descriptor-flags! + get-file-descriptor-status set-file-descriptor-status! + open/read open/write open/read-write + open/create open/exclusive open/truncate + open/append open/non-block + ) + (import-immutable (scheme)) + (include-shared "filesystem") + (include "filesystem.scm")) + diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm new file mode 100644 index 00000000..aa3fc69f --- /dev/null +++ b/lib/chibi/filesystem.scm @@ -0,0 +1,43 @@ +;; filesystem.scm -- additional filesystem utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (let lp ((res knil)) + (let ((file (readdir dir))) + (if file (lp (kons (dirent-name file) res)) res))))) + +(define (directory-files dir) + (directory-fold dir cons '())) + +(define (renumber-file-descriptor old new) + (and (duplicate-file-descriptor-to old new) + (close-file-descriptor old))) + +(define (file-status file) + (if (string? file) (stat file) (fstat file))) + +(define (file-device x) (stat-dev (if (stat? x) x (file-status x)))) +(define (file-inode x) (stat-ino (if (stat? x) x (file-status x)))) +(define (file-mode x) (stat-mode (if (stat? x) x (file-status x)))) +(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x)))) +(define (file-owner x) (stat-uid (if (stat? x) x (file-status x)))) +(define (file-group x) (stat-gid (if (stat? x) x (file-status x)))) +(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x)))) +(define (file-size x) (stat-size (if (stat? x) x (file-status x)))) +(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x)))) +(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x)))) +(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x)))) +(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x)))) +(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x)))) + +(define (file-regular? x) (S_ISREG (file-mode x))) +(define (file-directory? x) (S_ISDIR (file-mode x))) +(define (file-character? x) (S_ISCHR (file-mode x))) +(define (file-block? x) (S_ISBLK (file-mode x))) +(define (file-fifo? x) (S_ISFIFO (file-mode x))) +(define (file-link? x) (S_ISLNK (file-mode x))) +(define (file-socket? x) (S_ISSOCK (file-mode x))) + +(define (file-exists? x) (and (file-status x) #t)) diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub new file mode 100644 index 00000000..8c42466f --- /dev/null +++ b/lib/chibi/filesystem.stub @@ -0,0 +1,115 @@ + +(c-system-include "sys/types.h") +(c-system-include "unistd.h") +(c-system-include "dirent.h") +(c-system-include "fcntl.h") + +(define-c-type DIR + finalizer: closedir) + +(define-c-struct dirent + (string d_name dirent-name)) + +(define-c-struct stat + predicate: stat? + (dev_t st_dev stat-dev) + (ino_t st_ino stat-ino) + (mode_t st_mode stat-mode) + (nlink_t st_nlink stat-nlinks) + (uid_t st_uid stat-uid) + (gid_t st_gid stat-gid) + (dev_t st_rdev stat-rdev) + (off_t st_size stat-size) + (blksize_t st_blksize stat-blksize) + (blkcnt_t st_blocks stat-blocks) + (time_t st_atime stat-atime) + (time_t st_mtime stat-mtime) + (time_t st_ctime stat-ctime)) + +(define-c boolean S_ISREG (mode_t)) +(define-c boolean S_ISDIR (mode_t)) +(define-c boolean S_ISCHR (mode_t)) +(define-c boolean S_ISBLK (mode_t)) +(define-c boolean S_ISFIFO (mode_t)) +(define-c boolean S_ISLNK (mode_t)) +(define-c boolean S_ISSOCK (mode_t)) + +;;(define-c-const int ("S_IFMT")) +(define-c-const int (file/socket "S_IFSOCK")) +(define-c-const int (file/link "S_IFLNK")) +(define-c-const int (file/regular "S_IFREG")) +(define-c-const int (file/block "S_IFBLK")) +(define-c-const int (file/directory "S_IFDIR")) +(define-c-const int (file/character "S_IFCHR")) +(define-c-const int (file/fifo "S_IFIFO")) +(define-c-const int (file/suid "S_ISUID")) +(define-c-const int (file/sgid "S_ISGID")) +(define-c-const int (file/sticky "S_ISVTX")) +;;(define-c-const int ("S_IRWXU")) +(define-c-const int (perm/user-read "S_IRUSR")) +(define-c-const int (perm/user-write "S_IWUSR")) +(define-c-const int (perm/user-execute "S_IXUSR")) +;;(define-c-const int ("S_IRWXG")) +(define-c-const int (perm/group-read "S_IRGRP")) +(define-c-const int (perm/group-write "S_IWGRP")) +(define-c-const int (perm/group-execute "S_IXGRP")) +;;(define-c-const int ("S_IRWXO")) +(define-c-const int (perm/others-read "S_IROTH")) +(define-c-const int (perm/others-write "S_IWOTH")) +(define-c-const int (perm/others-execute "S_IXOTH")) + +(define-c errno stat (string (result stat))) +(define-c errno fstat (int (result stat))) +(define-c errno (file-link-status "lstat") (string (result stat))) + +(define-c input-port (open-input-file-descriptor "fdopen") + (int (value "r" string))) +(define-c output-port (open-output-file-descriptor "fdopen") + (int (value "w" string))) + +(define-c errno (delete-file "unlink") (string)) +(define-c errno (link-file "link") (string string)) +(define-c errno (symbolic-link-file "symlink") (string string)) +(define-c errno (rename-file "rename") (string string)) + +(define-c non-null-string (current-directory "getcwd") + ((result (array char (auto-expand arg1))) (value 256 int))) + +(define-c errno (create-directory "mkdir") (string int)) +(define-c errno (delete-directory "rmdir") (string)) + +(define-c (free DIR) opendir (string)) +(define-c dirent readdir ((link DIR))) + +(define-c int (duplicate-file-descriptor "dup") (int)) +(define-c errno (duplicate-file-descriptor-to "dup2") (int int)) +(define-c errno (close-file-descriptor "close") (int)) + +(define-c errno (open-pipe "pipe") ((result (array int 2)))) +(define-c errno (make-fifo "mkfifo") (string (default #o644 int))) + +(define-c int (get-file-descriptor-flags "fcntl") + (int (value F_GETFD int))) +(define-c errno (set-file-descriptor-flags! "fcntl") + (int (value F_SETFD int) long)) + +(define-c int (get-file-descriptor-status "fcntl") + (int (value F_GETFL int))) +(define-c errno (set-file-descriptor-status! "fcntl") + (int (value F_SETFL int) long)) + +;; (define-c int (get-file-descriptor-lock "fcntl") +;; (int (value F_GETLK int) flock)) +;; (define-c errno (set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLK int) flock)) +;; (define-c errno (try-set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLKW int) flock)) + +(define-c-const int (open/read "O_RDONLY")) +(define-c-const int (open/write "O_WRONLY")) +(define-c-const int (open/read-write "O_RDWR")) +(define-c-const int (open/create "O_CREAT")) +(define-c-const int (open/exclusive "O_EXCL")) +(define-c-const int (open/truncate "O_TRUNC")) +(define-c-const int (open/append "O_APPEND")) +(define-c-const int (open/non-block "O_NONBLOCK")) diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c new file mode 100644 index 00000000..34e415c1 --- /dev/null +++ b/lib/chibi/heap-stats.c @@ -0,0 +1,129 @@ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define SEXP_HEAP_VECTOR_DEPTH 1 + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); + +#if SEXP_USE_GLOBAL_HEAP +#endif + +static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { + int i; + if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x) + || sexp_flonump(x) || sexp_bignump(x)) { + sexp_write(ctx, x, out); + } else if (depth <= 0) { + goto print_name; + } else if (sexp_synclop(x)) { + sexp_write_string(ctx, "#", out); + } else if (sexp_pairp(x)) { + sexp_write_char(ctx, '(', out); + sexp_print_simple(ctx, sexp_car(x), out, depth-1); + sexp_write_string(ctx, " . ", out); + sexp_print_simple(ctx, sexp_cdr(x), out, depth-1); + sexp_write_char(ctx, ')', out); + } else if (sexp_vectorp(x)) { + sexp_write_string(ctx, "#(", out); + for (i=0; i0) + sexp_write_char(ctx, ' ', out); + sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); + } + if (i", out); + } +} + +static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { + size_t freed; + sexp_uint_t stats[256], hi_type=0, i; + sexp_heap h = sexp_context_heap(ctx); + sexp p, out=SEXP_FALSE; + sexp_free_list q, r; + char *end; + sexp_gc_var3(res, tmp, name); + + if (printp) + out = sexp_env_global_ref(sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + SEXP_FALSE); + + /* run gc once to remove unused variables */ + sexp_gc(ctx, &freed); + + /* initialize stats */ + for (i=0; i<256; i++) stats[i]=0; + + /* loop over each heap chunk */ + for ( ; h; h=h->next) { + 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) { /* this is a free block, skip */ + p = (sexp) (((char*)p) + r->size); + continue; + } + /* otherwise maybe print, then increment the stat and continue */ + if (sexp_oportp(out)) { + sexp_print_simple(ctx, p, out, depth); + sexp_write_char(ctx, '\n', out); + } + stats[sexp_pointer_tag(p)]++; + if (sexp_pointer_tag(p) > hi_type) + hi_type = sexp_pointer_tag(p); + p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p))); + } + } + + /* build and return results */ + sexp_gc_preserve3(ctx, res, tmp, name); + res = SEXP_NULL; + for (i=hi_type; i>0; i--) + if (stats[i]) { + name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i)); + tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); + res = sexp_cons(ctx, tmp, res); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_heap_stats (sexp ctx) { + return sexp_heap_walk(ctx, 0, 0); +} + +static sexp sexp_heap_dump (sexp ctx, sexp depth) { + if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) + return sexp_type_exception(ctx, "bad heap-dump depth", depth); + return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats); + sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE); + return SEXP_VOID; +} + diff --git a/lib/chibi/heap-stats.module b/lib/chibi/heap-stats.module new file mode 100644 index 00000000..af84ca44 --- /dev/null +++ b/lib/chibi/heap-stats.module @@ -0,0 +1,5 @@ + +(define-module (chibi heap-stats) + (export heap-stats heap-dump) + (include-shared "heap-stats")) + diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module new file mode 100644 index 00000000..5b76daf8 --- /dev/null +++ b/lib/chibi/loop.module @@ -0,0 +1,9 @@ + +(define-module (chibi loop) + (export loop in-list in-lists in-port in-file up-from down-from + listing listing-reverse appending appending-reverse + summing multiplying in-string in-string-reverse + in-vector in-vector-reverse) + (import-immutable (scheme)) + (include "loop/loop.scm")) + diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm new file mode 100644 index 00000000..09e12856 --- /dev/null +++ b/lib/chibi/loop/loop.scm @@ -0,0 +1,365 @@ +;;;; loop.scm - the chibi loop (aka foof-loop) +;; +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; The loop API is compatible with Taylor Campbell's foof-loop, but +;; the iterator API is different and subject to change. All loop +;; variables may be implicitly destructured with MATCH semantics. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (assoc-pred equal elt ls) + (and (pair? ls) + (if (equal elt (car (car ls))) + (car ls) + (assoc-pred equal elt (cdr ls))))) + +(define-syntax let-keyword-form + (syntax-rules () + ((let-keyword-form + ((labeled-arg-macro-name (positional-name . params))) + . body) + (let-syntax + ((labeled-arg-macro-name + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (named '()) (posns '())) + (cond + ((pair? ls) + (if (and (list? (car ls)) (compare (caar ls) (rename '=>))) + (lp (cdr ls) (cons (cdar ls) named) posns) + (lp (cdr ls) named (cons (car ls) posns)))) + (else + (let lp ((ls (syntax-quote params)) + (posns (reverse posns)) + (args '())) + (cond + ((null? ls) + (if (pair? posns) + (error "let-keyword-form: too many args" expr) + (cons (syntax-quote positional-name) (reverse args)))) + ((assoc-pred compare (caar ls) named) + => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args)))) + ((pair? posns) + (lp (cdr ls) (cdr posns) (cons (car posns) args))) + (else + (lp (cdr ls) posns (cons (cadar ls) args)))))))))))) + . body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax loop + (syntax-rules () + ;; unnamed, implicit recursion + ((loop (vars ...) body ...) + (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop))) + ;; named, explicit recursion + ((loop name (vars ...) body ...) + (%loop name () () () () () (vars ...) body ...)))) + +;; Main LOOP macro. Separate the variables from the iterator and +;; parameters, then walk through each parameter expanding the +;; bindings, and build the final form. + +(define-syntax %loop + (syntax-rules (=> for with let while until) + ;; automatic iteration + ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body) + (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ;; do equivalents, with optional guards + ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body) + (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init step) rest ...) . body) + (%loop name l (vars ... (var init step)) c r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init) rest ...) . body) + (%loop name l (vars ... (var init var)) c r f (rest ...) . body)) + ;; user-specified terminators + ((_ name l vars (checks ...) r f ((until expr) rest ...) . body) + (%loop name l vars (checks ... expr) r f (rest ...) . body)) + ((_ name l vars (checks ...) r f ((while expr) rest ...) . body) + (%loop name l vars (checks ... (not expr)) r f (rest ...) . body)) + ;; specify a default done? + ((_ name l v c r f ()) + (%loop name l v c r f () (#f #f))) + ((_ name l v c r f () () . body) + (%loop name l v c r f () (#f #f) . body)) + ;; final expansion + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => result + . body) + (let* (lets ...) + (letrec ((tmp (lambda (var ...) + (if (or checks ...) + (let-keyword-form ((name (tmp (var step) ...))) + (let (finals ...) result)) + (let (refs ...) + (let-keyword-form ((name (tmp (var step) ...))) + (if #f #f) + . body)))))) + (tmp init ...)))) + ;; unspecified return value case + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + . body) + (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => (if #f #f) . body)) + )) + +(define-syntax %loop-next + (syntax-rules () + ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...) + name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...) + . rest) + (%loop name (lets ... new-lets ...) (vars ... new-vars ...) + (checks ... new-checks ...) (refs ... new-refs ...) + (finals ... new-finals ...) + . rest)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Iterators + +;; Each gets passed two lists, those items left of the <- and those to +;; the right, followed by a NEXT and REST continuation. + +;; Should finish with +;; +;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...) +;; (loop-vars ...) (final-vars ...) . rest) +;; +;; OUTER-VARS: bound once outside the loop in a LET* +;; CURSOR-VARS: DO-style bindings of the form (name init update) +;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t +;; LOOP-VARS: inner variables, updated in parallel after the cursors +;; FINAL-VARS: final variables, bound only in the => result + +(define-syntax in-list ; called just "IN" in ITER + (syntax-rules () + ((in-list ((var) source) next . rest) + (in-list ((var cursor) source) next . rest)) + ((in-list ((var cursor) source) next . rest) + (in-list ((var cursor succ) source) next . rest)) + ((in-list ((var cursor succ) (source)) next . rest) + (next () ; outer let bindings + ((cursor source succ)) ; iterator, init, step + ((not (pair? cursor))) ; finish tests for iterator vars + ;; step variables and values + ((var (car cursor)) + (succ (cdr cursor))) + () ; final result bindings + . rest)) + ((in-list ((var cursor succ) (source step)) next . rest) + (next () + ((cursor source succ)) + ((not (pair? cursor))) + ((var (car cursor)) + (succ (step cursor))) + () + . rest)))) + +;; Iterator from Taylor R. Campbell. If you know the number of lists +;; ahead of time it's much more efficient to iterate over each one +;; separately. +(define-syntax in-lists + (syntax-rules () + ((in-lists ((elts) lol) next . rest) + (in-lists ((elts pairs) lol) next . rest)) + ((in-lists ((elts pairs) lol) next . rest) + (in-lists ((elts pairs succ) lol) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol step)) next . rest) + (in-lists ((elts pairs succ) (lol step null?)) next . rest)) + ((in-lists ((elts pairs succ) (lol step done?)) next . rest) + (next () + ((pairs lol succ)) + ((let lp ((ls pairs)) ; an in-lined ANY + (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls)))))) + ((elts (map car pairs)) + (succ (map step pairs))) + () + . rest)) + )) + +(define-syntax define-in-indexed + (syntax-rules () + ((define-in-indexed in-type in-type-reverse length ref) + (begin + (define-syntax in-type + (syntax-rules () + ((in-type ls next . rest) + (%in-idx >= + 0 (length tmp) ref tmp ls next . rest)))) + (define-syntax in-type-reverse + (syntax-rules () + ((in-type-reverse ls next . rest) + (%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest)))) + )))) + +(define-in-indexed in-string in-string-reverse string-length string-ref) +(define-in-indexed in-vector in-vector-reverse vector-length vector-ref) + +;; helper for the above string and vector iterators +(define-syntax %in-idx + (syntax-rules () + ;; cmp inc start end ref + ((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest) + (%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest) + (next ((tmp-vec vec) (end to)) + ((index from (+ index step))) + ((ge index end)) + ((var (r tmp-vec index))) + () + . rest)) + )) + +(define-syntax in-port + (syntax-rules () + ((in-port ((var) source) next . rest) + (in-port ((var p) source) next . rest)) + ((in-port ((var p) ()) next . rest) + (in-port ((var p) ((current-input-port))) next . rest)) + ((in-port ((var p) (port)) next . rest) + (in-port ((var p) (port read-char)) next . rest)) + ((in-port ((var p) (port read-char)) next . rest) + (in-port ((var p) (port read-char eof-object?)) next . rest)) + ((in-port ((var p) (port reader eof?)) next . rest) + (next ((p port) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + () + . rest)))) + +(define-syntax in-file + (syntax-rules () + ((in-file ((var) source) next . rest) + (in-file ((var p) source) next . rest)) + ((in-file ((var p) (file)) next . rest) + (in-file ((var p) (file read-char)) next . rest)) + ((in-file ((var p) (file reader)) next . rest) + (in-file ((var p) (file reader eof-object?)) next . rest)) + ((in-file ((var p) (file reader eof?)) next . rest) + (next ((p (open-input-file file)) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + ((dummy (close-input-port p))) + . rest)))) + +(define-syntax up-from + (syntax-rules (to by) + ((up-from (() . args) next . rest) + (up-from ((var) . args) next . rest)) + ((up-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var s (+ var e))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var s (+ var 1))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var s (+ var e))) () () () . rest)) + ((up-from ((var) (start)) next . rest) + (next ((s start)) ((var s (+ var 1))) () () () . rest)) + )) + +(define-syntax down-from + (syntax-rules (to by) + ((down-from (() . args) next . rest) + (down-from ((var) . args) next . rest)) + ((down-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var (- s e) (- var e))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var (- s 1) (- var 1))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var (- s e) (- var e))) () () () + . rest)) + ((down-from ((var) (start)) next . rest) + (next ((s start)) ((var (- s 1) (- var 1))) () () () + . rest)) + )) + +(define-syntax accumulating + (syntax-rules (initial if) + ((accumulating (kons final init) ((var) . x) next . rest) + (accumulating (kons final init) ((var cursor) . x) next . rest)) + ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest) + (accumulating (kons final i) ((var cursor) x) n . rest)) + ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (if check (tmp-kons expr cursor) cursor))) + () + () + ((var (final cursor))) + . rest)) + ((accumulating (kons final init) ((var cursor) (expr)) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (tmp-kons expr cursor))) + () + () + ((var (final cursor))) + . rest)))) + +(define-syntax listing + (syntax-rules () + ((listing args next . rest) + (accumulating (cons reverse '()) args next . rest)))) + +(define-syntax listing-reverse + (syntax-rules () + ((listing-reverse args next . rest) + (accumulating (cons (lambda (x) x) '()) args next . rest)))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define-syntax appending + (syntax-rules () + ((appending args next . rest) + (accumulating (append-reverse reverse '()) args next . rest)))) + +(define-syntax appending-reverse + (syntax-rules () + ((appending-reverse args next . rest) + (accumulating (append-reverse (lambda (x) x) '()) args next . rest)))) + +(define-syntax summing + (syntax-rules () + ((summing args next . rest) + (accumulating (+ (lambda (x) x) 0) args next . rest)))) + +(define-syntax multiplying + (syntax-rules () + ((multiplying args next . rest) + (accumulating (* (lambda (x) x) 1) args next . rest)))) diff --git a/lib/chibi/macroexpand.module b/lib/chibi/macroexpand.module new file mode 100644 index 00000000..47b0e7d4 --- /dev/null +++ b/lib/chibi/macroexpand.module @@ -0,0 +1,6 @@ + +(define-module (chibi macroexpand) + (import-immutable (scheme)) + (import (chibi ast)) + (export macroexpand) + (include "macroexpand.scm")) diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm new file mode 100644 index 00000000..a040855a --- /dev/null +++ b/lib/chibi/macroexpand.scm @@ -0,0 +1,85 @@ +;; macroexpand.scm -- macro expansion utility +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; This actually analyzes the expression then reverse-engineers an +;; sexp from the result, generating a minimal amount of renames. + +(define (macroexpand x) + (ast->sexp (analyze x))) + +(define (ast-renames ast) + (define i 0) + (define renames '()) + (define (rename-symbol id) + (set! i (+ i 1)) + (string->symbol + (string-append (symbol->string (identifier->symbol id)) + "." (number->string i)))) + (define (rename-lambda lam) + (or (assq lam renames) + (let ((res (list lam))) + (set! renames (cons res renames)) + res))) + (define (rename! id lam) + (let ((cell (rename-lambda lam))) + (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell))))) + (define (check-ref id lam env) + (let ((sym (identifier->symbol id))) + (let lp1 ((ls env)) + (cond + ((pair? ls) + (let lp2 ((ls2 (car ls)) (found? #f)) + (cond + ((null? ls2) + (if (not found?) (lp1 (cdr ls)))) + ((and (eq? id (caar ls2)) (eq? lam (cdar ls2))) + (lp2 (cdr ls2) #t)) + ((eq? sym (identifier->symbol (caar ls2))) + (rename! (caar ls2) (cdar ls2)) + (lp2 (cdr ls2) found?)) + (else + (lp2 (cdr ls2) found?))))))))) + (define (flatten-dot x) + (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) + ((null? x) x) + (else (list x)))) + (define (extend-env lam env) + (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env)) + (let lp ((x ast) (env '())) + (cond + ((lambda? x) (lp (lambda-body x) (extend-env x env))) + ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env)) + ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env)) + ((set? x) (lp (set-var x) env) (lp (set-value x) env)) + ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x))) + ((pair? x) (for-each (lambda (x) (lp x env)) x)))) + renames) + +(define (get-rename id lam renames) + (let ((ls (assq lam renames))) + (if (not ls) + (identifier->symbol id) + (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id)))))) + +(define (ast->sexp ast) + (let ((renames (ast-renames ast))) + (let a2s ((x ast)) + (cond + ((lambda? x) + `(lambda ,(map (lambda (id) (get-rename id x renames)) (lambda-params x)) + ,@(map (lambda (d) `(define ,(identifier->symbol (cadr d)) #f)) (lambda-defs x)) + ,@(if (seq? (lambda-body x)) + (map a2s (seq-ls (lambda-body x))) + (list (a2s (lambda-body x)))))) + ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) + ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) + ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) + ((seq? x) `(begin ,@(map a2s (seq-ls x)))) + ((lit? x) + (let ((v (lit-value x))) + (if (or (pair? v) (null? v) (symbol? v)) `',v v))) + ((pair? x) (cons (a2s (car x)) (a2s (cdr x)))) + ((opcode? x) (or (opcode-name x) x)) + (else x))))) + diff --git a/lib/chibi/match.module b/lib/chibi/match.module new file mode 100644 index 00000000..1366176a --- /dev/null +++ b/lib/chibi/match.module @@ -0,0 +1,6 @@ + +(define-module (chibi match) + (export match match-lambda match-lambda* match-let match-letrec match-let*) + (import-immutable (scheme)) + (include "match/match.scm")) + diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm new file mode 100644 index 00000000..963b89ff --- /dev/null +++ b/lib/chibi/match/match.scm @@ -0,0 +1,670 @@ +;;;; match.scm -- portable hygienic pattern matcher +;; +;; This code is written by Alex Shinn and placed in the +;; Public Domain. All warranties are disclaimed. + +;; This is a full superset of the popular MATCH package by Andrew +;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks +;; in R6RS SYNTAX-RULES), and thus preserving hygiene. + +;; This is a simple generative pattern matcher - each pattern is +;; expanded into the required tests, calling a failure continuation if +;; the tests fail. This makes the logic easy to follow and extend, +;; but produces sub-optimal code in cases where you have many similar +;; clauses due to repeating the same tests. Nonetheless a smart +;; compiler should be able to remove the redundant tests. For +;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance +;; hit. + +;; The original version was written on 2006/11/29 and described in the +;; following Usenet post: +;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd +;; and is still available at +;; http://synthcode.com/scheme/match-simple.scm +;; It's just 80 lines for the core MATCH, and an extra 40 lines for +;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar. +;; +;; A variant of this file which uses COND-EXPAND in a few places for +;; performance can be found at +;; http://synthcode.com/scheme/match-cond-expand.scm +;; +;; 2009/11/25 - adding `***' tree search patterns +;; 2008/03/20 - fixing bug where (a ...) matched non-lists +;; 2008/03/15 - removing redundant check in vector patterns +;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) +;; 2007/09/04 - fixing quasiquote patterns +;; 2007/07/21 - allowing ellipse patterns in non-final list positions +;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse +;; (thanks to Taylor Campbell) +;; 2007/04/08 - clean up, commenting +;; 2006/12/24 - bugfixes +;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; force compile-time syntax errors with useful messages + +(define-syntax match-syntax-error + (syntax-rules () + ((_) (match-syntax-error "invalid match-syntax-error usage")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The basic interface. MATCH just performs some basic syntax +;; validation, binds the match expression to a temporary variable `v', +;; and passes it on to MATCH-NEXT. It's a constant throughout the +;; code below that the binding `v' is a direct variable reference, not +;; an expression. + +(define-syntax match + (syntax-rules () + ((match) + (match-syntax-error "missing match expression")) + ((match atom) + (match-syntax-error "no match clauses")) + ((match (app ...) (pat . body) ...) + (let ((v (app ...))) + (match-next v ((app ...) (set! (app ...))) (pat . body) ...))) + ((match #(vec ...) (pat . body) ...) + (let ((v #(vec ...))) + (match-next v (v (set! v)) (pat . body) ...))) + ((match atom (pat . body) ...) + (match-next atom (atom (set! atom)) (pat . body) ...)) + )) + +;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure +;; thunk, which is expanded by recursing MATCH-NEXT on the remaining +;; clauses. `g+s' is a list of two elements, the get! and set! +;; expressions respectively. + +(define-syntax match-next + (syntax-rules (=>) + ;; no more clauses, the match failed + ((match-next v g+s) + (error 'match "no matching pattern")) + ;; named failure continuation + ((match-next v g+s (pat (=> failure) . body) . rest) + (let ((failure (lambda () (match-next v g+s . rest)))) + ;; match-one analyzes the pattern for us + (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ()))) + ;; anonymous failure continuation, give it a dummy name + ((match-next v g+s (pat . body) . rest) + (match-next v g+s (pat (=> failure) . body) . rest)))) + +;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to +;; MATCH-TWO. + +(define-syntax match-one + (syntax-rules () + ;; If it's a list of two or more values, check to see if the + ;; second one is an ellipse and handle accordingly, otherwise go + ;; to MATCH-TWO. + ((match-one v (p q . r) g+s sk fk i) + (match-check-ellipse + q + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()) + (match-two v (p q . r) g+s sk fk i))) + ;; Go directly to MATCH-TWO. + ((match-one . x) + (match-two . x)))) + +;; This is the guts of the pattern matcher. We are passed a lot of +;; information in the form: +;; +;; (match-two var pattern getter setter success-k fail-k (ids ...)) +;; +;; usually abbreviated +;; +;; (match-two v p g+s sk fk i) +;; +;; where VAR is the symbol name of the current variable we are +;; matching, PATTERN is the current pattern, getter and setter are the +;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding +;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure +;; continuation (which is just a thunk call and is thus safe to expand +;; multiple times) and IDS are the list of identifiers bound in the +;; pattern so far. + +(define-syntax match-two + (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!) + ((match-two v () g+s (sk ...) fk i) + (if (null? v) (sk ... i) fk)) + ((match-two v (quote p) g+s (sk ...) fk i) + (if (equal? v 'p) (sk ... i) fk)) + ((match-two v (quasiquote p) . x) + (match-quasiquote v p . x)) + ((match-two v (and) g+s (sk ...) fk i) (sk ... i)) + ((match-two v (and p q ...) g+s sk fk i) + (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i)) + ((match-two v (or) g+s sk fk i) fk) + ((match-two v (or p) . x) + (match-one v p . x)) + ((match-two v (or p ...) g+s sk fk i) + (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ())) + ((match-two v (not p) g+s (sk ...) fk i) + (match-one v p g+s (match-drop-ids fk) (sk ... i) i)) + ((match-two v (get! getter) (g s) (sk ...) fk i) + (let ((getter (lambda () g))) (sk ... i))) + ((match-two v (set! setter) (g (s ...)) (sk ...) fk i) + (let ((setter (lambda (x) (s ... x)))) (sk ... i))) + ((match-two v (? pred . p) g+s sk fk i) + (if (pred v) (match-one v (and . p) g+s sk fk i) fk)) + ((match-two v (= proc p) . x) + (let ((w (proc v))) (match-one w p . x))) + ((match-two v (p ___ . r) g+s sk fk i) + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())) + ((match-two v (p) g+s sk fk i) + (if (and (pair? v) (null? (cdr v))) + (let ((w (car v))) + (match-one w p ((car v) (set-car! v)) sk fk i)) + fk)) + ((match-two v (p *** q) g+s sk fk i) + (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) + ((match-two v (p *** . q) g+s sk fk i) + (match-syntax-error "invalid use of ***" (p *** . q))) + ((match-two v (p . q) g+s sk fk i) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-one w p ((car v) (set-car! v)) + (match-one x q ((cdr v) (set-cdr! v)) sk fk) + fk + i)) + fk)) + ((match-two v #(p ...) g+s . x) + (match-vector v 0 () (p ...) . x)) + ((match-two v _ g+s (sk ...) fk i) (sk ... i)) + ;; Not a pair or vector or special literal, test to see if it's a + ;; new symbol, in which case we just bind it, or if it's an + ;; already bound symbol or some other literal, in which case we + ;; compare it with EQUAL?. + ((match-two v x g+s (sk ...) fk (id ...)) + (let-syntax + ((new-sym? + (syntax-rules (id ...) + ((new-sym? x sk2 fk2) sk2) + ((new-sym? y sk2 fk2) fk2)))) + (new-sym? random-sym-to-match + (let ((x v)) (sk ... (id ... x))) + (if (equal? v x) (sk ... (id ...)) fk)))) + )) + +;; QUASIQUOTE patterns + +(define-syntax match-quasiquote + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ v (unquote p) g+s sk fk i) + (match-one v p g+s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g+s sk fk i) + (if (pair? v) + (match-one v + (p . tmp) + (match-quasiquote tmp rest g+s sk fk) + fk + i) + fk)) + ((_ v (quasiquote p) g+s sk fk i . depth) + (match-quasiquote v p g+s sk fk i #f . depth)) + ((_ v (unquote p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (unquote-splicing p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (p . q) g+s sk fk i . depth) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-quasiquote + w p g+s + (match-quasiquote-step x q g+s sk fk depth) + fk i . depth)) + fk)) + ((_ v #(elt ...) g+s sk fk i . depth) + (if (vector? v) + (let ((ls (vector->list v))) + (match-quasiquote ls (elt ...) g+s sk fk i . depth)) + fk)) + ((_ v x g+s sk fk i . depth) + (match-one v 'x g+s sk fk i)))) + +(define-syntax match-quasiquote-step + (syntax-rules () + ((match-quasiquote-step x q g+s sk fk depth i) + (match-quasiquote x q g+s sk fk i . depth)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities + +;; Takes two values and just expands into the first. +(define-syntax match-drop-ids + (syntax-rules () + ((_ expr ids ...) expr))) + +(define-syntax match-drop-first-arg + (syntax-rules () + ((_ arg expr) expr))) + +;; To expand an OR group we try each clause in succession, passing the +;; first that succeeds to the success continuation. On failure for +;; any clause, we just try the next clause, finally resorting to the +;; failure continuation fk if all clauses fail. The only trick is +;; that we want to unify the identifiers, so that the success +;; continuation can refer to a variable from any of the OR clauses. + +(define-syntax match-gen-or + (syntax-rules () + ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...)) + (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) + (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...)))))) + +(define-syntax match-gen-or-step + (syntax-rules () + ((_ v () g+s sk fk . x) + ;; no OR clauses, call the failure continuation + fk) + ((_ v (p) . x) + ;; last (or only) OR clause, just expand normally + (match-one v p . x)) + ((_ v (p . q) g+s sk fk i) + ;; match one and try the remaining on failure + (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) + )) + +;; We match a pattern (p ...) by matching the pattern p in a loop on +;; each element of the variable, accumulating the bound ids into lists. + +;; Look at the body of the simple case - it's just a named let loop, +;; matching each element in turn to the same pattern. The only trick +;; is that we want to keep track of the lists of each extracted id, so +;; when the loop recurses we cons the ids onto their respective list +;; variables, and on success we bind the ids (what the user input and +;; expects to see in the success body) to the reversed accumulated +;; list IDs. + +(define-syntax match-gen-ellipses + (syntax-rules () + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to (p ...), just bind the list + (let ((p v)) + (if (list? p) + (sk ... i) + fk)) + ;; simple case, match all elements of the list + (let loop ((ls v) (id-ls '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) + fk i))) + (else + fk))))) + ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking + (match-verify-no-ellipses + r + (let* ((tail-len (length 'r)) + (ls v) + (len (length ls))) + (if (< len tail-len) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond + ((= n tail-len) + (let ((id (reverse id-ls)) ...) + (match-one ls r (#f #f) (sk ... i) fk i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids + (loop (cdr ls) (- n 1) (cons id id-ls) ...)) + fk + i))) + (else + fk))))))))) + +;; This is just a safety check. Although unlike syntax-rules we allow +;; trailing patterns after an ellipses, we explicitly disable multiple +;; ellipses at the same level. This is because in the general case +;; such patterns are exponential in the number of ellipses, and we +;; don't want to make it easy to construct very expensive operations +;; with simple looking patterns. For example, it would be O(n^2) for +;; patterns like (a ... b ...) because we must consider every trailing +;; element for every possible break for the leading "a ...". + +(define-syntax match-verify-no-ellipses + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipse + x + (match-syntax-error + "multiple ellipse patterns not allowed at same level") + (match-verify-no-ellipses y sk))) + ((_ () sk) + sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipse" x)))) + +;; Matching a tree search pattern is only slightly more complicated. +;; Here we allow patterns of the form +;; +;; (x *** y) +;; +;; to represent the pattern y located somewhere in a tree where the +;; path from the current object to y can be seen as a list of the form +;; (X ...). Y can immediately match the current object in which case +;; the path is the empty list. In a sense it's a 2-dimensional +;; version of the ... pattern. +;; +;; As a common case the pattern (_ *** y) can be used to search for Y +;; anywhere in a tree, regardless of the path used. +;; +;; To implement the search, we use two recursive procedures. TRY +;; attempts to match Y once, and on success it calls the normal SK on +;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we +;; call NEXT which first checks if the current value is a list +;; beginning with X, then calls TRY on each remaining element of the +;; list. Since TRY will recursively call NEXT again on failure, this +;; effects a full depth-first search. +;; +;; The failure continuation throughout is a jump to the next step in +;; the tree search, initialized with the original failure continuation +;; FK. + +(define-syntax match-gen-search + (syntax-rules () + ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) + (letrec ((try (lambda (w fail id-ls ...) + (match-one w q g+s + (match-drop-ids + (let ((id (reverse id-ls)) ...) + sk)) + (next w fail id-ls ...) i))) + (next (lambda (w fail id-ls ...) + (if (not (pair? w)) + (fail) + (let ((u (car w))) + (match-one + u p ((car w) (set-car! w)) + (match-drop-ids + ;; accumulate the head variables from + ;; the p pattern, and loop over the tail + (let ((id-ls (cons id id-ls)) ...) + (let lp ((ls (cdr w))) + (if (pair? ls) + (try (car ls) + (lambda () (lp (cdr ls))) + id-ls ...) + (fail))))) + (fail) i)))))) + ;; the initial id-ls binding here is a dummy to get the right + ;; number of '()s + (let ((id-ls '()) ...) + (try v (lambda () fk) id-ls ...)))))) + +;; Vector patterns are just more of the same, with the slight +;; exception that we pass around the current vector index being +;; matched. + +(define-syntax match-vector + (syntax-rules (___) + ((_ v n pats (p q) . x) + (match-check-ellipse q + (match-gen-vector-ellipses v n pats p . x) + (match-vector-two v n pats (p q) . x))) + ((_ v n pats (p ___) sk fk i) + (match-gen-vector-ellipses v n pats p sk fk i)) + ((_ . x) + (match-vector-two . x)))) + +;; Check the exact vector length, then check each element in turn. + +(define-syntax match-vector-two + (syntax-rules () + ((_ v n ((pat index) ...) () sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (= len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) . x) + (match-vector v (+ n 1) (pats ... (p n)) q . x)))) + +(define-syntax match-vector-step + (syntax-rules () + ((_ v () (sk ...) fk i) (sk ... i)) + ((_ v ((pat index) . rest) sk fk i) + (let ((w (vector-ref v index))) + (match-one w pat ((vector-ref v index) (vector-set! v index)) + (match-vector-step v rest sk fk) + fk i))))) + +;; With a vector ellipse pattern we first check to see if the vector +;; length is at least the required length. + +(define-syntax match-gen-vector-ellipses + (syntax-rules () + ((_ v n ((pat index) ...) p sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (>= len n) + (match-vector-step v ((pat index) ...) + (match-vector-tail v p n len sk fk) + fk i) + fk)) + fk)))) + +(define-syntax match-vector-tail + (syntax-rules () + ((_ v p n len sk fk i) + (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())))) + +(define-syntax match-vector-tail-two + (syntax-rules () + ((_ v p n len (sk ...) fk i ((id id-ls) ...)) + (let loop ((j n) (id-ls '()) ...) + (if (>= j len) + (let ((id (reverse id-ls)) ...) (sk ... i)) + (let ((w (vector-ref v j))) + (match-one w p ((vector-ref v j) (vetor-set! v j)) + (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) + fk i))))))) + +;; Extract all identifiers in a pattern. A little more complicated +;; than just looking for symbols, we need to ignore special keywords +;; and non-pattern forms (such as the predicate expression in ? +;; patterns), and also ignore previously bound identifiers. +;; +;; Calls the continuation with all new vars as a list of the form +;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely +;; pair with the original variable (e.g. it's used in the ellipse +;; generation for list variables). +;; +;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) + +(define-syntax match-extract-vars + (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!) + ((match-extract-vars (? pred . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars ($ rec . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (= proc p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (quote x) (k ...) i v) + (k ... v)) + ((match-extract-vars (quasiquote x) k i v) + (match-extract-quasiquote-vars x k i v (#t))) + ((match-extract-vars (and . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (or . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (not . p) . x) + (match-extract-vars p . x)) + ;; A non-keyword pair, expand the CAR with a continuation to + ;; expand the CDR. + ((match-extract-vars (p q . r) k i v) + (match-check-ellipse + q + (match-extract-vars (p . r) k i v) + (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) + ((match-extract-vars (p . q) k i v) + (match-extract-vars p (match-extract-vars-step q k i v) i ())) + ((match-extract-vars #(p ...) . x) + (match-extract-vars (p ...) . x)) + ((match-extract-vars _ (k ...) i v) (k ... v)) + ((match-extract-vars ___ (k ...) i v) (k ... v)) + ((match-extract-vars *** (k ...) i v) (k ... v)) + ;; This is the main part, the only place where we might add a new + ;; var if it's an unbound symbol. + ((match-extract-vars p (k ...) (i ...) v) + (let-syntax + ((new-sym? + (syntax-rules (i ...) + ((new-sym? p sk fk) sk) + ((new-sym? x sk fk) fk)))) + (new-sym? random-sym-to-match + (k ... ((p p-ls) . v)) + (k ... v)))) + )) + +;; Stepper used in the above so it can expand the CAR and CDR +;; separately. + +(define-syntax match-extract-vars-step + (syntax-rules () + ((_ p k i v ((v2 v2-ls) ...)) + (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) + )) + +(define-syntax match-extract-quasiquote-vars + (syntax-rules (quasiquote unquote unquote-splicing) + ((match-extract-quasiquote-vars (quasiquote x) k i v d) + (match-extract-quasiquote-vars x k i v (#t . d))) + ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) + (match-extract-quasiquote-vars (unquote x) k i v d)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t)) + (match-extract-vars x k i v)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) + (match-extract-quasiquote-vars x k i v d)) + ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) + (match-extract-quasiquote-vars + x + (match-extract-quasiquote-vars-step y k i v d) i ())) + ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) + (match-extract-quasiquote-vars (x ...) k i v d)) + ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) + (k ... v)) + )) + +(define-syntax match-extract-quasiquote-vars-step + (syntax-rules () + ((_ x k i v d ((v2 v2-ls) ...)) + (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d)) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gimme some sugar baby. + +(define-syntax match-lambda + (syntax-rules () + ((_ clause ...) (lambda (expr) (match expr clause ...))))) + +(define-syntax match-lambda* + (syntax-rules () + ((_ clause ...) (lambda expr (match expr clause ...))))) + +(define-syntax match-let + (syntax-rules () + ((_ (vars ...) . body) + (match-let/helper let () () (vars ...) . body)) + ((_ loop . rest) + (match-named-let loop () . rest)))) + +(define-syntax match-letrec + (syntax-rules () + ((_ vars . body) (match-let/helper letrec () () vars . body)))) + +(define-syntax match-let/helper + (syntax-rules () + ((_ let ((var expr) ...) () () . body) + (let ((var expr) ...) . body)) + ((_ let ((var expr) ...) ((pat tmp) ...) () . body) + (let ((var expr) ...) + (match-let* ((pat tmp) ...) + . body))) + ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((a expr) . rest) . body) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)))) + +(define-syntax match-named-let + (syntax-rules () + ((_ loop ((pat expr var) ...) () . body) + (let loop ((var expr) ...) + (match-let ((pat var) ...) + . body))) + ((_ loop (v ...) ((pat expr) . rest) . body) + (match-named-let loop (v ... (pat expr tmp)) rest . body)))) + +(define-syntax match-let* + (syntax-rules () + ((_ () . body) + (begin . body)) + ((_ ((pat expr) . rest) . body) + (match expr (pat (match-let* rest . body)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Otherwise COND-EXPANDed bits. + +;; This *should* work, but doesn't :( +;; (define-syntax match-check-ellipse +;; (syntax-rules (...) +;; ((_ ... sk fk) sk) +;; ((_ x sk fk) fk))) + +;; This is a little more complicated, and introduces a new let-syntax, +;; but should work portably in any R[56]RS Scheme. Taylor Campbell +;; originally came up with the idea. +(define-syntax match-check-ellipse + (syntax-rules () + ;; these two aren't necessary but provide fast-case failures + ((match-check-ellipse (a . b) success-k failure-k) failure-k) + ((match-check-ellipse #(a ...) success-k failure-k) failure-k) + ;; matching an atom + ((match-check-ellipse id success-k failure-k) + (let-syntax ((ellipse? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipse? (foo id) sk fk) sk) + ((ellipse? other sk fk) fk)))) + ;; this list of three elements will only many the (foo id) list + ;; above if `id' is `...' + (ellipse? (a b c) success-k failure-k))))) + + +;; This is portable but can be more efficient with non-portable +;; extensions. This trick was originally discovered by Oleg Kiselyov. + +(define-syntax match-check-identifier + (syntax-rules () + ;; fast-case failures, lists and vectors are not identifiers + ((_ (x . y) success-k failure-k) failure-k) + ((_ #(x ...) success-k failure-k) failure-k) + ;; x is an atom + ((_ x success-k failure-k) + (let-syntax + ((sym? + (syntax-rules () + ;; if the symbol `abracadabra' matches x, then x is a + ;; symbol + ((sym? x sk fk) sk) + ;; otherwise x is a non-symbol datum + ((sym? y sk fk) fk)))) + (sym? abracadabra success-k failure-k))))) diff --git a/lib/chibi/net.module b/lib/chibi/net.module new file mode 100644 index 00000000..41cdafe4 --- /dev/null +++ b/lib/chibi/net.module @@ -0,0 +1,10 @@ + +(define-module (chibi net) + (export sockaddr? address-info? get-address-info socket connect with-net-io + address-info-family address-info-socket-type address-info-protocol + address-info-address address-info-address-length address-info-next) + (import-immutable (scheme)) + (import (chibi filesystem)) + (include-shared "net") + (include "net.scm")) + diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm new file mode 100644 index 00000000..85ed756a --- /dev/null +++ b/lib/chibi/net.scm @@ -0,0 +1,23 @@ +;; net.scm -- the high-level network interface +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (with-net-io host service proc) + (let lp ((addr (get-address-info host service #f))) + (if (not addr) + (error "couldn't find address" host service) + (let ((sock (socket (address-info-family addr) + (address-info-socket-type addr) + (address-info-protocol addr)))) + (if (negative? sock) + (lp (address-info-next addr)) + (if (negative? + (connect sock + (address-info-address addr) + (address-info-address-length addr))) + (lp (address-info-next addr)) + (let ((in (open-input-file-descriptor sock)) + (out (open-output-file-descriptor sock))) + (let ((res (proc in out))) + (close-input-port in) + res)))))))) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub new file mode 100644 index 00000000..0d72bc90 --- /dev/null +++ b/lib/chibi/net.stub @@ -0,0 +1,25 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/socket.h") +(c-system-include "netdb.h") + +(define-c-struct sockaddr + predicate: sockaddr?) + +(define-c-struct addrinfo + finalizer: freeaddrinfo + predicate: address-info? + (int ai_family address-info-family) + (int ai_socktype address-info-socket-type) + (int ai_protocol address-info-protocol) + ((link sockaddr) ai_addr address-info-address) + (size_t ai_addrlen address-info-address-length) + ((link addrinfo) ai_next address-info-next)) + +(define-c errno (get-address-info getaddrinfo) + (string string (maybe-null addrinfo) (result free addrinfo))) + +(define-c int bind (int sockaddr int)) +(define-c int listen (int int)) +(define-c int socket (int int int)) +(define-c int connect (int sockaddr int)) diff --git a/lib/chibi/pathname.module b/lib/chibi/pathname.module new file mode 100644 index 00000000..765ee189 --- /dev/null +++ b/lib/chibi/pathname.module @@ -0,0 +1,7 @@ + +(define-module (chibi pathname) + (export path-strip-directory path-directory path-extension-pos + path-extension path-strip-extension path-replace-extension + path-absolute? path-relative? path-normalize make-path) + (import-immutable (scheme)) + (include "pathname.scm")) diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm new file mode 100644 index 00000000..de27ad61 --- /dev/null +++ b/lib/chibi/pathname.scm @@ -0,0 +1,180 @@ +;; pathname.scm -- a general, non-host-specific path lib +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-scan-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (- i 1)))))) + +(define (string-skip c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (+ i 1))))))) + +(define (string-skip-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (- i 1)))))) + +;; POSIX basename +;; (define (path-strip-directory path) +;; (if (string=? path "") +;; path +;; (let ((end (string-skip-right #\/ path))) +;; (if (not end) +;; "/" +;; (let ((start (string-scan-right #\/ path (- end 1)))) +;; (substring path (if start (+ start 1) 0) (+ end 1))))))) + +;; GNU basename +(define (path-strip-directory path) + (if (string=? path "") + path + (let ((len (string-length path))) + (if (eqv? #\/ (string-ref path (- len 1))) + "" + (let ((slash (string-scan-right #\/ path))) + (if (not slash) + path + (substring path (+ slash 1) len))))))) + +(define (path-directory path) + (if (string=? path "") + "." + (let ((end (string-skip-right #\/ path))) + (if (not end) + "/" + (let ((start (string-scan-right #\/ path (- end 1)))) + (if (not start) + "." + (let ((start (string-skip-right #\/ path start))) + (if (not start) "/" (substring path 0 (+ start 1)))))))))) + +(define (path-extension-pos path) (string-scan-right #\. path)) + +(define (path-extension path) + (let ((i (path-extension-pos path))) + (and i + (let ((start (+ i 1)) (end (string-length path))) + (and (< start end) (substring path start end)))))) + +(define (path-strip-extension path) + (let ((i (path-extension-pos path))) + (if (and i (< (+ i 1) (string-length path))) + (substring path 0 i) + path))) + +(define (path-replace-extension path ext) + (string-append (path-strip-extension path) "." ext)) + +(define (path-absolute? path) + (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0)))) + +(define (path-relative? path) (not (path-absolute? path))) + +;; This looks big and hairy, but it's mutation-free and guarantees: +;; (string=? s (path-normalize s)) <=> (eq? s (path-normalize s)) +;; i.e. fast and simple for already normalized paths. + +(define (path-normalize path) + (let* ((len (string-length path)) (len-1 (- len 1))) + (define (collect i j res) + (if (>= i j) res (cons (substring path i j) res))) + (define (finish i res) + (if (zero? i) + path + (apply string-append (reverse (collect i len res))))) + ;; loop invariants: + ;; - res is a list such that (string-concatenate-reverse res) + ;; is always the normalized string up to j + ;; - the tail of the string from j onward can be concatenated to + ;; the above value to get a partially normalized path referring + ;; to the same location as the original path + (define (inside i j res) + (if (>= j len) + (finish i res) + (if (eqv? #\/ (string-ref path j)) + (boundary i (+ j 1) res) + (inside i (+ j 1) res)))) + (define (boundary i j res) + (if (>= j len-1) + (finish i res) + (case (string-ref path j) + ((#\.) + (case (string-ref path (+ j 1)) + ((#\.) + (if (or (>= j (- len 2)) (eqv? #\/ (string-ref path (+ j 2)))) + (if (>= i (- j 1)) + (if (null? res) + (backup j "" '()) + (backup j (car res) (cdr res))) + (backup j (substring path i j) res)) + (inside i (+ j 2) res))) + ((#\/) + (if (= i j) + (boundary (+ j 2) (+ j 2) res) + (let ((s (substring path i j))) + (boundary (+ j 2) (+ j 2) (cons s res))))) + (else (inside i (+ j 1) res)))) + ((#\/) (boundary (+ j 1) (+ j 1) (collect i j res))) + (else (inside i (+ j 1) res))))) + (define (backup j s res) + (let ((pos (+ j 3))) + (cond + ;; case 1: we're reduced to accumulating parents of the cwd + ((or (string=? s "/..") (string=? s "..")) + (boundary pos pos (cons "/.." (cons s res)))) + ;; case 2: the string isn't a component itself, skip it + ((or (string=? s "") (string=? s ".") (string=? s "/")) + (if (pair? res) + (backup j (car res) (cdr res)) + (boundary pos pos (if (string=? s "/") '("/") '(".."))))) + ;; case3: just take the directory of the string + (else + (let ((d (path-directory s))) + (cond + ((string=? d "/") + (boundary pos pos (if (null? res) '("/") res))) + ((string=? d ".") + (boundary pos pos res)) + (else (boundary pos pos (cons "/" (cons d res)))))))))) + ;; start with boundary if abs path, otherwise inside + (if (zero? len) + path + ((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '())))) + +(define (make-path . args) + (define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "not a valid path component" x)))) + (define (trim-trailing-slash s) + (let ((i (string-skip-right #\/ s))) + (if i (substring s 0 (+ i 1)) ""))) + (if (null? args) + "" + (let ((start (trim-trailing-slash (x->string (car args))))) + (let lp ((ls (cdr args)) + (res (if (string=? "" start) '() (list start)))) + (cond + ((null? ls) + (apply string-append (reverse res))) + ((pair? (car ls)) + (lp (append (car ls) (cdr ls)) res)) + (else + (let ((x (trim-trailing-slash (x->string (car ls))))) + (lp (cdr ls) + (if (string=? x "") res (cons x (cons "/" res))))))))))) diff --git a/lib/chibi/process.module b/lib/chibi/process.module new file mode 100644 index 00000000..fe03c2e5 --- /dev/null +++ b/lib/chibi/process.module @@ -0,0 +1,17 @@ + +(define-module (chibi process) + (export exit sleep alarm fork kill execute waitpid + set-signal-action! make-signal-set signal-set-contains? + signal-set-fill! signal-set-add! signal-set-delete! + current-signal-mask + signal-mask-block! signal-mask-unblock! signal-mask-set! + signal/hang-up signal/interrupt signal/quit + signal/illegal signal/abort signal/fpe + signal/kill signal/segv signal/pipe + signal/alarm signal/term signal/user1 + signal/user2 signal/child signal/continue + signal/stop signal/tty-stop signal/tty-input + signal/tty-output) + (import-immutable (scheme)) + (include-shared "process")) + diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub new file mode 100644 index 00000000..7dbca7eb --- /dev/null +++ b/lib/chibi/process.stub @@ -0,0 +1,72 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/wait.h") +(c-system-include "signal.h") +(c-system-include "unistd.h") + +(define-c-type siginfo_t + predicate: signal-info? + (int si_signo signal-number) + (int si_errno signal-error-number) + (int si_code signal-code) + (pid_t si_pid signal-pid) + (uid_t si_uid signal-uid) + (int si_status signal-status) + ;;(clock_t si_utime signal-user-time) + ;;(clock_t si_stime signal-system-time) + ) + +(define-c-type sigset_t + predicate: signal-set?) + +(define-c-const int (signal/hang-up "SIGHUP")) +(define-c-const int (signal/interrupt "SIGINT")) +(define-c-const int (signal/quit "SIGQUIT")) +(define-c-const int (signal/illegal "SIGILL")) +(define-c-const int (signal/abort "SIGABRT")) +(define-c-const int (signal/fpe "SIGFPE")) +(define-c-const int (signal/kill "SIGKILL")) +(define-c-const int (signal/segv "SIGSEGV")) +(define-c-const int (signal/pipe "SIGPIPE")) +(define-c-const int (signal/alarm "SIGALRM")) +(define-c-const int (signal/term "SIGTERM")) +(define-c-const int (signal/user1"SIGUSR1")) +(define-c-const int (signal/user2 "SIGUSR2")) +(define-c-const int (signal/child "SIGCHLD")) +(define-c-const int (signal/continue "SIGCONT")) +(define-c-const int (signal/stop "SIGSTOP")) +(define-c-const int (signal/tty-stop "SIGTSTP")) +(define-c-const int (signal/tty-input "SIGTTIN")) +(define-c-const int (signal/tty-output "SIGTTOU")) + +(c-include "signal.c") + +(define-c sexp (set-signal-action! "sexp_set_signal_action") + ((value ctx sexp) sexp sexp)) + +(define-c errno (make-signal-set "sigemptyset") ((result sigset_t))) +(define-c errno (signal-set-fill! "sigfillset") (sigset_t)) +(define-c errno (signal-set-add! "sigaddset") (sigset_t int)) +(define-c errno (signal-set-delete! "sigaddset") (sigset_t int)) +(define-c boolean (signal-set-contains? "sigismember") (sigset_t int)) + +(define-c errno (signal-mask-block! "sigprocmask") + ((value SIG_BLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-unblock! "sigprocmask") + ((value SIG_UNBLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-set! "sigprocmask") + ((value SIG_SETMASK int) sigset_t (value NULL sigset_t))) +(define-c errno (current-signal-mask "sigprocmask") + ((value SIG_BLOCK int) (value NULL sigset_t) (result sigset_t))) + +(define-c unsigned-int alarm (unsigned-int)) +(define-c unsigned-int sleep (unsigned-int)) + +(define-c pid_t fork ()) +;;(define-c pid_t wait ((result int))) +(define-c pid_t waitpid (int (result int) int)) +(define-c errno kill (int int)) +;;(define-c errno raise (int)) +(define-c void exit (int)) +(define-c int (execute execvp) (string (array string))) + diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c new file mode 100644 index 00000000..463e481d --- /dev/null +++ b/lib/chibi/signal.c @@ -0,0 +1,62 @@ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_MAX_SIGNUM 32 + +static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM]; + +static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { + sexp ctx, sigctx, handler; + sexp_gc_var1(args); + ctx = sexp_signal_contexts[signum]; + if (ctx) { + handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), + sexp_make_fixnum(signum)); + if (sexp_truep(handler)) { + sigctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve1(sigctx, args); + args = sexp_cons(sigctx, SEXP_FALSE, SEXP_NULL); + sexp_car(args) + = sexp_make_cpointer(sigctx, sexp_siginfo_t_type_id, info, SEXP_FALSE, 0); + args = sexp_cons(sigctx, SEXP_FALSE, args); + sexp_car(args) = sexp_make_fixnum(signum); + sexp_apply(sigctx, handler, args); + sexp_gc_release1(sigctx); + } + } +} + +static struct sigaction call_sigaction = { + .sa_sigaction = sexp_call_sigaction, + .sa_flags = SA_SIGINFO | SA_NODEFER +}; + +static struct sigaction call_sigdefault = {.sa_handler = SIG_DFL}; +static struct sigaction call_sigignore = {.sa_handler = SIG_IGN}; + +static sexp sexp_set_signal_action (sexp ctx, sexp signum, sexp newaction) { + int res; + sexp oldaction; + if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0 + && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) + return sexp_type_exception(ctx, "not a valid signal number", signum); + if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) + || sexp_booleanp(newaction))) + return sexp_type_exception(ctx, "not a procedure", newaction); + if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS))) + sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS) + = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE); + oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); + res = sigaction(sexp_unbox_fixnum(signum), + (sexp_booleanp(newaction) ? + (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore) + : &call_sigaction), + NULL); + if (res) + return sexp_user_exception(ctx, SEXP_FALSE, "couldn't set signal", signum); + sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction); + sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx; + return oldaction; +} + diff --git a/lib/chibi/system.module b/lib/chibi/system.module new file mode 100644 index 00000000..adc26ddc --- /dev/null +++ b/lib/chibi/system.module @@ -0,0 +1,15 @@ + +(define-module (chibi system) + (export user-information user-name user-password + user-id user-group-id user-gecos user-home user-shell + current-user-id current-group-id + current-effective-user-id current-effective-group-id + set-current-user-id! set-current-effective-user-id! + set-current-group-id! set-current-effective-group-id! + current-session-id create-session + set-root-directory!) + (import-immutable (scheme)) + (include-shared "system") + ;;(include "system.scm") + ) + diff --git a/lib/chibi/system.stub b/lib/chibi/system.stub new file mode 100644 index 00000000..7d4a836f --- /dev/null +++ b/lib/chibi/system.stub @@ -0,0 +1,34 @@ + +(c-system-include "unistd.h") +(c-system-include "pwd.h") +(c-system-include "sys/types.h") + +(define-c-struct passwd + predicate: user? + (string pw_name user-name) + (string pw_passwd user-password) + (uid_t pw_uid user-id) + (gid_t pw_gid user-group-id) + (string pw_gecos user-gecos) + (string pw_dir user-home) + (string pw_shell user-shell)) + +(define-c uid_t (current-user-id "getuid") ()) +(define-c gid_t (current-group-id "getgid") ()) +(define-c uid_t (current-effective-user-id "geteuid") ()) +(define-c gid_t (current-effective-group-id "getegid") ()) + +(define-c errno (set-current-user-id! "setuid") (uid_t)) +(define-c errno (set-current-effective-user-id! "seteuid") (uid_t)) +(define-c errno (set-current-group-id! "setgid") (gid_t)) +(define-c errno (set-current-effective-group-id! "setegid") (gid_t)) + +(define-c pid_t (current-session-id "getsid") ((default 0 pid_t))) +(define-c pid_t (create-session "setsid") ()) + +(define-c errno (set-root-directory! "chroot") (string)) + +;; (define-c errno getpwuid_r +;; (uid_t (result passwd) (result (array char arg3)) +;; (value 256 int) (result pointer passwd))) + diff --git a/lib/chibi/time.module b/lib/chibi/time.module new file mode 100644 index 00000000..84f2b800 --- /dev/null +++ b/lib/chibi/time.module @@ -0,0 +1,11 @@ + +(define-module (chibi time) + (export current-seconds get-time-of-day set-time-of-day! + seconds->time seconds->string time->seconds time->string + timeval-seconds timeval-microseconds + timezone-offset timezone-dst-time + time-second time-minute time-hour time-day time-month time-year + time-day-of-week time-day-of-year time-dst?) + (import-immutable (scheme)) + (include-shared "time")) + diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub new file mode 100644 index 00000000..bb5cd644 --- /dev/null +++ b/lib/chibi/time.stub @@ -0,0 +1,45 @@ + +(c-system-include "time.h") +(c-system-include "sys/time.h") + +(define-c-struct tm + (int tm_sec time-second) + (int tm_min time-minute) + (int tm_hour time-hour) + (int tm_mday time-day) + (int tm_mon time-month) + (int tm_year time-year) + (int tm_wday time-day-of-week) + (int tm_yday time-day-of-year) + (int tm_isdst time-dst?)) + +(define-c-struct timeval + predicate: timeval? + (time_t tv_sec timeval-seconds) + (int tv_usec timeval-microseconds)) + +(define-c-struct timezone + predicate: timezone? + (int tz_minuteswest timezone-offset) + (int tz_dsttime timezone-dst-time)) + +(define-c time_t (current-seconds "time") ((value NULL))) + +(define-c errno (get-time-of-day "gettimeofday") + ((result timeval) (result timezone))) + +(define-c errno (set-time-of-day! "settimeofday") + (timeval (maybe-null default NULL timezone))) + +(define-c non-null-pointer (seconds->time "localtime_r") + ((pointer time_t) (result tm))) + +(define-c time_t (time->seconds "mktime") + (tm)) + +(define-c non-null-string (seconds->string "ctime_r") + ((pointer time_t) (result (array char 64)))) + +(define-c non-null-string (time->string "asctime_r") + (tm (result (array char 64)))) + diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module new file mode 100644 index 00000000..2456dd9f --- /dev/null +++ b/lib/chibi/uri.module @@ -0,0 +1,10 @@ + +(define-module (chibi uri) + (export uri->string make-uri string->uri + uri-scheme uri-user uri-host uri-path uri-query uri-fragment + uri-with-scheme uri-with-user uri-with-host uri-with-path + uri-with-query uri-with-fragment + uri-encode uri-decode uri-query->alist uri-alist->query) + (import-immutable (scheme) + (srfi 9)) + (include "uri.scm")) diff --git a/lib/chibi/uri.scm b/lib/chibi/uri.scm new file mode 100644 index 00000000..41507961 --- /dev/null +++ b/lib/chibi/uri.scm @@ -0,0 +1,306 @@ +;; uri.scm -- URI parsing library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URI representation + +(define-record-type uri + (%make-uri scheme user host port path query fragment) + uri? + (scheme uri-scheme) + (user uri-user) + (host uri-host) + (port uri-port) + (path uri-path) + (query uri-query) + (fragment uri-fragment)) + +;; (make-uri scheme [user host port path query fragment]) +(define (make-uri scheme . o) + (let* ((user (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (host (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (port (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (path (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (query (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f))) + (%make-uri scheme user host port path query fragment))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils (don't feel like using SRFI-13 and these are more +;; specialised) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (string-scan-right str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i (- end 1))) + (and (>= i start) + (if (eqv? ch (string-ref str i)) + i + (lp (- i 1))))))) + +(define (string-index-of str pred . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond ((>= i end) #f) + ((pred (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase->symbol str) + (let ((len (string-length str))) + (let lp ((i 0)) + (cond + ((= i len) + (string->symbol str)) + ((char-upper-case? (string-ref str i)) + (let ((res (make-string len))) + (do ((j 0 (+ j 1))) + ((= j i)) + (string-set! res j (string-ref str j))) + (string-set! res i (char-downcase (string-ref str i))) + (do ((j (+ i 1) (+ j 1))) + ((= j len)) + (string-set! res j (char-downcase (string-ref str j)))) + (string->symbol res))) + (else + (lp (+ i 1))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; functional updaters (uses as much shared state as possible) + +(define (uri-with-scheme u scheme) + (%make-uri scheme (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-user u user) + (%make-uri (uri-scheme u) user (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-host u host) + (%make-uri (uri-scheme u) (uri-user u) host (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-port u port) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) port + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-path u path) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + path (uri-query u) (uri-fragment u))) + +(define (uri-with-query u query) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) query (uri-fragment u))) + +(define (uri-with-fragment u fragment) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) fragment)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parsing - without :// we just split into scheme & path + +(define (char-uri-scheme-unsafe? ch) + (not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\_ #\-))))) + +(define (string->path-uri scheme str . o) + (define decode? (and (pair? o) (car o))) + (define decode (if decode? uri-decode (lambda (x) x))) + (define decode-query + (if (and (pair? o) (pair? (cdr o)) (cadr o)) + uri-query->alist + decode)) + (if (pair? str) + str + (let* ((len (string-length str)) + (colon0 (string-scan str #\:)) + (colon + (and (not (string-index-of str char-uri-scheme-unsafe? + 0 (or colon0 len))) + colon0))) + (if (or (not colon) (zero? colon)) + (and scheme + (let* ((quest (string-scan str #\? 0)) + (pound (string-scan str #\# (or quest 0)))) + (make-uri scheme #f #f #f + (decode (substring str 0 (or quest pound len))) + (and quest + (decode-query + (substring str (+ quest 1) (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len)))))) + (let ((sc1 (+ colon 1)) + (scheme (string-downcase->symbol (substring str 0 colon)))) + (if (= sc1 len) + (make-uri scheme) + (if (or (>= (+ sc1 1) len) + (not (and (eqv? #\/ (string-ref str sc1)) + (eqv? #\/ (string-ref str (+ sc1 1)))))) + (make-uri scheme #f #f #f (substring str sc1 len)) + (if (>= (+ sc1 2) len) + (make-uri scheme #f "") + (let* ((sc2 (+ sc1 2)) + (slash (string-scan str #\/ sc2)) + (sc3 (or slash len)) + (at (string-scan-right str #\@ sc2 sc3)) + (colon3 (string-scan str #\: (or at sc2) sc3)) + (quest (string-scan str #\? sc3)) + (pound (string-scan str #\# (or quest sc3)))) + (%make-uri + scheme + (and at (decode (substring str sc2 at))) + (decode + (substring str + (if at (+ at 1) sc2) + (or colon3 sc3))) + (and colon3 + (string->number + (substring str (+ colon3 1) sc3))) + (and slash + (decode + (substring str slash (or quest pound len)))) + (and quest + (decode-query + (substring str (+ quest 1) + (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len))) + )))))))))) + +(define (string->uri str . o) + (apply string->path-uri #f str o)) + +(define (uri->string uri . o) + (define encode? (and (pair? o) (car o))) + (define encode (if encode? uri-encode (lambda (x) x))) + (if (string? uri) + uri + (let ((fragment (uri-fragment uri)) + (query (uri-query uri)) + (path (uri-path uri)) + (port (uri-port uri)) + (host (uri-host uri)) + (user (uri-user uri))) + (string-append + (symbol->string (uri-scheme uri)) ":" + (if (or user host port) "//" "") + (if user (encode user) "") (if user "@" "") + (or host "") ; host shouldn't need encoding + (if port ":" "") (if port (number->string port) "") + (if path (encode path) "") + (if query "?" "") + (if (pair? query) (uri-alist->query query) (or query "")) + (if fragment "#" "") (if fragment (encode fragment) ""))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; query encoding and decoding + +(define (uri-safe-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (case ch + ((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t) + (else #f)))) + +(define (collect str from to res) + (if (>= from to) + res + (cons (substring str from to) res))) + +(define (uri-encode str . o) + (define (encode-1-space ch) + (if (eqv? ch #\space) + "+" + (encode-1-normal ch))) + (define (encode-1-normal ch) + (let* ((i (char->integer ch)) + (hex (number->string i 16))) + (if (< i 16) + (string-append "%0" hex) + (string-append "%" hex)))) + (let ((start 0) + (end (string-length str)) + (encode-1 (if (and (pair? o) (car o)) + encode-1-space + encode-1-normal))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (if (uri-safe-char? ch) + (lp from next res) + (lp next next (cons (encode-1 ch) + (collect str from to res))))))))) + +(define (uri-decode str . o) + (let ((space-as-plus? (and (pair? o) (car o))) + (start 0) + (end (string-length str))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (cond + ((eqv? ch #\%) + (if (>= next end) + (lp next next (collect str from to res)) + (let ((next2 (+ next 1))) + (if (>= next2 end) + (lp next2 next2 (collect str from to res)) + (let* ((next3 (+ next2 1)) + (hex (substring str next next3)) + (i (string->number hex 16))) + (lp next3 next3 (cons (string (integer->char i)) + (collect str from to res)))))))) + ((and space-as-plus? (eqv? ch #\+)) + (lp next next (cons " " (collect str from to res)))) + (else + (lp from next res)))))))) + +(define (uri-query->alist str . o) + (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;))) + (let ((len (string-length str)) + (plus? (and (pair? o) (car o)))) + (let lp ((i 0) (res '())) + (if (>= i len) + (reverse res) + (let* ((j (or (string-index-of str split-char? i) len)) + (k (string-scan str #\= i j)) + (cell (if k + (cons (uri-decode (substring str i k) plus?) + (uri-decode (substring str (+ k 1) j) plus?)) + (cons (uri-decode (substring str i j) plus?) #f)))) + (lp (+ j 1) (cons cell res))))))) + +(define (uri-alist->query ls . o) + (define plus? (and (pair? o) (car o))) + (define (encode key val res) + (let ((res (cons (uri-encode key plus?) res))) + (if val (cons (uri-encode val plus?) (cons "=" res)) res))) + (if (null? ls) + "" + (let lp ((x (car ls)) (ls (cdr ls)) (res '())) + (let ((res (encode (car x) (cdr x) res))) + (if (null? ls) + (string-concatenate (reverse res)) + (lp (car ls) (cdr ls) (cons "&" res))))))) diff --git a/lib/config.scm b/lib/config.scm new file mode 100644 index 00000000..1254360d --- /dev/null +++ b/lib/config.scm @@ -0,0 +1,174 @@ +;; config.scm -- configuration module +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *this-module* '()) + +(define (make-module exports env meta) (vector exports env meta)) +(define (%module-exports mod) (vector-ref mod 0)) +(define (module-env mod) (vector-ref mod 1)) +(define (module-meta-data mod) (vector-ref mod 2)) +(define (module-env-set! mod env) (vector-set! mod 1 env)) + +(define (module-exports mod) + (or (%module-exports mod) (env-exports (module-env mod)))) + +(define (module-name->strings ls res) + (if (null? ls) + res + (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls))) + ((number? (car ls)) (number->string (car ls))) + ((string? (car ls)) (car ls)) + (else (error "invalid module name" (car ls)))))) + (module-name->strings (cdr ls) (cons "/" (cons str res)))))) + +(define (module-name->file name) + (string-concatenate + (reverse (cons ".module" (cdr (module-name->strings name '())))))) + +(define (module-name-prefix name) + (string-concatenate (reverse (cdr (cdr (module-name->strings name '())))))) + +(define (load-module-definition name) + (let* ((file (module-name->file name)) + (path (find-module-file file))) + (if path (load path *config-env*)))) + +(define (find-module name) + (cond + ((assoc name *modules*) => cdr) + (else + (load-module-definition name) + (cond ((assoc name *modules*) => cdr) + (else #f))))) + +(define (symbol-append a b) + (string->symbol (string-append (symbol->string a) (symbol->string b)))) + +(define (to-id id) (if (pair? id) (car id) id)) +(define (from-id id) (if (pair? id) (cdr id) id)) +(define (id-filter pred ls) + (cond ((null? ls) '()) + ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls)))) + (else (id-filter pred (cdr ls))))) + +(define (resolve-import x) + (cond + ((not (and (pair? x) (list? x))) + (error "invalid module syntax" x)) + ((and (pair? (cdr x)) (pair? (cadr x))) + (if (memq (car x) '(only except rename)) + (let* ((mod-name+imports (resolve-import (cadr x))) + (imp-ids (cdr mod-name+imports)) + (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x)))) + (begin + (set-cdr! mod-name+imports + (module-exports + (find-module (car mod-name+imports)))) + (cdr mod-name+imports)) + imp-ids))) + (cons (car mod-name+imports) + (case (car x) + ((only) + (if (not imp-ids) + (cddr x) + (id-filter (lambda (i) (memq i (cddr x))) imp-ids))) + ((except) + (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids)) + ((rename) + (map (lambda (i) + (let ((rename (assq (to-id i) (cddr x)))) + (if rename (cons (cdr rename) (from-id i)) i))) + imp-ids))))) + (error "invalid import modifier" x))) + ((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x))) + (let ((mod-name+imports (resolve-import (caddr x)))) + (cons (car mod-name+imports) + (map (lambda (i) + (cons (symbol-append (cadr x) (if (pair? i) (car i) i)) + (if (pair? i) (cdr i) i))) + (cdr mod-name+imports))))) + ((find-module x) + => (lambda (mod) (cons x (%module-exports mod)))) + (else + (error "couldn't find import" x)))) + +(define (eval-module name mod) + (let ((env (make-environment)) + (dir (module-name-prefix name))) + (for-each + (lambda (x) + (case (and (pair? x) (car x)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2 (load-module (car mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports) + (eq? (car x) 'import-immutable)))) + (cdr x))) + ((include include-shared) + (for-each + (lambda (f) + (let ((f (string-append + dir f + (if (eq? (car x) 'include) "" *shared-object-extension*)))) + (cond + ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + (cdr x))) + ((body) + (for-each (lambda (expr) (eval expr env)) (cdr x))))) + (module-meta-data mod)) + env)) + +(define (load-module name) + (let ((mod (find-module name))) + (if (and mod (not (module-env mod))) + (module-env-set! mod (eval-module name mod))) + mod)) + +(define-syntax define-module + (er-macro-transformer + (lambda (expr rename compare) + (let ((name (cadr expr)) + (body (cddr expr))) + `(let ((tmp *this-module*)) + (set! *this-module* '()) + ,@body + (set! *this-module* (reverse *this-module*)) + (let ((exports + (cond ((assq 'export *this-module*) => cdr) + (else '())))) + (set! *modules* + (cons (cons ',name (make-module exports #f *this-module*)) + *modules*))) + (set! *this-module* tmp)))))) + +(define-syntax define-config-primitive + (er-macro-transformer + (lambda (expr rename compare) + `(define-syntax ,(cadr expr) + (er-macro-transformer + (lambda (expr rename compare) + `(set! *this-module* (cons ',expr *this-module*)))))))) + +(define-config-primitive import) +(define-config-primitive import-immutable) +(define-config-primitive export) +(define-config-primitive include) +(define-config-primitive include-shared) +(define-config-primitive body) + +(define *modules* + (list (cons '(scheme) (make-module #f (interaction-environment) '())) + (cons '(srfi 0) (make-module (list 'cond-expand) + (interaction-environment) + (list (list 'export 'cond-expand)))) + (cons '(srfi 46) (make-module (list 'syntax-rules) + (interaction-environment) + (list (list 'export 'syntax-rules)))))) + diff --git a/lib/init.scm b/lib/init.scm new file mode 100644 index 00000000..cd50ad37 --- /dev/null +++ b/lib/init.scm @@ -0,0 +1,881 @@ +;; init.scm -- R5RS library procedures +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; 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 f ls . lol) + (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls))))) + (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f)))) + +(define (any pred ls) + (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f)) + +(define (every pred ls) + (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t)) + +(define (delq x ls) + (if (pair? ls) + (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls)))) + '())) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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) + (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 (rename 'else) (car cl)) + (if (pair? (cddr expr)) + (error "non-final else in cond" expr) + (cons (rename 'begin) (cdr cl))) + (if (if (null? (cdr cl)) #t (compare (rename '=>) (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 + ((compare (rename 'unquote) (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((compare (rename '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))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (compare (rename '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 (null? (cdr expr)) (error "empty let" expr)) + (if (null? (cddr expr)) (error "no let body" expr)) + ((lambda (bindings) + (if (list? bindings) #f (error "bad let bindings")) + (if (every (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + bindings) + (if (identifier? (cadr expr)) + `(,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,(map car bindings) + ,@(cdddr expr)))) + ,(cons (cadr expr) (map cadr bindings))) + `((,(rename 'lambda) ,(map car bindings) ,@(cddr expr)) + ,@(map cadr bindings))) + (error "bad let syntax" expr))) + (if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let*" expr)) + (if (null? (cddr expr)) (error "no let* body" expr)) + (if (null? (cadr expr)) + `(,(rename 'let) () ,@(cddr expr)) + (if (if (list? (cadr expr)) + (every + (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + (cadr expr)) + #f) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))) + (error "bad let* syntax")))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare (rename '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)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; promises + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exceptions + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f))) + +(define (with-exception-handler handler thunk) + (letrec ((orig-handler (current-exception-handler)) + (self (lambda (exn) + (current-exception-handler orig-handler) + (let ((res (handler exn))) + (current-exception-handler self) + res)))) + (current-exception-handler self) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; library functions + +;; 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 . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (and (pair? ls) (if (eq obj (car ls)) ls (lp (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 (if (bignum? 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 (numerator x) + (if (integer? x) x (numerator (* x 10)))) +(define (denominator x) + (if (exact? x) + 1 + (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10)))))) + +(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) + (if (<= n 9) + (integer->char (+ n (char->integer #\0))) + (integer->char (+ (- n 10) (char->integer #\A))))) +(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)) + (if (null? res) "0" (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 (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-output-port)) + (tmp-out (open-output-file file))) + (current-output-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)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dynamic-wind + +(define *dk* (list #f)) + +(define (dynamic-wind before thunk after) + (let ((dk *dk*)) + (set-dk! (cons (cons before after) dk)) + (let ((res (thunk))) (set-dk! dk) res))) + +(define (set-dk! dk) + (if (not (eq? dk *dk*)) + (begin + (set-dk! (cdr dk)) + (let ((before (car (car dk))) (dk dk)) + (set-car! *dk* (cons (cdr (car dk)) before)) + (set-cdr! *dk* dk) + (set-car! dk #f) + (set-cdr! dk '()) + (set! *dk* dk) + (before))))) + +(define (call-with-current-continuation proc) + (let ((dk *dk*)) + (%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((ellipse-specified? (identifier? (cadr 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 'syntax-quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_len (rename'len)) (_length (rename 'length)) + (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error)) + (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define ellipse (rename (if ellipse-specified? (cadr expr) '...))) + (define lits (if ellipse-specified? (caddr expr) (cadr expr))) + (define forms (if ellipse-specified? (cdddr expr) (cddr expr))) + (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))) + (cond + ((not (list? (cddr p))) + (error "dotted ellipse" p)) + ((any (lambda (x) (and (identifier? x) (compare x ellipse))) + (cddr p)) + (error "multiple ellipses" p)) + (else + (let ((len (length (cdr (cdr p))))) + `(,_let ((,_len (,_length ,v))) + (,_and (,_>= ,_len ,len) + (,_let ,_lp ((,_ls ,v) + (,_i (,_- ,_len ,len)) + (,_res (,_quote ()))) + (,_if (,_>= 0 ,_i) + ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p))) + `(,_append ,_ls (,_reverse ,_res)) + dim + vars + k) + (,_lp (,_cdr ,_ls) + (,_- ,_i 1) + (,_cons (,_car ,_ls) ,_res)))))))))) + ((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-escape? x) (and (pair? x) (compare ellipse (car x)))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare ellipse (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 (any (lambda (lit) (compare x lit)) 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 + ((any (lambda (v) (compare t (car v))) vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (cond + ((ellipse-escape? t) + (if (pair? (cdr t)) + (if (pair? (cddr t)) (cddr t) (cadr t)) + (cdr t))) + ((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))))))) + (else (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 for" + (list (rename 'strip-syntactic-closures) _expr))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *config-env* #f) + +(define-syntax import + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (res '())) + (cond + ((null? ls) + (cons 'begin (reverse res))) + (else + (let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*))) + (if (pair? mod+imps) + (lp (cdr ls) + (cons `(%env-copy! + #f + (vector-ref + (eval '(load-module ',(car mod+imps)) *config-env*) + 1) + ',(cdr mod+imps) + #f) + res)) + (error "couldn't find module" (car ls)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SRFI-0 + +(define-syntax cond-expand + (er-macro-transformer + (lambda (expr rename compare) + (define (check x) + (if (pair? x) + (case (car x) + ((and) (every check (cdr x))) + ((or) (any check (cdr x))) + ((not) (not (check (cadr x)))) + (else (error "cond-expand: bad feature" x))) + (memq (identifier->symbol x) *features*))) + (let expand ((ls (cdr expr))) + (cond ((null? ls) (error "cond-expand: no expansions" expr)) + ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) + ((eq? 'else (identifier->symbol (caar ls))) + (if (pair? (cdr ls)) + (error "cond-expand: else in non-final position") + `(,(rename 'begin) ,@(cdar ls)))) + ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) + (else (expand (cdr ls)))))))) + diff --git a/lib/srfi/1.module b/lib/srfi/1.module new file mode 100644 index 00000000..3d3da044 --- /dev/null +++ b/lib/srfi/1.module @@ -0,0 +1,31 @@ + +(define-module (srfi 1) + (export + xcons cons* make-list list-tabulate list-copy circular-list iota + proper-list? circular-list? dotted-list? not-pair? null-list? list= + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr take drop take-right drop-right take! drop-right! split-at split-at! + last last-pair length+ concatenate append! concatenate! reverse! + append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 count + fold unfold pair-fold reduce fold-right unfold-right + pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter partition remove filter! partition! remove! find find-tail any every + list-index take-while drop-while take-while! span break span! break! + delete delete-duplicates delete! delete-duplicates! + alist-cons alist-copy alist-delete alist-delete! + lset<= lset= lset-adjoin lset-union lset-union! lset-intersection + lset-intersection! lset-difference lset-difference! lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection!) + (import (scheme)) + (include "1/predicates.scm" + "1/selectors.scm" + "1/search.scm" + "1/misc.scm" + "1/constructors.scm" + "1/fold.scm" + "1/deletion.scm" + "1/alists.scm" + "1/lset.scm")) + diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm new file mode 100644 index 00000000..a35db42c --- /dev/null +++ b/lib/srfi/1/alists.scm @@ -0,0 +1,14 @@ +;; alist.scm -- association list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (alist-cons key value ls) (cons (cons key value) ls)) + +(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls)) + +(define (alist-delete key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (remove (lambda (x) (eq (car x) key)) ls))) + +(define alist-delete! alist-delete) + diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm new file mode 100644 index 00000000..e205cee0 --- /dev/null +++ b/lib/srfi/1/constructors.scm @@ -0,0 +1,36 @@ +;; constructors.scm -- list construction utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (xcons a b) (cons b a)) + +(define (cons* x . args) + (let lp ((rev '()) (x x) (ls args)) + (if (null? ls) + (append-reverse rev x) + (lp (cons x rev) (car ls) (cdr ls))))) + +(define (make-list n . o) + (let ((default (if (pair? o) (car o)))) + (let lp ((n n) (res '())) + (if (<= n 0) res (lp (- n 1) (cons default res)))))) + +(define (list-tabulate n proc) + (let lp ((n n) (res '())) + (if (< n 0) res (lp (- n 1) (cons (proc n) res))))) + +(define (list-copy ls) (reverse! (reverse ls))) + +(define (circular-list x . args) + (let ((res (cons x args))) + (set-cdr! (last-pair res) res) + res)) + +(define (iota count . o) + (let ((start (if (pair? o) (car o) count)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) + (let lp ((i count) (n (- start step)) (res '())) + (if (<= i 0) + res + (lp (- i 1) (- n step) (cons n res)))))) + diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm new file mode 100644 index 00000000..70ee5cc5 --- /dev/null +++ b/lib/srfi/1/deletion.scm @@ -0,0 +1,25 @@ +;; deletion.scm -- list deletion utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (delete x ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (if (eq? eq eq?) + (let lp ((ls ls) (rev '())) ;; fast path for delq + (let ((tail (memq x ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls)))) + (filter (lambda (y) (eq x y)) ls)))) + +(define delete! delete) + +(define (delete-duplicates ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res))) + (reverse! res))))) + +(define delete-duplicates! delete-duplicates) + diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm new file mode 100644 index 00000000..892b075c --- /dev/null +++ b/lib/srfi/1/fold.scm @@ -0,0 +1,115 @@ +;; fold.scm -- list fold/reduce utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (map-onto car lists (list acc)))) + acc)))) + +(define (fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (map-onto car lists (lp (map cdr lists)))) + knil)))) + +(define (pair-fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (append lists (list acc)))) + acc)))) + +(define (pair-fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (append lists (lp (map cdr lists)))) + knil)))) + +(define (reduce f identity ls) + (if (null? ls) identity (fold f (car ls) (cdr ls)))) + +(define (reduce-right f identity ls) + (if (null? ls) identity (fold-right f (car ls) (cdr ls)))) + +(define (unfold p f g seed . o) + (let lp ((seed seed)) + (if (p seed) + (if (pair? o) ((car o) seed) '()) + (cons (f seed) (lp (g seed)))))) + +(define (unfold-right p f g seed . o) + (let lp ((seed seed) (res (if (pair? o) (car o) '()))) + (if (p seed) res (lp (g seed) (cons (f seed) res))))) + +(define (append-map-helper append f ls lists) + (if (null? lists) + (if (null? ls) + '() + (let ((rev-ls (reverse ls))) + (let lp ((ls (cdr rev-ls)) (res (car rev-ls))) + (if (null? ls) res (lp (cdr ls) (append (f (car ls) res)))) + ))) + (if (and (pair? ls) (every pair? lists)) + (let lp ((lists (cons ls lists))) + (let ((vals (apply f (map car lists))) + (cdrs (map cdr lists))) + (if (every pair? cdrs) (append vals (lp cdrs)) vals))) + '()))) + +(define (append-map f ls . lists) + (append-map-helper append f ls lists)) + +(define (append-map! f ls . lists) + (append-map-helper append! f ls lists)) + +(define map! map) +(define map-in-order map) + +(define (pair-for-each f ls . lists) + (apply pair-fold (lambda (x _) (f x)) ls lists)) + +(define (filter-map f ls . lists) + (if (null? lists) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res))) + (reverse! res))) + (filter (lambda (x) x) (apply map f ls lists)))) + +(define (take-up-to-reverse from to init) + (if (eq? from to) + init + (take-up-to-reverse (cdr from) to (cons (car from) init)))) + +(define (remove pred ls) + (let lp ((ls ls) (rev '())) + (let ((tail (find-tail pred ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls))))) + +(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls)) + +(define (partition pred ls) + (let lp ((ls ls) (good '()) (bad '())) + (cond ((null? ls) (values (reverse! good) (reverse! bad))) + ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad)) + (else (lp (cdr ls) good (cons (car ls) bad)))))) + +(define filter! filter) +(define remove! remove) +(define partition! partition) + diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm new file mode 100644 index 00000000..f2ffc4ae --- /dev/null +++ b/lib/srfi/1/lset.scm @@ -0,0 +1,51 @@ +;; lset.scm -- list set library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (lset<= eq . sets) + (if (null? sets) + #t + (let lp1 ((set1 (car sets)) (sets (cdr sets))) + (if (null? sets) + #t + (let ((set2 (car sets))) + (let lp2 ((ls set1)) + (if (pair? ls) + (and (member (car set1) set2 eq) (lp2 (cdr ls))) + (lp1 set2 (cdr sets))))))))) + +(define (lset= eq . sets) + (and (apply lset<= eq sets) (apply lset<= eq (reverse sets)))) + +(define (lset-adjoin eq set . elts) + (lset-union2 eq elts set)) + +(define (lset-union2 eq a b) + (if (null? b) + a + (lset-union2 (cdr b) (if (member (car b) a eq) a (cons (car b) a))))) + +(define (lset-union eq . sets) + (reduce (lambda (a b) (lset-union2 eq a b)) '() sets)) + +(define (lset-intersection eq . sets) + (reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-difference eq . sets) + (reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-xor eq . sets) + (reduce (lambda (a b) + (append (filter (lambda (x) (member x b eq)) a) + (filter (lambda (x) (member x a eq)) b))) + '() + sets)) + +(define (lset-diff+intersection eq . sets) + (values (apply lset-difference eq sets) (apply lset-intersection eq sets))) + +(define lset-diff+intersection! lset-diff+intersection) +(define lset-xor! lset-xor) +(define lset-difference! lset-difference) +(define lset-intersection! lset-intersection) +(define lset-union! lset-union) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm new file mode 100644 index 00000000..1e7568df --- /dev/null +++ b/lib/srfi/1/misc.scm @@ -0,0 +1,54 @@ +;; misc.scm -- miscellaneous list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (map-onto proc ls init) + (let lp ((ls ls) (res init)) + (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res))))) + +(define (append! . lists) (concatenate! lists)) + +(define (concatenate lists) + (let lp ((ls (reverse lists)) (res '())) + (if (null? ls) res (lp (cdr ls) (append (car ls) res))))) + +(define (concatenate! lists) + (if (null? lists) + '() + (let lp ((ls lists)) + (cond ((not (pair? (cdr ls))) + lists) + (else + (set-cdr! (last-pair (car ls)) (cadr ls)) + (lp (cdr ls))))))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define (append-reverse! rev tail) + (if (null? rev) + tail + (let ((head (reverse! rev))) + (set-cdr! rev tail) + head))) + +(define (zip . lists) (apply map list lists)) + +(define (unzip1 ls) (map car ls)) +(define (unzip2 ls) (values (map car ls) (map cadr ls))) +(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls))) +(define (unzip4 ls) + (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) +(define (unzip5 ls) + (values (map car ls) (map cadr ls) (map caddr ls) + (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls))) + +(define (count pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (res 0)) + (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res)) + (let lp ((lists (cons ls lists)) (res 0)) + (if (every pair? lists) + (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res)) + res)))) + diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm new file mode 100644 index 00000000..be84e085 --- /dev/null +++ b/lib/srfi/1/predicates.scm @@ -0,0 +1,42 @@ +;; predicates.scm -- list prediates +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (proper-list? x) + (cond ((null? x) #t) + ((pair? x) (proper-list? (cdr x))) + (else #f))) + +(define (circular-list? x) + (and (pair? x) (pair? (cdr x)) + (let race ((hare (cdr x)) (tortoise x)) + (or (eq? hare tortoise) + (and (pair? hare) (pair? (cdr hare)) + (race (cddr hare) (cdr tortoise))))))) + +(define (dotted-list? x) + (not (proper-list? x))) + +(define (not-pair? x) (not (pair? x))) + +(define (null-list? x) (null? x)) ; no error + +(define (list= eq . lists) + (let lp1 ((lists lists)) + (or (null? lists) + (null? (cdr lists)) + (let lp2 ((ls1 (car lists)) (ls2 (cadr lists))) + (if (null? ls1) + (and (null? ls2) + (lp1 (cdr lists))) + (and (eq (car ls1) (car ls2)) + (lp2 (cdr ls1) (cdr ls2)))))))) + +(define (length+ x) + (if (not (pair? x)) + 0 + (let lp ((hare (cdr x)) (tortoise x) (res 0)) + (and (not (eq? hare tortoise)) + (if (pair? hare) + (lp (cddr hare) (cdr tortoise) (+ res 1)) + res))))) diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm new file mode 100644 index 00000000..ea31d931 --- /dev/null +++ b/lib/srfi/1/search.scm @@ -0,0 +1,54 @@ +;; search.scm -- list searching and splitting +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (find pred ls) + (cond ((find-tail pred ls) => car) (else #f))) + +(define (find-tail pred ls) + (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls))))) + +(define (take-while pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (reverse! res)))) + +(define take-while! take-while) + +(define (drop-while pred ls) + (or (find-tail (lambda (x) (not (pred x))) ls) '())) + +(define (span pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (values (reverse! res) ls)))) + +(define span! span) + +(define (break pred ls) (span (lambda (x) (not (pred x))) ls)) + +(define break! break) + +(define (any pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls))))) + (let lp ((lists (cons ls lists))) + (and (every pair? lists) + (let ((args (map car lists))) + (if (apply pred args) args (lp (map cdr lists)))))))) + +(define (every pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t)) + (not (apply any (lambda (x) (not (pred x))) ls lists)))) + +(define (list-index pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (n 0)) + (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1))))) + (let lp ((lists (cons ls lists)) (n 0)) + (and (every pair? lists) + (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1))) + )))) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm new file mode 100644 index 00000000..74ef7119 --- /dev/null +++ b/lib/srfi/1/selectors.scm @@ -0,0 +1,59 @@ +;; selectors.scm -- extended list selectors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth ls) (car (cdr (cdr (cdr (cdr ls)))))) +(define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls))))))) +(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (eighth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (ninth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))) +(define (tenth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))) + +(define (car+cdr x) (values (car x) (cdr x))) + +(define (take ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (reverse! res) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (take! ls i) + (if (<= i 0) + '() + (let ((tail (list-tail ls (- i 1)))) + (set-cdr! tail '()) + ls))) + +(define (drop ls i) + (if (<= i 0) ls (drop (cdr ls) (- i 1)))) + +(define (take-right ls i) + (drop ls (- (length+ ls) i))) + +(define (drop-right ls i) + (take ls (- (length+ ls) i))) + +(define (drop-right! ls i) + (take! ls (- (length+ ls) i))) + +(define (split-at ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (values (reverse! res) ls) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (split-at! ls i) + (if (<= i 0) + (values '() ls) + (let* ((tail (list-tail ls (- i 1))) + (right (cdr tail))) + (set-cdr! tail '()) + (values ls right)))) + +(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls)))) +(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls)))) + diff --git a/lib/srfi/11.module b/lib/srfi/11.module new file mode 100644 index 00000000..f3c91df8 --- /dev/null +++ b/lib/srfi/11.module @@ -0,0 +1,28 @@ + +(define-module (srfi 11) + (export let-values let*-values) + (import-immutable (scheme)) + (body + (define-syntax let*-values + (syntax-rules () + ((let*-values () . body) + (begin . body)) + ((let*-values (((a) expr) . rest) . body) + (let ((a expr)) (let*-values rest . body))) + ((let*-values ((params expr) . rest) . body) + (call-with-values (lambda () expr) + (lambda params (let*-values rest . body)))))) + (define-syntax let-values + (syntax-rules () + ((let-values ("step") (binds ...) bind expr maps () () . body) + (let*-values (binds ... (bind expr)) (let maps . body))) + ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body) + (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body) + (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body) + (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body)) + ((let-values ((params expr) . rest) . body) + (let-values ("step") () () expr () params rest . body)) + )))) + diff --git a/lib/srfi/16.module b/lib/srfi/16.module new file mode 100644 index 00000000..f931a376 --- /dev/null +++ b/lib/srfi/16.module @@ -0,0 +1,24 @@ + +(define-module (srfi 16) + (export case-lambda) + (import-immutable (scheme)) + (body + (define-syntax %case + (syntax-rules () + ((%case args len n p ((params ...) . body) . rest) + (if (= len (length '(params ...))) + (apply (lambda (params ...) . body) args) + (%case args len 0 () . rest))) + ((%case args len n (p ...) ((x . y) . body) . rest) + (%case args len (+ n 1) (p ... x) (y . body) . rest)) + ((%case args len n (p ...) (y . body) . rest) + (if (>= len n) + (apply (lambda (p ... y) . body) args) + (%case args len 0 () . rest))) + ((%case args len n p) + (error "case-lambda: no cases matched")))) + (define-syntax case-lambda + (syntax-rules () + ((case-lambda . clauses) + (lambda args (let ((len (length args))) (%case args len 0 () . clauses)))))))) + diff --git a/lib/srfi/2.module b/lib/srfi/2.module new file mode 100644 index 00000000..4ceb8b6b --- /dev/null +++ b/lib/srfi/2.module @@ -0,0 +1,16 @@ + +(define-module (srfi 2) + (export and-let*) + (import-immutable (scheme)) + (body + (define-syntax and-let* + (syntax-rules () + ((and-let* () . body) + (begin . body)) + ((and-let* ((var expr) . rest) . body) + (let ((var expr)) + (and var (and-let* rest . body)))) + ((and-let* ((expr) . rest) . body) + (let ((tmp expr)) + (and tmp (and-let* rest . body)))))))) + diff --git a/lib/srfi/26.module b/lib/srfi/26.module new file mode 100644 index 00000000..f97ab783 --- /dev/null +++ b/lib/srfi/26.module @@ -0,0 +1,24 @@ + +(define-module (srfi 26) + (export cut cute) + (import-immutable (scheme)) + (body + (define-syntax %cut + (syntax-rules (<> <...>) + ((%cut e? params args) + (lambda params args)) + ((%cut e? (params ...) (args ...) <> . rest) + (%cut e? (params ... tmp) (args ... tmp) . rest)) + ((%cut e? (params ...) (args ...) <...>) + (%cut e? (params ... . tmp) (apply args ... tmp))) + ((%cut e? (params ...) (args ...) <...> . rest) + (error "cut: non-terminal <...>")) + ((%cut #t (params ...) (args ...) x . rest) + (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest))) + ((%cut #f (params ...) (args ...) x . rest) + (%cut #t (params ...) (args ... x) . rest)))) + (define-syntax cut + (syntax-rules () ((cut args ...) (%cut #f () () args ...)))) + (define-syntax cute + (syntax-rules () ((cute args ...) (%cut #t () () args ...)))))) + diff --git a/lib/srfi/27.module b/lib/srfi/27.module new file mode 100644 index 00000000..5c451629 --- /dev/null +++ b/lib/srfi/27.module @@ -0,0 +1,11 @@ + +(define-module (srfi 27) + (export random-integer random-real default-random-source + make-random-source random-source? + random-source-state-ref random-source-state-set! + random-source-randomize! random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals) + (import-immutable (scheme)) + (include-shared "27/rand") + (include "27/constructors.scm")) + diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm new file mode 100644 index 00000000..dbd0a8c6 --- /dev/null +++ b/lib/srfi/27/constructors.scm @@ -0,0 +1,10 @@ +;; constructors.scm -- random function constructors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (random-source-make-integers rs) + (lambda (n) (%random-integer rs n))) + +(define (random-source-make-reals rs . o) + (lambda () (%random-real rs))) + diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c new file mode 100644 index 00000000..d5d3d984 --- /dev/null +++ b/lib/srfi/27/rand.c @@ -0,0 +1,204 @@ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include + +#define SEXP_RANDOM_STATE_SIZE 128 + +#define ZERO sexp_make_fixnum(0) +#define ONE sexp_make_fixnum(1) +#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE) + +#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id) + +#define sexp_random_init(x, seed) \ + initstate_r(seed, \ + sexp_string_data(sexp_random_state(x)), \ + SEXP_RANDOM_STATE_SIZE, \ + sexp_random_data(x)) + +#if SEXP_BSD +typedef unsigned int sexp_random_t; +#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs))) +#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n) +#else +typedef struct random_data sexp_random_t; +#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst) +#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs)) +#endif + +#define sexp_random_state(x) (sexp_slot_ref((x), 0)) +#define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1))) + +#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp)) + +static sexp_uint_t rs_type_id; +static sexp default_random_source; + +static sexp sexp_rs_random_integer (sexp ctx, sexp rs, sexp bound) { + sexp res; + int32_t n; +#if SEXP_USE_BIGNUMS + int32_t hi, mod, len, i, *data; +#endif + if (! sexp_random_source_p(rs)) + res = sexp_type_exception(ctx, "not a random-source", rs); + if (sexp_fixnump(bound)) { + sexp_call_random(rs, n); + res = sexp_make_fixnum(n % sexp_unbox_fixnum(bound)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(bound)) { + hi = sexp_bignum_hi(bound); + len = hi * sizeof(sexp_uint_t) / sizeof(int32_t); + res = sexp_make_bignum(ctx, hi); + data = (int32_t*) sexp_bignum_data(res); + for (i=0; i +#include + +#if SEXP_USE_BIGNUMS +#include +#else +#define sexp_bignum_normalize(x) x +#endif + +static sexp sexp_bit_and (sexp ctx, sexp x, sexp y) { + sexp res; +#if SEXP_USE_BIGNUMS + sexp_sint_t len, i; +#endif + if (sexp_fixnump(x)) { + if (sexp_fixnump(y)) + res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(y)) + res = sexp_bit_and(ctx, y, x); +#endif + else + res = sexp_type_exception(ctx, "bitwise-and: not an integer", y); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + if (sexp_fixnump(y)) { + res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); + } else if (sexp_bignump(y)) { + if (sexp_bignum_length(x) < sexp_bignum_length(y)) + res = sexp_copy_bignum(ctx, NULL, x, 0); + else + res = sexp_copy_bignum(ctx, NULL, y, 0); + for (i=0, len=sexp_bignum_length(res); i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i> -c); + } else { + tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c; +#if SEXP_USE_BIGNUMS + if (((tmp >> c) == sexp_unbox_fixnum(i)) + && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) { +#endif + res = sexp_make_fixnum(tmp); +#if SEXP_USE_BIGNUMS + } else { + sexp_gc_preserve1(ctx, res); + res = sexp_fixnum_to_bignum(ctx, i); + res = sexp_arithmetic_shift(ctx, res, count); + sexp_gc_release1(ctx); + } +#endif + } +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(i)) { + len = sexp_bignum_hi(i); + if (c < 0) { + c = -c; + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + if (len < offset) { + res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1); + } else { + res = sexp_make_bignum(ctx, len - offset + 1); + for (j=len-offset, tmp=0; j>=0; j--) { + sexp_bignum_data(res)[j] + = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp; + tmp = sexp_bignum_data(i)[j+offset] + << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + } + } else { + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + res = sexp_make_bignum(ctx, len + offset + 1); + for (j=tmp=0; j> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + sexp_bignum_data(res)[len+offset] = tmp; + } +#endif + } else { + res = sexp_type_exception(ctx, "arithmetic-shift: not an integer", i); + } + return sexp_bignum_normalize(res); +} + +/* bit-count and integer-length were adapted from: */ +/* http://graphics.stanford.edu/~seander/bithacks.html */ +static sexp_uint_t bit_count (sexp_uint_t i) { + i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3); + i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3) + + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3)); + i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15; + return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255)) + >> (sizeof(i) - 1) * CHAR_BIT); +} + +static sexp sexp_bit_count (sexp ctx, sexp x) { + sexp res; + sexp_sint_t i; +#if SEXP_USE_BIGNUMS + sexp_uint_t count; +#endif + if (sexp_fixnump(x)) { + i = sexp_unbox_fixnum(x); + res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + for (i=count=0; i> 32)) + return integer_log2(tt) + 32; + else +#endif + if ((tt = x >> 16)) + return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt]; + else + return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; +} + +static sexp sexp_integer_length (sexp ctx, sexp x) { + sexp_sint_t tmp; +#if SEXP_USE_BIGNUMS + sexp_sint_t hi; +#endif + if (sexp_fixnump(x)) { + tmp = sexp_unbox_fixnum(x); + return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + hi = sexp_bignum_hi(x); + return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi]) + + hi*sizeof(sexp_uint_t)); +#endif + } else { + return sexp_type_exception(ctx, "integer-length: not an integer", x); + } +} + +static sexp sexp_bit_set_p (sexp ctx, sexp i, sexp x) { +#if SEXP_USE_BIGNUMS + sexp_uint_t pos; +#endif + if (! sexp_fixnump(i)) + return sexp_type_exception(ctx, "bit-set?: not an integer", i); + if (sexp_fixnump(x)) { + return sexp_make_boolean(sexp_unbox_fixnum(x) & (1<hash-table + hash-table-equivalence-function hash-table-hash-function + hash-table-ref hash-table-ref/default hash-table-set! + hash-table-delete! hash-table-exists? + hash-table-update! hash-table-update!/default + hash-table-size hash-table-keys hash-table-values + hash-table-walk hash-table-fold hash-table->alist + hash-table-copy hash-table-merge! + hash string-hash string-ci-hash hash-by-identity) + (import-immutable (scheme) + (srfi 9)) + (include-shared "69/hash") + (include "69/type.scm" "69/interface.scm")) + diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c new file mode 100644 index 00000000..e38c23c0 --- /dev/null +++ b/lib/srfi/69/hash.c @@ -0,0 +1,242 @@ +/* hash.c -- type-general hashing */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define HASH_DEPTH 5 +#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM) + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0) +#define sexp_hash_table_size(x) sexp_slot_ref(x, 1) +#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2) +#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3) + +#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2)) + +static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc % bound; +} + +static sexp sexp_string_hash (sexp ctx, sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string-hash: not a string", str); + else if (! sexp_integerp(bound)) + return sexp_type_exception(ctx, "string-hash: not an integer", bound); + return sexp_make_fixnum(string_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= tolower(*str++);} + return acc % bound; +} + +static sexp sexp_string_ci_hash (sexp ctx, sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string-ci-hash: not a string", str); + else if (! sexp_integerp(bound)) + return sexp_type_exception(ctx, "string-ci-hash: not an integer", bound); + return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) { + sexp_uint_t acc = FNV_OFFSET_BASIS, size; + sexp_sint_t i, len; + sexp t, *p; + char *p0; + loop: +#if SEXP_USE_FLONUMS + if (sexp_flonump(obj)) + acc ^= (sexp_sint_t) sexp_flonum_value(obj); + else +#endif + if (sexp_pointerp(obj)) { + if (depth) { + t = sexp_object_type(ctx, obj); + p = (sexp*) (((char*)obj) + sexp_type_field_base(t)); + p0 = ((char*)obj) + offsetof(struct sexp_struct, value); + if ((sexp)p == obj) p=(sexp*)p0; + /* hash trailing non-object data */ + size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp)); + if (((char*)obj + size) > p0) + for (i=0; i 0) { + depth--; + for (i=0; ialist table) + (hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '())) + +(define (hash-table-keys table) + (hash-table-fold table (lambda (k v a) (cons k a)) '())) + +(define (hash-table-values table) + (hash-table-fold table (lambda (k v a) (cons v a)) '())) + +(define (alist->hash-table ls . o) + (let ((res (apply make-hash-table o))) + (for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls) + res)) + +(define (hash-table-merge! a b) + (hash-table-walk b (lambda (k v) (hash-table-set! a k v))) + a) + +(define (hash-table-copy table) + (assert-hash-table "hash-table-copy" table) + (let ((res (make-hash-table (hash-table-equivalence-function table)))) + (hash-table-merge! res table) + res)) + diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm new file mode 100644 index 00000000..1fca9953 --- /dev/null +++ b/lib/srfi/69/type.scm @@ -0,0 +1,12 @@ +;; types.scm -- the hash-table record type +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type hash-table + (%make-hash-table buckets size hash-fn eq-fn) + hash-table? + (buckets hash-table-buckets hash-table-buckets-set!) + (size hash-table-size hash-table-size-set!) + (hash-fn %hash-table-hash-function) + (eq-fn %hash-table-equivalence-function)) + diff --git a/lib/srfi/8.module b/lib/srfi/8.module new file mode 100644 index 00000000..64a3e6e2 --- /dev/null +++ b/lib/srfi/8.module @@ -0,0 +1,10 @@ + +(define-module (srfi 8) + (export receive) + (import-immutable (scheme)) + (body + (define-syntax receive + (syntax-rules () + ((receive params expr . body) + (call-with-values (lambda () expr) (lambda params . body))))))) + diff --git a/lib/srfi/9.module b/lib/srfi/9.module new file mode 100644 index 00000000..0516b201 --- /dev/null +++ b/lib/srfi/9.module @@ -0,0 +1,82 @@ + +(define-module (srfi 9) + (export define-record-type) + (import-immutable (scheme)) + (body + (define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((name (cadr expr)) + (make (caaddr expr)) + (make-fields (cdaddr expr)) + (pred (cadddr expr)) + (fields (cddddr expr)) + (num-fields (length fields)) + (index (register-simple-type (symbol->string name) num-fields)) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let))) + (define (index-of field ls) + (let lp ((ls ls) (i 0)) + (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) + `(,(rename 'begin) + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string pred) + ,index)) + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string (cadar ls)) + ,index + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string (caddar ls)) + ,index + ,i)) + res) + res))))) + (,_define ,make + ,(let lp ((ls make-fields) (sets '()) (set-defs '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string make) + ,index)) + ,@set-defs) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets) + set-defs)) + (else + (let* ((setter-name + (string-append "%" (symbol->string name) "-" + (symbol->string (car ls)) "-set!")) + (setter (rename (string->symbol setter-name))) + (i (index-of (car ls) fields))) + (lp (cdr ls) + (cons (list setter 'res (car ls)) sets) + (cons (list setter + (list (rename 'make-setter) + setter-name + index + (index-of (car ls) fields))) + set-defs))))))))))))))))) + diff --git a/lib/srfi/95.module b/lib/srfi/95.module new file mode 100644 index 00000000..25e0d3ff --- /dev/null +++ b/lib/srfi/95.module @@ -0,0 +1,7 @@ + +(define-module (srfi 95) + (export sorted? merge merge! sort sort!) + (import-immutable (scheme)) + (include-shared "95/qsort") + (include "95/sort.scm")) + diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c new file mode 100644 index 00000000..6b304e54 --- /dev/null +++ b/lib/srfi/95/qsort.c @@ -0,0 +1,170 @@ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var) + +static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) { + sexp_sint_t i; + sexp ls, *data=sexp_vector_data(vec); + for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls)) + sexp_car(ls) = data[i]; + return seq; +} + +static sexp sexp_vector_nreverse (sexp ctx, sexp vec) { + int i, j; + sexp tmp, *data=sexp_vector_data(vec); + for (i=0, j=sexp_vector_length(vec)-1; i 2) { + sexp_qsort(ctx, vec, lo, j-1); + lo = j+1; + goto loop; + } + } +} + +static sexp sexp_qsort_less (sexp ctx, sexp *vec, + sexp_sint_t lo, sexp_sint_t hi, + sexp less, sexp key) { + sexp_sint_t mid, i, j; + sexp tmp, res, args1; + sexp_gc_var3(a, b, args2); + sexp_gc_preserve3(ctx, a, b, args2); + args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID); + args1 = sexp_cdr(args2); + loop: + if (lo >= hi) { + res = SEXP_VOID; + } else { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + sexp_car(args1) = tmp; + b = sexp_apply(ctx, key, args1); + for (i=j=lo; i < hi; i++) { + sexp_car(args1) = vec[i]; + a = sexp_apply(ctx, key, args1); + sexp_car(args2) = a; + sexp_car(args1) = b; + res = sexp_apply(ctx, less, args2); + if (sexp_exceptionp(res)) + goto done; + else if (sexp_truep(res)) + swap(res, vec[i], vec[j]), j++; + } + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + res = sexp_qsort_less(ctx, vec, lo, j-1, less, key); + if (sexp_exceptionp(res)) + goto done; + lo = j+1; + goto loop; + } + } + done: + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_sort_x (sexp ctx, sexp seq, sexp less, sexp key) { + sexp_sint_t len; + sexp res, *data; + sexp_gc_var1(vec); + + if (sexp_nullp(seq)) return seq; + + sexp_gc_preserve1(ctx, vec); + + vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); + + if (! sexp_vectorp(vec)) { + res = sexp_type_exception(ctx, "sort: not a vector", vec); + } else { + data = sexp_vector_data(vec); + len = sexp_vector_length(vec); + if (sexp_not(key) && sexp_basic_comparator(less)) { + sexp_qsort(ctx, data, 0, len-1); + if (sexp_opcodep(less) && sexp_opcode_inverse(less)) + sexp_vector_nreverse(ctx, vec); + } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { + res = sexp_type_exception(ctx, "sort: not a procedure", less); + } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { + res = sexp_type_exception(ctx, "sort: not a procedure", less); + } else { + res = sexp_qsort_less(ctx, data, 0, len-1, less, key); + } + } + + if (sexp_pairp(seq)) + res = sexp_vector_copy_to_list(ctx, vec, seq); + else if (! sexp_exceptionp(res)) + res = vec; + + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE); + return SEXP_VOID; +} diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm new file mode 100644 index 00000000..38273199 --- /dev/null +++ b/lib/srfi/95/sort.scm @@ -0,0 +1,70 @@ +;; sort.scm -- SRFI-95 sorting utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (copy seq) + (if (vector? seq) + (let* ((len (vector-length seq)) + (res (make-vector len))) + (do ((i (- len 1) (- i 1))) + ((< i 0) res) + (vector-set! res i (vector-ref seq i)))) + (map (lambda (x) x) seq))) + +(define (sort seq . o) + (let ((less (and (pair? o) (car o))) + (key (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (sort! (copy seq) less key))) + +(define (sorted? seq less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (cond + ((vector? seq) + (let ((len (- (vector-length seq) 1))) + (let lp ((i 0)) + (cond + ((>= i len) #t) + ((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f) + (else (lp (+ i 1))))))) + ((null? seq) + #f) + (else + (let lp ((ls1 seq) (ls2 (cdr seq))) + (cond ((null? ls2) #t) + ((less (key (car ls2)) (key (car ls1))) #f) + (else (lp ls2 (cdr ls2))))))))) + +(define (merge! ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (define (lp prev ls1 ls2 a b less key) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))) + (else + (set-cdr! prev ls2) + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))))) + (cond + ((null? ls1) ls2) + ((null? ls2) ls1) + (else + (let ((a (key (car ls1))) + (b (key (car ls2)))) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)) + ls1) + (else + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)) + ls2))))))) + +(define (merge ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (merge! (copy ls1) (copy ls2) less key))) diff --git a/lib/srfi/98.module b/lib/srfi/98.module new file mode 100644 index 00000000..9d124d66 --- /dev/null +++ b/lib/srfi/98.module @@ -0,0 +1,5 @@ + +(define-module (srfi 98) + (export get-environment-variable get-environment-variables) + (include-shared "98/env")) + diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c new file mode 100644 index 00000000..38f8b883 --- /dev/null +++ b/lib/srfi/98/env.c @@ -0,0 +1,48 @@ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifdef __APPLE__ +#include +#define environ (*_NSGetEnviron()) +#else +extern char **environ; +#endif + +#include + +sexp sexp_get_environment_variable (sexp ctx, sexp str) { + char *cstr; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "get-environment-variable: not a string", str); + cstr = getenv(sexp_string_data(str)); + return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE; +} + +sexp sexp_get_environment_variables (sexp ctx) { + int i; + char **env, *cname, *cval; + sexp_gc_var3(res, name, val); + sexp_gc_preserve3(ctx, res, name, val); + res = SEXP_NULL; + env = environ; + for (i=0; env[i]; i++) { + cname = env[i]; + cval = strchr(cname, '='); + if (cval) { + name = sexp_c_string(ctx, cname, cval-cname); + val = sexp_c_string(ctx, cval+1, -1); + val = sexp_cons(ctx, name, val); + res = sexp_cons(ctx, val, res); + } + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable); + sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables); + return SEXP_VOID; +} + diff --git a/main.c b/main.c new file mode 100644 index 00000000..a8e52c8d --- /dev/null +++ b/main.c @@ -0,0 +1,193 @@ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define sexp_argv_symbol "*command-line-arguments*" +#define sexp_argv_proc "(define (command-line-arguments) "sexp_argv_symbol")" + +#define sexp_import_prefix "(import (" +#define sexp_import_suffix "))" + +#ifdef PLAN9 +#define exit_failure() exits("ERROR") +#else +#define exit_failure() exit(70) +#endif + +static void repl (sexp ctx) { + sexp in, out, err; + sexp_gc_var4(obj, tmp, res, env); + sexp_gc_preserve4(ctx, obj, tmp, res, env); + env = sexp_context_env(ctx); + sexp_context_tracep(ctx) = 1; + in = sexp_eval_string(ctx, "(current-input-port)", env); + out = sexp_eval_string(ctx, "(current-output-port)", env); + err = sexp_eval_string(ctx, "(current-error-port)", env); + 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, env); + if (sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, err); + } else { +#if SEXP_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_release4(ctx); +} + +static sexp check_exception (sexp ctx, sexp res) { + sexp err; + if (res && sexp_exceptionp(res)) { + err = sexp_current_error_port(ctx); + if (! sexp_oportp(err)) + err = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_print_exception(ctx, res, err); + exit_failure(); + } + return res; +} + +#define init_context() if (! ctx) do { \ + ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \ + env = sexp_context_env(ctx); \ + sexp_gc_preserve2(ctx, tmp, args); \ + } while (0) + +#define load_init() if (! init_loaded++) do { \ + init_context(); \ + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \ + } while (0) + +void run_main (int argc, char **argv) { + char *arg, *impmod, *p; + sexp env, out=SEXP_FALSE, res=SEXP_VOID, ctx=NULL; + sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0; + sexp_uint_t heap_size=0; + sexp_gc_var2(tmp, args); + args = SEXP_NULL; + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + case 'p': + load_init(); + print = (argv[i][1] == 'p'); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + res = check_exception(ctx, sexp_read_from_string(ctx, arg)); + res = check_exception(ctx, sexp_eval(ctx, res, env)); + if (print) { + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", env); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + quit = 1; + i++; + break; + case 'l': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_exception(ctx, sexp_load_module_file(ctx, argv[++i], env)); + break; + case 'm': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); + impmod = (char*) malloc(len+1); + strcpy(impmod, sexp_import_prefix); + strcpy(impmod+strlen(sexp_import_prefix), arg); + strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix); + impmod[len] = '\0'; + for (p=impmod; *p; p++) + if (*p == '.') *p=' '; + check_exception(ctx, sexp_eval_string(ctx, impmod, env)); + free(impmod); + break; + case 'q': + init_context(); + if (! init_loaded++) sexp_load_standard_parameters(ctx, env); + break; + case 'A': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); + break; + case 'I': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); + break; + case '-': + i++; + goto done_options; + case 'h': + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + heap_size = atol(arg); + len = strlen(arg); + if (heap_size && isalpha(arg[len-1])) { + switch (tolower(arg[len-1])) { + case 'k': heap_size *= 1024; break; + case 'm': heap_size *= (1024*1024); break; + } + } + break; + case 'V': + printf("chibi-scheme 0.3\n"); + exit(0); + default: + fprintf(stderr, "unknown option: %s\n", argv[i]); + exit_failure(); + } + } + + done_options: + if (! quit) { + load_init(); + if (i < argc) + for (j=argc-1; j>i; j--) + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); + else + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); + sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol), args); + sexp_eval_string(ctx, sexp_argv_proc, env); + if (i < argc) { /* script usage */ + check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); + tmp = sexp_intern(ctx, "main"); + tmp = sexp_env_ref(env, tmp, SEXP_FALSE); + if (sexp_procedurep(tmp)) { + args = sexp_list1(ctx, args); + check_exception(ctx, sexp_apply(ctx, tmp, args)); + } + } else { + repl(ctx); + } + } + + sexp_gc_release2(ctx); +} + +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..b5b413fc --- /dev/null +++ b/mkfile @@ -0,0 +1,26 @@ + include/chibi/install.h + echo '#define sexp_platform "plan9"' >> include/chibi/install.h + +install:V: $BIN/$TARG + test -d $MODDIR || mkdir -p $MODDIR + cp -r lib/* $MODDIR/ + +test:V: + ./$O.out tests/r5rs-tests.scm + +sexp.c:N: gc.c opt/bignum.c diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..d3c77865 --- /dev/null +++ b/opcodes.c @@ -0,0 +1,153 @@ + +#define _OP(c,o,n,m,t,u,i,s,d,f) \ + {.tag=SEXP_OPCODE, \ + .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}} +#define _FN(o,n,m,t,u,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f) +#define _FN0(s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, 0, 0, s, d, f) +#define _FN1(t, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, t, 0, s, d, f) +#define _FN1OPT(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, t, u, s, d, f) +#define _FN1OPTP(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, t, 0, s, d, f) +#define _FN2(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, t, u, s, d, f) +#define _FN2OPT(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, t, u, s, d, f) +#define _FN2OPTP(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, t, u, s, d, f) +#define _FN3(t, u, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, t, u, s, d, f) +#define _FN4(t, u, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, t, u, s, d, f) +#define _FN5(t, u, s, d, f) _FN(SEXP_OP_FCALL5, 5, 0, t, u, s, d, f) +#define _FN6(t, u, s, d, f) _FN(SEXP_OP_FCALL6, 6, 0, t, u, s, d, f) +#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, 0, 0, n, a, 0) + +static struct sexp_struct opcodes[] = { +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_fixnum(0), NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_fixnum(1), NULL), +_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_SUB, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_NEGATIVE, "-", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_DIV, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_INVERSE, "/", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), +#if SEXP_USE_IMMEDIATE_FLONUMS +_FN1(0, "flonum?", 0, sexp_flonum_predicate), +#else +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), +#endif +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read), +_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write), +_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display), +_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output), +_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), +_FN0("make-environment", 0, sexp_make_env), +_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), +_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), +_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval), +_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load), +_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), +_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), +_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), +_FN1(0, "strip-syntactic-closures", 0, sexp_strip_synclos), +_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), +_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 SEXP_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), +#endif +_FN2(0, 0, "expt", 0, sexp_expt), +#if SEXP_USE_TYPE_DEFS +_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter), +#endif +#if PLAN9 +#include "opt/plan9-opcodes.c" +#endif +#if SEXP_USE_MODULES +_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports), +_FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), +_FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), +_FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory), +#endif +}; + diff --git a/opt/bignum.c b/opt/bignum.c new file mode 100644 index 00000000..90f71661 --- /dev/null +++ b/opt/bignum.c @@ -0,0 +1,734 @@ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_INIT_BIGNUM_SIZE 2 + +#define sexp_negate(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_fixnump(x)) \ + x = sexp_fx_neg(x); + +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { + sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + sexp_bignum_length(res) = len; + sexp_bignum_sign(res) = 1; + return res; +} + +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { + sexp res = sexp_make_bignum(ctx, 1); + sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a)); + sexp_bignum_sign(res) = sexp_fx_sign(a); + return res; +} + +sexp sexp_make_integer (sexp ctx, sexp_sint_t x) { + sexp res; + if ((SEXP_MIN_FIXNUM < x) && (x < SEXP_MAX_FIXNUM)) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + sexp_bignum_sign(res) = (x < 0 ? -1 : 1); + sexp_bignum_data(res)[0] = x * sexp_bignum_sign(res); + } + return res; +} + +#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) +#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) + +sexp sexp_double_to_bignum (sexp ctx, double f) { + int sign; + sexp_gc_var3(res, scale, tmp); + sexp_gc_preserve3(ctx, res, scale, tmp); + res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0)); + scale = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + sign = (f < 0 ? -1 : 1); + for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { + tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); + res = sexp_bignum_add(ctx, res, res, tmp); + scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); + } + sexp_bignum_sign(res) = sign; + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { + sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size; + size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + if (! dst || sexp_bignum_length(dst) < len) { + dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + memcpy(dst, a, size); + sexp_bignum_length(dst) = len; + } else { + memset(dst->value.bignum.data, 0, + sexp_bignum_length(dst)*sizeof(sexp_uint_t)); + memcpy(dst->value.bignum.data, a->value.bignum.data, + sexp_bignum_length(a)*sizeof(sexp_uint_t)); + } + return dst; +} + +int sexp_bignum_zerop (sexp a) { + int i; + sexp_uint_t *data = sexp_bignum_data(a); + for (i=sexp_bignum_length(a)-1; i>=0; i--) + if (data[i]) + return 0; + return 1; +} + +sexp_uint_t sexp_bignum_hi (sexp a) { + sexp_uint_t i=sexp_bignum_length(a)-1; + while ((i>0) && ! sexp_bignum_data(a)[i]) + i--; + return i+1; +} + +sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) { + int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b); + sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b); + if (ai != bi) + return ai - bi; + for (--ai; ai >= 0; ai--) { + if (adata[ai] > bdata[ai]) + return 1; + else if (adata[ai] < bdata[ai]) + return -1; + } + return 0; +} + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { + if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) + return sexp_bignum_sign(a); + return sexp_bignum_compare_abs(a, b); +} + +sexp sexp_bignum_normalize (sexp a) { + sexp_uint_t *data; + if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) + return a; + data = sexp_bignum_data(a); + if ((data[0] > SEXP_MAX_FIXNUM) + && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1))) + return a; + return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a)); +} + +double sexp_bignum_to_double (sexp a) { + double res = 0; + sexp_uint_t i, *data=sexp_bignum_data(a); + for (i=0; i (SEXP_UINT_T_MAX - carry)); + } while (++i> (sizeof(sexp_uint_t)*8); + } + if (carry) { + if (sexp_bignum_length(d)+offset <= len) + d = sexp_copy_bignum(ctx, NULL, d, len+offset+1); + sexp_bignum_data(d)[len+offset] = carry; + } + return d; +} + +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0; + int i; + sexp_luint_t n = 0; + for (i=len-1; i>=offset; i--) { + n = (n << sizeof(sexp_uint_t)*8) + data[i]; + q = n / b; + r = n - (sexp_luint_t)q * b; + data[i] = q; + n = r; + } + return r; +} + +sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, + char sign, sexp_uint_t base) { + int c, digit; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE); + sexp_bignum_sign(res) = sign; + sexp_bignum_data(res)[0] = init; + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + res = sexp_bignum_fxmul(ctx, res, res, base, 0); + res = sexp_bignum_fxadd(ctx, res, digit); + } + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); + } else if ((c!=EOF) && ! is_separator(c)) { + res = sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + } + sexp_push_char(ctx, c, in); + sexp_gc_release1(ctx); + return sexp_bignum_normalize(res); +} + +static int log2i(int v) { + int i; + for (i = 0; i < sizeof(v)*8; i++) + if ((1<<(i+1)) > v) + break; + return i; +} + +sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { + int i, str_len, lg_base = log2i(base); + char *data; + sexp_gc_var2(b, str); + sexp_gc_preserve2(ctx, b, str); + b = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(b) = 1; + i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) + / lg_base + 1; + str = sexp_make_string(ctx, sexp_make_fixnum(str_len), + sexp_make_character(' ')); + data = sexp_string_data(str); + while (! sexp_bignum_zerop(b)) + data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0)); + if (i == str_len) + data[--i] = '0'; + else if (sexp_bignum_sign(a) == -1) + data[--i] = '-'; + sexp_write_string(ctx, data + i, out); + sexp_gc_release2(ctx); + return SEXP_VOID; +} + +/****************** bignum arithmetic *************************/ + +sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(c); + sexp_gc_preserve1(ctx, c); + c = sexp_copy_bignum(ctx, NULL, a, 0); + if (sexp_bignum_sign(c) == sexp_fx_sign(b)) + c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + else + c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + sexp_gc_release1(ctx); + return c; +} + +sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), + borrow=0, i, *adata, *bdata, *cdata; + sexp_gc_var1(c); + if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) + return sexp_bignum_sub_digits(ctx, dst, b, a); + sexp_gc_preserve1(ctx, c); + c = ((dst && sexp_bignum_hi(dst) >= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0); + } + for ( ; carry && (i= 0 ? a : b); + } + return res; +} + +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { + sexp res; + if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { + res = sexp_bignum_sub_digits(ctx, dst, a, b); + sexp_bignum_sign(res) + = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a) + : -sexp_bignum_sign(a)); + } else { + res = sexp_bignum_add_digits(ctx, dst, a, b); + sexp_bignum_sign(res) = sexp_bignum_sign(a); + } + return res; +} + +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, + *bdata=sexp_bignum_data(b); + sexp_gc_var2(c, d); + if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); + sexp_gc_preserve2(ctx, c, d); + c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); + d = sexp_make_bignum(ctx, alen+blen+1); + for (i=0; i 0) { + *rem = a; + return sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0)); + } + sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); + k2 = sexp_bignum_double(ctx, k); + i2 = sexp_bignum_double(ctx, i); + x = quot_step(ctx, rem, a, b, k2, i2); + prod = sexp_bignum_mul(ctx, NULL, x, b); + diff = sexp_bignum_sub_digits(ctx, NULL, a, prod); + if (sexp_bignum_compare(diff, k) >= 0) { + *rem = sexp_bignum_sub_digits(ctx, NULL, diff, k); + res = sexp_bignum_add_digits(ctx, NULL, x, i); + } else { + *rem = diff; + res = x; + } + sexp_gc_release5(ctx); + return res; +} + +sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { + sexp res; + sexp_gc_var4(k, i, a1, b1); + sexp_gc_preserve4(ctx, k, i, a1, b1); + a1 = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(a1) = 1; + b1 = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_bignum_sign(b1) = 1; + k = sexp_copy_bignum(ctx, NULL, b1, 0); + i = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + res = quot_step(ctx, rem, a1, b1, k, i); + sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); + if (sexp_bignum_sign(a) < 0) { + sexp_negate(*rem); + } + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { + sexp res; + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + res = sexp_bignum_quot_rem(ctx, &rem, a, b); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { + sexp rem; + sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */ + return rem; +} + +sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { + sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b)); + sexp_gc_var2(res, acc); + sexp_gc_preserve2(ctx, res, acc); + res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + acc = sexp_copy_bignum(ctx, NULL, a, 0); + for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) + if (e & 1) + res = sexp_bignum_mul(ctx, NULL, res, acc); + sexp_gc_release2(ctx); + return res; +} + +/****************** generic arithmetic ************************/ + +enum sexp_number_types { + SEXP_NUM_NOT = 0, + SEXP_NUM_FIX, + SEXP_NUM_FLO, + SEXP_NUM_BIG +}; + +enum sexp_number_combs { + SEXP_NUM_NOT_NOT = 0, + SEXP_NUM_NOT_FIX, + SEXP_NUM_NOT_FLO, + SEXP_NUM_NOT_BIG, + SEXP_NUM_FIX_NOT, + SEXP_NUM_FIX_FIX, + SEXP_NUM_FIX_FLO, + SEXP_NUM_FIX_BIG, + SEXP_NUM_FLO_NOT, + SEXP_NUM_FLO_FIX, + SEXP_NUM_FLO_FLO, + SEXP_NUM_FLO_BIG, + SEXP_NUM_BIG_NOT, + SEXP_NUM_BIG_FIX, + SEXP_NUM_BIG_FLO, + SEXP_NUM_BIG_BIG +}; + +static int sexp_number_types[] = + {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, 0}; + +static int sexp_number_type (sexp a) { + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] +#if SEXP_USE_IMMEDIATE_FLONUMS + : sexp_flonump(a) ? 2 +#endif + : sexp_fixnump(a); +} + +sexp sexp_add (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "+: not a number", a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_add(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_add(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_add(ctx, NULL, b, a)); + break; + } + return r; +} + +sexp sexp_sub (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "-: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "-: not a number", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_sub(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a)); + sexp_negate(r); + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)+sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_sub(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, sexp_fixnum_to_bignum(ctx, b))); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_flonum_value(b) - sexp_bignum_to_double(a)); + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); + break; + } + return r; +} + +sexp sexp_mul (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "*: not a number", a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_mul(a, b); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0); + sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_mul(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_mul(ctx, NULL, a, b); + break; + } + return r; +} + +sexp sexp_div (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + double f; + sexp r=SEXP_VOID, rem; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "/: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "/: not a number", b); + break; + case SEXP_NUM_FIX_FIX: + f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b); + r = ((f == trunc(f)) ? sexp_make_fixnum((sexp_sint_t)f) + : sexp_make_flonum(ctx, f)); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)/sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_div(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_quot_rem(ctx, &rem, a, b); + if (sexp_bignum_normalize(rem) != sexp_make_fixnum(0)) + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) + / sexp_fixnum_to_double(b)); + else + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b)); + break; + } + return r; +} + +sexp sexp_quotient (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "quotient: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "quotient: not a number", b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_div(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(0); + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b)); + break; + } + return r; +} + +sexp sexp_remainder (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "remainder: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "remainder: not a number", b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_rem(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = a; + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b)); + break; + } + return r; +} + +sexp sexp_compare (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + double f; + if (at > bt) { + r = sexp_compare(ctx, b, a); + sexp_negate(r); + } else { + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "compare: not a number", a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); + break; + case SEXP_NUM_FIX_FLO: + f = sexp_fixnum_to_double(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(-1); + break; + case SEXP_NUM_FLO_FLO: + f = sexp_flonum_value(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FLO_BIG: + f = sexp_flonum_value(a) - sexp_bignum_to_double(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_make_fixnum(sexp_bignum_compare(a, b)); + break; + } + } + return r; +} + diff --git a/opt/plan9-opcodes.c b/opt/plan9-opcodes.c new file mode 100644 index 00000000..9f7cac33 --- /dev/null +++ b/opt/plan9-opcodes.c @@ -0,0 +1,19 @@ +_FN0("random-integer", 0, sexp_rand), +_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), +_FN0("current-directory", 0, sexp_getwd), +_FN0("current-user", 0, sexp_getuser), +_FN0("system-name", 0, sexp_sysname), +_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), +_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), +_FN0("fork", 0, sexp_fork), +_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), +_FN1(SEXP_STRING, "exits", 0, sexp_exits), +_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), +_FN0("pipe", 0, sexp_pipe), +_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), +_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), +_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), +_FN0("wait", 0, sexp_wait), +_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), +_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), +_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), diff --git a/opt/plan9.c b/opt/plan9.c new file mode 100644 index 00000000..b103912a --- /dev/null +++ b/opt/plan9.c @@ -0,0 +1,351 @@ +/* plan9.c -- extended Plan 9 system utils */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +sexp sexp_rand (sexp ctx) { + return sexp_make_fixnum(rand()); +} + +sexp sexp_srand (sexp ctx, sexp seed) { + srand(sexp_unbox_fixnum(seed)); + return SEXP_VOID; +} + +sexp sexp_file_exists_p (sexp ctx, sexp path) { + int res; + uchar statbuf[STATMAX]; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "file-exists?: not a string", path); + res = stat(sexp_string_data(path), statbuf, sizeof(statbuf)); + return (res < 0) ? SEXP_FALSE : SEXP_TRUE; +} + +sexp sexp_fdopen (sexp ctx, sexp fd, sexp mode) { + FILE *f; + if (! sexp_integerp(fd)) + return sexp_type_exception(ctx, "fdopen: not an integer", fd); + if (! sexp_stringp(mode)) + return sexp_type_exception(ctx, "fdopen: not a mode string", mode); + f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode)); + if (! f) + return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd); + /* maybe use fd2path to get the name of the fd */ + if (sexp_string_data(mode)[0] == 'w') + return sexp_make_output_port(ctx, f, SEXP_FALSE); + else + return sexp_make_input_port(ctx, f, SEXP_FALSE); +} + +sexp sexp_fileno (sexp ctx, sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "fileno: not a port", port); + return sexp_make_fixnum(fileno(sexp_port_stream(port))); +} + +sexp sexp_fork (sexp ctx) { + return sexp_make_fixnum(fork()); +} + +sexp sexp_exec (sexp ctx, sexp name, sexp args) { + int i, len = sexp_unbox_fixnum(sexp_length(ctx, args)); + char **argv = malloc((len+1)*sizeof(char*)); + for (i=0; imsg, -1); + res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg); + sexp_gc_release(ctx, msg, s_msg); + return res; +} + +sexp sexp_postnote (sexp ctx, sexp pid, sexp note) { + if (! sexp_integerp(pid)) + return sexp_type_exception(ctx, "postnote: not an integer", pid); + if (! sexp_stringp(note)) + return sexp_type_exception(ctx, "postnote: not a string", note); + postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note)); + return SEXP_VOID; +} + +/**********************************************************************/ +/* 9p interface */ + +typedef struct sexp_plan9_srv { + sexp context, auth, attach, walk, walk1, clone, open, create, remove, + read, write, stat, wstat, flush, destroyfid, destroyreq, end; +} *sexp_plan9_srv; + +void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) { + s->context = ctx; + s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open + = s->create = s->remove = s->read = s->write = s->stat = s->wstat + = s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE; + for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) { + if (sexp_car(ls) == sexp_intern(ctx, "auth:")) { + s->auth = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "attach:")) { + s->attach = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk:")) { + s->walk = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:")) { + s->walk1 = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "clone:")) { + s->clone = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "open:")) { + s->open = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "create:")) { + s->create = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "remove:")) { + s->remove = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "read:")) { + s->read = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "write:")) { + s->write = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "stat:")) { + s->stat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:")) { + s->wstat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "flush:")) { + s->flush = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:")) { + s->destroyfid = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:")) { + s->destroyreq = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "end:")) { + s->end = sexp_cadr(ls); + } + } +} + +void sexp_run_9p_handler (Req *r, sexp handler) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, handler, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +#define sexp_def_9p_handler(name, field) \ + void name (Req *r) { \ + sexp_run_9p_handler(r, ((sexp_plan9_srv)r->srv->aux)->field); \ + } + +sexp_def_9p_handler(sexp_9p_auth, auth) +sexp_def_9p_handler(sexp_9p_attach, attach) +sexp_def_9p_handler(sexp_9p_walk, walk) +sexp_def_9p_handler(sexp_9p_open, open) +sexp_def_9p_handler(sexp_9p_create, create) +sexp_def_9p_handler(sexp_9p_remove, remove) +sexp_def_9p_handler(sexp_9p_read, read) +sexp_def_9p_handler(sexp_9p_write, write) +sexp_def_9p_handler(sexp_9p_stat, stat) +sexp_def_9p_handler(sexp_9p_wstat, wstat) +sexp_def_9p_handler(sexp_9p_flush, flush) + +char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_c_string(ctx, name, -1); + args = sexp_cons(ctx, ptr, args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->walk1, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +char* sexp_9p_clone (Fid *oldfid, Fid *newfid) { + sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->clone, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +void sexp_9p_destroyfid (Fid *fid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyfid, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_destroyreq (Req *r) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyreq, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_end (Srv *srv) { + sexp_plan9_srv s = (sexp_plan9_srv)srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->end, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +sexp sexp_postmountsrv (sexp ctx, sexp ls, sexp name, sexp mtpt, sexp flags) { + Srv s; + struct sexp_plan9_srv p9s; + if (! sexp_listp(ctx, ls)) + return sexp_type_exception(ctx, "postmountsrv: not a list", ls); + if (! sexp_stringp(name)) + return sexp_type_exception(ctx, "postmountsrv: not a string", name); + if (! sexp_stringp(mtpt)) + return sexp_type_exception(ctx, "postmountsrv: not a string", mtpt); + if (! sexp_integerp(flags)) + return sexp_type_exception(ctx, "postmountsrv: not an integer", flags); + sexp_build_srv(ctx, &p9s, ls); + s.aux = &p9s; + s.auth = &sexp_9p_auth; + s.attach = &sexp_9p_attach; + s.walk = &sexp_9p_walk; + s.walk1 = &sexp_9p_walk1; + s.clone = &sexp_9p_clone; + s.open = &sexp_9p_open; + s.create = &sexp_9p_create; + s.remove = &sexp_9p_remove; + s.read = &sexp_9p_read; + s.write = &sexp_9p_write; + s.stat = &sexp_9p_stat; + s.wstat = &sexp_9p_wstat; + s.flush = &sexp_9p_flush; + s.destroyfid = &sexp_9p_destroyfid; + s.destroyreq = &sexp_9p_destroyreq; + s.end = &sexp_9p_end; + postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt), + sexp_unbox_fixnum(flags)); + return SEXP_UNDEF; +} + +sexp sexp_9p_req_offset (sexp ctx, sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset); +} + +sexp sexp_9p_req_count (sexp ctx, sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count); +} + +#if 0 +sexp sexp_9p_req_path (sexp ctx, sexp req) { + return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1); +} +#endif + +sexp sexp_9p_req_fid (sexp ctx, sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0); +} + +sexp sexp_9p_req_newfid (sexp ctx, sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0); +} + +sexp sexp_9p_respond (sexp ctx, sexp req, sexp err) { + char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil; + respond(sexp_cpointer_value(req), cerr); + return SEXP_VOID; +} + +sexp sexp_9p_responderror (sexp ctx, sexp req) { + responderror(sexp_cpointer_value(req)); + return SEXP_VOID; +} + 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/opt/simplify.c b/opt/simplify.c new file mode 100644 index 00000000..d4ac576d --- /dev/null +++ b/opt/simplify.c @@ -0,0 +1,135 @@ +/* simplify.c -- basic simplification pass */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda)) + +static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { + int check; + sexp ls1, ls2, p1, p2, sv, ctx2; + sexp_gc_var4(res, substs, tmp, app); + sexp_gc_preserve4(ctx, res, substs, tmp, app); + res = ast; /* return the ast as-is by default */ + substs = init_substs; + + loop: + switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) { + + case SEXP_PAIR: + /* don't simplify the operator if it's a lambda because we + simplify that as a special case below, with the appropriate + substs list */ + app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res) + : (tmp=simplify(ctx, sexp_car(res), substs, lambda))); + for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); + app = sexp_nreverse(ctx, app); + if (sexp_opcodep(sexp_car(app))) { + if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) { + for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { + if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { + check = 0; + break; + } + } + if (check) { + ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0); + generate(ctx2, app); + app = finalize_bytecode(ctx2); + if (! sexp_exceptionp(app)) { + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + app = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, app, tmp); + if (! sexp_exceptionp(app)) + app = sexp_apply(ctx2, app, SEXP_NULL); + } + } + } + } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */ + p1 = NULL; + p2 = sexp_lambda_params(sexp_car(app)); + ls1 = app; + ls2 = sexp_cdr(app); + sv = sexp_lambda_sv(sexp_car(app)); + for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) { + if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv)) + && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2)) + || (sexp_refp(sexp_car(ls2)) + && sexp_lambdap(sexp_ref_loc(sexp_car(ls2)))))) { + tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2)); + tmp = sexp_cons(ctx, sexp_car(p2), tmp); + sexp_push(ctx, substs, tmp); + sexp_cdr(ls1) = sexp_cdr(ls2); + if (p1) + sexp_cdr(p1) = sexp_cdr(p2); + else + sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2); + } else { + p1 = p2; + ls1 = ls2; + } + } + sexp_lambda_body(sexp_car(app)) + = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app)); + if (sexp_nullp(sexp_cdr(app)) + && sexp_nullp(sexp_lambda_params(sexp_car(app))) + && sexp_nullp(sexp_lambda_defs(sexp_car(app)))) + app = sexp_lambda_body(sexp_car(app)); + } + res = app; + break; + + case SEXP_LAMBDA: + sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res); + break; + + case SEXP_CND: + tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda); + if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) { + res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp)) + ? sexp_cnd_fail(res) : sexp_cnd_pass(res); + goto loop; + } else { + sexp_cnd_test(res) = tmp; + simplify_it(sexp_cnd_pass(res)); + simplify_it(sexp_cnd_fail(res)); + } + break; + + case SEXP_REF: + tmp = sexp_ref_name(res); + for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) { + res = sexp_cddar(ls1); + break; + } + break; + + case SEXP_SET: + simplify_it(sexp_set_value(res)); + break; + + case SEXP_SEQ: + app = SEXP_NULL; + for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { + tmp = simplify(ctx, sexp_car(ls2), substs, lambda); + if (! (sexp_pairp(sexp_cdr(ls2)) + && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) + || sexp_lambdap(tmp)))) + sexp_push(ctx, app, tmp); + } + if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app))) + res = sexp_car(app); + else + sexp_seq_ls(res) = sexp_nreverse(ctx, app); + break; + + } + + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_simplify (sexp ctx, sexp ast) { + return simplify(ctx, ast, SEXP_NULL, NULL); +} + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..a4aa5efc --- /dev/null +++ b/sexp.c @@ -0,0 +1,1662 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* optional huffman-compressed immediate symbols */ +struct sexp_huff_entry { + unsigned char len; + unsigned short bits; +}; + +#if SEXP_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; + +sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp); + +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 (int c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int hex_digit (int n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + +static int is_separator(int c) { + return 0= SEXP_MAXIMUM_TYPES) { + res = sexp_user_exception(ctx, SEXP_FALSE, "register-type: exceeded maximum type limit", name); + } else if (! sexp_stringp(name)) { + res = sexp_type_exception(ctx, "register-type: not a string", name); + } else { + if (num_types >= type_array_size) { + len = type_array_size*2; + if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES; +#if SEXP_USE_GLOBAL_TYPES + new = malloc(len * sizeof(_sexp_type_specs[0])); + for (i=0; i num_types) free(tmp); + sexp_type_array_size = len; +#else + res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID); + v1 = sexp_vector_data(res); + v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)); + for (i=0; i= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(sexp_exception_message(exn))) + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); + else + sexp_write(ctx, 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_var4(sym, name, str, irr); + sexp_gc_preserve4(ctx, sym, name, str, irr); + name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); + name = sexp_cons(ctx, name, sexp_make_fixnum(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, sym = sexp_intern(ctx, "read"), + str, irr, SEXP_FALSE, name); + sexp_gc_release4(ctx); + return res; +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons (sexp ctx, sexp head, sexp tail) { + sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); + if (sexp_exceptionp(pair)) return 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_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release1(ctx); + 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_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(ctx, sexp_car(ls), res); + sexp_gc_release1(ctx); + 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_type_exception(ctx, "not a list", ls); + } 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_var2(a1, b1); + sexp_gc_preserve2(ctx, a1, 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_release2(ctx); + 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_fixnum(res); +} + +sexp sexp_equalp (sexp ctx, sexp a, sexp b) { + sexp_uint_t size; + sexp_sint_t i, len; + sexp t, *p, *q; + char *p0, *q0; + + loop: + if (a == b) + return SEXP_TRUE; + else if ((! sexp_pointerp(a)) || (! sexp_pointerp(b)) + || (sexp_pointer_tag(a) != sexp_pointer_tag(b))) + return SEXP_FALSE; + + /* a and b are both pointers of the same type */ +#if SEXP_USE_BIGNUMS + if (sexp_pointer_tag(a) == SEXP_BIGNUM) + return sexp_make_boolean(!sexp_bignum_compare(a, b)); +#endif +#if SEXP_USE_FLONUMS && ! SEXP_USE_IMMEDIATE_FLONUMS + if (sexp_pointer_tag(a) == SEXP_FLONUM) + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); +#endif + t = sexp_object_type(ctx, a); + p0 = ((char*)a) + offsetof(struct sexp_struct, value); + p = (sexp*) (((char*)a) + sexp_type_field_base(t)); + q0 = ((char*)b) + offsetof(struct sexp_struct, value); + q = (sexp*) (((char*)b) + sexp_type_field_base(t)); + if ((sexp)p == a) {p=(sexp*)p0; q=(sexp*)q0;} + /* check preliminary non-object data */ + if ((p0 < (char*)p) && memcmp(p0, q0, ((char*)p - p0))) + return SEXP_FALSE; + /* check trailing non-object data */ + size = sexp_type_size_of_object(t, a) - offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,a)*sizeof(sexp)); + if (((char*)a + size) > p0) { + q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp)); + if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value)) + return SEXP_FALSE; + if (memcmp(p0, q0, size)) + return SEXP_FALSE; + } + /* check eq-object slots */ + len = sexp_type_num_eq_slots_of_object(t, a); + if (len > 0) { + for (i=0; i> 32; + return r.flonum; +} +sexp sexp_make_flonum (sexp ctx, float f) { + union sexp_flonum_conv x; + x.flonum = f; + return (sexp)(((sexp_uint_t)(x.bits) << 32) + SEXP_IFLONUM_TAG); +} +#endif +#endif + +sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { + sexp_sint_t clen = sexp_unbox_fixnum(len); + sexp s; + if (! sexp_fixnump(len)) return sexp_type_exception(ctx, "bad length", len); + if (clen < 0) return sexp_type_exception(ctx, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); + if (sexp_exceptionp(s)) return s; + 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_fixnum(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_fixnump(start)) + return sexp_type_exception(ctx, "not a number", start); + if (sexp_not(end)) + end = sexp_make_fixnum(sexp_string_length(str)); + if (! sexp_fixnump(end)) + return sexp_type_exception(ctx, "not a number", end); + if ((sexp_unbox_fixnum(start) < 0) + || (sexp_unbox_fixnum(start) > sexp_string_length(str)) + || (sexp_unbox_fixnum(end) < 0) + || (sexp_unbox_fixnum(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_fixnum(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_fixnum(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 SEXP_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) { +#if SEXP_USE_HUFF_SYMS + struct sexp_huff_entry he; + sexp_uint_t space=3, newbits; + char c; +#endif + sexp_uint_t len, res=FNV_OFFSET_BASIS, bucket; + char *p=str; + sexp ls; + sexp_gc_var1(sym); + +#if SEXP_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); + + normal_intern: +#endif +#if SEXP_USE_HASH_SYMS + bucket = (sexp_string_hash(p, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + len = strlen(str) + 1; /* include the trailing NULL in the comparison */ + for (ls=sexp_context_symbols(ctx)[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_preserve1(ctx, sym); + sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); + if (sexp_exceptionp(sym)) return sym; + sexp_symbol_string(sym) = sexp_c_string(ctx, str, len-1); + sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); + sexp_gc_release1(ctx); + return sym; +} + +sexp sexp_string_to_symbol (sexp ctx, sexp str) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string->symbol: not a string", str); + return sexp_intern(ctx, sexp_string_data(str)); +} + +sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { + sexp vec, *x; + int i, clen = sexp_unbox_fixnum(len); + if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR); + vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); + if (sexp_exceptionp(vec)) return vec; + x = sexp_vector_data(vec); + 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_fixnum(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_fixnum(sexp_stream_size(vec)); + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_stream_ctx(vec), + sexp_make_fixnum(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_fixnum(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_fixnum(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_fixnum(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_fixnum(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_fixnum(pos); + return pos; +} + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + FILE *in; + sexp res; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = str; + sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str)); + sexp_stream_pos(cookie) = SEXP_ZERO; + 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_release1(ctx); + return res; +} + +sexp sexp_make_output_string_port (sexp ctx) { + FILE *out; + sexp res, size; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + size = sexp_make_fixnum(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(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_ZERO; + 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_release1(ctx); + 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_ZERO, + sexp_stream_pos(cookie)); +} + +#else + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + FILE *in; + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "open-input-string: not a string", str); + in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + 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_var1(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_preserve1(ctx, tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_gc_release1(ctx); + } + sexp_port_offset(p) = 0; + return SEXP_VOID; + } +} + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "open-input-string: not a string", str); + res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + 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); + if (sexp_exceptionp(res)) return res; + 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_var2(ls, tmp); + sexp_gc_preserve2(ctx, ls, 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_release2(ctx); + return res; +} + +#endif + +sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { + sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); + if (sexp_exceptionp(p)) return p; + 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); + if (sexp_exceptionp(p)) return p; + sexp_pointer_tag(p) = SEXP_OPORT; + return p; +} + +sexp sexp_write (sexp ctx, sexp obj, sexp out) { +#if SEXP_USE_HUFF_SYMS + unsigned long res, c; +#endif + unsigned long len; + 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; +#if SEXP_USE_BIGNUMS + case SEXP_BIGNUM: + sexp_write_bignum(ctx, obj, out, 10); + break; +#endif + default: + i = sexp_pointer_tag(obj); + sexp_write_string(ctx, "#<", out); + sexp_write_string(ctx, + (i < sexp_context_num_types(ctx)) + ? sexp_type_name_by_index(ctx, i) : "invalid", + out); + sexp_write_char(ctx, '>', out); + break; + } + } else if (sexp_fixnump(obj)) { + sprintf(numbuf, "%ld", sexp_unbox_fixnum(obj)); + sexp_write_string(ctx, numbuf, out); +#if SEXP_USE_IMMEDIATE_FLONUMS + } else if (sexp_flonump(obj)) { + f = sexp_flonum_value(obj); +#if SEXP_USE_INFINITIES + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else +#endif + { + i = sprintf(numbuf, "%.8g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + 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 SEXP_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); + } + } + return SEXP_VOID; +} + +sexp sexp_display (sexp ctx, sexp obj, sexp out) { + if (sexp_stringp(obj)) + sexp_write_string(ctx, sexp_string_data(obj), out); + else if (sexp_charp(obj)) + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else + sexp_write(ctx, obj, out); + return SEXP_VOID; +} + +sexp sexp_flush_output (sexp ctx, sexp out) { + sexp_flush(ctx, out); + return SEXP_VOID; +} + +#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 'r': c = '\r'; 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_uint_t whole, int negp) { + sexp exponent=SEXP_VOID; + 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; + if (c=='e' || c=='E') { + exponent = sexp_read_number(ctx, in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(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); + } else { + sexp_push_char(ctx, c, in); + } + res = ((double)whole + res) * pow(10, e); + if (negp) res *= -1; + if ((scale == 0.1) && (exponent != SEXP_VOID) && (res == round(res))) + return sexp_make_fixnum(res); + else + return sexp_make_flonum(ctx, res); +} + +sexp sexp_read_number(sexp ctx, sexp in, int base) { + sexp den; + sexp_uint_t res = 0, tmp; + int c, digit, negativep = 0; + + c = sexp_read_char(ctx, in); + if (c == '-') + negativep = 1; + else if (isdigit(c)) + res = digit_value(c); + + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + tmp = res * base + digit; +#if SEXP_USE_BIGNUMS + if ((tmp < res) || (tmp > SEXP_MAX_FIXNUM)) { + sexp_push_char(ctx, c, in); + return sexp_read_bignum(ctx, in, res, (negativep ? -1 : 1), base); + } +#endif + res = tmp; + } + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + return sexp_read_float_tail(ctx, in, res, negativep); + } else if (c=='/') { + den = sexp_read_number(ctx, in, base); + if (! sexp_fixnump(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_fixnum(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_fixnum(negativep ? -res : res); +} + +sexp sexp_read_raw (sexp ctx, sexp in) { + char *str; + int c1, c2, line; + sexp tmp2; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, 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); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res); + break; + case '`': + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res); + break; + case ',': + if ((c1 = sexp_read_char(ctx, in)) == '@') { + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_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)) { + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } + res = sexp_cons(ctx, tmp, res); + tmp = sexp_read_raw(ctx, in); + } + 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_fixnum(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_fixnum((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(ctx, in); + if (sexp_fixnump(res)) + res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res)); + break; + case 'f': case 'F': + case 't': case 'T': + c2 = sexp_read_char(ctx, in); + if (c2 == EOF || is_separator(c2)) { + res = (tolower(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; + break; + case '!': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + sexp_port_line(in)++; + 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, 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 SEXP_USE_FLONUMS + if (sexp_flonump(res)) +#if SEXP_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 +#if SEXP_USE_BIGNUMS + if (sexp_bignump(res)) + sexp_bignum_sign(res) = -sexp_bignum_sign(res); + else +#endif + res = sexp_fx_mul(res, SEXP_NEG_ONE); + } + } else { + sexp_push_char(ctx, c2, in); + res = sexp_read_symbol(ctx, in, c1, 1); +#if SEXP_USE_INFINITIES + if (res == sexp_intern(ctx, "+inf.0")) + res = sexp_make_flonum(ctx, 1.0/0.0); + else if (res == sexp_intern(ctx, "-inf.0")) + res = sexp_make_flonum(ctx, -1.0/0.0); + else if (res == sexp_intern(ctx, "+nan.0")) + res = sexp_make_flonum(ctx, 0.0/0.0); +#endif + } + 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_release2(ctx); + 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_var2(s, in); + sexp_gc_preserve2(ctx, s, in); + s = sexp_c_string(ctx, str, -1); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_write_to_string(sexp ctx, sexp obj) { + sexp str; + sexp_gc_var1(out); + sexp_gc_preserve1(ctx, out); + out = sexp_make_output_string_port(ctx); + sexp_write(ctx, obj, out); + str = sexp_get_output_string(ctx, out); + sexp_gc_release1(ctx); + return str; +} + +void sexp_init(void) { +#if SEXP_USE_GLOBAL_SYMBOLS + int i; +#endif + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if SEXP_USE_BOEHM + GC_init(); +#if SEXP_USE_GLOBAL_SYMBOLS + GC_add_roots((char*)&sexp_symbol_table, + ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); +#endif +#elif ! SEXP_USE_MALLOC + sexp_gc_init(); +#endif +#if SEXP_USE_GLOBAL_SYMBOLS + 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..820020c1 --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,48 @@ + +(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)))) 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/build/build-opts.txt b/tests/build/build-opts.txt new file mode 100644 index 00000000..e6bcd056 --- /dev/null +++ b/tests/build/build-opts.txt @@ -0,0 +1,21 @@ +CPPFLAGS=-DSEXP_USE_MODULES=0 +CPPFLAGS=-DSEXP_USE_DL=0 +CPPFLAGS=-DSEXP_USE_SIMPLIFY=0 +CPPFLAGS=-DSEXP_USE_TYPE_DEFS=0 +SEXP_USE_BOEHM=1 +CPPFLAGS=-DSEXP_USE_DEBUG_GC=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_HEAP=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_TYPES=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_SYMBOLS=1 +CPPFLAGS=-DSEXP_USE_FLONUMS=0 +CPPFLAGS=-DSEXP_USE_IMMEDIATE_FLONUMS=1 +CPPFLAGS=-DSEXP_USE_BIGNUMS=0 +CPPFLAGS=-DSEXP_USE_MATH=0 +CPPFLAGS=-DSEXP_WARN_UNDEFS=0 +CPPFLAGS=-DSEXP_USE_HUFF_SYMS=0 +CPPFLAGS=-DSEXP_USE_HASH_SYMS=0 +CPPFLAGS=-DSEXP_USE_STRING_STREAMS=0 +CPPFLAGS=-DSEXP_USE_AUTOCLOSE_PORTS=0 +CPPFLAGS=-DSEXP_USE_2010_EPOCH=0 +CPPFLAGS=-DSEXP_USE_CHECK_STACK=0 +CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 diff --git a/tests/build/build-tests.sh b/tests/build/build-tests.sh new file mode 100755 index 00000000..1d239629 --- /dev/null +++ b/tests/build/build-tests.sh @@ -0,0 +1,37 @@ +#! /bin/bash + +# test basic build options + +# for bootstrapping reasons this is a shell script, instead of a +# scheme script using (chibi process) + +# we just check each build against r5rs-tests.scm - +# some of the libraries will fail to build (notably +# if modules or user-defined types are disabled). + +BUILDDIR=tests/build +FAILURES=0 +i=0 + +for opts in `cat ${BUILDDIR}/build-opts.txt`; do + make cleaner 2>&1 >/dev/null + if make $opts chibi-scheme 2>&1 >${BUILDDIR}/build${i}-make.out; then + if make test 2>&1 | tee ${BUILDDIR}/build${i}-test.out | grep -q -E 'FAIL|ERROR'; then + echo "[FAIL] ${i}: tests failed with $opts" + FAILURES=$((FAILURES + 1)) + else + echo "[PASS] ${i}: tests passed with $opts" + fi + else + echo "[FAIL] ${i}: couldn't build with $opts" + FAILURES=$((FAILURES + 1)) + fi + i=$((i+1)) +done + +if (( FAILURES == 0 )); then + echo "build-tests: all tests passed" +else + echo "build-tests: ${FAILURES} tests failed" +fi + diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm new file mode 100644 index 00000000..1c49d48f --- /dev/null +++ b/tests/loop-tests.scm @@ -0,0 +1,202 @@ + +(import (chibi loop)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test + "stepping" + '(0 1 2) + (loop lp ((with i 0 (+ i 1)) + (with res '() (cons i res))) + (if (= i 3) + (reverse res) + (lp)))) + +(test + "basic in-list" + '(c b a) + (let ((res '())) + (loop ((for x (in-list '(a b c)))) + (set! res (cons x res))) + res)) + +(test + "in-list with result" + '(c b a) + (loop ((for x (in-list '(a b c))) + (with res '() (cons x res))) + => res)) + +(test + "in-list with listing" + '(a b c) + (loop ((for x (in-list '(a b c))) (for res (listing x))) => res)) + +(test + "in-list with listing-reverse" + '(c b a) + (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res)) + +(test + "uneven length in-list's" + '((a . 1) (b . 2) (c . 3)) + (loop ((for x (in-list '(a b c))) + (for y (in-list '(1 2 3 4))) + (for res (listing (cons x y)))) + => res)) + +(test + "in-lists" + '((a 1) (b 2) (c 3)) + (loop ((for ls (in-lists '((a b c) (1 2 3)))) + (for res (listing ls))) + => res)) + +(define (flatten ls) + (reverse + (loop lp ((for x ls (in-list ls)) (with res '())) + => res + (if (pair? x) + (lp (=> res (lp (=> ls x)))) + (lp (=> res (cons x res))))))) + +(test + "flatten (recursion test)" + '(1 2 3 4 5 6 7) + (flatten '(1 (2) (3 (4 (5)) 6) 7))) + +(test + "in-string" + '(#\h #\e #\l #\l #\o) + (loop ((for c (in-string "hello")) (for res (listing c))) => res)) + +(test + "in-string with start" + '(#\l #\o) + (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res)) + +(test + "in-string with start and end" + '(#\h #\e #\l #\l) + (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res)) + +(test + "in-string with start, end and step" + '(#\e #\l) + (loop ((for c (in-string "hello" 1 4 2)) (for res (listing c))) => res)) + +(test + "in-string-reverse" + '(#\o #\l #\l #\e #\h) + (loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res)) + +(test + "in-vector" + '(1 2 3) + (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res)) + +(test "up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 8))) + (for res (listing i))) + => res)) + +(test "up-from by" '(5 10 15) + (loop ((for i (up-from 5 (to 20) (by 5))) + (for res (listing i))) + => res)) + +(test "up-from listing if" '(10 12 14 16 18) + (loop ((for i (up-from 10 (to 20))) + (for res (listing i (if (even? i))))) + => res)) + +(test "down-from" '(7 6 5) + (loop ((for i (down-from 8 (to 5))) + (for res (listing i))) + => res)) + +(test "down-from by" '(15 10 5) + (loop ((for i (down-from 20 (to 5) (by 5))) + (for res (listing i))) + => res)) + +(test "down-from listing if" '(18 16 14 12 10) + (loop ((for i (down-from 20 (to 10))) + (for res (listing i (if (even? i))))) + => res)) + +(test "appending" '(1 2 3 4 5 6 7 8 9) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending ls))) + => res)) + +(test "appending-reverse" '(9 8 7 6 5 4 3 2 1) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending-reverse ls))) + => res)) + +(test "while + up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 10))) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "up-from by, open-ended" '(5 7 9) + (loop ((for i (up-from 5 (by 2))) + (while (< i 10)) + (for res (listing i))) + => res)) + +(test "up-from open-ended" '(5 6 7) + (loop ((for i (up-from 5)) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "down-from by, open-ended" '(5 3 1) + (loop ((for i (down-from 7 (by 2))) + (until (< i 1)) + (for res (listing i))) + => res)) + +(test "down-from open-ended" '(4 3 2) + (loop ((for i (down-from 5)) + (until (< i 2)) + (for res (listing i))) + => res)) + +(test-report) + diff --git a/tests/match-tests.scm b/tests/match-tests.scm new file mode 100644 index 00000000..a223e729 --- /dev/null +++ b/tests/match-tests.scm @@ -0,0 +1,196 @@ + +(import (chibi match)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test "any" (match 'any (_ 'ok)) 'ok) +(test "symbol" (match 'ok (x x)) 'ok) +(test "number" (match 28 (28 'ok)) 'ok) +(test "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok) +(test "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok) +(test "null" (match '() (() 'ok)) 'ok) +(test "pair" (match '(ok) ((x) x)) 'ok) +(test "vector" (match '#(ok) (#(x) x)) 'ok) +(test "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok) +(test "and empty" (match '(o k) ((and) 'ok)) 'ok) +(test "and single" (match 'ok ((and x) x)) 'ok) +(test "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok) +(test "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok) +(test "or single" (match 'ok ((or x) 'ok)) 'ok) +(test "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok) +(test "not" (match 28 ((not (a . b)) 'ok)) 'ok) +(test "pred" (match 28 ((? number?) 'ok)) 'ok) +(test "named pred" (match 28 ((? number? x) (+ x 1))) 29) + +(test "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok) +(test "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok) +(test "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok) + +(test "ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ___) (list x y))) + '((a b c) (1 2 3))) + +(test "real ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ...) (list x y))) + '((a b c) (1 2 3))) + +(test "vector ellipses" + (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) + (#(a b c (hd . tl) ...) (list a b c hd tl))) + '(1 2 3 (a b c) (1 2 3))) + +(test "pred ellipses" + (match '(1 2 3) + (((? odd? n) ___) n) + (((? number? n) ___) n)) + '(1 2 3)) + +(test "failure continuation" + (match '(1 2) + ((a . b) (=> next) (if (even? a) 'fail (next))) + ((a . b) 'ok)) + 'ok) + +(test "let" + (match-let ((x 'ok) (y '(o k))) + y) + '(o k)) + +(test "let*" + (match-let* ((x 'f) (y 'o) ((z w) (list y x))) + (list x y z w)) + '(f o o f)) + +(test "getter car" + (match '(1 . 2) (((get! a) . b) (list (a) b))) + '(1 2)) + +(test "getter cdr" + (match '(1 . 2) ((a . (get! b)) (list a (b)))) + '(1 2)) + +(test "getter vector" + (match '#(1 2 3) (#((get! a) b c) (list (a) b c))) + '(1 2 3)) + +(test "setter car" + (let ((x (cons 1 2))) + (match x (((set! a) . b) (a 3))) + x) + '(3 . 2)) + +(test "setter cdr" + (let ((x (cons 1 2))) + (match x ((a . (set! b)) (b 3))) + x) + '(1 . 3)) + +(test "setter vector" + (let ((x (vector 1 2 3))) + (match x (#(a (set! b) c) (b 0))) + x) + '#(1 0 3)) + +(test "single tail" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) (c . 3))) + +(test "single tail 2" + (match '((a . 1) (b . 2) 3) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) 3)) + +(test "multiple tail" + (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) + (((x . y) ... u v w) (list x y u v w))) + '((a b) (1 2) (c . 3) (d . 4) (e . 5))) + +(test "Riastradh quasiquote" + (match '(1 2 3) (`(1 ,b ,c) (list b c))) + '(2 3)) + +(test "trivial tree search" + (match '(1 2 3) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "simple tree search" + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "deep tree search" + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "non-tail tree search" + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "restricted tree search" + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "fail restricted tree search" + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f)) + #f) + +(test "sxml tree search" + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f)) + '(((href . "http://synthcode.com/")) ("synthcode"))) + +(test "failed sxml tree search" + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f)) + #f) + +(test "collect tree search" + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f)) + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))) + +(test-report) + diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm new file mode 100644 index 00000000..76a783f0 --- /dev/null +++ b/tests/numeric-tests.scm @@ -0,0 +1,150 @@ + +;; these tests are only valid if chibi-scheme is compiled with full +;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-neighborhoods x) + (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) + +(test '(536870912 536870913 536870911 -536870912 -536870911 -536870913) + (integer-neighborhoods (expt 2 29))) + +(test '(1073741824 1073741825 1073741823 -1073741824 -1073741823 -1073741825) + (integer-neighborhoods (expt 2 30))) + +(test '(2147483648 2147483649 2147483647 -2147483648 -2147483647 -2147483649) + (integer-neighborhoods (expt 2 31))) + +(test '(4294967296 4294967297 4294967295 -4294967296 -4294967295 -4294967297) + (integer-neighborhoods (expt 2 32))) + +(test '(4611686018427387904 4611686018427387905 4611686018427387903 + -4611686018427387904 -4611686018427387903 -4611686018427387905) + (integer-neighborhoods (expt 2 62))) + +(test '(9223372036854775808 9223372036854775809 9223372036854775807 + -9223372036854775808 -9223372036854775807 -9223372036854775809) + (integer-neighborhoods (expt 2 63))) + +(test '(18446744073709551616 18446744073709551617 18446744073709551615 + -18446744073709551616 -18446744073709551615 -18446744073709551617) + (integer-neighborhoods (expt 2 64))) + +(test '(85070591730234615865843651857942052864 + 85070591730234615865843651857942052865 + 85070591730234615865843651857942052863 + -85070591730234615865843651857942052864 + -85070591730234615865843651857942052863 + -85070591730234615865843651857942052865) + (integer-neighborhoods (expt 2 126))) + +(test '(170141183460469231731687303715884105728 + 170141183460469231731687303715884105729 + 170141183460469231731687303715884105727 + -170141183460469231731687303715884105728 + -170141183460469231731687303715884105727 + -170141183460469231731687303715884105729) + (integer-neighborhoods (expt 2 127))) + +(test '(340282366920938463463374607431768211456 + 340282366920938463463374607431768211457 + 340282366920938463463374607431768211455 + -340282366920938463463374607431768211456 + -340282366920938463463374607431768211455 + -340282366920938463463374607431768211457) + (integer-neighborhoods (expt 2 128))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-arithmetic-combinations a b) + (list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b))) + +(define (sign-combinations a b) + (list (integer-arithmetic-combinations a b) + (integer-arithmetic-combinations (- a) b) + (integer-arithmetic-combinations a (- b)) + (integer-arithmetic-combinations (- a) (- b)))) + +;; fix x fix +(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0)) + (sign-combinations 0 1)) +(test '((2 0 1 1 0) (0 -2 -1 -1 0) (0 2 -1 -1 0) (-2 0 1 1 0)) + (sign-combinations 1 1)) +(test '((59 25 714 2 8) (-25 -59 -714 -2 -8) + (25 59 -714 -2 8) (-59 -25 714 2 -8)) + (sign-combinations 42 17)) + +;; fix x big +(test '((4294967338 -4294967254 180388626432 0 42) + (4294967254 -4294967338 -180388626432 0 -42) + (-4294967254 4294967338 -180388626432 0 42) + (-4294967338 4294967254 180388626432 0 -42)) + (sign-combinations 42 (expt 2 32))) + +;; big x fix +(test '((4294967338 4294967254 180388626432 102261126 4) + (-4294967254 -4294967338 -180388626432 -102261126 -4) + (4294967254 4294967338 -180388626432 -102261126 4) + (-4294967338 -4294967254 180388626432 102261126 -4)) + (sign-combinations (expt 2 32) 42)) + +;; big x bigger +(test '((12884901889 -4294967297 36893488151714070528 0 4294967296) + (4294967297 -12884901889 -36893488151714070528 0 -4294967296) + (-4294967297 12884901889 -36893488151714070528 0 4294967296) + (-12884901889 4294967297 36893488151714070528 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) + +(test '((18446744078004518913 -18446744069414584321 79228162514264337597838917632 0 4294967296) + (18446744069414584321 -18446744078004518913 -79228162514264337597838917632 0 -4294967296) + (-18446744069414584321 18446744078004518913 -79228162514264337597838917632 0 4294967296) + (-18446744078004518913 18446744069414584321 79228162514264337597838917632 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 64)))) + +;; bigger x big +(test '((12884901889 4294967297 36893488151714070528 2 1) + (-4294967297 -12884901889 -36893488151714070528 -2 -1) + (4294967297 12884901889 -36893488151714070528 -2 1) + (-12884901889 -4294967297 36893488151714070528 2 -1)) + (sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) + +(test '((18446744078004518913 18446744069414584321 79228162514264337597838917632 4294967296 1) + (-18446744069414584321 -18446744078004518913 -79228162514264337597838917632 -4294967296 -1) + (18446744069414584321 18446744078004518913 -79228162514264337597838917632 -4294967296 1) + (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1)) + (sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) + +(test-report) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..1b22acd2 --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,483 @@ + +(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) + (write *tests-run*) + (display ". ") + (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 -2 (let () + (define x 2) + (define f (lambda () (- x))) + (f))) + +(define let*-def 1) +(let* () (define let*-def 2) #f) +(test 1 let*-def) + +(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 4 16 9 8) + `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 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 #f (eqv? 2 2.0)) + +;;(test #f (equal? 2.0 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)) + +;;;; these will fail when compiled either without flonums or trig funcs + +;; (test #t (= -5 (floor -4.3))) + +;; (test #t (= -4 (ceiling -4.3))) + +;; (test #t (= -4 (truncate -4.3))) + +;; (test #t (= -4 (round -4.3))) + +;; (test #t (= 3 (floor 3.5))) + +;; (test #t (= 4 (ceiling 3.5))) + +;; (test #t (= 3 (truncate 3.5))) + +;; (test #t (= 4 (round 3.5))) + +(test 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 127 (string->number "177" 8)) + +(test 5 (string->number "101" 2)) + +(test 100 (string->number "1e2")) + +(test "100" (number->string 100)) + +(test "100" (number->string 256 16)) + +(test "FF" (number->string 255 16)) + +(test "177" (number->string 127 8)) + +(test "101" (number->string 5 2)) + +(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 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + +(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 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad)))) + +(test 'ok (let ((=> 1)) (cond (#t => 'ok)))) + +(test '(,foo) (let ((unquote 1)) `(,foo))) + +(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) + +(test 'ok + (let ((... 2)) + (let-syntax ((s (syntax-rules () + ((_ x ...) 'bad) + ((_ . r) 'ok)))) + (s a b c)))) + +(test 'ok (let () + (let-syntax () + (define internal-def 'ok)) + internal-def)) + +(test 'ok (let () + (letrec-syntax () + (define internal-def 'ok)) + internal-def)) + +(test '(2 1) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y)))))) + +(test '(2 2) + ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y)))))) + +(test '(1 2) + ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y)))))) + +(test '(2 3) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) + +(test '(a b c) + (let* ((path '()) + (add (lambda (s) (set! path (cons s path))))) + (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) + (reverse path))) + +(test '(connect talk1 disconnect connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + +(test 2 (let-syntax + ((foo (syntax-rules ::: () + ((foo ... args :::) + (args ::: ...))))) + (foo 3 - 5))) + +(test '(5 4 1 2 3) + (let-syntax + ((foo (syntax-rules () + ((foo args ... penultimate ultimate) + (list ultimate penultimate args ...))))) + (foo 1 2 3 4 5))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) diff --git a/tools/genstubs.scm b/tools/genstubs.scm new file mode 100755 index 00000000..037e853e --- /dev/null +++ b/tools/genstubs.scm @@ -0,0 +1,1154 @@ +#! /usr/bin/env chibi-scheme + +;; Note: this evolved as a throw-away script to provide certain core +;; modules, and so is a mess. Tread carefully. + +;; Simple C FFI. "genstubs.scm file.stub" will read in the C function +;; FFI definitions from file.stub and output the appropriate C +;; wrappers into file.c. You can then compile that file with: +;; +;; cc -fPIC -shared file.c -lchibi-scheme +;; +;; (or using whatever flags are appropriate to generate shared libs on +;; your platform) and then the generated .so file can be loaded +;; directly with load, or portably using (include-shared "file") in a +;; module definition (note that include-shared uses no suffix). + +;; The goal of this interface is to make access to C types and +;; functions easy, without requiring the user to write any C code. +;; That means the stubber needs to be intelligent about various C +;; calling conventions and idioms, such as return values passed in +;; actual parameters. Writing C by hand is still possible, and +;; several of the core modules provide C interfaces directly without +;; using the stubber. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Struct Interface +;; +;; (define-c-struct struct-name +;; [predicate: predicate-name] +;; [constructor: constructor-name] +;; [finalizer: c_finalizer_name] +;; (type c_field_name getter-name setter-name) ...) +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Function Interface +;; +;; (define-c return-type name-spec (arg-type ...)) +;; +;; where name-space is either a symbol name, or a list of +;; (scheme-name c_name). If just a symbol, the C name is taken +;; to be the same with -'s replaced by _'s. +;; +;; arg-type is a type suitable for input validation and conversion. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Types +;; +;; Types +;; +;; Basic Types +;; void +;; boolean +;; char +;; sexp (no conversions) +;; +;; Integer Types: +;; signed-char short int long +;; unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t +;; time_t (in seconds, but using the chibi epoch of 2010/01/01) +;; errno (as a return type returns #f on error) +;; +;; Float Types: +;; float double long-double +;; +;; String Types: +;; string - a null-terminated char* +;; env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme +;; in addition you can use (array char) as a string +;; +;; Port Types: +;; input-port output-port +;; +;; Struct Types: +;; +;; Struct types are by default just referred to by the bare +;; struct-name from define-c-struct, and it is assumed you want a +;; pointer to that type. To refer to the full struct, use the struct +;; modifier, as in (struct struct-name). + +;; Type modifiers +;; +;; Any type may also be written as a list of modifiers followed by the +;; type itself. The supported modifiers are: +;; +;; const: prepends the "const" C type modifier +;; * as a return or result parameter, makes non-immediates immutable +;; +;; free: it's Scheme's responsibility to "free" this resource +;; * as a return or result parameter, registers the freep flag +;; this causes the type finalizer to be run when GCed +;; +;; maybe-null: this pointer type may be NULL +;; * as a result parameter, NULL is translated to #f +;; normally this would just return a wrapped NULL pointer +;; * as an input parameter, #f is translated to NULL +;; normally this would be a type error +;; +;; pointer: create a pointer to this type +;; * as a return parameter, wraps the result in a vanilla cpointer +;; * as a result parameter, boxes then unboxes the value +;; +;; struct: treat this struct type as a struct, not a pointer +;; * as an input parameter, dereferences the pointer +;; * as a type field, indicates a nested struct +;; +;; link: add a gc link +;; * as a field getter, link to the parent object, so the +;; parent won't be GCed so long as we have a reference +;; to the child. this behavior is automatic for nested +;; structs. +;; +;; result: return a result in this parameter +;; * if there are multiple results (including the return type), +;; they are all returned in a list +;; * if there are any result parameters, a return type +;; of errno returns #f on failure, and as eliminated +;; from the list of results otherwise +;; +;; (value ): specify a fixed value +;; * as an input parameter, this parameter is not provided +;; in the Scheme API but always passed as +;; +;; (default ): specify a default value +;; * as the final input parameter, makes the Scheme parameter +;; optional, defaulting to +;; +;; (array []) an array type +;; * length must be specified for return and result parameters +;; * if specified, length can be any of +;; ** an integer, for a fixed size +;; ** the symbol null, indicating a NULL-terminated array + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; globals + +(define *types* '()) +(define *funcs* '()) +(define *consts* '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type objects + +(define (parse-type type . o) + (cond + ((vector? type) + type) + (else + (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) + (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f) + (value #f) (default? #f)) + (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) + (case (and (pair? type) (car type)) + ((free) + (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) + ((const) + (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) + ((maybe-null) + (lp (next) free? const? #t ptr? struct? link? result? array value default?)) + ((pointer) + (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) + ((struct) + (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) + ((link) + (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) + ((result) + (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) + ((array) + (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) + ((value) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) + ((default) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) + (else + (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) + +(define (type-base type) (vector-ref type 0)) +(define (type-free? type) (vector-ref type 1)) +(define (type-const? type) (vector-ref type 2)) +(define (type-null? type) (vector-ref type 3)) +(define (type-pointer? type) (vector-ref type 4)) +(define (type-struct? type) (vector-ref type 5)) +(define (type-link? type) (vector-ref type 6)) +(define (type-result? type) (vector-ref type 7)) +(define (type-array type) (vector-ref type 8)) +(define (type-value type) (vector-ref type 9)) +(define (type-default? type) (vector-ref type 10)) +(define (type-index type) (vector-ref type 11)) + +(define (type-auto-expand? type) + (and (pair? (type-array type)) + (memq 'auto-expand (type-array type)))) + +(define (type-index-string type) + (if (integer? (type-index type)) + (number->string (type-index type)) + "")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type predicates + +(define (signed-int-type? type) + (memq type '(signed-char short int long boolean))) + +(define (unsigned-int-type? type) + (memq type '(unsigned-char unsigned-short unsigned-int unsigned-long + size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t + uid_t gid_t pid_t blksize_t blkcnt_t sigval_t))) + +(define (int-type? type) + (or (signed-int-type? type) (unsigned-int-type? type))) + +(define (float-type? type) + (memq type '(float double long-double long-long-double))) + +(define (string-type? type) + (or (memq type '(char* string env-string non-null-string)) + (and (vector? type) + (type-array type) + (not (type-pointer? type)) + (eq? 'char (type-base type))))) + +(define (error-type? type) + (memq type '(errno non-null-string non-null-pointer))) + +(define (array-type? type) + (and (type-array type) (not (eq? 'char (type-base type))))) + +(define (basic-type? type) + (let ((type (parse-type type))) + (and (not (type-array type)) + (not (assq (type-base type) *types*))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; function objects + +(define (parse-func func) + (if (not (and (= 3 (length func)) + (or (identifier? (cadr func)) (list (cadr func))) + (list (caddr func)))) + (error "bad function definition" func)) + (let* ((ret-type (parse-type (car func))) + (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) + (c-name (if (pair? (cadr func)) + (cadadr func) + (mangle scheme-name))) + (stub-name (if (and (pair? (cadr func)) (pair? (cddadr func))) + (car (cddadr func)) + (generate-stub-name scheme-name)))) + (let lp ((ls (caddr func)) + (i 0) + (results '()) + (c-args '()) + (s-args '())) + (cond + ((null? ls) + (if (>= i 6) + (error "FFI currently only supports up to 6 scheme args" func)) + (vector scheme-name c-name stub-name ret-type + (reverse results) (reverse c-args) (reverse s-args))) + (else + (let ((type (parse-type (car ls) i))) + (cond + ((type-result? type) + (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) + ((and (type-value type) (not (type-default? type))) + (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) + (else + (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) + ))))))) + +(define (func-scheme-name func) (vector-ref func 0)) +(define (func-c-name func) (vector-ref func 1)) +(define (func-stub-name func) (vector-ref func 2)) +(define (func-ret-type func) (vector-ref func 3)) +(define (func-results func) (vector-ref func 4)) +(define (func-c-args func) (vector-ref func 5)) +(define (func-scheme-args func) (vector-ref func 6)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (cat . args) + (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (filter pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (cons (car ls) (filter pred (cdr ls)))) + (else (filter pred (cdr ls))))) + +(define (remove pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (filter pred (cdr ls))) + (else (cons (car ls) (filter pred (cdr ls)))))) + +(define (strip-extension path) + (let lp ((i (- (string-length path) 1))) + (cond ((<= i 0) path) + ((eq? #\. (string-ref path i)) (substring path 0 i)) + (else (lp (- i 1)))))) + +(define (string-concatenate-reverse ls) + (cond ((null? ls) "") + ((null? (cdr ls)) (car ls)) + (else (string-concatenate (reverse ls))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase str) + (list->string (map char-downcase (string->list str)))) + +(define (with-output-to-string thunk) + (call-with-output-string + (lambda (out) + (let ((old-out (current-output-port))) + (current-output-port out) + (thunk) + (current-output-port old-out))))) + +(define (definite-article x) + (define (vowel? c) + (memv c '(#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U))) + (define (vowel-exception? str) + (member (string-downcase str) + '("european" "ewe" "unicorn" "unicycle" "university" "user"))) + (define (consonant-exception? str) + ;; not "historic" according to elements of style + (member (string-downcase str) + '("heir" "herb" "herbal" "herbivore" "honest" "honor" "hour"))) + (let* ((full-str (with-output-to-string (lambda () (cat x)))) + (i (string-scan #\space full-str)) + (str (if i (substring full-str 0 i) full-str))) + (string-append + (cond + ((equal? str "") "a ") + ((vowel? (string-ref str 0)) (if (vowel-exception? str) "a " "an ")) + (else (if (consonant-exception? str) "an " "a "))) + full-str))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; naming + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +(define (generate-stub-name sym) + (string-append "sexp_" (mangle sym) "_stub")) + +(define (type-id-name sym) + (string-append "sexp_" (mangle sym) "_type_id")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; .stub file interface + +(define (c-declare . args) + (apply cat args) + (newline)) + +(define (c-include header) + (cat "\n#include \"" header "\"\n")) + +(define (c-system-include header) + (cat "\n#include <" header ">\n")) + +(define (parse-struct-like ls) + (map (lambda (x) (if (pair? x) (cons (parse-type (car x)) (cdr x)) x)) ls)) + +(define-syntax define-struct-like + (er-macro-transformer + (lambda (expr rename compare) + (set! *types* + `((,(cadr expr) + ,@(parse-struct-like (cddr expr))) + ,@*types*)) + `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) + +(define-syntax define-c-struct + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr))))) + +(define-syntax define-c-class + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) + +(define-syntax define-c-type + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) ,@(cddr expr))))) + +(define-syntax define-c + (er-macro-transformer + (lambda (expr rename compare) + (set! *funcs* (cons (parse-func (cdr expr)) *funcs*)) + #f))) + +(define-syntax define-c-const + (er-macro-transformer + (lambda (expr rename compare) + (set! *consts* + (cons (cons (parse-type (cadr expr)) (cddr expr)) *consts*))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; C code generation + +(define (c->scheme-converter type val . o) + (let ((base (type-base type))) + (cond + ((eq? base 'void) + (cat "((" val "), SEXP_VOID)")) + ((or (eq? base 'sexp) (error-type? base)) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_make_boolean(" val ")")) + ((eq? base 'time_t) + (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) + ((int-type? base) + (cat "sexp_make_integer(ctx, " val ")")) + ((eq? base 'char) + (if (type-array type) + (cat "sexp_c_string(ctx, " val ", -1)") + (cat "sexp_make_character(ctx, " val ")"))) + ((eq? 'env-string base) + (cat "(p=strchr(" val ", '=') ? " + "sexp_cons(ctx, str=sexp_c_string(ctx, " val ", p - " val "), str=sexp_c_string(ctx, p, -1))" + " : sexp_cons(ctx, str=" val ", SEXP_FALSE)")) + ((string-type? base) + (cat "sexp_c_string(ctx, " val ", -1)")) + ((eq? 'input-port base) + (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)")) + ((eq? 'output-port base) + (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) + (else + (let ((ctype (assq base *types*))) + (cond + (ctype + (cat "sexp_make_cpointer(ctx, " (type-id-name base) ", " + val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " + (if (or (type-free? type) + (and (type-result? type) (not (basic-type? type)))) + 1 + 0) + ")")) + (else + (error "unknown type" base)))))))) + +(define (scheme->c-converter type val) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'sexp) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_truep(" val ")")) + ((eq? base 'time_t) + (cat "sexp_unshift_epoch(sexp_uint_value(" val "))")) + ((signed-int-type? base) + (cat "sexp_sint_value(" val ")")) + ((unsigned-int-type? base) + (cat "sexp_uint_value(" val ")")) + ((eq? base 'char) + (cat "sexp_unbox_character(" val ")")) + ((eq? base 'env-string) + (cat "sexp_concat_env_string(" val ")")) + ((string-type? base) + (cat "sexp_string_data(" val ")")) + (else + (let ((ctype (assq base *types*))) + (cond + (ctype + (cat "(" (type-c-name type) ")" + (if (type-null? type) + "sexp_cpointer_maybe_null_value" + "sexp_cpointer_value") + "(" val ")")) + (else + (error "unknown type" base)))))))) + +(define (type-predicate type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "sexp_exact_integerp") + ((float-type? base) "sexp_flonump") + ((string-type? base) "sexp_stringp") + ((eq? base 'char) "sexp_charp") + ((eq? base 'boolean) "sexp_booleanp") + (else #f)))) + +(define (type-name type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "integer") + ((float-type? base) "flonum") + ((eq? 'boolean base) "int") + (else base)))) + +(define (base-type-c-name base) + (case base + ((string env-string non-null-string) "char*") + (else (symbol->string base)))) + +(define (type-struct-type type) + (let ((type-spec (assq (if (vector? type) (type-base type) type) *types*))) + (cond ((and type-spec (memq 'type: type-spec)) => cadr) + (else #f)))) + +(define (type-c-name type) + (let* ((type (parse-type type)) + (base (type-base type)) + (type-spec (assq base *types*)) + (struct-type (type-struct-type type))) + (string-append + (if (type-const? type) "const " "") + (if struct-type (string-append (symbol->string struct-type) " ") "") + (string-replace (base-type-c-name base) #\- " ") + (if type-spec "*" "") + (if (type-pointer? type) "*" "")))) + +(define (check-type arg type) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'env-string) + (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg + ")) && sexp_stringp(sexp_cdr(" arg ")))")) + ((or (int-type? base) (float-type? base) (string-type? base)) + (cat (type-predicate type) "(" arg ")")) + (else + (cond + ((assq base *types*) + (cat + (if (type-null? type) "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " (type-id-name base) "))" + (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) + (else + (display "WARNING: don't know how to check: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (cat "1"))))))) + +(define (write-validator arg type) + (let* ((type (parse-type type)) + (array (type-array type)) + (base-type (type-base type))) + (cond + ((and array (not (string-type? type))) + (cond + ((number? array) + (cat " if (!sexp_listp(ctx, " arg ")" + " || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n" + " return sexp_type_exception(ctx, \"not a list\", " arg ");\n"))) + (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" + " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" + " return sexp_type_exception(ctx, \"not a list of " + (type-name type) "s\", " arg ");\n") + (if (not (number? array)) + (cat " if (! sexp_nullp(res))\n" + " return sexp_type_exception(ctx, \"not a list of " + (type-name type) "s\", " arg ");\n"))) + ((or (int-type? base-type) + (float-type? base-type) + (string-type? base-type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, \"not " + (definite-article (type-name type)) "\", " + arg ");\n")) + (else + (cond + ((assq base-type *types*) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, \"not " + (definite-article (type-name type)) "\", " arg ");\n")) + ((eq? 'sexp base-type)) + ((string-type? type) + (write-validator arg 'string)) + (else + (display "WARNING: don't know how to validate: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (write type))))))) + +(define (write-parameters args) + (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) + +(define (get-array-length func x) + (let ((len (if (pair? (type-array x)) + (car (reverse (type-array x))) + (type-array x)))) + (if (number? len) + len + (and (symbol? len) + (let* ((str (symbol->string len)) + (len (string-length str))) + (and (> len 3) + (string=? "arg" (substring str 0 3)) + (let ((i (string->number (substring str 3 len)))) + (if i + (let ((y (list-ref (func-c-args func) i))) + (or (type-value y) y)))))))))) + +(define (write-locals func) + (define (arg-res x) + (string-append "res" (type-index-string x))) + (let* ((ret-type (func-ret-type func)) + (results (func-results func)) + (scheme-args (func-scheme-args func)) + (return-res? (not (error-type? (type-base ret-type)))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons ret-type results))) + (gc-vars (map arg-res results)) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (sexps (if preserve-res? '() '("res"))) + (num-gc-vars (length gc-vars)) + (ints (if (or return-res? + (memq (type-base ret-type) + '(non-null-string non-null-pointer))) + '() + '("err"))) + (ints (if (or (array-type? ret-type) + (any array-type? results) + (any array-type? scheme-args)) + (cons "i" ints) + ints))) + (case (type-base ret-type) + ((non-null-string) (cat " char *err;\n")) + ((non-null-pointer) (cat " void *err;\n"))) + (cond + ((pair? ints) + (cat " int " (car ints)) + (for-each (lambda (x) (display ", ") (display x)) (cdr ints)) + (cat ";\n"))) + (if (any (lambda (a) (eq? 'env-string (type-base a))) + (cons ret-type results)) + (cat " char *p;\n")) + (for-each + (lambda (x) + (let ((len (get-array-length func x))) + (cat " " (type-c-name (type-base x)) " ") + (if (and (type-array x) (not (number? len))) + (cat "*")) + (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) + (if (number? len) + (cat "[" len "]")) + (cat ";\n") + (if (or (vector? len) (type-auto-expand? x)) + (cat " int len" (type-index x) ";\n")) + (if (type-auto-expand? x) + (cat " " (type-c-name (type-base x)) + " *tmp" (type-index-string x) ";\n")))) + (append (if (type-array ret-type) (list ret-type) '()) + results + (remove type-result? (filter type-array scheme-args)))) + (for-each + (lambda (arg) + (cond + ((and (type-pointer? arg) (basic-type? arg)) + (cat " " (type-c-name (type-base arg)) + " tmp" (type-index arg) ";\n")))) + scheme-args) + (cond + ((pair? sexps) + (cat " sexp " (car sexps)) + (for-each (lambda (x) (display ", ") (display x)) (cdr sexps)) + (cat ";\n"))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_var" num-gc-vars "(") + (display (car gc-vars)) + (for-each (lambda (x) (display ", ") (display x)) (cdr gc-vars)) + (cat ");\n") + (cat " sexp_gc_preserve" num-gc-vars "(ctx") + (for-each (lambda (x) (display ", ") (display x)) gc-vars) + (cat ");\n"))))) + +(define (write-validators args) + (for-each + (lambda (a) + (write-validator (string-append "arg" (type-index-string a)) a)) + args)) + +(define (write-temporaries func) + (for-each + (lambda (a) + (let ((len (and (type-array a) (get-array-length func a)))) + (cond + ((and (type-array a) (or (vector? len) (type-auto-expand? a))) + (cat " len" (type-index a) " = " + (lambda () + (if (number? len) (cat len) (scheme->c-converter 'int len))) + ";\n" + " tmp" (type-index a) " = buf" (type-index a) ";\n")))) + (cond + ((and (not (type-result? a)) (type-array a) (not (string-type? a))) + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) + " = (" (type-c-name (type-base a)) "*) malloc(" + "(sexp_unbox_fixnum(sexp_length(ctx, arg" (type-index a) + "))+1) * sizeof(tmp" (type-index a) "[0]));\n")) + (cat " for (i=0, res=arg" (type-index a) + "; sexp_pairp(res); res=sexp_cdr(res), i++) {\n" + " tmp" (type-index a) "[i] = " + (lambda () (scheme->c-converter (type-base a) "sexp_car(res)")) + ";\n" + " }\n") + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) "[i] = NULL;\n"))) + ((and (type-result? a) (not (basic-type? a)) + (not (type-free? a)) (not (type-pointer? a)) + (not (type-auto-expand? a)) + (or (not (type-array a)) + (not (integer? (get-array-length func a))))) + (cat " tmp" (type-index a) " = malloc(sizeof(tmp" (type-index a) + "[0]));\n")) + ((and (type-pointer? a) (basic-type? a)) + (cat " tmp" (type-index a) " = " + (lambda () + (scheme->c-converter + a + (string-append "arg" (type-index-string a)))) + ";\n")))) + (func-c-args func))) + +(define (write-actual-parameter func arg) + (cond + ((and (not (type-default? arg)) (type-value arg)) + => (lambda (x) + (cond + ((any (lambda (y) + (and (type-array y) + (type-auto-expand? y) + (eq? x (get-array-length func y)))) + (func-c-args func)) + => (lambda (y) (cat "len" (type-index y)))) + (else (write x))))) + ((or (type-result? arg) (type-array arg)) + (cat (if (or (type-pointer? arg) (type-free? arg) (basic-type? arg)) + "&" + "") + "tmp" (type-index arg))) + ((and (type-pointer? arg) (basic-type? arg)) + (cat "&tmp" (type-index arg))) + (else + (scheme->c-converter + arg + (string-append "arg" (type-index-string arg)))))) + +(define (write-call func) + (let ((ret-type (func-ret-type func)) + (c-name (func-c-name func)) + (c-args (func-c-args func))) + (if (any type-auto-expand? (func-c-args func)) + (cat " loop:\n")) + (cat (cond ((error-type? (type-base ret-type)) " err = ") + ((type-array ret-type) " tmp = ") + (else " res = "))) + ((if (type-array ret-type) + (lambda (t f x) (f)) + c->scheme-converter) + ret-type + (lambda () + (cat c-name "(") + (for-each + (lambda (arg) + (if (> (type-index arg) 0) (cat ", ")) + (write-actual-parameter func arg)) + c-args) + (cat ")")) + (cond + ((any type-link? (func-c-args func)) + => (lambda (a) (string-append "arg" (type-index-string a)))) + (else #f))) + (cat ";\n") + (if (type-array ret-type) + (write-result ret-type)))) + +(define (write-result result) + (let ((res (string-append "res" (type-index-string result))) + (tmp (string-append "tmp" (type-index-string result)))) + (cond + ((and (type-array result) (eq? 'char (type-base result))) + (cat " " res " = " (lambda () (c->scheme-converter result tmp)) ";\n")) + ((type-array result) + (cat " " res " = SEXP_NULL;\n") + (let ((auto-expand? + (and (pair? (type-array result)) + (memq 'auto-expand (type-array result)))) + (len (if (pair? (type-array result)) + (car (reverse (type-array result))) + (type-array result)))) + (cond + ((eq? 'null len) + (cat " for (i=0; " tmp "[i]; i++) {\n" + " sexp_push(ctx, " res ", " + (if (eq? 'string (type-base result)) + "str=" + (lambda () (cat "SEXP_VOID);\n sexp_car(" res ") = "))) + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ");\n" + " }\n" + " " res " = sexp_nreverse(ctx, " res ");\n")) + (else + (cat " for (i=" len "-1; i>=0; i--) {\n" + " sexp_push(ctx, " res ", SEXP_VOID);\n" + " sexp_car(" res ") = " + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ";\n" + " }\n"))))) + (else + (cat " " res " = ") + (c->scheme-converter + result + (string-append "tmp" (type-index-string result))) + (cat ";\n"))))) + +(define (write-results func) + (let ((error-res? (error-type? (type-base (func-ret-type func)))) + (results (func-results func))) + (if error-res? + (cat " if (" + (if (memq (type-base (func-ret-type func)) + '(non-null-string non-null-pointer)) + "!" + "") + "err) {\n" + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (lambda () + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")) + (cat " len" i " *= 2;\n" + " tmp" i + " = malloc(len" i "*sizeof(tmp" i "[0]));\n" + " goto loop;\n"))))) + (else + " res = SEXP_FALSE;\n")) + " } else {\n")) + (if (null? results) + (if error-res? + (cat " res = SEXP_TRUE;\n")) + (for-each write-result results)) + (cond + ((> (length results) (if error-res? 1 0)) + (if error-res? + (cat " res = SEXP_NULL;\n") + (cat " res = sexp_cons(ctx, res, SEXP_NULL);\n")) + (for-each + (lambda (x) + (if error-res? + (cat " sexp_push(ctx, res, res" (type-index x) ");\n") + (cat " sexp_push(ctx, res, sexp_car(res));\n" + " sexp_cadr(res) = res" (type-index x) ";\n"))) + (reverse results))) + ((pair? results) + (cat " res = res" (type-index (car results)) ";\n"))) + (if error-res? + (cat " }\n")))) + +(define (write-free type) + (if (type-array type) + (cat " free(tmp" (type-index-string type) ");\n"))) + +(define (write-cleanup func) + (for-each write-free (func-scheme-args func)) + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n"))))) + (else + " res = SEXP_FALSE;\n")) + (let* ((results (func-results func)) + (return-res? (not (error-type? (type-base (func-ret-type func))))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons (func-ret-type func) + (func-results func)))) + (gc-vars results) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (num-gc-vars (length gc-vars))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_release" num-gc-vars "(ctx);\n"))))) + +(define (write-func func) + (cat "static sexp " (func-stub-name func) + " (sexp ctx" (write-parameters (func-scheme-args func)) ") {\n") + (write-locals func) + (write-validators (func-scheme-args func)) + (write-temporaries func) + (write-call func) + (write-results func) + (write-cleanup func) + (cat " return res;\n" + "}\n\n")) + +(define (write-func-binding func) + (let ((default (and (pair? (func-scheme-args func)) + (type-default? (car (reverse (func-scheme-args func)))) + (car (reverse (func-scheme-args func)))))) + (cat (if default + " sexp_define_foreign_opt(ctx, env, " + " sexp_define_foreign(ctx, env, ") + (lambda () (write (symbol->string (func-scheme-name func)))) + ", " (length (func-scheme-args func)) ", " + (func-stub-name func) + (if default ", " "") + (if default + (lambda () + (c->scheme-converter default (type-value default))) + "") + ");\n"))) + +(define (write-type type) + (let ((name (car type)) + (type (cdr type))) + (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" + " " (type-id-name name) + " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, " + (cond ((memq 'finalizer: type) + => (lambda (x) (generate-stub-name (cadr x)))) + (else "sexp_finalize_c_type")) + "));\n") + (cond + ((memq 'predicate: type) + => (lambda (x) + (let ((pred (cadr x))) + (cat " tmp = sexp_make_type_predicate(ctx, name, " + "sexp_make_fixnum(" (type-id-name name) "));\n" + " name = sexp_intern(ctx, \"" pred "\");\n" + " sexp_env_define(ctx, env, name, tmp);\n"))))))) + +(define (type-getter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_get_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-getter type name field) + (cat "static sexp " (type-getter-name type name field) + " (sexp ctx, sexp x) {\n" + (lambda () (write-validator "x" name)) + " return " + (lambda () + (c->scheme-converter + (car field) + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (x->string (cadr field))) + (and (or (type-struct? (car field)) (type-link? (car field))) "x"))) + ";\n" + "}\n\n")) + +(define (type-setter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_set_" (x->string (type-base (parse-type (car field)))))) + +(define (write-type-setter type name field) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx, sexp x, sexp v) {\n" + (lambda () (write-validator "x" name)) + (lambda () (write-validator "v" (car field))) + " " + (lambda () (c->scheme-converter + (car field) + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (x->string (cadr field))))) + " = v;\n" + " return SEXP_VOID;" + "}\n\n")) + +(define (write-type-funcs type) + (let ((name (car type)) + (type (cdr type))) + ;; maybe write finalizer + (cond + ((memq 'finalizer: type) + => (lambda (x) + (cat "static sexp " (generate-stub-name (cadr x)) + " (sexp ctx, sexp x) {\n" + " if (sexp_cpointer_freep(x))\n" + " " (cadr x) "(sexp_cpointer_value(x));\n" + " return SEXP_VOID;\n" + "}\n\n")))) + ;; maybe write constructor + (cond + ((memq 'constructor: type) + => (lambda (x) + (let ((make (caadr x)) + (args (cdadr x))) + (cat "static sexp " (generate-stub-name make) + " (sexp ctx" + (lambda () (for-each (lambda (x) (cat ", sexp " x)) args)) + ") {\n" + " struct " (type-name name) " *r;\n" + " sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + (type-id-name name) + ");\n" + " sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " r = sexp_cpointer_value(res);\n" + " return res;\n" + "}\n\n") + (set! *funcs* + (cons (parse-func `(void ,make ,args)) *funcs*)))))) + ;; write field accessors + (for-each + (lambda (field) + (cond + ((and (pair? field) (pair? (cdr field))) + (cond + ((and (pair? (cddr field)) (caddr field)) + (write-type-getter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(caddr field) + #f + ,(type-getter-name type name field)) + (,name))) + *funcs*)))) + (cond + ((and (pair? (cddr field)) + (pair? (cdddr field)) + (car (cdddr field))) + (write-type-setter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(car (cdddr field)) + #f + ,(type-setter-name type name field)) + (,name ,(car field)))) + *funcs*))))))) + type))) + +(define (write-const const) + (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) + (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) + (cat " name = sexp_intern(ctx, \"" scheme-name "\");\n" + " sexp_env_define(ctx, env, name, tmp=" + (lambda () (c->scheme-converter (car const) c-name)) ");\n"))) + +(define (write-utilities) + (define (input-env-string? x) + (and (eq? 'env-string (type-base x)) (not (type-result? x)))) + (cond + ((any (lambda (f) + (or (any input-env-string? (func-results f)) + (any input-env-string? (func-scheme-args f)))) + *funcs*) + (cat "static char* sexp_concat_env_string (sexp x) {\n" + " int klen=sexp_string_length(sexp_car(x)), vlen=sexp_string_length(sexp_cdr(x));\n" + " char *res = (char*) malloc(klen+vlen+2);\n" + " strncpy(res, sexp_string_data(sexp_car(x)), klen);\n" + " res[sexp_string_length(sexp_car(x))] = '=';\n" + " strncpy(res+sexp_string_length(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n" + " res[len-1] = '\\0';\n" + " return res;\n" + "}\n\n")))) + +(define (write-init) + (newline) + (write-utilities) + (for-each write-func *funcs*) + (for-each write-type-funcs *types*) + (cat "sexp sexp_init_library (sexp ctx, sexp env) {\n" + " sexp_gc_var2(name, tmp);\n" + " sexp_gc_preserve2(ctx, name, tmp);\n") + (for-each write-const *consts*) + (for-each write-type *types*) + (for-each write-func-binding *funcs*) + (cat " sexp_gc_release2(ctx);\n" + " return SEXP_VOID;\n" + "}\n\n")) + +(define (generate file) + (display "/* automatically generated by chibi genstubs */\n") + (c-system-include "chibi/eval.h") + (load file) + (write-init)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main + +(define (main args) + (case (length args) + ((1) + (with-output-to-file (string-append (strip-extension (car args)) ".c") + (lambda () (generate (car args))))) + ((2) + (if (equal? "-" (cadr args)) + (generate (car args)) + (with-output-to-file (cadr args) (lambda () (generate (car args)))))) + (else + (error "usage: genstubs []")))) From 3a708218c4dc748b3d4257c2bd9cd5e76689ac3a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Dec 2009 23:41:38 +0900 Subject: [PATCH 310/535] removing reference to exit(0) for plan9 --- main.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main.c b/main.c index a8e52c8d..6edd9185 100644 --- a/main.c +++ b/main.c @@ -153,7 +153,7 @@ void run_main (int argc, char **argv) { break; case 'V': printf("chibi-scheme 0.3\n"); - exit(0); + return; default: fprintf(stderr, "unknown option: %s\n", argv[i]); exit_failure(); From f897ecc9c1041b7ca126dd497dd94d61d4388ba9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Dec 2009 03:17:03 +0900 Subject: [PATCH 311/535] adding chroot-based install test --- tests/install/install-tests.pl | 57 +++++++++++++++++++++++++++++++ tests/install/run-install-test.sh | 12 +++++++ 2 files changed, 69 insertions(+) create mode 100755 tests/install/install-tests.pl create mode 100755 tests/install/run-install-test.sh diff --git a/tests/install/install-tests.pl b/tests/install/install-tests.pl new file mode 100755 index 00000000..63681324 --- /dev/null +++ b/tests/install/install-tests.pl @@ -0,0 +1,57 @@ +#! /usr/bin/env perl + +use strict; +use warnings; + +my $ROOT="tests/install/root"; +my $USER=$ENV{USER}; + +my $ignore = qr!/lib\d*/modules|/X11|alsa-lib|aspell|dosemu|emacs|erlang|/perl|python|ruby|lisp|sbcl|/ghc-|ocaml|evolution|office|gimp|gtk|mysql|postgres|wordnet|xulrunner!; + +sub linkdir ($$$) { + my ($FROM, $TO, $DEPTH) = @_; + mkdir $TO; + for my $f (`ls $FROM`) { + chomp $f; + if (-d "$FROM/$f") { + if (($DEPTH > 0) && ($FROM !~ $ignore)) { + linkdir("$FROM/$f", "$TO/$f", $DEPTH-1); + } + } else { + link "$FROM/$f", "$TO/$f"; + } + } +} + +mkdir "$ROOT"; +mkdir "$ROOT/bin"; +mkdir "$ROOT/sbin"; +mkdir "$ROOT/dev"; +mkdir "$ROOT/etc"; +mkdir "$ROOT/etc/alternatives"; +mkdir "$ROOT/lib"; +mkdir "$ROOT/lib64"; +mkdir "$ROOT/usr"; +mkdir "$ROOT/usr/bin"; +mkdir "$ROOT/usr/include"; +mkdir "$ROOT/usr/lib"; +mkdir "$ROOT/usr/lib/gcc"; + +linkdir "/bin", "$ROOT/bin", 1; +linkdir "/sbin", "$ROOT/sbin", 1; +link "/etc/passwd", "$ROOT/etc/passwd"; +linkdir "/etc/alternatives", "$ROOT/etc/alternatives", 1; +linkdir "/lib", "$ROOT/lib", 3; +linkdir "/lib64", "$ROOT/lib64", 3; +linkdir "/usr/bin", "$ROOT/usr/bin", 3; +linkdir "/usr/include", "$ROOT/usr/include", 2; +linkdir "/usr/lib", "$ROOT/usr/lib", 3; +linkdir "/usr/lib/gcc", "$ROOT/usr/lib/gcc", 3; + +`make dist`; +my $VERSION=`cat VERSION`; +chomp $VERSION; +`cp chibi-scheme-$VERSION.tgz $ROOT/`; +`sed -e 's/\@VERSION\@/$VERSION/g' $ROOT/bin/run-install-test.sh`; +`chmod 755 $ROOT/bin/run-install-test.sh`; +exec "sudo chroot $ROOT run-install-test.sh"; diff --git a/tests/install/run-install-test.sh b/tests/install/run-install-test.sh new file mode 100755 index 00000000..c558e7cd --- /dev/null +++ b/tests/install/run-install-test.sh @@ -0,0 +1,12 @@ +#! /bin/bash + +export PATH=/usr/local/bin:$PATH +export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH + +tar xzvf chibi-scheme-@VERSION@.tgz +cd chibi-scheme-@VERSION@ +make +make install +cp tests/r5rs-tests.scm .. +cd .. +chibi-scheme r5rs-tests.scm | tee r5rs-tests.out From e5bcac2142a001bcf0f81ffeee69cc3f300d529d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Dec 2009 14:27:53 +0900 Subject: [PATCH 312/535] adding sexp_make_unsigned_integer, using that in the stubber for unsigned types --- include/chibi/sexp.h | 4 +++- opt/bignum.c | 23 ++++++++++++++++++++--- tools/genstubs.scm | 4 +++- 3 files changed, 26 insertions(+), 5 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 72fbe564..28f2fed8 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -474,10 +474,12 @@ sexp sexp_make_flonum(sexp ctx, double f); #endif #if SEXP_USE_BIGNUMS -SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); +SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x); +SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) #else #define sexp_make_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_make_unsigned_integer(ctx, x) sexp_make_fixnum(x) #define sexp_exact_integerp(x) sexp_fixnump(x) #endif diff --git a/opt/bignum.c b/opt/bignum.c index 90f71661..60215de8 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -25,14 +25,31 @@ sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { return res; } -sexp sexp_make_integer (sexp ctx, sexp_sint_t x) { +sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { sexp res; if ((SEXP_MIN_FIXNUM < x) && (x < SEXP_MAX_FIXNUM)) { res = sexp_make_fixnum(x); } else { res = sexp_make_bignum(ctx, 1); - sexp_bignum_sign(res) = (x < 0 ? -1 : 1); - sexp_bignum_data(res)[0] = x * sexp_bignum_sign(res); + if (x < 0) { + sexp_bignum_sign(res) = -1; + sexp_bignum_data(res)[0] = -x; + } else { + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + } + return res; +} + +sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { + sexp res; + if (x < SEXP_MAX_FIXNUM) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; } return res; } diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 037e853e..4f248554 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -452,7 +452,9 @@ (cat "sexp_make_boolean(" val ")")) ((eq? base 'time_t) (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) - ((int-type? base) + ((unsigned-int-type? base) + (cat "sexp_make_unsigned_integer(ctx, " val ")")) + ((signed-int-type? base) (cat "sexp_make_integer(ctx, " val ")")) ((eq? base 'char) (if (type-array type) From dd16dcef2dbe5a5b1af2373dd50da3bf90a72117 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Dec 2009 14:39:13 +0900 Subject: [PATCH 313/535] renaming config.h to features.h --- Makefile | 2 +- README | 52 +++++++++++++++++--------- include/chibi/{config.h => features.h} | 2 +- include/chibi/sexp.h | 2 +- 4 files changed, 38 insertions(+), 20 deletions(-) rename include/chibi/{config.h => features.h} (99%) diff --git a/Makefile b/Makefile index fee25951..aa4fd2df 100644 --- a/Makefile +++ b/Makefile @@ -90,7 +90,7 @@ COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ libs: $(COMPILED_LIBS) -INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h +INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/install.h: Makefile echo '#define sexp_so_extension "'$(SO)'"' > $@ diff --git a/README b/README index d1476de2..172c476d 100644 --- a/README +++ b/README @@ -23,9 +23,9 @@ To build, just run "make". This will provide a shared library 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 +You can edit the file chibi/features.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 CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 @@ -36,7 +36,7 @@ to optimize for size, or 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 +against the Boehm conservative GC by editing the features.h file, or directly from make with: make SEXP_USE_BOEHM=1 @@ -154,7 +154,25 @@ this. Currently you can load the following SRFIs with (import (srfi N)): - 0, 1, 2, 6, 8, 9, 11, 16, 22, 23, 26, 27, 33, 39, 46, 62, 69, 95, 98 + (srfi 0) - cond-expand + (srfi 1) - list library + (srfi 2) - and-let* + (srfi 6) - basic string ports + (srfi 8) - receive + (srfi 9) - define-record-type + (srfi 11) - let-values/let*-values + (srfi 16) - case-lambda + (srfi 22) - running scheme scripts on Unix + (srfi 23) - error reporting mechanism + (srfi 26) - cut/cute partial application + (srfi 27) - sources of random bits + (srfi 33) - bitwise operators + (srfi 39) - prameter objects + (srfi 46) - basic syntax-rules extensions + (srfi 62) - s-expression comments + (srfi 69) - basic hash tables + (srfi 95) - sorting and merging + (srfi 98) - environment access although 0, 22, 23, 46 and 62 are built into the default environment so there's no need to import them. @@ -162,19 +180,19 @@ so there's no need to import them. Included non-standard modules are put in the (chibi) module namespace. The following additional modules are available: - (chibi net) - networking interface - (chibi filesystem) - local filesystem and file descriptor interface - (chibi process) - processes and signals - (chibi system) - host system and user information - (chibi time) - time and date library - (chibi match) - pattern-matching library - (chibi loop) - extensible loop syntax - (chibi pathname) - pathname manipulation utilities - (chibi uri) - URI parsing and construction utilities + (chibi net) - networking interface + (chibi filesystem) - local filesystem and file descriptor interface + (chibi process) - processes and signals + (chibi system) - host system and user information + (chibi time) - time and date library + (chibi match) - pattern-matching library + (chibi loop) - extensible loop syntax + (chibi pathname) - pathname manipulation utilities + (chibi uri) - URI parsing and construction utilities (chibi macroexpand) - macro expansion utility - (chibi ast) - interface to the internal Abstract Syntax Tree - (chibi disasm) - disassembly utility for the chibi VM - (chibi heap-stats) - debugging tool to analyze or dump the heap + (chibi ast) - interface to the internal Abstract Syntax Tree + (chibi disasm) - disassembly utility for the chibi VM + (chibi heap-stats) - debugging tool to analyze or dump the heap ------------------------------------------------------------------------ C INTERFACE diff --git a/include/chibi/config.h b/include/chibi/features.h similarity index 99% rename from include/chibi/config.h rename to include/chibi/features.h index a3301d22..9143a071 100644 --- a/include/chibi/config.h +++ b/include/chibi/features.h @@ -1,4 +1,4 @@ -/* config.h -- general configuration */ +/* features.h -- general feature configuration */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 28f2fed8..687daefb 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -7,7 +7,7 @@ #define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" -#include "chibi/config.h" +#include "chibi/features.h" #include "chibi/install.h" #include From 98d03e884ebe6fd75229dcf2d30b701b87ad972a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Dec 2009 14:51:13 +0900 Subject: [PATCH 314/535] adding sexp_version constant which is just a string holding the version information (currently "0.3"). also adding some features that may be important to test for: dynamic-loading, modules, and boehm-gc. --- Makefile | 1 + eval.c | 13 +++++++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index aa4fd2df..9ba61469 100644 --- a/Makefile +++ b/Makefile @@ -96,6 +96,7 @@ include/chibi/install.h: Makefile echo '#define sexp_so_extension "'$(SO)'"' > $@ echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@ echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ + echo '#define sexp_version "'`cat VERSION`'"' >> $@ sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< diff --git a/eval.c b/eval.c index c9a02bd5..6d0ed08e 100644 --- a/eval.c +++ b/eval.c @@ -2546,10 +2546,19 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { sexp_gc_preserve3(ctx, op, tmp, sym); sexp_load_standard_parameters(ctx, e); #if SEXP_USE_DL - sexp_env_define(ctx, e, sexp_intern(ctx, "*shared-object-extension*"), - sexp_c_string(ctx, sexp_so_extension, -1)); + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*"), + tmp=sexp_c_string(ctx, sexp_so_extension, -1)); #endif tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform)); +#if SEXP_USE_DL + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading")); +#endif +#if SEXP_USE_MODULES + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules")); +#endif +#if SEXP_USE_BOEHM + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc")); +#endif sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp); sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; From 9bbe80f4bf34b81195aded9a2c9f3e91404005ee Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Dec 2009 15:33:06 +0900 Subject: [PATCH 315/535] adding descriptive sexp_release_name for more detailed information in "about this software" dialogs and such. 0.3 is lithium. 0.1 and 0.2 are retroacively hydrogen and helium, respectively. --- Makefile | 1 + RELEASE | 1 + 2 files changed, 2 insertions(+) create mode 100644 RELEASE diff --git a/Makefile b/Makefile index 9ba61469..e429da1a 100644 --- a/Makefile +++ b/Makefile @@ -97,6 +97,7 @@ include/chibi/install.h: Makefile echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@ echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ echo '#define sexp_version "'`cat VERSION`'"' >> $@ + echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@ sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< diff --git a/RELEASE b/RELEASE new file mode 100644 index 00000000..35f6fb33 --- /dev/null +++ b/RELEASE @@ -0,0 +1 @@ +lithium From 7e0464154a54a0ca1b2b92856ec0cddecf841af7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Dec 2009 18:45:22 +0900 Subject: [PATCH 317/535] number? includes a check for bignums (issue #19) --- lib/init.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/init.scm b/lib/init.scm index cd50ad37..d448a650 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -421,7 +421,7 @@ ;; math utils -(define (number? x) (if (fixnum? x) #t (flonum? x))) +(define (number? x) (if (fixnum? x) #t (if (bignum? x) #t (flonum? x)))) (define complex? number?) (define rational? number?) (define real? number?) From f785134851c1eeacf10755668eea69813cf49ff5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Dec 2009 19:03:50 +0900 Subject: [PATCH 318/535] updating plan9 mkfile to use features.h --- .hgignore | 21 + COPYING | 24 + Makefile | 192 ++ README | 424 ++++ TODO | 148 ++ VERSION | 1 + doc/chibi-scheme.1 | 133 ++ eval.c | 2724 ++++++++++++++++++++++++ gc.c | 249 +++ include/chibi/bignum.h | 43 + include/chibi/eval.h | 163 ++ include/chibi/features.h | 297 +++ include/chibi/sexp.h | 862 ++++++++ lib/chibi/ast.c | 80 + lib/chibi/ast.module | 14 + lib/chibi/disasm.c | 127 ++ lib/chibi/disasm.module | 4 + lib/chibi/filesystem.module | 27 + lib/chibi/filesystem.scm | 43 + lib/chibi/filesystem.stub | 115 + lib/chibi/heap-stats.c | 129 ++ lib/chibi/heap-stats.module | 5 + lib/chibi/loop.module | 9 + lib/chibi/loop/loop.scm | 365 ++++ lib/chibi/macroexpand.module | 6 + lib/chibi/macroexpand.scm | 85 + lib/chibi/match.module | 6 + lib/chibi/match/match.scm | 670 ++++++ lib/chibi/net.module | 10 + lib/chibi/net.scm | 23 + lib/chibi/net.stub | 25 + lib/chibi/pathname.module | 7 + lib/chibi/pathname.scm | 180 ++ lib/chibi/process.module | 17 + lib/chibi/process.stub | 72 + lib/chibi/signal.c | 62 + lib/chibi/system.module | 15 + lib/chibi/system.stub | 34 + lib/chibi/time.module | 11 + lib/chibi/time.stub | 45 + lib/chibi/uri.module | 10 + lib/chibi/uri.scm | 306 +++ lib/config.scm | 174 ++ lib/init.scm | 881 ++++++++ lib/srfi/1.module | 31 + lib/srfi/1/alists.scm | 14 + lib/srfi/1/constructors.scm | 36 + lib/srfi/1/deletion.scm | 25 + lib/srfi/1/fold.scm | 115 + lib/srfi/1/lset.scm | 51 + lib/srfi/1/misc.scm | 54 + lib/srfi/1/predicates.scm | 42 + lib/srfi/1/search.scm | 54 + lib/srfi/1/selectors.scm | 59 + lib/srfi/11.module | 28 + lib/srfi/16.module | 24 + lib/srfi/2.module | 16 + lib/srfi/26.module | 24 + lib/srfi/27.module | 11 + lib/srfi/27/constructors.scm | 10 + lib/srfi/27/rand.c | 204 ++ lib/srfi/33.module | 17 + lib/srfi/33/bit.c | 303 +++ lib/srfi/33/bitwise.scm | 61 + lib/srfi/39.module | 25 + lib/srfi/6.module | 5 + lib/srfi/69.module | 17 + lib/srfi/69/hash.c | 242 +++ lib/srfi/69/interface.scm | 115 + lib/srfi/69/type.scm | 12 + lib/srfi/8.module | 10 + lib/srfi/9.module | 82 + lib/srfi/95.module | 7 + lib/srfi/95/qsort.c | 170 ++ lib/srfi/95/sort.scm | 70 + lib/srfi/98.module | 5 + lib/srfi/98/env.c | 48 + main.c | 193 ++ mkfile | 26 + opcodes.c | 153 ++ opt/bignum.c | 751 +++++++ opt/plan9-opcodes.c | 19 + opt/plan9.c | 351 +++ opt/sexp-huff.c | 128 ++ opt/sexp-hufftabs.c | 92 + opt/sexp-unhuff.c | 71 + opt/simplify.c | 135 ++ sexp.c | 1662 +++++++++++++++ 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 | 48 + tests/basic/test10-unhygiene.res | 6 + tests/basic/test10-unhygiene.scm | 49 + tests/build/build-opts.txt | 21 + tests/build/build-tests.sh | 37 + tests/install/install-tests.pl | 57 + tests/install/run-install-test.sh | 12 + tests/loop-tests.scm | 202 ++ tests/match-tests.scm | 196 ++ tests/numeric-tests.scm | 150 ++ tests/r5rs-tests.scm | 483 +++++ tools/genstubs.scm | 1156 ++++++++++ 119 files changed, 16985 insertions(+) create mode 100644 .hgignore create mode 100644 COPYING create mode 100644 Makefile create mode 100644 README create mode 100644 TODO create mode 100644 VERSION create mode 100644 doc/chibi-scheme.1 create mode 100644 eval.c create mode 100644 gc.c create mode 100644 include/chibi/bignum.h create mode 100644 include/chibi/eval.h create mode 100644 include/chibi/features.h create mode 100644 include/chibi/sexp.h create mode 100644 lib/chibi/ast.c create mode 100644 lib/chibi/ast.module create mode 100644 lib/chibi/disasm.c create mode 100644 lib/chibi/disasm.module create mode 100644 lib/chibi/filesystem.module create mode 100644 lib/chibi/filesystem.scm create mode 100644 lib/chibi/filesystem.stub create mode 100644 lib/chibi/heap-stats.c create mode 100644 lib/chibi/heap-stats.module create mode 100644 lib/chibi/loop.module create mode 100644 lib/chibi/loop/loop.scm create mode 100644 lib/chibi/macroexpand.module create mode 100644 lib/chibi/macroexpand.scm create mode 100644 lib/chibi/match.module create mode 100644 lib/chibi/match/match.scm create mode 100644 lib/chibi/net.module create mode 100644 lib/chibi/net.scm create mode 100644 lib/chibi/net.stub create mode 100644 lib/chibi/pathname.module create mode 100644 lib/chibi/pathname.scm create mode 100644 lib/chibi/process.module create mode 100644 lib/chibi/process.stub create mode 100644 lib/chibi/signal.c create mode 100644 lib/chibi/system.module create mode 100644 lib/chibi/system.stub create mode 100644 lib/chibi/time.module create mode 100644 lib/chibi/time.stub create mode 100644 lib/chibi/uri.module create mode 100644 lib/chibi/uri.scm create mode 100644 lib/config.scm create mode 100644 lib/init.scm create mode 100644 lib/srfi/1.module create mode 100644 lib/srfi/1/alists.scm create mode 100644 lib/srfi/1/constructors.scm create mode 100644 lib/srfi/1/deletion.scm create mode 100644 lib/srfi/1/fold.scm create mode 100644 lib/srfi/1/lset.scm create mode 100644 lib/srfi/1/misc.scm create mode 100644 lib/srfi/1/predicates.scm create mode 100644 lib/srfi/1/search.scm create mode 100644 lib/srfi/1/selectors.scm create mode 100644 lib/srfi/11.module create mode 100644 lib/srfi/16.module create mode 100644 lib/srfi/2.module create mode 100644 lib/srfi/26.module create mode 100644 lib/srfi/27.module create mode 100644 lib/srfi/27/constructors.scm create mode 100644 lib/srfi/27/rand.c create mode 100644 lib/srfi/33.module create mode 100644 lib/srfi/33/bit.c create mode 100644 lib/srfi/33/bitwise.scm create mode 100644 lib/srfi/39.module create mode 100644 lib/srfi/6.module create mode 100644 lib/srfi/69.module create mode 100644 lib/srfi/69/hash.c create mode 100644 lib/srfi/69/interface.scm create mode 100644 lib/srfi/69/type.scm create mode 100644 lib/srfi/8.module create mode 100644 lib/srfi/9.module create mode 100644 lib/srfi/95.module create mode 100644 lib/srfi/95/qsort.c create mode 100644 lib/srfi/95/sort.scm create mode 100644 lib/srfi/98.module create mode 100644 lib/srfi/98/env.c create mode 100644 main.c create mode 100644 mkfile create mode 100644 opcodes.c create mode 100644 opt/bignum.c create mode 100644 opt/plan9-opcodes.c create mode 100644 opt/plan9.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 opt/simplify.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/build/build-opts.txt create mode 100755 tests/build/build-tests.sh create mode 100755 tests/install/install-tests.pl create mode 100755 tests/install/run-install-test.sh create mode 100644 tests/loop-tests.scm create mode 100644 tests/match-tests.scm create mode 100644 tests/numeric-tests.scm create mode 100644 tests/r5rs-tests.scm create mode 100755 tools/genstubs.scm diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..babe41d2 --- /dev/null +++ b/.hgignore @@ -0,0 +1,21 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dylib +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +chibi-scheme +chibi-scheme-static +include/chibi/install.h diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..1fcee28e --- /dev/null +++ b/COPYING @@ -0,0 +1,24 @@ +Copyright (c) 2009 Alex Shinn +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..9ba61469 --- /dev/null +++ b/Makefile @@ -0,0 +1,192 @@ +# -*- makefile-gmake -*- + +.PHONY: all libs doc dist clean cleaner test install uninstall +.PRECIOUS: %.c + +# install configuration + +CC ?= cc +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +SOLIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi +LIBDIR ?= $(PREFIX)/lib/chibi +MANDIR ?= $(PREFIX)/share/man/man1 + +DESTDIR ?= + +GENSTUBS ?= ./tools/genstubs.scm + +######################################################################## +# system configuration - if not using GNU make, set PLATFORM and the +# following flags as necessary. + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +PLATFORM=unix +endif +endif +endif + +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0 +else +ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL -DSEXP_USE_DEBUG=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static -DSEXP_USE_DL=0 +endif +endif + +ifeq ($(USE_BOEHM),1) +SEXP_USE_BOEHM = 1 +endif + +ifeq ($(SEXP_USE_BOEHM),1) +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DSEXP_USE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude +endif + +ifeq ($(SEXP_USE_DL),0) +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS) +else +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -ldl -lm +XCFLAGS := -Wall -g3 $(CFLAGS) +endif + +######################################################################## + +all: chibi-scheme$(EXE) libs + +COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ + lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \ + lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \ + lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \ + lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + +libs: $(COMPILED_LIBS) + +INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h + +include/chibi/install.h: Makefile + echo '#define sexp_so_extension "'$(SO)'"' > $@ + echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@ + echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ + echo '#define sexp_version "'`cat VERSION`'"' >> $@ + +sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +eval.o: eval.c opcodes.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +main.o: main.c $(INCLUDES) include/chibi/eval.h 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) + +%.c: %.stub $(GENSTUBS) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) PATH=.:$(PATH) $(GENSTUBS) $< + +lib/%$(SO): lib/%.c $(INCLUDES) + -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +clean: + rm -f *.o *.i *.s *.8 + find lib -name \*$(SO) -exec rm -f '{}' \; + rm -f tests/basic/*.out tests/basic/*.err + +cleaner: clean + rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h + rm -rf *.dSYM + +test-basic: chibi-scheme$(EXE) + @for f in tests/basic/*.scm; do \ + ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + +test-build: + ./tests/build/build-tests.sh + +test-numbers: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/numeric-tests.scm + +test-hash: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/hash-tests.scm + +test-match: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/match-tests.scm + +test-loop: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/loop-tests.scm + +test: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/r5rs-tests.scm + +install: chibi-scheme$(EXE) + mkdir -p $(DESTDIR)$(BINDIR) + cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ + mkdir -p $(DESTDIR)$(MODDIR) + cp lib/init.scm lib/config.scm $(DESTDIR)$(MODDIR)/ + cp -r lib/ $(DESTDIR)$(MODDIR)/ + mkdir -p $(DESTDIR)$(INCDIR) + cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ + mkdir -p $(DESTDIR)$(LIBDIR) + mkdir -p $(DESTDIR)$(SOLIBDIR) + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ + mkdir -p $(DESTDIR)$(MANDIR) + cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/ + if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + +uninstall: + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE) + rm -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO) + rm -f $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a + cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -rf $(DESTDIR)$(MODDIR) + +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..172c476d --- /dev/null +++ b/README @@ -0,0 +1,424 @@ + + 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. + +------------------------------------------------------------------------ +INSTALLING + +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 chibi/features.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 CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 + +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 features.h file, or +directly from make with: + + make SEXP_USE_BOEHM=1 + +------------------------------------------------------------------------ +CHIBI-SCHEME LANGUAGE + +The default language is mostly compatible with the R5RS, with all +differences made by design, not through difficulty of implementation. +The following procedures are omitted: + + transcript-on and transcript-off (because they're silly) + rationalize (pending the addition of rational numbers) + +Apart from this, chibi-scheme is case-sensitive, unlike the R5RS. +The default configuration includes fixnums, flonums and bignums +but no exact rationals or complex numbers. + +Full continuations are supported, but currently continuations don't +take C code into account. The only higher-order C functions in the +standard environment are LOAD and EVAL. + +LOAD is extended to accept an optional environment argument, like +EVAL. You can also LOAD shared libraries in addition to Scheme source +files - in this case the function sexp_init_library is automatically +called with the following signature: + + sexp_init_library(sexp context, sexp environment) + +SYNTAX-RULES macros are provided by default, with the extensions from +SRFI-46. In addition, low-level hygienic macros are provided with +a syntactic-closures interface, including SC-MACRO-TRANSFORMER, +RSC-MACRO-TRANSFORMER, and ER-MACRO-TRANSFORMER. A good introduction +to syntactic-closures can be found at: + + http://community.schemewiki.org/?syntactic-closures + +IDENTIFIER?, IDENTIFIER->SYMBOL, IDENTIFIER=?, and +MAKE-SYNTACTIC-CLOSURE and STRIP-SYNTACTIC-CLOSURES are provided. + +SRFI-0's COND-EXPAND is provided, with the feature `chibi'. + +STRING-CONCATENATE concatenates a list of strings. + +------------------------------------------------------------------------ +TYPES + +You can define new data types with SRFI-9. This is just syntactic +sugar for the following more primitive type constructors: + +(register-simple-type ) + => ; a fixnum + +(make-type-predicate ) + => ; takes 1 arg, returns #t iff that arg is of the type + +(make-constructor ) + => ; takes 0 args, returns a newly allocated instance of type + +(make-getter ) + => ; takes 1 args, retrieves the field located at the index + +(make-setter ) + => ; takes 2 args, sets the field located at the index + +------------------------------------------------------------------------ +MODULE SYSTEM + +A configurable module system, in the style of the Scheme48 module +system, is provided by default. + +Modules names are hierarchical lists of symbols or numbers. The +definition of the module (foo bar baz) is searched for in the file +foo/bar/baz.module. This file should contain an expression of the +form: + + (define-module (foo bar baz) + ...) + +where can be any of + + (export ...) - specify an export list + (import ...) - specify one or more imports + (import-immutable ...) - specify an immutable import + (body ...) - inline Scheme code + (include ...) - load one or more files + (include-shared ...) - dynamic load a library + + can either be a module name or any of + + (only ...) + (except ...) + (rename ( ) ...) + (prefix ) + +The can be composed and perform basic selection and renaming of +individual identifiers from the given module. + +Files are loaded relative to the .module file, and are written with +their extension (so you can use whatever suffix you prefer - .scm, +.ss, .sls, etc.). + +Shared modules, on the other hand, should be specified _without_ the +extension - the correct suffix will be added portably (e.g. .so for +Unix and .dylib for OS X). + +You may also use COND-EXPAND and arbitrary macro expansions in a +module definition to generate . + +------------------------------------------------------------------------ +MODULES + +The default environment is (scheme) - you almost always want to import +this. + +Currently you can load the following SRFIs with (import (srfi N)): + + (srfi 0) - cond-expand + (srfi 1) - list library + (srfi 2) - and-let* + (srfi 6) - basic string ports + (srfi 8) - receive + (srfi 9) - define-record-type + (srfi 11) - let-values/let*-values + (srfi 16) - case-lambda + (srfi 22) - running scheme scripts on Unix + (srfi 23) - error reporting mechanism + (srfi 26) - cut/cute partial application + (srfi 27) - sources of random bits + (srfi 33) - bitwise operators + (srfi 39) - prameter objects + (srfi 46) - basic syntax-rules extensions + (srfi 62) - s-expression comments + (srfi 69) - basic hash tables + (srfi 95) - sorting and merging + (srfi 98) - environment access + +although 0, 22, 23, 46 and 62 are built into the default environment +so there's no need to import them. + +Included non-standard modules are put in the (chibi) module namespace. +The following additional modules are available: + + (chibi net) - networking interface + (chibi filesystem) - local filesystem and file descriptor interface + (chibi process) - processes and signals + (chibi system) - host system and user information + (chibi time) - time and date library + (chibi match) - pattern-matching library + (chibi loop) - extensible loop syntax + (chibi pathname) - pathname manipulation utilities + (chibi uri) - URI parsing and construction utilities + (chibi macroexpand) - macro expansion utility + (chibi ast) - interface to the internal Abstract Syntax Tree + (chibi disasm) - disassembly utility for the chibi VM + (chibi heap-stats) - debugging tool to analyze or dump the heap + +------------------------------------------------------------------------ +C INTERFACE + +See the file main.c for an example of using chibi-scheme as a library. + +The basic usage involves creating a context for evaluation and loading +or evaluating Scheme source with it. Begin by including the eval.h +header file: + + #include + +then call + + sexp_scheme_init(); + +with no parameters to initialize any globals (this actually does +nothing in the standard configuration but is a good idea to call +anyway). + +Then you can use the following to create and manipulate contexts: + + sexp_make_eval_context(context, stack, environment, heap_size) + Creates a new context with the given stack and environment. + If context is non-NULL, this will be the "parent" context and + the two contexts will share a heap. Otherwise, a new heap + will be allocated with heap_size, or a default size if heap_size + is zero. stack and environment may both also be NULL (and _must_ + be NULL if context is NULL) and will be given standard defaults. + + Thus the to create your first context you generally call: + + sexp_make_eval_context(NULL, NULL, NULL, 0) + + You can create as many contexts as you want, and other than those + sharing a heap they are all independent and thread-safe. + + sexp_load_standard_env(context, env, version) + Loads the init.scm file in the environment env. Version refers + to the RnRS version number and should always be SEXP_FIVE. The + environment created with sexp_make_eval_context only contains + core syntactic forms and C primitives (thus for example it has + CAR but not CADR or LIST), so to get a full featured + environment, plus a module system with which to load additional + modules, you want to use this. + + sexp_destroy_context(context) + Signals that you no longer need context, or any other context + sharing the heap. It will thus free() the context and heap and + all associated memory. Does nothing if using the Boehm GC. + +Environments can be handled with the following: + + sexp_context_env(context) + A macro returning the default environment associated with context. + + sexp_env_define(context, env, symbol, value) + Define a variable in an environment. + + sexp_env_ref(env, symbol, dflt) + Fetch the binding for symbol from the environment env, + returning the default dflt if the symbol is unbound. + +You can evaluate code with the following utility: + + sexp_eval(context, expr, env) + Evaluates an s-expression in an environment. + env can be NULL to use the context's default env. + + sexp_eval_string(context, str, env) + Reads an s-expression from str and evaluates it in env. + + sexp_load(context, file, env) + Read and eval all top-level forms from file in environment env. + As described in LOAD above, file may be a shared library. + +To define new primitive functions from C, use sexp_define_foreign, +which takes a Scheme environment, a name, a number of arguments the C +function takes (not counting the context argument), and a C function. + + /* sexp_define_foreign(context, env, name, num_args, f) */ + + sexp add (sexp context, sexp x, sexp y) { + return sexp_fx_add(x, y); + } + + sexp_define_foreign(context, env, "add", 2, add); + +You can also define functions with a single optional argument: + + sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); + +See the SRFI-69 implementation for more detailed examples of this. + +------------------------------------------------------------------------ +FFI + +Simple C FFI. "genstubs.scm file.stub" will read in the C function +FFI definitions from file.stub and output the appropriate C +wrappers into file.c. You can then compile that file with: + + cc -fPIC -shared file.c -lchibi-scheme + +(or using whatever flags are appropriate to generate shared libs on +your platform) and then the generated .so file can be loaded +directly with LOAD, or portably using (include-shared "file") in a +module definition (note that include-shared uses no suffix). + +The goal of this interface is to make access to C types and +functions easy, without requiring the user to write any C code. +That means the stubber needs to be intelligent about various C +calling conventions and idioms, such as return values passed in +actual parameters. Writing C by hand is still possible, and +several of the core modules provide C interfaces directly without +using the stubber. + +================================ + +Struct Interface + +(define-c-struct struct-name + [predicate: predicate-name] + [constructor: constructor-name] + [finalizer: c_finalizer_name] + (type c_field_name getter-name setter-name) ...) + + +================================ + + +Function Interface + +(define-c return-type name-spec (arg-type ...)) + +where name-space is either a symbol name, or a list of +(scheme-name c_name). If just a symbol, the C name is taken +to be the same with -'s replaced by _'s. + +arg-type is a type suitable for input validation and conversion. + +================================ + + +Types + +Types + +Basic Types + void + boolean + char + sexp (no conversions) + +Integer Types: + signed-char short int long + unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t + time_t (in seconds, but using the chibi epoch of 2010/01/01) + errno (as a return type returns #f on error) + +Float Types: + float double long-double + +String Types: + string - a null-terminated char* + env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme + in addition you can use (array char) as a string + +Port Types: + input-port output-port + +Struct Types: + +Struct types are by default just referred to by the bare +struct-name from define-c-struct, and it is assumed you want a +pointer to that type. To refer to the full struct, use the struct +modifier, as in (struct struct-name). + +Type modifiers + +Any type may also be written as a list of modifiers followed by the +type itself. The supported modifiers are: + +const: prepends the "const" C type modifier + * as a return or result parameter, makes non-immediates immutable + +free: it's Scheme's responsibility to "free" this resource + * as a return or result parameter, registers the freep flag + this causes the type finalizer to be run when GCed + +maybe-null: this pointer type may be NULL + * as a result parameter, NULL is translated to #f + normally this would just return a wrapped NULL pointer + * as an input parameter, #f is translated to NULL + normally this would be a type error + +pointer: create a pointer to this type + * as a return parameter, wraps the result in a vanilla cpointer + * as a result parameter, boxes then unboxes the value + +struct: treat this struct type as a struct, not a pointer + * as an input parameter, dereferences the pointer + * as a type field, indicates a nested struct + +link: add a gc link + * as a field getter, link to the parent object, so the + parent won't be GCed so long as we have a reference + to the child. this behavior is automatic for nested + structs. + +result: return a result in this parameter + * if there are multiple results (including the return type), + they are all returned in a list + * if there are any result parameters, a return type + of errno returns #f on failure, and as eliminated + from the list of results otherwise + +(value ): specify a fixed value + * as an input parameter, this parameter is not provided + in the Scheme API but always passed as + +(default ): specify a default value + * as the final input parameter, makes the Scheme parameter + optional, defaulting to + +(array []) an array type + * length must be specified for return and result parameters + * if specified, length can be any of + ** an integer, for a fixed size + ** the symbol null, indicating a NULL-terminated array diff --git a/TODO b/TODO new file mode 100644 index 00000000..93f7c837 --- /dev/null +++ b/TODO @@ -0,0 +1,148 @@ +-*- org -*- + +* compiler +** DONE ast rewrite + - State "DONE" [2009-04-09 Thu 14:32] +** DONE call/cc support + - State "DONE" [2009-04-09 Thu 14:36] +** DONE exceptions + - State "DONE" [2009-04-09 Thu 14:45] +** TODO native x86 backend +** TODO fasl/image files +** DONE shared stack on EVAL + - State "DONE" [2009-12-26 Sat 08:22] + +* compiler optimizations +** DONE constant folding + - State "DONE" [2009-12-16 Wed 23:25] +** DONE simplification pass, dead-code elimination + - State "DONE" [2009-12-18 Fri 14:14] + This is important in particular for the output generated by + syntax-rules. +** TODO lambda lift + The current closure representation is not very efficient, so this + would help a lot. +** TODO inlining (and disabling primitive inlining) + Being able to redefine procedures is important though. +** TODO unsafe operations + Possibly, don't want to make things too complicated or unstable. +** TODO plugin infrastructure +** TODO type inference with warnings + +* macros +** DONE hygiene + - State "DONE" [2009-04-09 Thu 14:41] +** DONE hygienic nested let-syntax + - State "DONE" [2009-12-08 Tue 14:41] +** DONE macroexpand utility + - State "DONE" [2009-12-08 Tue 14:41] +** DONE SRFI-46 basic syntax-rules extensions + - State "DONE" [2009-12-26 Sat 07:59] +** DONE (... ...) support + - State "DONE" [2009-12-26 Sat 02:06] +** TODO compiler macros +** TODO syntax-rules common pattern reduction +** TODO syntax-rules loop optimization + +* garbage collection +** DONE precise gc rewrite + - State "DONE" [2009-06-22 Mon 14:27] +** DONE fix heap growing + - State "DONE" [2009-06-22 Mon 14:29] +** DONE separate gc heaps + - State "DONE" [2009-12-08 Tue 14:29] +** DONE add finalizers + - State "DONE" [2009-12-08 Tue 14:29] +** TODO support weak references + +* runtime +** DONE bignums + - State "DONE" [2009-07-07 Tue 14:42] +** TODO unicode +** TODO threads +** TODO virtual ports +** DONE dynamic-wind + - State "DONE" [2009-12-26 Sat 01:51] + Adapted a version from Scheme48. +** DONE recursive disasm + - State "DONE" [2009-12-18 Fri 14:15] + +* FFI +** DONE libdl support + - State "DONE" [2009-12-08 Tue 14:45] +** DONE opcode generation interface + - State "DONE" [2009-11-15 Sun 14:45] +** DONE stub generator + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE define-c-struct + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE define-c + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE array return types + - State "DONE" [2009-12-26 Sat 01:49] +*** DONE pre-buffered string types (like getcwd) + - State "DONE" [2009-12-26 Sat 01:49] + +* module system +** DONE scheme48-like config language + - State "DONE" [2009-10-13 Tue 14:38] +** DONE shared library includes + - State "DONE" [2009-12-08 Tue 14:39] +** DONE only/except/rename/prefix modifiers + - State "DONE" [2009-12-16 Wed 18:57] +** TODO scheme-complete.el support +** DONE access individual modules from repl + - State "DONE" [2009-12-26 Sat 01:49] + +* core modules +** DONE SRFI-0 cond-expand + - State "DONE" [2009-12-16 Wed 20:12] +** DONE SRFI-9 define-record-type + - State "DONE" [2009-12-08 Tue 14:50] +** DONE SRFI-69 hash-tables + - State "DONE" [2009-11-15 Sun 14:50] +** DONE match library + - State "DONE" [2009-12-08 Tue 14:54] +** DONE loop library + - State "DONE" [2009-12-08 Tue 14:54] +** TODO network interface +** TODO posix interface + Splitting this into several parts. +*** DONE filesystem interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE process interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE time interface + - State "DONE" [2009-12-26 Sat 01:50] +*** TODO host system interface +** DONE pathname library + - State "DONE" [2009-12-16 Wed 18:58] +** DONE uri library + - State "DONE" [2009-12-16 Wed 18:58] +** TODO http library +** TODO show (formatting) library +** TODO zip library +** TODO tar library +** TODO md5sum library + +* ports +** DONE basic mingw support + - State "DONE" [2009-06-22 Mon 14:36] +** DONE Plan 9 support + - State "DONE" [2009-08-10 Mon 14:37] +** DONE 64-bit support + - State "DONE" [2009-11-01 Sun 14:37] +** TODO iPhone support +** TODO bare-metal support + +* miscellaneous +** TODO overall cleanup +** TODO user documentation +** TODO thorough source documentation +** TODO full test suite for libraries + +* distribution +** TODO packaging format +** TODO code repository with fetch+install tool +** TODO translator to/from other implementations + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..be586341 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.3 diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1 new file mode 100644 index 00000000..f20c50e5 --- /dev/null +++ b/doc/chibi-scheme.1 @@ -0,0 +1,133 @@ +.TH "chibi-scheme" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-scheme \- a tiny Scheme interpreter + +.SH SYNOPSIS +.B chibi-scheme +[-qV] +[-I +.I path +] +[-A +.I path +] +[-u +.I module +] +[-l +.I file +] +[-e +.I expr +] +[-p +.I expr +] +[--] +[ +.I script argument ... +] +.br +.sp 0.3 + +.SH DESCRIPTION +.I chibi-scheme +is a sample interactive Scheme interpreter for the +.I chibi-scheme +library. It serves as an example of how to embed +.I chibi-scheme +in applications, and can be useful on its own for writing +scripts and interactive development. + +When +.I script +is given, the script will be loaded with SRFI-22 semantics, +calling the procedure +.I main +(if defined) with a single parameter as a list of the +command-line arguments beginning with the script name. + +Otherwise, if no script is given and no -e or -p options +are given an interactive repl is entered, reading, evaluating, +then printing expressions until EOF is reached. The repl +provided is very minimal - if you want readline +completion you may want to wrap it with the +.I rlwrap(1) +program. Signals aren't caught either - to enable handling keyboard +interrupts you can use the (chibi process) module. + +.SH OPTIONS +.TP 5 +.BI -V +Prints the version information and exits. +.TP +.BI -q +Don't load the initialization file. The resulting +environment will only contain the core syntactic forms +and primitives coded in C. +.TP +.BI -h size +Specifies the initial size of the heap, in bytes. +.I size +can be any integer value, optionally suffixed by +"K" for kilobytes, or "M" for megabytes. +.I -h +must be specified before any options which load or +evaluate Scheme code. +.TP +.BI -I path +Inserts +.I path +on front of the load path list. +.TP +.BI -A path +Appends +.I path +to the load path list. +.TP +.BI -m module +Imports +.I module +as though "(import +.I module +)" were evaluated. However, to reduce the need for shell +escapes, modules are written in a dot notation, so that the module +.I (foo bar) +is written as +.I foo.bar +.TP +.BI -l file +Loads the Scheme source from the file +.I file +searched for in the default load path. +.TP +.BI -e expr +Evaluates the Scheme expression +.I expr. +.TP +.BI -p expr +Evaluates the Scheme expression +.I expr +then prints the result to stdout. + +.SH ENVIRONMENT +.TP +.B CHIBI_MODULE_PATH +.TQ +A colon separated list of directories to search for module +files, inserted before the system default load paths. + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +More detailed information can be found in the README file +included in the distribution. + +The chibi-scheme home-page: +.br +http://code.google.com/p/chibi-scheme/ diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..6d0ed08e --- /dev/null +++ b/eval.c @@ -0,0 +1,2724 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +#if SEXP_USE_DEBUG_VM +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { + int i; + if (! sexp_oport(out)) out = sexp_current_error_port(ctx); + 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, NULL); + } else if (sexp_synclop(x)) { + tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(tmp) = sexp_synclo_env(x); + sexp_context_fv(tmp) = sexp_append2(tmp, + sexp_synclo_free_vars(x), + sexp_context_fv(tmp)); + x = sexp_synclo_expr(x); + res = analyze(tmp, x); + } else { + res = x; + } + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res)) + && sexp_pairp(x)) + sexp_exception_source(res) = sexp_pair_source(x); + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} + +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 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, SEXP_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, SEXP_OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + emit(ctx, SEXP_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, SEXP_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, SEXP_OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, SEXP_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) + ? SEXP_OP_GLOBAL_REF : SEXP_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, SEXP_OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, SEXP_OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, SEXP_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_var1(ls); + sexp_gc_preserve1(ctx, ls); + + num_args = sexp_unbox_fixnum(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_data(op) + && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) + emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* push the arguments onto the stack in reverse order */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != SEXP_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 SEXP_OPC_ARITHMETIC: + if (num_args > 1) + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_INV: + emit(ctx, (num_args==1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + emit(ctx, SEXP_OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_FOREIGN: + emit(ctx, sexp_opcode_code(op)); + emit_word(ctx, (sexp_uint_t)op); + break; + case SEXP_OPC_TYPE_PREDICATE: + case SEXP_OPC_ACCESSOR: + case SEXP_OPC_CONSTRUCTOR: + emit(ctx, sexp_opcode_code(op)); + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE) { + if (sexp_opcode_data(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); + if (sexp_opcode_data2(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + } + break; + case SEXP_OPC_PARAMETER: + emit_push(ctx, sexp_opcode_data(op)); + emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + /* emit optional folding of operator */ + if ((num_args > 2) + && (sexp_opcode_class(op) == SEXP_OPC_ARITHMETIC + || sexp_opcode_class(op) == SEXP_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_release1(ctx); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, 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 ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); + + sexp_context_tailp(ctx) = tailp; + sexp_context_depth(ctx) -= len; + sexp_gc_release1(ctx); +} + +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_var2(tmp, bc); + sexp_gc_preserve2(ctx, tmp, 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_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); + 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, SEXP_OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, SEXP_OP_CONS); + emit(ctx2, SEXP_OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, SEXP_OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_fixnum((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_ZERO, 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, SEXP_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_fixnum(k)); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_VECTOR_SET); + emit(ctx, SEXP_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, SEXP_OP_MAKE_PROCEDURE); + } + sexp_gc_release2(ctx); +} + +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_var1(res); + if (sexp_nullp(fv2)) + return fv1; + sexp_gc_preserve1(ctx, res); + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, 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_release1(ctx); + return res; +} + +static sexp free_vars (sexp ctx, sexp x, sexp fv) { + sexp_gc_var2(fv1, fv2); + sexp_gc_preserve2(ctx, fv1, 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_release2(ctx); + return fv1; +} + +static sexp make_param_list (sexp ctx, sexp_uint_t i) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_fixnum(i), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ls, bc, res, env; + sexp_gc_var5(params, ref, refs, lambda, ctx2); + if (i == sexp_opcode_num_args(op)) { /* return before preserving */ + if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); + } else if (i < sexp_opcode_num_args(op)) { + return sexp_compile_error(ctx, "not enough args for opcode", op); + } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ + return sexp_compile_error(ctx, "too many args for opcode", op); + } + sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = sexp_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), sexp_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_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + sexp_gc_release5(ctx); + 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_fixnum(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= SEXP_INIT_STACK_SIZE) { + _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); + goto end_loop; + } +#endif + i = sexp_unbox_fixnum(_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_fixnum(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_fixnum(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_fixnum(i); + stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + stack[top+1] = self; + stack[top+2] = sexp_make_fixnum(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 SEXP_OP_FCALL0: + sexp_context_top(ctx) = top; + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx)); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL1: + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx, _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL2: + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL3: + sexp_context_top(ctx) = top; + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL4: + sexp_context_top(ctx) = top; + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL5: + sexp_context_top(ctx) = top; + _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL6: + sexp_context_top(ctx) = top; + _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_JUMP_UNLESS: + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case SEXP_OP_JUMP: + ip += _SWORD0; + break; + case SEXP_OP_PUSH: + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case SEXP_OP_DROP: + top--; + break; + case SEXP_OP_GLOBAL_REF: + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case SEXP_OP_GLOBAL_KNOWN_REF: + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_STACK_REF: /* `pick' in forth */ + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_REF: + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_SET: + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case SEXP_OP_CLOSURE_REF: + _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); + ip += sizeof(sexp); + break; + case SEXP_OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_VECTOR_LENGTH: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); + break; + case SEXP_OP_STRING_REF: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_string_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2)); + else if (! sexp_charp(_ARG3)) + sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_string_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_STRING_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); + break; + case SEXP_OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; + _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case SEXP_OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; + if (! sexp_fixnump(_ARG1)) + sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); + _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_MAKE_EXCEPTION: + _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + break; + case SEXP_OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case SEXP_OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case SEXP_OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case SEXP_OP_FIXNUMP: + _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; + case SEXP_OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case SEXP_OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case SEXP_OP_TYPEP: + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_MAKE: + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_REF: + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_SET: + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); + sexp_slot_set(_ARG1, _UWORD1, _ARG2); + _ARG2 = SEXP_VOID; + ip += sizeof(sexp)*2; + top--; + break; + case SEXP_OP_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case SEXP_OP_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case SEXP_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 SEXP_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 SEXP_OP_CONS: + sexp_context_top(ctx) = top; + _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_ADD: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(j); + } + else + _ARG2 = sexp_add(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_add(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) + sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_SUB: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(j); + } + else + _ARG2 = sexp_sub(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_sub(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) - sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_MUL: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); + if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(prod); + } + else + _ARG2 = sexp_mul(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_mul(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) * sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_DIV: + if (_ARG2 == SEXP_ZERO) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) + _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { +#if SEXP_USE_FLONUMS + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); + _ARG2 = sexp_fixnum_to_flonum(ctx, _ARG2); + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + if (sexp_flonum_value(_ARG2) == trunc(sexp_flonum_value(_ARG2))) + _ARG2 = sexp_make_fixnum(sexp_flonum_value(_ARG2)); +#else + _ARG2 = sexp_fx_div(_ARG1, _ARG2); +#endif + } +#if SEXP_USE_BIGNUMS + else + _ARG2 = sexp_div(ctx, _ARG1, _ARG2); +#else +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) / sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_QUOTIENT: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG2 = sexp_fx_div(_ARG1, _ARG2); + top--; + } +#if SEXP_USE_BIGNUMS + else { + _ARG2 = sexp_quotient(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case SEXP_OP_REMAINDER: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + tmp1 = sexp_fx_rem(_ARG1, _ARG2); + top--; + _ARG1 = tmp1; + } +#if SEXP_USE_BIGNUMS + else { + _ARG2 = sexp_remainder(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case SEXP_OP_NEGATIVE: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_make_fixnum(-sexp_unbox_fixnum(_ARG1)); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) { + _ARG1 = sexp_copy_bignum(ctx, NULL, _ARG1, 0); + sexp_bignum_sign(_ARG1) = -sexp_bignum_sign(_ARG1); + } +#endif +#if SEXP_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 SEXP_OP_INVERSE: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, 1/(double)sexp_unbox_fixnum(_ARG1)); +#if SEXP_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 SEXP_OP_LT: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) < 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) < sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_LE: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) <= 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) <= sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_EQN: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = _ARG1 == _ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) == 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) == sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case SEXP_OP_FIX2FLO: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); +#endif + else if (! sexp_flonump(_ARG1)) + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case SEXP_OP_FLO2FIX: + if (sexp_flonump(_ARG1)) { + if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { + sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_BIGNUMS + } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { + _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); +#endif + } else { + _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); + } + } else if (! sexp_fixnump(_ARG1) && ! sexp_bignump(_ARG1)) { + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + } + break; + case SEXP_OP_CHAR2INT: + if (! sexp_charp(_ARG1)) + sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); + break; + case SEXP_OP_INT2CHAR: + if (! sexp_fixnump(_ARG1)) + sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); + break; + case SEXP_OP_CHAR_UPCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_CHAR_DOWNCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_WRITE_CHAR: + if (! sexp_charp(_ARG1)) + sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_NEWLINE: + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case SEXP_OP_READ_CHAR: + i = sexp_read_char(ctx, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_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 SEXP_OP_RET: + i = sexp_unbox_fixnum(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_fixnum(stack[fp+1]); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_fixnum(stack[fp+3]); + break; + case SEXP_OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); + } + goto loop; + + end_loop: + sexp_gc_release3(ctx); + 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_stream(port)) + fclose(sexp_port_stream(port)); +#if ! SEXP_USE_STRING_STREAMS + if (sexp_port_buf(port) && sexp_oportp(port)) + free(sexp_port_buf(port)); +#endif + 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); + } +} + +#if SEXP_USE_DL +sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); + if (! handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = dlsym(handle, "sexp_init_library"); + if (! init) { + dlclose(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx, env); +} +#endif + +sexp sexp_load (sexp ctx, sexp source, sexp env) { +#if SEXP_USE_DL + char *suffix; +#endif + sexp tmp, out=SEXP_FALSE; + sexp_gc_var4(ctx2, x, in, res); + if (! sexp_stringp(source)) + return sexp_type_exception(ctx, "not a string", source); + if (! sexp_envp(env)) + return sexp_type_exception(ctx, "not an environment", env); +#if SEXP_USE_DL + suffix = sexp_string_data(source) + + sexp_string_length(source) - strlen(sexp_so_extension); + if (strcmp(suffix, sexp_so_extension) == 0) { + res = sexp_load_dl(ctx, source, env); + } else { +#endif + sexp_gc_preserve4(ctx, ctx2, x, in, res); + res = SEXP_VOID; + in = sexp_open_input_file(ctx, source); + out = sexp_current_error_port(ctx); + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0); + sexp_context_parent(ctx2) = ctx; + tmp = sexp_env_bindings(env); + sexp_context_tailp(ctx2) = 0; + if (sexp_exceptionp(in)) { + if (sexp_not(out)) out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) + 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, env); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); + } + sexp_gc_release4(ctx); +#if SEXP_USE_DL + } +#endif +#if SEXP_USE_WARN_UNDEFS + if (sexp_oportp(out) && ! sexp_exceptionp(res)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out); +#endif + return res; +} + +#if SEXP_USE_MATH + +#if SEXP_USE_BIGNUMS +#define maybe_convert_bignum(z) \ + else if (sexp_bignump(z)) d = sexp_bignum_to_double(z); +#else +#define maybe_convert_bignum(z) +#endif + +#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_fixnump(z)) \ + d = (double)sexp_unbox_fixnum(z); \ + maybe_convert_bignum(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_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +static sexp sexp_sqrt (sexp ctx, sexp z) { + double d, r; + if (sexp_flonump(z)) + d = sexp_flonum_value(z); + else if (sexp_fixnump(z)) + d = (double)sexp_unbox_fixnum(z); + maybe_convert_bignum(z) /* XXXX add bignum sqrt */ + else + return sexp_type_exception(ctx, "not a number", z); + r = sqrt(d); + if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) + return sexp_make_fixnum(round(r)); + else + return sexp_make_flonum(ctx, r); +} + +#endif + +static sexp sexp_expt (sexp ctx, sexp x, sexp e) { + long double f, x1, e1; + sexp res; +#if SEXP_USE_BIGNUMS + if (sexp_bignump(e)) { /* bignum exponent needs special handling */ + if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) + res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ + else if (x == SEXP_ONE) + res = SEXP_ONE; /* 1.0 */ + else if (sexp_flonump(x)) + res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); + else + res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */ + } else if (sexp_bignump(x)) { + res = sexp_bignum_expt(ctx, x, e); + } else { +#endif + if (sexp_fixnump(x)) + x1 = sexp_unbox_fixnum(x); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception(ctx, "expt: not a number", x); + if (sexp_fixnump(e)) + e1 = sexp_unbox_fixnum(e); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception(ctx, "expt: not a number", e); + f = pow(x1, e1); + if ((f > SEXP_MAX_FIXNUM) || (f < SEXP_MIN_FIXNUM) +#if SEXP_USE_FLONUMS + || (! sexp_fixnump(x)) || (! sexp_fixnump(e)) +#endif + ) { +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(x) && sexp_fixnump(e)) + res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); + else +#endif +#if SEXP_USE_FLONUMS + res = sexp_make_flonum(ctx, f); +#else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#endif + } else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#if SEXP_USE_BIGNUMS + } +#endif + 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)) + 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 = ((len1= SEXP_OPC_NUM_OP_CLASSES)) + res = sexp_type_exception(ctx, "make-opcode: bad opcode class", op_class); + else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) + || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) + res = sexp_type_exception(ctx, "make-opcode: bad opcode", code); + else if (! sexp_fixnump(num_args)) + res = sexp_type_exception(ctx, "make-opcode: bad num_args", num_args); + else if (! sexp_fixnump(flags)) + res = sexp_type_exception(ctx, "make-opcode: bad flags", flags); + else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_arg1_type(res) = sexp_unbox_fixnum(arg1t); + sexp_opcode_arg2_type(res) = sexp_unbox_fixnum(arg2t); + sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_data(res) = data; + sexp_opcode_data2(res) = data2; + sexp_opcode_func(res) = func; + sexp_opcode_name(res) = strdup(sexp_string_data(name)); + } + return res; +} + +sexp sexp_make_foreign (sexp ctx, char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res; + if (num_args > 6) { + res = sexp_type_exception(ctx, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); + } else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; + sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1; + if (flags & 1) num_args--; + sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; + sexp_opcode_name(res) = name; + sexp_opcode_data(res) = data; + sexp_opcode_func(res) = f; + } + return res; +} + +sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp_gc_var1(op); + sexp_gc_preserve1(ctx, op); + sexp res = SEXP_VOID; + op = sexp_make_foreign(ctx, name, num_args, flags, f, data); + if (sexp_exceptionp(op)) + res = op; + else + sexp_env_define(ctx, env, sexp_intern(ctx, name), op); + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_TYPE_DEFS + +sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { + if (! sexp_fixnump(type)) + return sexp_type_exception(ctx, "make-type-predicate: bad type", type); + return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), + sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); +} + +sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { + sexp_uint_t type_size; + if (! sexp_fixnump(type)) + return sexp_type_exception(ctx, "make-constructor: bad type", type); + type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); + return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), + sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, + sexp_make_fixnum(type_size), NULL); +} + +sexp sexp_make_accessor (sexp ctx, sexp name, sexp type, sexp index, sexp code) { + if (! sexp_fixnump(type)) + return sexp_type_exception(ctx, "make-accessor: bad type", type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, "make-accessor: bad index", index); + return + sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_ACCESSOR), code, + sexp_make_fixnum(sexp_unbox_fixnum(code)==SEXP_OP_SLOT_REF?1:2), + SEXP_ZERO, type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(SEXP_OP_SLOT_REF)); +} +sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index) { + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(SEXP_OP_SLOT_SET)); +} + +#endif + +/*********************** standard environment *************************/ + +static struct sexp_struct core_forms[] = { + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE, "define"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SET, "set!"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LAMBDA, "lambda"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_IF, "if"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_BEGIN, "begin"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_QUOTE, "quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LET_SYNTAX, "let-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}}}, +}; + +sexp sexp_make_env (sexp ctx) { + 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; + return e; +} + +sexp sexp_make_null_env (sexp ctx, sexp version) { + sexp_uint_t i; + sexp e = sexp_make_env(ctx); + for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i])), + sexp_copy_core(ctx, &core_forms[i])); + return e; +} + +sexp sexp_make_primitive_env (sexp ctx, sexp version) { + int i; + sexp_gc_var3(e, op, sym); + sexp_gc_preserve3(ctx, e, op, sym); + e = sexp_make_null_env(ctx, version); + for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { + op = sexp_copy_opcode(ctx, &opcodes[i]); + if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op)); + sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); + } + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); + } + sexp_gc_release3(ctx); + return e; +} + +sexp sexp_find_module_file (sexp ctx, char *file) { + sexp res=SEXP_FALSE, ls; + char *dir, *path; + sexp_uint_t slash, dirlen, filelen, len; +#ifdef PLAN9 +#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0) + unsigned char buf[128]; +#else +#define file_exists_p(path, buf) (! stat(path, buf)) + struct stat buf_str; + struct stat *buf = &buf_str; +#endif + + filelen = strlen(file); + + ls = sexp_global(ctx, SEXP_G_MODULE_PATH); + for ( ; sexp_pairp(ls) && sexp_not(res); ls=sexp_cdr(ls)) { + dir = sexp_string_data(sexp_car(ls)); + dirlen = sexp_string_length(sexp_car(ls)); + slash = dir[dirlen-1] == '/'; + len = dirlen+filelen+2-slash; + path = (char*) malloc(len); + memcpy(path, dir, dirlen); + if (! slash) path[dirlen] = '/'; + memcpy(path+len-filelen-1, file, filelen); + path[len-1] = '\0'; + if (file_exists_p(path, buf)) + res = sexp_c_string(ctx, path, len-1); + free(path); + } + + return res; +} + +#define sexp_file_not_found "couldn't find file in module path" + +sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { + sexp res; + sexp_gc_var1(path); + sexp_gc_preserve1(ctx, path); + path = sexp_find_module_file(ctx, file); + if (sexp_stringp(path)) { + res = sexp_load(ctx, path, env); + } else { + path = sexp_c_string(ctx, file, -1); + res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path); + } + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_MODULES +static sexp sexp_find_module_file_op (sexp ctx, sexp file) { + if (! sexp_stringp(file)) + return sexp_type_exception(ctx, "not a string", file); + else + return sexp_find_module_file(ctx, sexp_string_data(file)); +} +sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env) { + if (! sexp_stringp(file)) + return sexp_type_exception(ctx, "not a string", file); + else if (! sexp_envp(env)) + return sexp_type_exception(ctx, "not an environment", env); + return sexp_load_module_file(ctx, sexp_string_data(file), env); +} +#endif + +sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp) { + sexp ls; + if (! sexp_stringp(dir)) + return sexp_type_exception(ctx, "not a string", dir); + if (sexp_truep(appendp)) { + if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { + for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) + ; + sexp_cdr(ls) = sexp_list1(ctx, dir); + } else { + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir); + } + } else { + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir); + } + return SEXP_VOID; +} + +sexp sexp_load_standard_parameters (sexp ctx, sexp e) { + /* add io port and interaction env parameters */ + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), + sexp_make_input_port(ctx, stdin, SEXP_FALSE)); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + sexp_make_output_port(ctx, stdout, SEXP_FALSE)); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), + sexp_make_output_port(ctx, stderr, SEXP_FALSE)); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); + return SEXP_VOID; +} + +sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { + sexp_gc_var3(op, tmp, sym); + sexp_gc_preserve3(ctx, op, tmp, sym); + sexp_load_standard_parameters(ctx, e); +#if SEXP_USE_DL + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*"), + tmp=sexp_c_string(ctx, sexp_so_extension, -1)); +#endif + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform)); +#if SEXP_USE_DL + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading")); +#endif +#if SEXP_USE_MODULES + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules")); +#endif +#if SEXP_USE_BOEHM + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc")); +#endif + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp); + sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; +#if SEXP_USE_SIMPLIFY + op = sexp_make_foreign(ctx, "simplify", 1, 0, + (sexp_proc1)sexp_simplify, SEXP_VOID); + tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); +#endif + /* load init.scm */ + tmp = sexp_load_module_file(ctx, sexp_init_file, e); + /* load and bind config env */ +#if SEXP_USE_MODULES + if (! sexp_exceptionp(tmp)) { + sym = sexp_intern(ctx, "*config-env*"); + if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { + tmp = sexp_make_env(ctx); + if (! sexp_exceptionp(tmp)) { + sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; + sexp_env_parent(tmp) = e; + op = sexp_load_module_file(ctx, sexp_config_file, tmp); + if (sexp_exceptionp(op)) + sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); + sexp_env_define(ctx, tmp, sym, tmp); + } + } + sexp_env_define(ctx, e, sym, tmp); + } +#endif + sexp_gc_release3(ctx); + return sexp_exceptionp(tmp) ? tmp : e; +} + +sexp sexp_make_standard_env (sexp ctx, sexp version) { + sexp_gc_var1(env); + sexp_gc_preserve1(ctx, env); + env = sexp_make_primitive_env(ctx, version); + if (! sexp_exceptionp(env)) sexp_load_standard_env(ctx, env, version); + sexp_gc_release1(ctx); + return env; +} + +sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls, sexp immutp) { + sexp oldname, newname, value, out; + if (! sexp_envp(to)) to = sexp_context_env(ctx); + if (! sexp_envp(from)) from = sexp_context_env(ctx); + if (sexp_not(ls)) { + if (sexp_truep(immutp)) { + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_parent(to) = value; + sexp_immutablep(value) = 1; + sexp_env_bindings(value) = sexp_env_bindings(from); + } else { + for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls)); + } + } else { + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (sexp_pairp(sexp_car(ls))) { + newname = sexp_caar(ls); oldname = sexp_cdar(ls); + } else { + newname = oldname = sexp_car(ls); + } + value = sexp_env_ref(from, oldname, SEXP_UNDEF); + if (value != SEXP_UNDEF) { + sexp_env_define(ctx, to, newname, value); +#if SEXP_USE_WARN_UNDEFS + } else if (sexp_oportp(out=sexp_current_error_port(ctx))) { + sexp_write_string(ctx, "WARNING: importing undefined variable: ", out); + sexp_write(ctx, oldname, out); + sexp_write_char(ctx, '\n', out); +#endif + } + } + } + return SEXP_VOID; +} + +/************************** eval interface ****************************/ + +sexp sexp_apply (sexp ctx, sexp proc, sexp args) { + sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx), len, offset; + len = sexp_unbox_fixnum(sexp_length(ctx, args)); + if (sexp_opcodep(proc)) + proc = make_opcode_procedure(ctx, proc, len); + if (! sexp_procedurep(proc)) { + res = sexp_exceptionp(proc) ? proc : + sexp_type_exception(ctx, "apply: not a procedure", proc); + } else { + offset = top + len; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) + stack[--offset] = sexp_car(ls); + stack[top] = sexp_make_fixnum(len); + top++; + stack[top++] = SEXP_ZERO; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + stack[top++] = SEXP_ZERO; + sexp_context_top(ctx) = top; + res = sexp_vm(ctx, proc); + if (! res) res = SEXP_VOID; + } + return res; +} + +sexp sexp_compile (sexp ctx, sexp x) { + sexp_gc_var3(ast, vec, res); + sexp_gc_preserve3(ctx, ast, vec, res); + ast = sexp_analyze(ctx, x); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(res); res=sexp_cdr(res)) + ast = sexp_apply_optimization(ctx, sexp_cdar(res), ast); + free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + generate(ctx, ast); + res = finalize_bytecode(ctx); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec); + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_eval (sexp ctx, sexp obj, sexp env) { + sexp_sint_t top; + sexp ctx2; + sexp_gc_var2(res, err_handler); + sexp_gc_preserve2(ctx, res, err_handler); + top = sexp_context_top(ctx); + err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = SEXP_FALSE; + ctx2 = sexp_make_eval_context(ctx, + sexp_context_stack(ctx), + (env ? env : sexp_context_env(ctx)), + 0); + res = sexp_compile(ctx2, obj); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; + sexp_context_top(ctx) = top; + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_eval_string (sexp ctx, char *str, sexp env) { + sexp res; + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); + obj = sexp_read_from_string(ctx, str); + res = sexp_eval(ctx, obj, env); + sexp_gc_release1(ctx); + return res; +} + +void sexp_scheme_init (void) { + if (! scheme_initialized_p) { + scheme_initialized_p = 1; + sexp_init(); + } +} diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..1130c15b --- /dev/null +++ b/gc.c @@ -0,0 +1,249 @@ +/* gc.c -- simple mark&sweep garbage collector */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* These settings are configurable but only recommended for */ +/* experienced users, so they're not in config.h. */ + +/* the initial heap size in bytes */ +#ifndef SEXP_INITIAL_HEAP_SIZE +#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) +#endif + +/* the maximum heap size in bytes - if 0 there is no limit */ +#ifndef SEXP_MAXIMUM_HEAP_SIZE +#define SEXP_MAXIMUM_HEAP_SIZE 0 +#endif +#ifndef SEXP_MINIMUM_HEAP_SIZE +#define SEXP_MINIMUM_HEAP_SIZE 512*1024 +#endif + +/* if after GC more than this percentage of memory is still in use, */ +/* and we've not exceeded the maximum size, grow the heap */ +#ifndef SEXP_GROW_HEAP_RATIO +#define SEXP_GROW_HEAP_RATIO 0.75 +#endif + +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair)) + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +#if SEXP_USE_GLOBAL_HEAP +sexp_heap sexp_global_heap; +#endif + +#if SEXP_USE_DEBUG_GC +static sexp* stack_base; +#endif + +static sexp_heap sexp_heap_last (sexp_heap h) { + while (h->next) h = h->next; + return h; +} + +sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) { + sexp_uint_t res; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) + return sexp_heap_align(1); + t = sexp_object_type(ctx, x); + res = sexp_type_size_of_object(t, x); + return res; +} + +void sexp_mark (sexp ctx, sexp x) { + 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(ctx, *(saves->var)); + t = sexp_object_type(ctx, x); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len = sexp_type_num_slots_of_object(t, x) - 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(ctx, p)); + if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + /* free p */ + finalizer = sexp_type_finalize(sexp_object_type(ctx, p)); + if (finalizer) finalizer(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_fixnum(max_freed); +} + +sexp sexp_gc (sexp ctx, size_t *sum_freed) { + sexp res; +#if SEXP_USE_GLOBAL_SYMBOLS + int i; + 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(sexp_context_heap(ctx)); + 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=sexp_context_heap(ctx); 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_fixnum(sexp_gc(ctx, &sum_freed)); + h = sexp_heap_last(sexp_context_heap(ctx)); + if (((max_freed < size) + || ((h->size - sum_freed) > (h->size*SEXP_GROW_HEAP_RATIO))) + && ((! SEXP_MAXIMUM_HEAP_SIZE) || (h->size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); + if (! res) + res = sexp_global(ctx, SEXP_G_OOM_ERROR); + } + return res; +} + +void sexp_gc_init (void) { +#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_DEBUG_GC + sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); +#endif +#if SEXP_USE_GLOBAL_HEAP + sexp_global_heap = sexp_make_heap(size); +#endif +#if SEXP_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/bignum.h b/include/chibi/bignum.h new file mode 100644 index 00000000..580b0a7d --- /dev/null +++ b/include/chibi/bignum.h @@ -0,0 +1,43 @@ +/* bignum.h -- header for bignum utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_BIGNUM_H +#define SEXP_BIGNUM_H + +#if (SEXP_64_BIT) +typedef unsigned int uint128_t __attribute__((mode(TI))); +typedef int sint128_t __attribute__((mode(TI))); +typedef uint128_t sexp_luint_t; +typedef sint128_t sexp_lsint_t; +#else +typedef unsigned long long sexp_luint_t; +typedef long long sexp_lsint_t; +#endif + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b); +sexp sexp_compare (sexp ctx, sexp a, sexp b); +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len); +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len); +sexp sexp_bignum_normalize (sexp a); +sexp_uint_t sexp_bignum_hi (sexp a); +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a); +double sexp_bignum_to_double (sexp a); +sexp sexp_double_to_bignum (sexp ctx, double f); +sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b); +sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset); +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset); +sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_div (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_expt (sexp ctx, sexp n, sexp e); +sexp sexp_add (sexp ctx, sexp a, sexp b); +sexp sexp_sub (sexp ctx, sexp a, sexp b); +sexp sexp_mul (sexp ctx, sexp a, sexp b); +sexp sexp_div (sexp ctx, sexp a, sexp b); +sexp sexp_quotient (sexp ctx, sexp a, sexp b); +sexp sexp_remainder (sexp ctx, sexp a, sexp b); + +#endif /* ! SEXP_BIGNUM_H */ + diff --git a/include/chibi/eval.h b/include/chibi/eval.h new file mode 100644 index 00000000..60201c61 --- /dev/null +++ b/include/chibi/eval.h @@ -0,0 +1,163 @@ +/* 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 SEXP_INIT_BCODE_SIZE 128 +#define SEXP_INIT_STACK_SIZE 8192 + +#define sexp_init_file "init.scm" +#define sexp_config_file "config.scm" + +enum sexp_core_form_names { + SEXP_CORE_DEFINE = 1, + SEXP_CORE_SET, + SEXP_CORE_LAMBDA, + SEXP_CORE_IF, + SEXP_CORE_BEGIN, + SEXP_CORE_QUOTE, + SEXP_CORE_SYNTAX_QUOTE, + SEXP_CORE_DEFINE_SYNTAX, + SEXP_CORE_LET_SYNTAX, + SEXP_CORE_LETREC_SYNTAX +}; + +enum sexp_opcode_classes { + SEXP_OPC_GENERIC = 1, + SEXP_OPC_TYPE_PREDICATE, + SEXP_OPC_PREDICATE, + SEXP_OPC_ARITHMETIC, + SEXP_OPC_ARITHMETIC_INV, + SEXP_OPC_ARITHMETIC_CMP, + SEXP_OPC_IO, + SEXP_OPC_CONSTRUCTOR, + SEXP_OPC_ACCESSOR, + SEXP_OPC_PARAMETER, + SEXP_OPC_FOREIGN, + SEXP_OPC_NUM_OP_CLASSES +}; + +enum sexp_opcode_names { + SEXP_OP_NOOP, + SEXP_OP_RAISE, + SEXP_OP_RESUMECC, + SEXP_OP_CALLCC, + SEXP_OP_APPLY1, + SEXP_OP_TAIL_CALL, + SEXP_OP_CALL, + SEXP_OP_FCALL0, + SEXP_OP_FCALL1, + SEXP_OP_FCALL2, + SEXP_OP_FCALL3, + SEXP_OP_FCALL4, + SEXP_OP_FCALL5, + SEXP_OP_FCALL6, + SEXP_OP_JUMP_UNLESS, + SEXP_OP_JUMP, + SEXP_OP_PUSH, + SEXP_OP_DROP, + SEXP_OP_GLOBAL_REF, + SEXP_OP_GLOBAL_KNOWN_REF, + SEXP_OP_STACK_REF, + SEXP_OP_LOCAL_REF, + SEXP_OP_LOCAL_SET, + SEXP_OP_CLOSURE_REF, + SEXP_OP_VECTOR_REF, + SEXP_OP_VECTOR_SET, + SEXP_OP_VECTOR_LENGTH, + SEXP_OP_STRING_REF, + SEXP_OP_STRING_SET, + SEXP_OP_STRING_LENGTH, + SEXP_OP_MAKE_PROCEDURE, + SEXP_OP_MAKE_VECTOR, + SEXP_OP_MAKE_EXCEPTION, + SEXP_OP_AND, + SEXP_OP_NULLP, + SEXP_OP_FIXNUMP, + SEXP_OP_SYMBOLP, + SEXP_OP_CHARP, + SEXP_OP_EOFP, + SEXP_OP_TYPEP, + SEXP_OP_MAKE, + SEXP_OP_SLOT_REF, + SEXP_OP_SLOT_SET, + SEXP_OP_CAR, + SEXP_OP_CDR, + SEXP_OP_SET_CAR, + SEXP_OP_SET_CDR, + SEXP_OP_CONS, + SEXP_OP_ADD, + SEXP_OP_SUB, + SEXP_OP_MUL, + SEXP_OP_DIV, + SEXP_OP_QUOTIENT, + SEXP_OP_REMAINDER, + SEXP_OP_NEGATIVE, + SEXP_OP_INVERSE, + SEXP_OP_LT, + SEXP_OP_LE, + SEXP_OP_EQN, + SEXP_OP_EQ, + SEXP_OP_FIX2FLO, + SEXP_OP_FLO2FIX, + SEXP_OP_CHAR2INT, + SEXP_OP_INT2CHAR, + SEXP_OP_CHAR_UPCASE, + SEXP_OP_CHAR_DOWNCASE, + SEXP_OP_WRITE_CHAR, + SEXP_OP_NEWLINE, + SEXP_OP_READ_CHAR, + SEXP_OP_PEEK_CHAR, + SEXP_OP_RET, + SEXP_OP_DONE, + SEXP_OP_NUM_OPCODES +}; + +/**************************** prototypes ******************************/ + +SEXP_API void sexp_scheme_init (void); +SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size); +SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); +SEXP_API sexp sexp_analyze (sexp context, sexp x); +SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); +SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); +SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); +SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); +SEXP_API sexp sexp_make_env (sexp context); +SEXP_API sexp sexp_make_null_env (sexp context, sexp version); +SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version); +SEXP_API sexp sexp_make_standard_env (sexp context, sexp version); +SEXP_API sexp sexp_load_standard_parameters (sexp context, sexp env); +SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version); +SEXP_API sexp sexp_find_module_file (sexp ctx, char *file); +SEXP_API sexp sexp_load_module_file (sexp ctx, char *file, sexp env); +SEXP_API sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp); +SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); +SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls, sexp immutp); +SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val); +SEXP_API sexp sexp_env_cell (sexp env, sexp sym); +SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); +SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); +SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); +SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); +SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data); +SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, int flags, sexp_proc1 f, sexp data); + +#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL) +#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d) + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); +SEXP_API sexp sexp_make_constructor (sexp ctx, sexp name, sexp type); +SEXP_API sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index); +SEXP_API sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index); +#endif + +#endif /* ! SEXP_EVAL_H */ + diff --git a/include/chibi/features.h b/include/chibi/features.h new file mode 100644 index 00000000..9143a071 --- /dev/null +++ b/include/chibi/features.h @@ -0,0 +1,297 @@ +/* features.h -- general feature configuration */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +/* uncomment this to disable most features */ +/* Most features are enabled by default, but setting this */ +/* option will disable any not explicitly enabled. */ +/* #define SEXP_USE_NO_FEATURES 1 */ + +/* uncomment this to disable the module system */ +/* Currently this just loads the config.scm from main and */ +/* sets up an (import (module name)) macro. */ +/* #define SEXP_USE_MODULES 0 */ + +/* uncomment this to disable dynamic loading */ +/* If enabled, you can LOAD .so files with a */ +/* sexp_init_library(ctx, env) function provided. */ +/* #define SEXP_USE_DL 0 */ + +/* uncomment this to disable a simplifying optimization pass */ +/* This performs some simple optimizations such as dead-code */ +/* elimination, constant-folding, and directly propagating */ +/* non-mutated let values bound to constants or non-mutated */ +/* references. More than performance, this is aimed at reducing the */ +/* size of the compiled code, especially as the result of macro */ +/* expansions, so it's a good idea to leave it enabled. */ +/* #define SEXP_USE_SIMPLIFY 0 */ + +/* uncomment this to disable dynamic type definitions */ +/* This enables register-simple-type and related */ +/* opcodes for defining types, needed by the default */ +/* implementation of (srfi 9). */ +/* #define SEXP_USE_TYPE_DEFS 0 */ + +/* uncomment this to use the Boehm conservative GC */ +/* Conservative GCs make it easier to write extensions, */ +/* since you don't have to keep track of intermediate */ +/* variables, but can leak memory. Boehm is also a */ +/* very large library to link in. You may want to */ +/* enable this when debugging your own extensions, or */ +/* if you suspect a bug in the native GC. */ +/* #define SEXP_USE_BOEHM 1 */ + +/* uncomment this to just malloc manually instead of any GC */ +/* Mostly for debugging purposes, this is the no GC option. */ +/* You can use just the read/write API and */ +/* explicitly free sexps, though. */ +/* #define SEXP_USE_MALLOC 1 */ + +/* uncomment this to add conservative checks to the native GC */ +/* Please mail the author if enabling this makes a bug */ +/* go away and you're not working on your own C extension. */ +/* #define SEXP_USE_DEBUG_GC 1 */ + +/* uncomment this to make the heap common to all contexts */ +/* By default separate contexts can have separate heaps, */ +/* and are thus thread-safe and independant. */ +/* #define SEXP_USE_GLOBAL_HEAP 1 */ + +/* uncomment this to make type definitions common to all contexts */ +/* By default types are only global if you don't allow user type */ +/* definitions, so new types will be local to a given set of */ +/* contexts sharing thei heap. */ +/* #define SEXP_USE_GLOBAL_TYPES 1 */ + +/* uncomment this to make the symbol table common to all contexts */ +/* Will still be restricted to all contexts sharing the same */ +/* heap, of course. */ +/* #define SEXP_USE_GLOBAL_SYMBOLS 1 */ + +/* uncomment this if you don't need flonum support */ +/* This is only for EVAL - you'll still be able to read */ +/* and write flonums directly through the sexp API. */ +/* #define SEXP_USE_FLONUMS 0 */ + +/* uncomment this to disable reading/writing IEEE infinities */ +/* By default you can read/write +inf.0, -inf.0 and +nan.0 */ +/* #define SEXP_USE_INFINITIES 0 */ + +/* uncomment this if you want immediate flonums */ +/* This is experimental, enable at your own risk. */ +/* #define SEXP_USE_IMMEDIATE_FLONUMS 1 */ + +/* uncomment this if you don't want bignum support */ +/* Bignums are implemented with a small, custom library */ +/* in opt/bignum.c. */ +/* #define SEXP_USE_BIGNUMS 0 */ + +/* uncomment this if you don't need extended math operations */ +/* This includes the trigonometric and expt functions. */ +/* Automatically disabled if you've disabled flonums. */ +/* #define SEXP_USE_MATH 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* This is something of a hack, but can be quite useful. */ +/* It's very fast and doesn't involve any separate analysis */ +/* passes. */ +/* #define SEXP_USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* By default (this may change) small symbols are represented */ +/* as immediates using a simple huffman encoding. This keeps */ +/* the symbol table small, and minimizes hashing when doing a */ +/* lot of reading. */ +/* #define SEXP_USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* You can trade off some space in exchange for longer read */ +/* times by disabling hashing and just putting all */ +/* non-immediate symbols in a single list. */ +/* #define SEXP_USE_HASH_SYMS 0 */ + +/* uncomment this to disable string ports */ +/* If disabled some basic functionality such as number->string */ +/* will not be available by default. */ +/* #define SEXP_USE_STRING_STREAMS 0 */ + +/* uncomment this to disable automatic closing of ports */ +/* If enabled, the underlying FILE* for file ports will be */ +/* automatically closed when they're garbage collected. Doesn't */ +/* apply to stdin/stdout/stderr. */ +/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */ + +/* uncomment this to use the normal 1970 unix epoch */ +/* By default chibi uses an datetime epoch starting at */ +/* 2010/01/01 00:00:00 in order to be able to represent */ +/* more common times as fixnums. */ +/* #define SEXP_USE_2010_EPOCH 0 */ + +/* uncomment this to disable stack overflow checks */ +/* By default stacks are fairly small, so it's good to leave */ +/* this enabled. */ +/* #define SEXP_USE_CHECK_STACK 0 */ + +/* #define SEXP_USE_DEBUG_VM 0 */ +/* Experts only. */ +/* For *very* verbose output on every VM operation. */ + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#ifndef SEXP_64_BIT +#if defined(__amd64) || defined(__x86_64) +#define SEXP_64_BIT 1 +#else +#define SEXP_64_BIT 0 +#endif +#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 SEXP_USE_NO_FEATURES +#define SEXP_USE_NO_FEATURES 0 +#endif + +#ifndef SEXP_USE_MODULES +#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_TYPE_DEFS +#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_MAXIMUM_TYPES +#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1) +#endif + +#ifndef SEXP_USE_DL +#ifdef PLAN9 +#define SEXP_USE_DL 0 +#else +#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 0 +#endif + +#ifndef SEXP_USE_MALLOC +#define SEXP_USE_MALLOC 0 +#endif + +#ifndef SEXP_USE_DEBUG_GC +#define SEXP_USE_DEBUG_GC 0 +#endif + +#ifndef SEXP_USE_GLOBAL_HEAP +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_HEAP 1 +#else +#define SEXP_USE_GLOBAL_HEAP 0 +#endif +#endif + +#ifndef SEXP_USE_GLOBAL_TYPES +#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS) +#endif + +#ifndef SEXP_USE_GLOBAL_SYMBOLS +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_SYMBOLS 1 +#else +#define SEXP_USE_GLOBAL_SYMBOLS 0 +#endif +#endif + +#ifndef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_INFINITIES +#if defined(PLAN9) || ! SEXP_USE_FLONUMS +#define SEXP_USE_INFINITIES 0 +#else +#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_IMMEDIATE_FLONUMS +#define SEXP_USE_IMMEDIATE_FLONUMS 0 +#endif + +#ifndef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MATH +#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_WARN_UNDEFS +#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HUFF_SYMS +#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HASH_SYMS +#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_DEBUG_VM +#define SEXP_USE_DEBUG_VM 0 +#endif + +#ifndef SEXP_USE_STRING_STREAMS +#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_AUTOCLOSE_PORTS +#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_2010_EPOCH +#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_EPOCH_OFFSET +#if SEXP_USE_2010_EPOCH +#define SEXP_EPOCH_OFFSET 1262271600 +#else +#define SEXP_EPOCH_OFFSET 0 +#endif +#endif + +#ifndef SEXP_USE_CHECK_STACK +#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES +#endif + +#ifdef PLAN9 +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#endif + +#ifdef __MINGW32__ +#ifdef BUILDING_DLL +#define SEXP_API __declspec(dllexport) +#else +#define SEXP_API __declspec(dllimport) +#endif +#else +#define SEXP_API +#endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h new file mode 100644 index 00000000..687daefb --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,862 @@ +/* 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 + +#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" + +#include "chibi/features.h" +#include "chibi/install.h" + +#include +#include + +#if SEXP_USE_DL +#include +#endif + +#ifdef PLAN9 +#include +#include +#include +#include +#include <9p.h> +typedef unsigned long size_t; +#else +#include +#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 + +#if SEXP_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_CPOINTER, + 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_CORE_TYPES +}; + +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +#if SEXP_64_BIT +typedef unsigned int sexp_tag_t; +#else +typedef unsigned short sexp_tag_t; +#endif +typedef struct sexp_struct *sexp; + +#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2)) +#define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type)) +#define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type)) + +#define SEXP_UINT_T_MAX ((sexp_uint_t)-1) +#define SEXP_UINT_T_MIN (0) +#define SEXP_SINT_T_MAX __MAX_SIGNED(sexp_sint_t) +#define SEXP_SINT_T_MIN __MIN_SIGNED(sexp_sint_t) + +#define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1) +#define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1) + +/* procedure types */ +typedef sexp (*sexp_proc0) (void); +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 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 free_list; + sexp_heap next; + char *data; +}; + +struct sexp_gc_var_t { + sexp *var; + /* char *name; */ + struct sexp_gc_var_t *next; +}; + +struct sexp_struct { + sexp_tag_t tag; + char gc_mark; + unsigned int immutablep:1; + unsigned int freep:1; + union { + /* basic types */ + double flonum; + struct { + sexp_tag_t tag; + short field_base, field_eq_len_base, field_len_base, field_len_off; + unsigned short field_len_scale; + short size_base, size_off; + unsigned short size_scale; + char *name; + sexp_proc2 finalize; + } 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; + char openp, sourcep; + sexp_uint_t offset, line; + size_t size; + 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; + struct { + sexp_uint_t length; + void *value; + sexp parent; + char body[]; + } cpointer; + /* runtime types */ + struct { + unsigned int syntacticp:1; + 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, data2, proc; + sexp_proc1 func; + } opcode; + struct { + char code; + char *name; + } core; + /* ast types */ + struct { + sexp name, params, body, defs, locals, flags, 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_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp_heap heap; + struct sexp_gc_var_t *saves; + sexp_uint_t pos, depth, tailp, tracep; + sexp bc, lambda, stack, env, fv, parent, globals; + } 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_offsetof_slot0 (offsetof(struct sexp_struct, value)) + +#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double)) + +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) +#define sexp_alloc_bytecode(ctx, i) sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE) + +#if SEXP_USE_BIGNUMS +#include "chibi/bignum.h" +#endif + +/***************************** 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_fixnump(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_flags(x) ((x)->flags) +#define sexp_immutablep(x) ((x)->immutablep) +#define sexp_freep(x) ((x)->freep) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) +#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) + +#if SEXP_USE_IMMEDIATE_FLONUMS +union sexp_flonum_conv { + float flonum; + unsigned int bits; +}; +#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x); +#if SEXP_64_BIT +SEXP_API float sexp_flonum_value (sexp x); +SEXP_API sexp sexp_make_flonum(sexp ctx, float f); +#else +#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)(((unsigned int)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) +#endif +#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_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) +#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER)) +#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)) + +#if SEXP_USE_HUFF_SYMS +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +#else +#define sexp_symbolp(x) (sexp_lsymbolp(x)) +#endif + +#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_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) + +#define SEXP_NEG_ONE sexp_make_fixnum(-1) +#define SEXP_ZERO sexp_make_fixnum(0) +#define SEXP_ONE sexp_make_fixnum(1) +#define SEXP_TWO sexp_make_fixnum(2) +#define SEXP_THREE sexp_make_fixnum(3) +#define SEXP_FOUR sexp_make_fixnum(4) +#define SEXP_FIVE sexp_make_fixnum(5) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) + +#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x))) +#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x)) +#else +#define _or_integer_flonump(x) +#endif + +#if SEXP_USE_BIGNUMS +SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x); +SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); +#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) +#else +#define sexp_make_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_make_unsigned_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_exact_integerp(x) sexp_fixnump(x) +#endif + +#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) +#else +#define sexp_fixnum_to_flonum(ctx, x) (x) +#endif + +#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS +#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0])) +#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0])) +#else +#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x)) +#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x)) +#endif + +#define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET) +#define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET) + +/*************************** 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_fixnum(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_fixnum(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_fixnum(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_fixnum(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(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_cpointer_freep(p) (sexp_freep(p)) +#define sexp_cpointer_length(p) ((p)->value.cpointer.length) +#define sexp_cpointer_body(p) ((p)->value.cpointer.body) +#define sexp_cpointer_parent(p) ((p)->value.cpointer.parent) +#define sexp_cpointer_value(p) ((p)->value.cpointer.value) +#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p)) + +#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_syntactic_p(x) ((x)->value.env.syntacticp) +#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_data(x) ((x)->value.opcode.data) +#define sexp_opcode_data2(x) ((x)->value.opcode.data2) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) +#define sexp_opcode_func(x) ((x)->value.opcode.func) + +#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_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) + +#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_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_globals(x) ((x)->value.context.globals) + +#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) + +#if SEXP_USE_GLOBAL_HEAP +#if ! SEXP_USE_BOEHM +SEXP_API sexp_heap sexp_global_heap; +#endif +#define sexp_context_heap(ctx) sexp_global_heap +#else +#define sexp_context_heap(ctx) ((ctx)->value.context.heap) +#endif + +#if SEXP_USE_GLOBAL_SYMBOLS +#define sexp_context_symbols(ctx) sexp_symbol_table +#else +#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) +#endif + +#if SEXP_USE_GLOBAL_TYPES +SEXP_API struct sexp_struct *sexp_type_specs; +#define sexp_context_types(ctx) sexp_type_specs +#define sexp_type_by_index(ctx,i) (&(sexp_context_types(ctx)[i])) +#define sexp_context_num_types(ctx) sexp_num_types +#define sexp_context_type_array_size(ctx) sexp_type_array_size +#else +#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#define sexp_type_by_index(ctx,i) (sexp_context_types(ctx)[i]) +#define sexp_context_num_types(ctx) \ + sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES)) +#define sexp_context_type_array_size(ctx) \ + sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES)) +#endif + +#define sexp_object_type(ctx,x) (sexp_type_by_index(ctx, ((x)->tag))) +#define sexp_object_type_name(ctx,x) (sexp_type_name(sexp_object_type(ctx, x))) +#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i))) + +#define sexp_type_size_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \ + * sexp_type_size_scale(t) \ + + sexp_type_size_base(t)) +#define sexp_type_num_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_len_base(t)) +#define sexp_type_num_eq_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_eq_len_base(t)) + +#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_eq_len_base(x) ((x)->value.type.field_eq_len_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_type_finalize(x) ((x)->value.type.finalize) + +#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_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b))) +#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b))) +#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1))) +#define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a)))) +#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) + +#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 *****************************/ + +enum sexp_context_globals { +#if ! SEXP_USE_GLOBAL_SYMBOLS + SEXP_G_SYMBOLS, +#endif +#if ! SEXP_USE_GLOBAL_TYPES + SEXP_G_TYPES, + SEXP_G_NUM_TYPES, +#endif + SEXP_G_OOM_ERROR, /* out of memory exception object */ + SEXP_G_OOS_ERROR, /* out of stack exception object */ + SEXP_G_OPTIMIZATIONS, + SEXP_G_SIGNAL_HANDLERS, + SEXP_G_CONFIG_ENV, + SEXP_G_MODULE_PATH, + SEXP_G_QUOTE_SYMBOL, + SEXP_G_QUASIQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SPLICING_SYMBOL, + SEXP_G_EMPTY_VECTOR, + SEXP_G_CUR_IN_SYMBOL, + SEXP_G_CUR_OUT_SYMBOL, + SEXP_G_CUR_ERR_SYMBOL, + SEXP_G_INTERACTION_ENV_SYMBOL, + SEXP_G_ERR_HANDLER, + SEXP_G_RESUMECC_BYTECODE, + SEXP_G_FINAL_RESUMER, + SEXP_G_NUM_GLOBALS +}; + +#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(ctx, (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 SEXP_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)) + +SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); +SEXP_API sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p); +SEXP_API sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p); +SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) + +SEXP_API sexp sexp_make_context(sexp ctx, sexp_uint_t size); +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_string_concatenate (sexp ctx, sexp str_ls); +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_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, sexp parent, int freep); +SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_flush_output(sexp ctx, 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_write_to_string(sexp ctx, sexp obj); +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 source); +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(void); + +#if SEXP_USE_GLOBAL_HEAP +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_destroy_context(sexp ctx); +#endif + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots); +SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); +SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp obj); +#define sexp_register_c_type(ctx, name, finalizer) \ + sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ + SEXP_ZERO, SEXP_ZERO, finalizer) +#endif + +#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) +#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))) + +#endif /* ! SEXP_H */ + diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c new file mode 100644 index 00000000..19721c10 --- /dev/null +++ b/lib/chibi/ast.c @@ -0,0 +1,80 @@ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +static void sexp_define_type_predicate (sexp ctx, sexp env, + char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname), op); + sexp_gc_release2(ctx); +} + +static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, + sexp_uint_t cindex, char* get, char *set) { + sexp type, index; + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + type = sexp_make_fixnum(ctype); + index = sexp_make_fixnum(cindex); + op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, get), op); + op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, set), op); + sexp_gc_release2(ctx); +} + +static sexp sexp_get_env_cell (sexp ctx, sexp env, sexp id) { + sexp cell = sexp_env_cell(env, id); + while ((! cell) && sexp_synclop(id)) { + env = sexp_synclo_env(id); + id = sexp_synclo_expr(id); + } + return cell ? cell : SEXP_FALSE; +} + +static sexp sexp_get_opcode_name (sexp ctx, sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, "not an opcode", op); + else if (! sexp_opcode_name(op)) + return SEXP_FALSE; + else + return sexp_intern(ctx, sexp_opcode_name(op)); +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); + sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); + sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); + sexp_define_type_predicate(ctx, env, "set?", SEXP_SET); + sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF); + sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ); + sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); + sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); + sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); + sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); + sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze); + sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); + sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); + sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + return SEXP_VOID; +} + diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module new file mode 100644 index 00000000..57068ece --- /dev/null +++ b/lib/chibi/ast.module @@ -0,0 +1,14 @@ + +(define-module (chibi ast) + (export analyze env-cell opcode-name + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + lambda-name lambda-params lambda-body lambda-defs + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + cnd-test cnd-pass cnd-fail + cnd-test-set! cnd-pass-set! cnd-fail-set! + set-var set-value set-var-set! set-value-set! + ref-name ref-cell ref-name-set! ref-cell-set! + seq-ls seq-ls-set! lit-value lit-value-set!) + (include-shared "ast")) + diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c new file mode 100644 index 00000000..2aac1943 --- /dev/null +++ b/lib/chibi/disasm.c @@ -0,0 +1,127 @@ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define SEXP_DISASM_MAX_DEPTH 8 +#define SEXP_DISASM_PAD_WIDTH 4 + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", + "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", + "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "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", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", + }; + +static sexp disasm (sexp ctx, sexp bc, sexp out, int depth) { + sexp tmp; + unsigned char *ip, opcode, i; + + if (sexp_procedurep(bc)) { + bc = sexp_procedure_code(bc); + } else if (sexp_opcodep(bc)) { + sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); + return SEXP_VOID; + } else if (! sexp_bytecodep(bc)) { + return sexp_type_exception(ctx, "not a procedure", bc); + } + if (! sexp_oportp(out)) { + return sexp_type_exception(ctx, "not an output-port", out); + } + + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + sexp_write_string(ctx, "-------------- ", out); + if (sexp_truep(sexp_bytecode_name(bc))) { + sexp_write(ctx, sexp_bytecode_name(bc), out); + sexp_write_char(ctx, ' ', out); + } + sexp_printf(ctx, out, "%p\n", bc); + + ip = sexp_bytecode_data(bc); + + loop: + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + 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 SEXP_OP_STACK_REF: + case SEXP_OP_LOCAL_REF: + case SEXP_OP_LOCAL_SET: + case SEXP_OP_CLOSURE_REF: + case SEXP_OP_JUMP: + case SEXP_OP_JUMP_UNLESS: + case SEXP_OP_TYPEP: + case SEXP_OP_FCALL0: + case SEXP_OP_FCALL1: + case SEXP_OP_FCALL2: + case SEXP_OP_FCALL3: + case SEXP_OP_FCALL4: + case SEXP_OP_FCALL5: + case SEXP_OP_FCALL6: + sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case SEXP_OP_SLOT_REF: + case SEXP_OP_SLOT_SET: + case SEXP_OP_MAKE: + ip += sizeof(sexp)*2; + break; + case SEXP_OP_GLOBAL_REF: + case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_TAIL_CALL: + case SEXP_OP_CALL: + case SEXP_OP_PUSH: + tmp = ((sexp*)ip)[0]; + if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF)) + && sexp_pairp(tmp)) + tmp = sexp_car(tmp); + else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) + sexp_write_char(ctx, '\'', out); + sexp_write(ctx, tmp, out); + ip += sizeof(sexp); + break; + } + sexp_write_char(ctx, '\n', out); + if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) + && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) + disasm(ctx, tmp, out, depth+1); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { + return disasm(ctx, bc, out, 0); +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_gc_var2(op, name); + sexp_gc_preserve2(ctx, op, name); + name = sexp_c_string(ctx, "disasm", -1); + op = sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_FOREIGN), + sexp_make_fixnum(SEXP_OP_FCALL2), SEXP_ONE, + SEXP_THREE, 0, 0, 0, 0, 0, (sexp_proc1)sexp_disasm); + name = sexp_intern(ctx, "*current-error-port*"); + sexp_opcode_data(op) = sexp_env_cell(sexp_context_env(ctx), name); + name = sexp_intern(ctx, "disasm"); + sexp_env_define(ctx, env, name, op); + sexp_gc_release2(ctx); + return SEXP_VOID; +} + diff --git a/lib/chibi/disasm.module b/lib/chibi/disasm.module new file mode 100644 index 00000000..46c6189c --- /dev/null +++ b/lib/chibi/disasm.module @@ -0,0 +1,4 @@ + +(define-module (chibi disasm) + (export disasm) + (include-shared "disasm")) diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module new file mode 100644 index 00000000..38a8fab1 --- /dev/null +++ b/lib/chibi/filesystem.module @@ -0,0 +1,27 @@ + +(define-module (chibi filesystem) + (export open-input-file-descriptor open-output-file-descriptor + duplicate-file-descriptor duplicate-file-descriptor-to + close-file-descriptor renumber-file-descriptor + delete-file link-file symbolic-link-file rename-file + directory-files create-directory delete-directory + file-status + file-device file-inode + file-mode file-num-links + file-owner file-group + file-represented-device file-size + file-block-size file-num-blocks + file-access-time file-modification-time file-change-time + file-regular? file-directory? file-character? + file-block? file-fifo? file-link? + file-socket? file-exists? + get-file-descriptor-flags set-file-descriptor-flags! + get-file-descriptor-status set-file-descriptor-status! + open/read open/write open/read-write + open/create open/exclusive open/truncate + open/append open/non-block + ) + (import-immutable (scheme)) + (include-shared "filesystem") + (include "filesystem.scm")) + diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm new file mode 100644 index 00000000..aa3fc69f --- /dev/null +++ b/lib/chibi/filesystem.scm @@ -0,0 +1,43 @@ +;; filesystem.scm -- additional filesystem utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (let lp ((res knil)) + (let ((file (readdir dir))) + (if file (lp (kons (dirent-name file) res)) res))))) + +(define (directory-files dir) + (directory-fold dir cons '())) + +(define (renumber-file-descriptor old new) + (and (duplicate-file-descriptor-to old new) + (close-file-descriptor old))) + +(define (file-status file) + (if (string? file) (stat file) (fstat file))) + +(define (file-device x) (stat-dev (if (stat? x) x (file-status x)))) +(define (file-inode x) (stat-ino (if (stat? x) x (file-status x)))) +(define (file-mode x) (stat-mode (if (stat? x) x (file-status x)))) +(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x)))) +(define (file-owner x) (stat-uid (if (stat? x) x (file-status x)))) +(define (file-group x) (stat-gid (if (stat? x) x (file-status x)))) +(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x)))) +(define (file-size x) (stat-size (if (stat? x) x (file-status x)))) +(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x)))) +(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x)))) +(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x)))) +(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x)))) +(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x)))) + +(define (file-regular? x) (S_ISREG (file-mode x))) +(define (file-directory? x) (S_ISDIR (file-mode x))) +(define (file-character? x) (S_ISCHR (file-mode x))) +(define (file-block? x) (S_ISBLK (file-mode x))) +(define (file-fifo? x) (S_ISFIFO (file-mode x))) +(define (file-link? x) (S_ISLNK (file-mode x))) +(define (file-socket? x) (S_ISSOCK (file-mode x))) + +(define (file-exists? x) (and (file-status x) #t)) diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub new file mode 100644 index 00000000..8c42466f --- /dev/null +++ b/lib/chibi/filesystem.stub @@ -0,0 +1,115 @@ + +(c-system-include "sys/types.h") +(c-system-include "unistd.h") +(c-system-include "dirent.h") +(c-system-include "fcntl.h") + +(define-c-type DIR + finalizer: closedir) + +(define-c-struct dirent + (string d_name dirent-name)) + +(define-c-struct stat + predicate: stat? + (dev_t st_dev stat-dev) + (ino_t st_ino stat-ino) + (mode_t st_mode stat-mode) + (nlink_t st_nlink stat-nlinks) + (uid_t st_uid stat-uid) + (gid_t st_gid stat-gid) + (dev_t st_rdev stat-rdev) + (off_t st_size stat-size) + (blksize_t st_blksize stat-blksize) + (blkcnt_t st_blocks stat-blocks) + (time_t st_atime stat-atime) + (time_t st_mtime stat-mtime) + (time_t st_ctime stat-ctime)) + +(define-c boolean S_ISREG (mode_t)) +(define-c boolean S_ISDIR (mode_t)) +(define-c boolean S_ISCHR (mode_t)) +(define-c boolean S_ISBLK (mode_t)) +(define-c boolean S_ISFIFO (mode_t)) +(define-c boolean S_ISLNK (mode_t)) +(define-c boolean S_ISSOCK (mode_t)) + +;;(define-c-const int ("S_IFMT")) +(define-c-const int (file/socket "S_IFSOCK")) +(define-c-const int (file/link "S_IFLNK")) +(define-c-const int (file/regular "S_IFREG")) +(define-c-const int (file/block "S_IFBLK")) +(define-c-const int (file/directory "S_IFDIR")) +(define-c-const int (file/character "S_IFCHR")) +(define-c-const int (file/fifo "S_IFIFO")) +(define-c-const int (file/suid "S_ISUID")) +(define-c-const int (file/sgid "S_ISGID")) +(define-c-const int (file/sticky "S_ISVTX")) +;;(define-c-const int ("S_IRWXU")) +(define-c-const int (perm/user-read "S_IRUSR")) +(define-c-const int (perm/user-write "S_IWUSR")) +(define-c-const int (perm/user-execute "S_IXUSR")) +;;(define-c-const int ("S_IRWXG")) +(define-c-const int (perm/group-read "S_IRGRP")) +(define-c-const int (perm/group-write "S_IWGRP")) +(define-c-const int (perm/group-execute "S_IXGRP")) +;;(define-c-const int ("S_IRWXO")) +(define-c-const int (perm/others-read "S_IROTH")) +(define-c-const int (perm/others-write "S_IWOTH")) +(define-c-const int (perm/others-execute "S_IXOTH")) + +(define-c errno stat (string (result stat))) +(define-c errno fstat (int (result stat))) +(define-c errno (file-link-status "lstat") (string (result stat))) + +(define-c input-port (open-input-file-descriptor "fdopen") + (int (value "r" string))) +(define-c output-port (open-output-file-descriptor "fdopen") + (int (value "w" string))) + +(define-c errno (delete-file "unlink") (string)) +(define-c errno (link-file "link") (string string)) +(define-c errno (symbolic-link-file "symlink") (string string)) +(define-c errno (rename-file "rename") (string string)) + +(define-c non-null-string (current-directory "getcwd") + ((result (array char (auto-expand arg1))) (value 256 int))) + +(define-c errno (create-directory "mkdir") (string int)) +(define-c errno (delete-directory "rmdir") (string)) + +(define-c (free DIR) opendir (string)) +(define-c dirent readdir ((link DIR))) + +(define-c int (duplicate-file-descriptor "dup") (int)) +(define-c errno (duplicate-file-descriptor-to "dup2") (int int)) +(define-c errno (close-file-descriptor "close") (int)) + +(define-c errno (open-pipe "pipe") ((result (array int 2)))) +(define-c errno (make-fifo "mkfifo") (string (default #o644 int))) + +(define-c int (get-file-descriptor-flags "fcntl") + (int (value F_GETFD int))) +(define-c errno (set-file-descriptor-flags! "fcntl") + (int (value F_SETFD int) long)) + +(define-c int (get-file-descriptor-status "fcntl") + (int (value F_GETFL int))) +(define-c errno (set-file-descriptor-status! "fcntl") + (int (value F_SETFL int) long)) + +;; (define-c int (get-file-descriptor-lock "fcntl") +;; (int (value F_GETLK int) flock)) +;; (define-c errno (set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLK int) flock)) +;; (define-c errno (try-set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLKW int) flock)) + +(define-c-const int (open/read "O_RDONLY")) +(define-c-const int (open/write "O_WRONLY")) +(define-c-const int (open/read-write "O_RDWR")) +(define-c-const int (open/create "O_CREAT")) +(define-c-const int (open/exclusive "O_EXCL")) +(define-c-const int (open/truncate "O_TRUNC")) +(define-c-const int (open/append "O_APPEND")) +(define-c-const int (open/non-block "O_NONBLOCK")) diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c new file mode 100644 index 00000000..34e415c1 --- /dev/null +++ b/lib/chibi/heap-stats.c @@ -0,0 +1,129 @@ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define SEXP_HEAP_VECTOR_DEPTH 1 + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); + +#if SEXP_USE_GLOBAL_HEAP +#endif + +static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { + int i; + if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x) + || sexp_flonump(x) || sexp_bignump(x)) { + sexp_write(ctx, x, out); + } else if (depth <= 0) { + goto print_name; + } else if (sexp_synclop(x)) { + sexp_write_string(ctx, "#", out); + } else if (sexp_pairp(x)) { + sexp_write_char(ctx, '(', out); + sexp_print_simple(ctx, sexp_car(x), out, depth-1); + sexp_write_string(ctx, " . ", out); + sexp_print_simple(ctx, sexp_cdr(x), out, depth-1); + sexp_write_char(ctx, ')', out); + } else if (sexp_vectorp(x)) { + sexp_write_string(ctx, "#(", out); + for (i=0; i0) + sexp_write_char(ctx, ' ', out); + sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); + } + if (i", out); + } +} + +static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { + size_t freed; + sexp_uint_t stats[256], hi_type=0, i; + sexp_heap h = sexp_context_heap(ctx); + sexp p, out=SEXP_FALSE; + sexp_free_list q, r; + char *end; + sexp_gc_var3(res, tmp, name); + + if (printp) + out = sexp_env_global_ref(sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + SEXP_FALSE); + + /* run gc once to remove unused variables */ + sexp_gc(ctx, &freed); + + /* initialize stats */ + for (i=0; i<256; i++) stats[i]=0; + + /* loop over each heap chunk */ + for ( ; h; h=h->next) { + 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) { /* this is a free block, skip */ + p = (sexp) (((char*)p) + r->size); + continue; + } + /* otherwise maybe print, then increment the stat and continue */ + if (sexp_oportp(out)) { + sexp_print_simple(ctx, p, out, depth); + sexp_write_char(ctx, '\n', out); + } + stats[sexp_pointer_tag(p)]++; + if (sexp_pointer_tag(p) > hi_type) + hi_type = sexp_pointer_tag(p); + p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p))); + } + } + + /* build and return results */ + sexp_gc_preserve3(ctx, res, tmp, name); + res = SEXP_NULL; + for (i=hi_type; i>0; i--) + if (stats[i]) { + name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i)); + tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); + res = sexp_cons(ctx, tmp, res); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_heap_stats (sexp ctx) { + return sexp_heap_walk(ctx, 0, 0); +} + +static sexp sexp_heap_dump (sexp ctx, sexp depth) { + if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) + return sexp_type_exception(ctx, "bad heap-dump depth", depth); + return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats); + sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE); + return SEXP_VOID; +} + diff --git a/lib/chibi/heap-stats.module b/lib/chibi/heap-stats.module new file mode 100644 index 00000000..af84ca44 --- /dev/null +++ b/lib/chibi/heap-stats.module @@ -0,0 +1,5 @@ + +(define-module (chibi heap-stats) + (export heap-stats heap-dump) + (include-shared "heap-stats")) + diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module new file mode 100644 index 00000000..5b76daf8 --- /dev/null +++ b/lib/chibi/loop.module @@ -0,0 +1,9 @@ + +(define-module (chibi loop) + (export loop in-list in-lists in-port in-file up-from down-from + listing listing-reverse appending appending-reverse + summing multiplying in-string in-string-reverse + in-vector in-vector-reverse) + (import-immutable (scheme)) + (include "loop/loop.scm")) + diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm new file mode 100644 index 00000000..09e12856 --- /dev/null +++ b/lib/chibi/loop/loop.scm @@ -0,0 +1,365 @@ +;;;; loop.scm - the chibi loop (aka foof-loop) +;; +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; The loop API is compatible with Taylor Campbell's foof-loop, but +;; the iterator API is different and subject to change. All loop +;; variables may be implicitly destructured with MATCH semantics. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (assoc-pred equal elt ls) + (and (pair? ls) + (if (equal elt (car (car ls))) + (car ls) + (assoc-pred equal elt (cdr ls))))) + +(define-syntax let-keyword-form + (syntax-rules () + ((let-keyword-form + ((labeled-arg-macro-name (positional-name . params))) + . body) + (let-syntax + ((labeled-arg-macro-name + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (named '()) (posns '())) + (cond + ((pair? ls) + (if (and (list? (car ls)) (compare (caar ls) (rename '=>))) + (lp (cdr ls) (cons (cdar ls) named) posns) + (lp (cdr ls) named (cons (car ls) posns)))) + (else + (let lp ((ls (syntax-quote params)) + (posns (reverse posns)) + (args '())) + (cond + ((null? ls) + (if (pair? posns) + (error "let-keyword-form: too many args" expr) + (cons (syntax-quote positional-name) (reverse args)))) + ((assoc-pred compare (caar ls) named) + => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args)))) + ((pair? posns) + (lp (cdr ls) (cdr posns) (cons (car posns) args))) + (else + (lp (cdr ls) posns (cons (cadar ls) args)))))))))))) + . body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax loop + (syntax-rules () + ;; unnamed, implicit recursion + ((loop (vars ...) body ...) + (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop))) + ;; named, explicit recursion + ((loop name (vars ...) body ...) + (%loop name () () () () () (vars ...) body ...)))) + +;; Main LOOP macro. Separate the variables from the iterator and +;; parameters, then walk through each parameter expanding the +;; bindings, and build the final form. + +(define-syntax %loop + (syntax-rules (=> for with let while until) + ;; automatic iteration + ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body) + (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ;; do equivalents, with optional guards + ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body) + (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init step) rest ...) . body) + (%loop name l (vars ... (var init step)) c r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init) rest ...) . body) + (%loop name l (vars ... (var init var)) c r f (rest ...) . body)) + ;; user-specified terminators + ((_ name l vars (checks ...) r f ((until expr) rest ...) . body) + (%loop name l vars (checks ... expr) r f (rest ...) . body)) + ((_ name l vars (checks ...) r f ((while expr) rest ...) . body) + (%loop name l vars (checks ... (not expr)) r f (rest ...) . body)) + ;; specify a default done? + ((_ name l v c r f ()) + (%loop name l v c r f () (#f #f))) + ((_ name l v c r f () () . body) + (%loop name l v c r f () (#f #f) . body)) + ;; final expansion + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => result + . body) + (let* (lets ...) + (letrec ((tmp (lambda (var ...) + (if (or checks ...) + (let-keyword-form ((name (tmp (var step) ...))) + (let (finals ...) result)) + (let (refs ...) + (let-keyword-form ((name (tmp (var step) ...))) + (if #f #f) + . body)))))) + (tmp init ...)))) + ;; unspecified return value case + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + . body) + (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => (if #f #f) . body)) + )) + +(define-syntax %loop-next + (syntax-rules () + ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...) + name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...) + . rest) + (%loop name (lets ... new-lets ...) (vars ... new-vars ...) + (checks ... new-checks ...) (refs ... new-refs ...) + (finals ... new-finals ...) + . rest)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Iterators + +;; Each gets passed two lists, those items left of the <- and those to +;; the right, followed by a NEXT and REST continuation. + +;; Should finish with +;; +;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...) +;; (loop-vars ...) (final-vars ...) . rest) +;; +;; OUTER-VARS: bound once outside the loop in a LET* +;; CURSOR-VARS: DO-style bindings of the form (name init update) +;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t +;; LOOP-VARS: inner variables, updated in parallel after the cursors +;; FINAL-VARS: final variables, bound only in the => result + +(define-syntax in-list ; called just "IN" in ITER + (syntax-rules () + ((in-list ((var) source) next . rest) + (in-list ((var cursor) source) next . rest)) + ((in-list ((var cursor) source) next . rest) + (in-list ((var cursor succ) source) next . rest)) + ((in-list ((var cursor succ) (source)) next . rest) + (next () ; outer let bindings + ((cursor source succ)) ; iterator, init, step + ((not (pair? cursor))) ; finish tests for iterator vars + ;; step variables and values + ((var (car cursor)) + (succ (cdr cursor))) + () ; final result bindings + . rest)) + ((in-list ((var cursor succ) (source step)) next . rest) + (next () + ((cursor source succ)) + ((not (pair? cursor))) + ((var (car cursor)) + (succ (step cursor))) + () + . rest)))) + +;; Iterator from Taylor R. Campbell. If you know the number of lists +;; ahead of time it's much more efficient to iterate over each one +;; separately. +(define-syntax in-lists + (syntax-rules () + ((in-lists ((elts) lol) next . rest) + (in-lists ((elts pairs) lol) next . rest)) + ((in-lists ((elts pairs) lol) next . rest) + (in-lists ((elts pairs succ) lol) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol step)) next . rest) + (in-lists ((elts pairs succ) (lol step null?)) next . rest)) + ((in-lists ((elts pairs succ) (lol step done?)) next . rest) + (next () + ((pairs lol succ)) + ((let lp ((ls pairs)) ; an in-lined ANY + (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls)))))) + ((elts (map car pairs)) + (succ (map step pairs))) + () + . rest)) + )) + +(define-syntax define-in-indexed + (syntax-rules () + ((define-in-indexed in-type in-type-reverse length ref) + (begin + (define-syntax in-type + (syntax-rules () + ((in-type ls next . rest) + (%in-idx >= + 0 (length tmp) ref tmp ls next . rest)))) + (define-syntax in-type-reverse + (syntax-rules () + ((in-type-reverse ls next . rest) + (%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest)))) + )))) + +(define-in-indexed in-string in-string-reverse string-length string-ref) +(define-in-indexed in-vector in-vector-reverse vector-length vector-ref) + +;; helper for the above string and vector iterators +(define-syntax %in-idx + (syntax-rules () + ;; cmp inc start end ref + ((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest) + (%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest) + (next ((tmp-vec vec) (end to)) + ((index from (+ index step))) + ((ge index end)) + ((var (r tmp-vec index))) + () + . rest)) + )) + +(define-syntax in-port + (syntax-rules () + ((in-port ((var) source) next . rest) + (in-port ((var p) source) next . rest)) + ((in-port ((var p) ()) next . rest) + (in-port ((var p) ((current-input-port))) next . rest)) + ((in-port ((var p) (port)) next . rest) + (in-port ((var p) (port read-char)) next . rest)) + ((in-port ((var p) (port read-char)) next . rest) + (in-port ((var p) (port read-char eof-object?)) next . rest)) + ((in-port ((var p) (port reader eof?)) next . rest) + (next ((p port) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + () + . rest)))) + +(define-syntax in-file + (syntax-rules () + ((in-file ((var) source) next . rest) + (in-file ((var p) source) next . rest)) + ((in-file ((var p) (file)) next . rest) + (in-file ((var p) (file read-char)) next . rest)) + ((in-file ((var p) (file reader)) next . rest) + (in-file ((var p) (file reader eof-object?)) next . rest)) + ((in-file ((var p) (file reader eof?)) next . rest) + (next ((p (open-input-file file)) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + ((dummy (close-input-port p))) + . rest)))) + +(define-syntax up-from + (syntax-rules (to by) + ((up-from (() . args) next . rest) + (up-from ((var) . args) next . rest)) + ((up-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var s (+ var e))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var s (+ var 1))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var s (+ var e))) () () () . rest)) + ((up-from ((var) (start)) next . rest) + (next ((s start)) ((var s (+ var 1))) () () () . rest)) + )) + +(define-syntax down-from + (syntax-rules (to by) + ((down-from (() . args) next . rest) + (down-from ((var) . args) next . rest)) + ((down-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var (- s e) (- var e))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var (- s 1) (- var 1))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var (- s e) (- var e))) () () () + . rest)) + ((down-from ((var) (start)) next . rest) + (next ((s start)) ((var (- s 1) (- var 1))) () () () + . rest)) + )) + +(define-syntax accumulating + (syntax-rules (initial if) + ((accumulating (kons final init) ((var) . x) next . rest) + (accumulating (kons final init) ((var cursor) . x) next . rest)) + ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest) + (accumulating (kons final i) ((var cursor) x) n . rest)) + ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (if check (tmp-kons expr cursor) cursor))) + () + () + ((var (final cursor))) + . rest)) + ((accumulating (kons final init) ((var cursor) (expr)) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (tmp-kons expr cursor))) + () + () + ((var (final cursor))) + . rest)))) + +(define-syntax listing + (syntax-rules () + ((listing args next . rest) + (accumulating (cons reverse '()) args next . rest)))) + +(define-syntax listing-reverse + (syntax-rules () + ((listing-reverse args next . rest) + (accumulating (cons (lambda (x) x) '()) args next . rest)))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define-syntax appending + (syntax-rules () + ((appending args next . rest) + (accumulating (append-reverse reverse '()) args next . rest)))) + +(define-syntax appending-reverse + (syntax-rules () + ((appending-reverse args next . rest) + (accumulating (append-reverse (lambda (x) x) '()) args next . rest)))) + +(define-syntax summing + (syntax-rules () + ((summing args next . rest) + (accumulating (+ (lambda (x) x) 0) args next . rest)))) + +(define-syntax multiplying + (syntax-rules () + ((multiplying args next . rest) + (accumulating (* (lambda (x) x) 1) args next . rest)))) diff --git a/lib/chibi/macroexpand.module b/lib/chibi/macroexpand.module new file mode 100644 index 00000000..47b0e7d4 --- /dev/null +++ b/lib/chibi/macroexpand.module @@ -0,0 +1,6 @@ + +(define-module (chibi macroexpand) + (import-immutable (scheme)) + (import (chibi ast)) + (export macroexpand) + (include "macroexpand.scm")) diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm new file mode 100644 index 00000000..a040855a --- /dev/null +++ b/lib/chibi/macroexpand.scm @@ -0,0 +1,85 @@ +;; macroexpand.scm -- macro expansion utility +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; This actually analyzes the expression then reverse-engineers an +;; sexp from the result, generating a minimal amount of renames. + +(define (macroexpand x) + (ast->sexp (analyze x))) + +(define (ast-renames ast) + (define i 0) + (define renames '()) + (define (rename-symbol id) + (set! i (+ i 1)) + (string->symbol + (string-append (symbol->string (identifier->symbol id)) + "." (number->string i)))) + (define (rename-lambda lam) + (or (assq lam renames) + (let ((res (list lam))) + (set! renames (cons res renames)) + res))) + (define (rename! id lam) + (let ((cell (rename-lambda lam))) + (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell))))) + (define (check-ref id lam env) + (let ((sym (identifier->symbol id))) + (let lp1 ((ls env)) + (cond + ((pair? ls) + (let lp2 ((ls2 (car ls)) (found? #f)) + (cond + ((null? ls2) + (if (not found?) (lp1 (cdr ls)))) + ((and (eq? id (caar ls2)) (eq? lam (cdar ls2))) + (lp2 (cdr ls2) #t)) + ((eq? sym (identifier->symbol (caar ls2))) + (rename! (caar ls2) (cdar ls2)) + (lp2 (cdr ls2) found?)) + (else + (lp2 (cdr ls2) found?))))))))) + (define (flatten-dot x) + (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) + ((null? x) x) + (else (list x)))) + (define (extend-env lam env) + (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env)) + (let lp ((x ast) (env '())) + (cond + ((lambda? x) (lp (lambda-body x) (extend-env x env))) + ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env)) + ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env)) + ((set? x) (lp (set-var x) env) (lp (set-value x) env)) + ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x))) + ((pair? x) (for-each (lambda (x) (lp x env)) x)))) + renames) + +(define (get-rename id lam renames) + (let ((ls (assq lam renames))) + (if (not ls) + (identifier->symbol id) + (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id)))))) + +(define (ast->sexp ast) + (let ((renames (ast-renames ast))) + (let a2s ((x ast)) + (cond + ((lambda? x) + `(lambda ,(map (lambda (id) (get-rename id x renames)) (lambda-params x)) + ,@(map (lambda (d) `(define ,(identifier->symbol (cadr d)) #f)) (lambda-defs x)) + ,@(if (seq? (lambda-body x)) + (map a2s (seq-ls (lambda-body x))) + (list (a2s (lambda-body x)))))) + ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) + ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) + ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) + ((seq? x) `(begin ,@(map a2s (seq-ls x)))) + ((lit? x) + (let ((v (lit-value x))) + (if (or (pair? v) (null? v) (symbol? v)) `',v v))) + ((pair? x) (cons (a2s (car x)) (a2s (cdr x)))) + ((opcode? x) (or (opcode-name x) x)) + (else x))))) + diff --git a/lib/chibi/match.module b/lib/chibi/match.module new file mode 100644 index 00000000..1366176a --- /dev/null +++ b/lib/chibi/match.module @@ -0,0 +1,6 @@ + +(define-module (chibi match) + (export match match-lambda match-lambda* match-let match-letrec match-let*) + (import-immutable (scheme)) + (include "match/match.scm")) + diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm new file mode 100644 index 00000000..963b89ff --- /dev/null +++ b/lib/chibi/match/match.scm @@ -0,0 +1,670 @@ +;;;; match.scm -- portable hygienic pattern matcher +;; +;; This code is written by Alex Shinn and placed in the +;; Public Domain. All warranties are disclaimed. + +;; This is a full superset of the popular MATCH package by Andrew +;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks +;; in R6RS SYNTAX-RULES), and thus preserving hygiene. + +;; This is a simple generative pattern matcher - each pattern is +;; expanded into the required tests, calling a failure continuation if +;; the tests fail. This makes the logic easy to follow and extend, +;; but produces sub-optimal code in cases where you have many similar +;; clauses due to repeating the same tests. Nonetheless a smart +;; compiler should be able to remove the redundant tests. For +;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance +;; hit. + +;; The original version was written on 2006/11/29 and described in the +;; following Usenet post: +;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd +;; and is still available at +;; http://synthcode.com/scheme/match-simple.scm +;; It's just 80 lines for the core MATCH, and an extra 40 lines for +;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar. +;; +;; A variant of this file which uses COND-EXPAND in a few places for +;; performance can be found at +;; http://synthcode.com/scheme/match-cond-expand.scm +;; +;; 2009/11/25 - adding `***' tree search patterns +;; 2008/03/20 - fixing bug where (a ...) matched non-lists +;; 2008/03/15 - removing redundant check in vector patterns +;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) +;; 2007/09/04 - fixing quasiquote patterns +;; 2007/07/21 - allowing ellipse patterns in non-final list positions +;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse +;; (thanks to Taylor Campbell) +;; 2007/04/08 - clean up, commenting +;; 2006/12/24 - bugfixes +;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; force compile-time syntax errors with useful messages + +(define-syntax match-syntax-error + (syntax-rules () + ((_) (match-syntax-error "invalid match-syntax-error usage")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The basic interface. MATCH just performs some basic syntax +;; validation, binds the match expression to a temporary variable `v', +;; and passes it on to MATCH-NEXT. It's a constant throughout the +;; code below that the binding `v' is a direct variable reference, not +;; an expression. + +(define-syntax match + (syntax-rules () + ((match) + (match-syntax-error "missing match expression")) + ((match atom) + (match-syntax-error "no match clauses")) + ((match (app ...) (pat . body) ...) + (let ((v (app ...))) + (match-next v ((app ...) (set! (app ...))) (pat . body) ...))) + ((match #(vec ...) (pat . body) ...) + (let ((v #(vec ...))) + (match-next v (v (set! v)) (pat . body) ...))) + ((match atom (pat . body) ...) + (match-next atom (atom (set! atom)) (pat . body) ...)) + )) + +;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure +;; thunk, which is expanded by recursing MATCH-NEXT on the remaining +;; clauses. `g+s' is a list of two elements, the get! and set! +;; expressions respectively. + +(define-syntax match-next + (syntax-rules (=>) + ;; no more clauses, the match failed + ((match-next v g+s) + (error 'match "no matching pattern")) + ;; named failure continuation + ((match-next v g+s (pat (=> failure) . body) . rest) + (let ((failure (lambda () (match-next v g+s . rest)))) + ;; match-one analyzes the pattern for us + (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ()))) + ;; anonymous failure continuation, give it a dummy name + ((match-next v g+s (pat . body) . rest) + (match-next v g+s (pat (=> failure) . body) . rest)))) + +;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to +;; MATCH-TWO. + +(define-syntax match-one + (syntax-rules () + ;; If it's a list of two or more values, check to see if the + ;; second one is an ellipse and handle accordingly, otherwise go + ;; to MATCH-TWO. + ((match-one v (p q . r) g+s sk fk i) + (match-check-ellipse + q + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()) + (match-two v (p q . r) g+s sk fk i))) + ;; Go directly to MATCH-TWO. + ((match-one . x) + (match-two . x)))) + +;; This is the guts of the pattern matcher. We are passed a lot of +;; information in the form: +;; +;; (match-two var pattern getter setter success-k fail-k (ids ...)) +;; +;; usually abbreviated +;; +;; (match-two v p g+s sk fk i) +;; +;; where VAR is the symbol name of the current variable we are +;; matching, PATTERN is the current pattern, getter and setter are the +;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding +;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure +;; continuation (which is just a thunk call and is thus safe to expand +;; multiple times) and IDS are the list of identifiers bound in the +;; pattern so far. + +(define-syntax match-two + (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!) + ((match-two v () g+s (sk ...) fk i) + (if (null? v) (sk ... i) fk)) + ((match-two v (quote p) g+s (sk ...) fk i) + (if (equal? v 'p) (sk ... i) fk)) + ((match-two v (quasiquote p) . x) + (match-quasiquote v p . x)) + ((match-two v (and) g+s (sk ...) fk i) (sk ... i)) + ((match-two v (and p q ...) g+s sk fk i) + (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i)) + ((match-two v (or) g+s sk fk i) fk) + ((match-two v (or p) . x) + (match-one v p . x)) + ((match-two v (or p ...) g+s sk fk i) + (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ())) + ((match-two v (not p) g+s (sk ...) fk i) + (match-one v p g+s (match-drop-ids fk) (sk ... i) i)) + ((match-two v (get! getter) (g s) (sk ...) fk i) + (let ((getter (lambda () g))) (sk ... i))) + ((match-two v (set! setter) (g (s ...)) (sk ...) fk i) + (let ((setter (lambda (x) (s ... x)))) (sk ... i))) + ((match-two v (? pred . p) g+s sk fk i) + (if (pred v) (match-one v (and . p) g+s sk fk i) fk)) + ((match-two v (= proc p) . x) + (let ((w (proc v))) (match-one w p . x))) + ((match-two v (p ___ . r) g+s sk fk i) + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())) + ((match-two v (p) g+s sk fk i) + (if (and (pair? v) (null? (cdr v))) + (let ((w (car v))) + (match-one w p ((car v) (set-car! v)) sk fk i)) + fk)) + ((match-two v (p *** q) g+s sk fk i) + (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) + ((match-two v (p *** . q) g+s sk fk i) + (match-syntax-error "invalid use of ***" (p *** . q))) + ((match-two v (p . q) g+s sk fk i) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-one w p ((car v) (set-car! v)) + (match-one x q ((cdr v) (set-cdr! v)) sk fk) + fk + i)) + fk)) + ((match-two v #(p ...) g+s . x) + (match-vector v 0 () (p ...) . x)) + ((match-two v _ g+s (sk ...) fk i) (sk ... i)) + ;; Not a pair or vector or special literal, test to see if it's a + ;; new symbol, in which case we just bind it, or if it's an + ;; already bound symbol or some other literal, in which case we + ;; compare it with EQUAL?. + ((match-two v x g+s (sk ...) fk (id ...)) + (let-syntax + ((new-sym? + (syntax-rules (id ...) + ((new-sym? x sk2 fk2) sk2) + ((new-sym? y sk2 fk2) fk2)))) + (new-sym? random-sym-to-match + (let ((x v)) (sk ... (id ... x))) + (if (equal? v x) (sk ... (id ...)) fk)))) + )) + +;; QUASIQUOTE patterns + +(define-syntax match-quasiquote + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ v (unquote p) g+s sk fk i) + (match-one v p g+s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g+s sk fk i) + (if (pair? v) + (match-one v + (p . tmp) + (match-quasiquote tmp rest g+s sk fk) + fk + i) + fk)) + ((_ v (quasiquote p) g+s sk fk i . depth) + (match-quasiquote v p g+s sk fk i #f . depth)) + ((_ v (unquote p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (unquote-splicing p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (p . q) g+s sk fk i . depth) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-quasiquote + w p g+s + (match-quasiquote-step x q g+s sk fk depth) + fk i . depth)) + fk)) + ((_ v #(elt ...) g+s sk fk i . depth) + (if (vector? v) + (let ((ls (vector->list v))) + (match-quasiquote ls (elt ...) g+s sk fk i . depth)) + fk)) + ((_ v x g+s sk fk i . depth) + (match-one v 'x g+s sk fk i)))) + +(define-syntax match-quasiquote-step + (syntax-rules () + ((match-quasiquote-step x q g+s sk fk depth i) + (match-quasiquote x q g+s sk fk i . depth)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities + +;; Takes two values and just expands into the first. +(define-syntax match-drop-ids + (syntax-rules () + ((_ expr ids ...) expr))) + +(define-syntax match-drop-first-arg + (syntax-rules () + ((_ arg expr) expr))) + +;; To expand an OR group we try each clause in succession, passing the +;; first that succeeds to the success continuation. On failure for +;; any clause, we just try the next clause, finally resorting to the +;; failure continuation fk if all clauses fail. The only trick is +;; that we want to unify the identifiers, so that the success +;; continuation can refer to a variable from any of the OR clauses. + +(define-syntax match-gen-or + (syntax-rules () + ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...)) + (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) + (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...)))))) + +(define-syntax match-gen-or-step + (syntax-rules () + ((_ v () g+s sk fk . x) + ;; no OR clauses, call the failure continuation + fk) + ((_ v (p) . x) + ;; last (or only) OR clause, just expand normally + (match-one v p . x)) + ((_ v (p . q) g+s sk fk i) + ;; match one and try the remaining on failure + (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) + )) + +;; We match a pattern (p ...) by matching the pattern p in a loop on +;; each element of the variable, accumulating the bound ids into lists. + +;; Look at the body of the simple case - it's just a named let loop, +;; matching each element in turn to the same pattern. The only trick +;; is that we want to keep track of the lists of each extracted id, so +;; when the loop recurses we cons the ids onto their respective list +;; variables, and on success we bind the ids (what the user input and +;; expects to see in the success body) to the reversed accumulated +;; list IDs. + +(define-syntax match-gen-ellipses + (syntax-rules () + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to (p ...), just bind the list + (let ((p v)) + (if (list? p) + (sk ... i) + fk)) + ;; simple case, match all elements of the list + (let loop ((ls v) (id-ls '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) + fk i))) + (else + fk))))) + ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking + (match-verify-no-ellipses + r + (let* ((tail-len (length 'r)) + (ls v) + (len (length ls))) + (if (< len tail-len) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond + ((= n tail-len) + (let ((id (reverse id-ls)) ...) + (match-one ls r (#f #f) (sk ... i) fk i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids + (loop (cdr ls) (- n 1) (cons id id-ls) ...)) + fk + i))) + (else + fk))))))))) + +;; This is just a safety check. Although unlike syntax-rules we allow +;; trailing patterns after an ellipses, we explicitly disable multiple +;; ellipses at the same level. This is because in the general case +;; such patterns are exponential in the number of ellipses, and we +;; don't want to make it easy to construct very expensive operations +;; with simple looking patterns. For example, it would be O(n^2) for +;; patterns like (a ... b ...) because we must consider every trailing +;; element for every possible break for the leading "a ...". + +(define-syntax match-verify-no-ellipses + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipse + x + (match-syntax-error + "multiple ellipse patterns not allowed at same level") + (match-verify-no-ellipses y sk))) + ((_ () sk) + sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipse" x)))) + +;; Matching a tree search pattern is only slightly more complicated. +;; Here we allow patterns of the form +;; +;; (x *** y) +;; +;; to represent the pattern y located somewhere in a tree where the +;; path from the current object to y can be seen as a list of the form +;; (X ...). Y can immediately match the current object in which case +;; the path is the empty list. In a sense it's a 2-dimensional +;; version of the ... pattern. +;; +;; As a common case the pattern (_ *** y) can be used to search for Y +;; anywhere in a tree, regardless of the path used. +;; +;; To implement the search, we use two recursive procedures. TRY +;; attempts to match Y once, and on success it calls the normal SK on +;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we +;; call NEXT which first checks if the current value is a list +;; beginning with X, then calls TRY on each remaining element of the +;; list. Since TRY will recursively call NEXT again on failure, this +;; effects a full depth-first search. +;; +;; The failure continuation throughout is a jump to the next step in +;; the tree search, initialized with the original failure continuation +;; FK. + +(define-syntax match-gen-search + (syntax-rules () + ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) + (letrec ((try (lambda (w fail id-ls ...) + (match-one w q g+s + (match-drop-ids + (let ((id (reverse id-ls)) ...) + sk)) + (next w fail id-ls ...) i))) + (next (lambda (w fail id-ls ...) + (if (not (pair? w)) + (fail) + (let ((u (car w))) + (match-one + u p ((car w) (set-car! w)) + (match-drop-ids + ;; accumulate the head variables from + ;; the p pattern, and loop over the tail + (let ((id-ls (cons id id-ls)) ...) + (let lp ((ls (cdr w))) + (if (pair? ls) + (try (car ls) + (lambda () (lp (cdr ls))) + id-ls ...) + (fail))))) + (fail) i)))))) + ;; the initial id-ls binding here is a dummy to get the right + ;; number of '()s + (let ((id-ls '()) ...) + (try v (lambda () fk) id-ls ...)))))) + +;; Vector patterns are just more of the same, with the slight +;; exception that we pass around the current vector index being +;; matched. + +(define-syntax match-vector + (syntax-rules (___) + ((_ v n pats (p q) . x) + (match-check-ellipse q + (match-gen-vector-ellipses v n pats p . x) + (match-vector-two v n pats (p q) . x))) + ((_ v n pats (p ___) sk fk i) + (match-gen-vector-ellipses v n pats p sk fk i)) + ((_ . x) + (match-vector-two . x)))) + +;; Check the exact vector length, then check each element in turn. + +(define-syntax match-vector-two + (syntax-rules () + ((_ v n ((pat index) ...) () sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (= len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) . x) + (match-vector v (+ n 1) (pats ... (p n)) q . x)))) + +(define-syntax match-vector-step + (syntax-rules () + ((_ v () (sk ...) fk i) (sk ... i)) + ((_ v ((pat index) . rest) sk fk i) + (let ((w (vector-ref v index))) + (match-one w pat ((vector-ref v index) (vector-set! v index)) + (match-vector-step v rest sk fk) + fk i))))) + +;; With a vector ellipse pattern we first check to see if the vector +;; length is at least the required length. + +(define-syntax match-gen-vector-ellipses + (syntax-rules () + ((_ v n ((pat index) ...) p sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (>= len n) + (match-vector-step v ((pat index) ...) + (match-vector-tail v p n len sk fk) + fk i) + fk)) + fk)))) + +(define-syntax match-vector-tail + (syntax-rules () + ((_ v p n len sk fk i) + (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())))) + +(define-syntax match-vector-tail-two + (syntax-rules () + ((_ v p n len (sk ...) fk i ((id id-ls) ...)) + (let loop ((j n) (id-ls '()) ...) + (if (>= j len) + (let ((id (reverse id-ls)) ...) (sk ... i)) + (let ((w (vector-ref v j))) + (match-one w p ((vector-ref v j) (vetor-set! v j)) + (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) + fk i))))))) + +;; Extract all identifiers in a pattern. A little more complicated +;; than just looking for symbols, we need to ignore special keywords +;; and non-pattern forms (such as the predicate expression in ? +;; patterns), and also ignore previously bound identifiers. +;; +;; Calls the continuation with all new vars as a list of the form +;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely +;; pair with the original variable (e.g. it's used in the ellipse +;; generation for list variables). +;; +;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) + +(define-syntax match-extract-vars + (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!) + ((match-extract-vars (? pred . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars ($ rec . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (= proc p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (quote x) (k ...) i v) + (k ... v)) + ((match-extract-vars (quasiquote x) k i v) + (match-extract-quasiquote-vars x k i v (#t))) + ((match-extract-vars (and . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (or . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (not . p) . x) + (match-extract-vars p . x)) + ;; A non-keyword pair, expand the CAR with a continuation to + ;; expand the CDR. + ((match-extract-vars (p q . r) k i v) + (match-check-ellipse + q + (match-extract-vars (p . r) k i v) + (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) + ((match-extract-vars (p . q) k i v) + (match-extract-vars p (match-extract-vars-step q k i v) i ())) + ((match-extract-vars #(p ...) . x) + (match-extract-vars (p ...) . x)) + ((match-extract-vars _ (k ...) i v) (k ... v)) + ((match-extract-vars ___ (k ...) i v) (k ... v)) + ((match-extract-vars *** (k ...) i v) (k ... v)) + ;; This is the main part, the only place where we might add a new + ;; var if it's an unbound symbol. + ((match-extract-vars p (k ...) (i ...) v) + (let-syntax + ((new-sym? + (syntax-rules (i ...) + ((new-sym? p sk fk) sk) + ((new-sym? x sk fk) fk)))) + (new-sym? random-sym-to-match + (k ... ((p p-ls) . v)) + (k ... v)))) + )) + +;; Stepper used in the above so it can expand the CAR and CDR +;; separately. + +(define-syntax match-extract-vars-step + (syntax-rules () + ((_ p k i v ((v2 v2-ls) ...)) + (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) + )) + +(define-syntax match-extract-quasiquote-vars + (syntax-rules (quasiquote unquote unquote-splicing) + ((match-extract-quasiquote-vars (quasiquote x) k i v d) + (match-extract-quasiquote-vars x k i v (#t . d))) + ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) + (match-extract-quasiquote-vars (unquote x) k i v d)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t)) + (match-extract-vars x k i v)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) + (match-extract-quasiquote-vars x k i v d)) + ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) + (match-extract-quasiquote-vars + x + (match-extract-quasiquote-vars-step y k i v d) i ())) + ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) + (match-extract-quasiquote-vars (x ...) k i v d)) + ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) + (k ... v)) + )) + +(define-syntax match-extract-quasiquote-vars-step + (syntax-rules () + ((_ x k i v d ((v2 v2-ls) ...)) + (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d)) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gimme some sugar baby. + +(define-syntax match-lambda + (syntax-rules () + ((_ clause ...) (lambda (expr) (match expr clause ...))))) + +(define-syntax match-lambda* + (syntax-rules () + ((_ clause ...) (lambda expr (match expr clause ...))))) + +(define-syntax match-let + (syntax-rules () + ((_ (vars ...) . body) + (match-let/helper let () () (vars ...) . body)) + ((_ loop . rest) + (match-named-let loop () . rest)))) + +(define-syntax match-letrec + (syntax-rules () + ((_ vars . body) (match-let/helper letrec () () vars . body)))) + +(define-syntax match-let/helper + (syntax-rules () + ((_ let ((var expr) ...) () () . body) + (let ((var expr) ...) . body)) + ((_ let ((var expr) ...) ((pat tmp) ...) () . body) + (let ((var expr) ...) + (match-let* ((pat tmp) ...) + . body))) + ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((a expr) . rest) . body) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)))) + +(define-syntax match-named-let + (syntax-rules () + ((_ loop ((pat expr var) ...) () . body) + (let loop ((var expr) ...) + (match-let ((pat var) ...) + . body))) + ((_ loop (v ...) ((pat expr) . rest) . body) + (match-named-let loop (v ... (pat expr tmp)) rest . body)))) + +(define-syntax match-let* + (syntax-rules () + ((_ () . body) + (begin . body)) + ((_ ((pat expr) . rest) . body) + (match expr (pat (match-let* rest . body)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Otherwise COND-EXPANDed bits. + +;; This *should* work, but doesn't :( +;; (define-syntax match-check-ellipse +;; (syntax-rules (...) +;; ((_ ... sk fk) sk) +;; ((_ x sk fk) fk))) + +;; This is a little more complicated, and introduces a new let-syntax, +;; but should work portably in any R[56]RS Scheme. Taylor Campbell +;; originally came up with the idea. +(define-syntax match-check-ellipse + (syntax-rules () + ;; these two aren't necessary but provide fast-case failures + ((match-check-ellipse (a . b) success-k failure-k) failure-k) + ((match-check-ellipse #(a ...) success-k failure-k) failure-k) + ;; matching an atom + ((match-check-ellipse id success-k failure-k) + (let-syntax ((ellipse? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipse? (foo id) sk fk) sk) + ((ellipse? other sk fk) fk)))) + ;; this list of three elements will only many the (foo id) list + ;; above if `id' is `...' + (ellipse? (a b c) success-k failure-k))))) + + +;; This is portable but can be more efficient with non-portable +;; extensions. This trick was originally discovered by Oleg Kiselyov. + +(define-syntax match-check-identifier + (syntax-rules () + ;; fast-case failures, lists and vectors are not identifiers + ((_ (x . y) success-k failure-k) failure-k) + ((_ #(x ...) success-k failure-k) failure-k) + ;; x is an atom + ((_ x success-k failure-k) + (let-syntax + ((sym? + (syntax-rules () + ;; if the symbol `abracadabra' matches x, then x is a + ;; symbol + ((sym? x sk fk) sk) + ;; otherwise x is a non-symbol datum + ((sym? y sk fk) fk)))) + (sym? abracadabra success-k failure-k))))) diff --git a/lib/chibi/net.module b/lib/chibi/net.module new file mode 100644 index 00000000..41cdafe4 --- /dev/null +++ b/lib/chibi/net.module @@ -0,0 +1,10 @@ + +(define-module (chibi net) + (export sockaddr? address-info? get-address-info socket connect with-net-io + address-info-family address-info-socket-type address-info-protocol + address-info-address address-info-address-length address-info-next) + (import-immutable (scheme)) + (import (chibi filesystem)) + (include-shared "net") + (include "net.scm")) + diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm new file mode 100644 index 00000000..85ed756a --- /dev/null +++ b/lib/chibi/net.scm @@ -0,0 +1,23 @@ +;; net.scm -- the high-level network interface +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (with-net-io host service proc) + (let lp ((addr (get-address-info host service #f))) + (if (not addr) + (error "couldn't find address" host service) + (let ((sock (socket (address-info-family addr) + (address-info-socket-type addr) + (address-info-protocol addr)))) + (if (negative? sock) + (lp (address-info-next addr)) + (if (negative? + (connect sock + (address-info-address addr) + (address-info-address-length addr))) + (lp (address-info-next addr)) + (let ((in (open-input-file-descriptor sock)) + (out (open-output-file-descriptor sock))) + (let ((res (proc in out))) + (close-input-port in) + res)))))))) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub new file mode 100644 index 00000000..0d72bc90 --- /dev/null +++ b/lib/chibi/net.stub @@ -0,0 +1,25 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/socket.h") +(c-system-include "netdb.h") + +(define-c-struct sockaddr + predicate: sockaddr?) + +(define-c-struct addrinfo + finalizer: freeaddrinfo + predicate: address-info? + (int ai_family address-info-family) + (int ai_socktype address-info-socket-type) + (int ai_protocol address-info-protocol) + ((link sockaddr) ai_addr address-info-address) + (size_t ai_addrlen address-info-address-length) + ((link addrinfo) ai_next address-info-next)) + +(define-c errno (get-address-info getaddrinfo) + (string string (maybe-null addrinfo) (result free addrinfo))) + +(define-c int bind (int sockaddr int)) +(define-c int listen (int int)) +(define-c int socket (int int int)) +(define-c int connect (int sockaddr int)) diff --git a/lib/chibi/pathname.module b/lib/chibi/pathname.module new file mode 100644 index 00000000..765ee189 --- /dev/null +++ b/lib/chibi/pathname.module @@ -0,0 +1,7 @@ + +(define-module (chibi pathname) + (export path-strip-directory path-directory path-extension-pos + path-extension path-strip-extension path-replace-extension + path-absolute? path-relative? path-normalize make-path) + (import-immutable (scheme)) + (include "pathname.scm")) diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm new file mode 100644 index 00000000..de27ad61 --- /dev/null +++ b/lib/chibi/pathname.scm @@ -0,0 +1,180 @@ +;; pathname.scm -- a general, non-host-specific path lib +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-scan-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (- i 1)))))) + +(define (string-skip c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (+ i 1))))))) + +(define (string-skip-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (- i 1)))))) + +;; POSIX basename +;; (define (path-strip-directory path) +;; (if (string=? path "") +;; path +;; (let ((end (string-skip-right #\/ path))) +;; (if (not end) +;; "/" +;; (let ((start (string-scan-right #\/ path (- end 1)))) +;; (substring path (if start (+ start 1) 0) (+ end 1))))))) + +;; GNU basename +(define (path-strip-directory path) + (if (string=? path "") + path + (let ((len (string-length path))) + (if (eqv? #\/ (string-ref path (- len 1))) + "" + (let ((slash (string-scan-right #\/ path))) + (if (not slash) + path + (substring path (+ slash 1) len))))))) + +(define (path-directory path) + (if (string=? path "") + "." + (let ((end (string-skip-right #\/ path))) + (if (not end) + "/" + (let ((start (string-scan-right #\/ path (- end 1)))) + (if (not start) + "." + (let ((start (string-skip-right #\/ path start))) + (if (not start) "/" (substring path 0 (+ start 1)))))))))) + +(define (path-extension-pos path) (string-scan-right #\. path)) + +(define (path-extension path) + (let ((i (path-extension-pos path))) + (and i + (let ((start (+ i 1)) (end (string-length path))) + (and (< start end) (substring path start end)))))) + +(define (path-strip-extension path) + (let ((i (path-extension-pos path))) + (if (and i (< (+ i 1) (string-length path))) + (substring path 0 i) + path))) + +(define (path-replace-extension path ext) + (string-append (path-strip-extension path) "." ext)) + +(define (path-absolute? path) + (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0)))) + +(define (path-relative? path) (not (path-absolute? path))) + +;; This looks big and hairy, but it's mutation-free and guarantees: +;; (string=? s (path-normalize s)) <=> (eq? s (path-normalize s)) +;; i.e. fast and simple for already normalized paths. + +(define (path-normalize path) + (let* ((len (string-length path)) (len-1 (- len 1))) + (define (collect i j res) + (if (>= i j) res (cons (substring path i j) res))) + (define (finish i res) + (if (zero? i) + path + (apply string-append (reverse (collect i len res))))) + ;; loop invariants: + ;; - res is a list such that (string-concatenate-reverse res) + ;; is always the normalized string up to j + ;; - the tail of the string from j onward can be concatenated to + ;; the above value to get a partially normalized path referring + ;; to the same location as the original path + (define (inside i j res) + (if (>= j len) + (finish i res) + (if (eqv? #\/ (string-ref path j)) + (boundary i (+ j 1) res) + (inside i (+ j 1) res)))) + (define (boundary i j res) + (if (>= j len-1) + (finish i res) + (case (string-ref path j) + ((#\.) + (case (string-ref path (+ j 1)) + ((#\.) + (if (or (>= j (- len 2)) (eqv? #\/ (string-ref path (+ j 2)))) + (if (>= i (- j 1)) + (if (null? res) + (backup j "" '()) + (backup j (car res) (cdr res))) + (backup j (substring path i j) res)) + (inside i (+ j 2) res))) + ((#\/) + (if (= i j) + (boundary (+ j 2) (+ j 2) res) + (let ((s (substring path i j))) + (boundary (+ j 2) (+ j 2) (cons s res))))) + (else (inside i (+ j 1) res)))) + ((#\/) (boundary (+ j 1) (+ j 1) (collect i j res))) + (else (inside i (+ j 1) res))))) + (define (backup j s res) + (let ((pos (+ j 3))) + (cond + ;; case 1: we're reduced to accumulating parents of the cwd + ((or (string=? s "/..") (string=? s "..")) + (boundary pos pos (cons "/.." (cons s res)))) + ;; case 2: the string isn't a component itself, skip it + ((or (string=? s "") (string=? s ".") (string=? s "/")) + (if (pair? res) + (backup j (car res) (cdr res)) + (boundary pos pos (if (string=? s "/") '("/") '(".."))))) + ;; case3: just take the directory of the string + (else + (let ((d (path-directory s))) + (cond + ((string=? d "/") + (boundary pos pos (if (null? res) '("/") res))) + ((string=? d ".") + (boundary pos pos res)) + (else (boundary pos pos (cons "/" (cons d res)))))))))) + ;; start with boundary if abs path, otherwise inside + (if (zero? len) + path + ((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '())))) + +(define (make-path . args) + (define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "not a valid path component" x)))) + (define (trim-trailing-slash s) + (let ((i (string-skip-right #\/ s))) + (if i (substring s 0 (+ i 1)) ""))) + (if (null? args) + "" + (let ((start (trim-trailing-slash (x->string (car args))))) + (let lp ((ls (cdr args)) + (res (if (string=? "" start) '() (list start)))) + (cond + ((null? ls) + (apply string-append (reverse res))) + ((pair? (car ls)) + (lp (append (car ls) (cdr ls)) res)) + (else + (let ((x (trim-trailing-slash (x->string (car ls))))) + (lp (cdr ls) + (if (string=? x "") res (cons x (cons "/" res))))))))))) diff --git a/lib/chibi/process.module b/lib/chibi/process.module new file mode 100644 index 00000000..fe03c2e5 --- /dev/null +++ b/lib/chibi/process.module @@ -0,0 +1,17 @@ + +(define-module (chibi process) + (export exit sleep alarm fork kill execute waitpid + set-signal-action! make-signal-set signal-set-contains? + signal-set-fill! signal-set-add! signal-set-delete! + current-signal-mask + signal-mask-block! signal-mask-unblock! signal-mask-set! + signal/hang-up signal/interrupt signal/quit + signal/illegal signal/abort signal/fpe + signal/kill signal/segv signal/pipe + signal/alarm signal/term signal/user1 + signal/user2 signal/child signal/continue + signal/stop signal/tty-stop signal/tty-input + signal/tty-output) + (import-immutable (scheme)) + (include-shared "process")) + diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub new file mode 100644 index 00000000..7dbca7eb --- /dev/null +++ b/lib/chibi/process.stub @@ -0,0 +1,72 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/wait.h") +(c-system-include "signal.h") +(c-system-include "unistd.h") + +(define-c-type siginfo_t + predicate: signal-info? + (int si_signo signal-number) + (int si_errno signal-error-number) + (int si_code signal-code) + (pid_t si_pid signal-pid) + (uid_t si_uid signal-uid) + (int si_status signal-status) + ;;(clock_t si_utime signal-user-time) + ;;(clock_t si_stime signal-system-time) + ) + +(define-c-type sigset_t + predicate: signal-set?) + +(define-c-const int (signal/hang-up "SIGHUP")) +(define-c-const int (signal/interrupt "SIGINT")) +(define-c-const int (signal/quit "SIGQUIT")) +(define-c-const int (signal/illegal "SIGILL")) +(define-c-const int (signal/abort "SIGABRT")) +(define-c-const int (signal/fpe "SIGFPE")) +(define-c-const int (signal/kill "SIGKILL")) +(define-c-const int (signal/segv "SIGSEGV")) +(define-c-const int (signal/pipe "SIGPIPE")) +(define-c-const int (signal/alarm "SIGALRM")) +(define-c-const int (signal/term "SIGTERM")) +(define-c-const int (signal/user1"SIGUSR1")) +(define-c-const int (signal/user2 "SIGUSR2")) +(define-c-const int (signal/child "SIGCHLD")) +(define-c-const int (signal/continue "SIGCONT")) +(define-c-const int (signal/stop "SIGSTOP")) +(define-c-const int (signal/tty-stop "SIGTSTP")) +(define-c-const int (signal/tty-input "SIGTTIN")) +(define-c-const int (signal/tty-output "SIGTTOU")) + +(c-include "signal.c") + +(define-c sexp (set-signal-action! "sexp_set_signal_action") + ((value ctx sexp) sexp sexp)) + +(define-c errno (make-signal-set "sigemptyset") ((result sigset_t))) +(define-c errno (signal-set-fill! "sigfillset") (sigset_t)) +(define-c errno (signal-set-add! "sigaddset") (sigset_t int)) +(define-c errno (signal-set-delete! "sigaddset") (sigset_t int)) +(define-c boolean (signal-set-contains? "sigismember") (sigset_t int)) + +(define-c errno (signal-mask-block! "sigprocmask") + ((value SIG_BLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-unblock! "sigprocmask") + ((value SIG_UNBLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-set! "sigprocmask") + ((value SIG_SETMASK int) sigset_t (value NULL sigset_t))) +(define-c errno (current-signal-mask "sigprocmask") + ((value SIG_BLOCK int) (value NULL sigset_t) (result sigset_t))) + +(define-c unsigned-int alarm (unsigned-int)) +(define-c unsigned-int sleep (unsigned-int)) + +(define-c pid_t fork ()) +;;(define-c pid_t wait ((result int))) +(define-c pid_t waitpid (int (result int) int)) +(define-c errno kill (int int)) +;;(define-c errno raise (int)) +(define-c void exit (int)) +(define-c int (execute execvp) (string (array string))) + diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c new file mode 100644 index 00000000..463e481d --- /dev/null +++ b/lib/chibi/signal.c @@ -0,0 +1,62 @@ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_MAX_SIGNUM 32 + +static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM]; + +static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { + sexp ctx, sigctx, handler; + sexp_gc_var1(args); + ctx = sexp_signal_contexts[signum]; + if (ctx) { + handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), + sexp_make_fixnum(signum)); + if (sexp_truep(handler)) { + sigctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve1(sigctx, args); + args = sexp_cons(sigctx, SEXP_FALSE, SEXP_NULL); + sexp_car(args) + = sexp_make_cpointer(sigctx, sexp_siginfo_t_type_id, info, SEXP_FALSE, 0); + args = sexp_cons(sigctx, SEXP_FALSE, args); + sexp_car(args) = sexp_make_fixnum(signum); + sexp_apply(sigctx, handler, args); + sexp_gc_release1(sigctx); + } + } +} + +static struct sigaction call_sigaction = { + .sa_sigaction = sexp_call_sigaction, + .sa_flags = SA_SIGINFO | SA_NODEFER +}; + +static struct sigaction call_sigdefault = {.sa_handler = SIG_DFL}; +static struct sigaction call_sigignore = {.sa_handler = SIG_IGN}; + +static sexp sexp_set_signal_action (sexp ctx, sexp signum, sexp newaction) { + int res; + sexp oldaction; + if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0 + && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) + return sexp_type_exception(ctx, "not a valid signal number", signum); + if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) + || sexp_booleanp(newaction))) + return sexp_type_exception(ctx, "not a procedure", newaction); + if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS))) + sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS) + = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE); + oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); + res = sigaction(sexp_unbox_fixnum(signum), + (sexp_booleanp(newaction) ? + (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore) + : &call_sigaction), + NULL); + if (res) + return sexp_user_exception(ctx, SEXP_FALSE, "couldn't set signal", signum); + sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction); + sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx; + return oldaction; +} + diff --git a/lib/chibi/system.module b/lib/chibi/system.module new file mode 100644 index 00000000..adc26ddc --- /dev/null +++ b/lib/chibi/system.module @@ -0,0 +1,15 @@ + +(define-module (chibi system) + (export user-information user-name user-password + user-id user-group-id user-gecos user-home user-shell + current-user-id current-group-id + current-effective-user-id current-effective-group-id + set-current-user-id! set-current-effective-user-id! + set-current-group-id! set-current-effective-group-id! + current-session-id create-session + set-root-directory!) + (import-immutable (scheme)) + (include-shared "system") + ;;(include "system.scm") + ) + diff --git a/lib/chibi/system.stub b/lib/chibi/system.stub new file mode 100644 index 00000000..7d4a836f --- /dev/null +++ b/lib/chibi/system.stub @@ -0,0 +1,34 @@ + +(c-system-include "unistd.h") +(c-system-include "pwd.h") +(c-system-include "sys/types.h") + +(define-c-struct passwd + predicate: user? + (string pw_name user-name) + (string pw_passwd user-password) + (uid_t pw_uid user-id) + (gid_t pw_gid user-group-id) + (string pw_gecos user-gecos) + (string pw_dir user-home) + (string pw_shell user-shell)) + +(define-c uid_t (current-user-id "getuid") ()) +(define-c gid_t (current-group-id "getgid") ()) +(define-c uid_t (current-effective-user-id "geteuid") ()) +(define-c gid_t (current-effective-group-id "getegid") ()) + +(define-c errno (set-current-user-id! "setuid") (uid_t)) +(define-c errno (set-current-effective-user-id! "seteuid") (uid_t)) +(define-c errno (set-current-group-id! "setgid") (gid_t)) +(define-c errno (set-current-effective-group-id! "setegid") (gid_t)) + +(define-c pid_t (current-session-id "getsid") ((default 0 pid_t))) +(define-c pid_t (create-session "setsid") ()) + +(define-c errno (set-root-directory! "chroot") (string)) + +;; (define-c errno getpwuid_r +;; (uid_t (result passwd) (result (array char arg3)) +;; (value 256 int) (result pointer passwd))) + diff --git a/lib/chibi/time.module b/lib/chibi/time.module new file mode 100644 index 00000000..84f2b800 --- /dev/null +++ b/lib/chibi/time.module @@ -0,0 +1,11 @@ + +(define-module (chibi time) + (export current-seconds get-time-of-day set-time-of-day! + seconds->time seconds->string time->seconds time->string + timeval-seconds timeval-microseconds + timezone-offset timezone-dst-time + time-second time-minute time-hour time-day time-month time-year + time-day-of-week time-day-of-year time-dst?) + (import-immutable (scheme)) + (include-shared "time")) + diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub new file mode 100644 index 00000000..bb5cd644 --- /dev/null +++ b/lib/chibi/time.stub @@ -0,0 +1,45 @@ + +(c-system-include "time.h") +(c-system-include "sys/time.h") + +(define-c-struct tm + (int tm_sec time-second) + (int tm_min time-minute) + (int tm_hour time-hour) + (int tm_mday time-day) + (int tm_mon time-month) + (int tm_year time-year) + (int tm_wday time-day-of-week) + (int tm_yday time-day-of-year) + (int tm_isdst time-dst?)) + +(define-c-struct timeval + predicate: timeval? + (time_t tv_sec timeval-seconds) + (int tv_usec timeval-microseconds)) + +(define-c-struct timezone + predicate: timezone? + (int tz_minuteswest timezone-offset) + (int tz_dsttime timezone-dst-time)) + +(define-c time_t (current-seconds "time") ((value NULL))) + +(define-c errno (get-time-of-day "gettimeofday") + ((result timeval) (result timezone))) + +(define-c errno (set-time-of-day! "settimeofday") + (timeval (maybe-null default NULL timezone))) + +(define-c non-null-pointer (seconds->time "localtime_r") + ((pointer time_t) (result tm))) + +(define-c time_t (time->seconds "mktime") + (tm)) + +(define-c non-null-string (seconds->string "ctime_r") + ((pointer time_t) (result (array char 64)))) + +(define-c non-null-string (time->string "asctime_r") + (tm (result (array char 64)))) + diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module new file mode 100644 index 00000000..2456dd9f --- /dev/null +++ b/lib/chibi/uri.module @@ -0,0 +1,10 @@ + +(define-module (chibi uri) + (export uri->string make-uri string->uri + uri-scheme uri-user uri-host uri-path uri-query uri-fragment + uri-with-scheme uri-with-user uri-with-host uri-with-path + uri-with-query uri-with-fragment + uri-encode uri-decode uri-query->alist uri-alist->query) + (import-immutable (scheme) + (srfi 9)) + (include "uri.scm")) diff --git a/lib/chibi/uri.scm b/lib/chibi/uri.scm new file mode 100644 index 00000000..41507961 --- /dev/null +++ b/lib/chibi/uri.scm @@ -0,0 +1,306 @@ +;; uri.scm -- URI parsing library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URI representation + +(define-record-type uri + (%make-uri scheme user host port path query fragment) + uri? + (scheme uri-scheme) + (user uri-user) + (host uri-host) + (port uri-port) + (path uri-path) + (query uri-query) + (fragment uri-fragment)) + +;; (make-uri scheme [user host port path query fragment]) +(define (make-uri scheme . o) + (let* ((user (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (host (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (port (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (path (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (query (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f))) + (%make-uri scheme user host port path query fragment))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils (don't feel like using SRFI-13 and these are more +;; specialised) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (string-scan-right str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i (- end 1))) + (and (>= i start) + (if (eqv? ch (string-ref str i)) + i + (lp (- i 1))))))) + +(define (string-index-of str pred . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond ((>= i end) #f) + ((pred (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase->symbol str) + (let ((len (string-length str))) + (let lp ((i 0)) + (cond + ((= i len) + (string->symbol str)) + ((char-upper-case? (string-ref str i)) + (let ((res (make-string len))) + (do ((j 0 (+ j 1))) + ((= j i)) + (string-set! res j (string-ref str j))) + (string-set! res i (char-downcase (string-ref str i))) + (do ((j (+ i 1) (+ j 1))) + ((= j len)) + (string-set! res j (char-downcase (string-ref str j)))) + (string->symbol res))) + (else + (lp (+ i 1))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; functional updaters (uses as much shared state as possible) + +(define (uri-with-scheme u scheme) + (%make-uri scheme (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-user u user) + (%make-uri (uri-scheme u) user (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-host u host) + (%make-uri (uri-scheme u) (uri-user u) host (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-port u port) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) port + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-path u path) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + path (uri-query u) (uri-fragment u))) + +(define (uri-with-query u query) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) query (uri-fragment u))) + +(define (uri-with-fragment u fragment) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) fragment)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parsing - without :// we just split into scheme & path + +(define (char-uri-scheme-unsafe? ch) + (not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\_ #\-))))) + +(define (string->path-uri scheme str . o) + (define decode? (and (pair? o) (car o))) + (define decode (if decode? uri-decode (lambda (x) x))) + (define decode-query + (if (and (pair? o) (pair? (cdr o)) (cadr o)) + uri-query->alist + decode)) + (if (pair? str) + str + (let* ((len (string-length str)) + (colon0 (string-scan str #\:)) + (colon + (and (not (string-index-of str char-uri-scheme-unsafe? + 0 (or colon0 len))) + colon0))) + (if (or (not colon) (zero? colon)) + (and scheme + (let* ((quest (string-scan str #\? 0)) + (pound (string-scan str #\# (or quest 0)))) + (make-uri scheme #f #f #f + (decode (substring str 0 (or quest pound len))) + (and quest + (decode-query + (substring str (+ quest 1) (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len)))))) + (let ((sc1 (+ colon 1)) + (scheme (string-downcase->symbol (substring str 0 colon)))) + (if (= sc1 len) + (make-uri scheme) + (if (or (>= (+ sc1 1) len) + (not (and (eqv? #\/ (string-ref str sc1)) + (eqv? #\/ (string-ref str (+ sc1 1)))))) + (make-uri scheme #f #f #f (substring str sc1 len)) + (if (>= (+ sc1 2) len) + (make-uri scheme #f "") + (let* ((sc2 (+ sc1 2)) + (slash (string-scan str #\/ sc2)) + (sc3 (or slash len)) + (at (string-scan-right str #\@ sc2 sc3)) + (colon3 (string-scan str #\: (or at sc2) sc3)) + (quest (string-scan str #\? sc3)) + (pound (string-scan str #\# (or quest sc3)))) + (%make-uri + scheme + (and at (decode (substring str sc2 at))) + (decode + (substring str + (if at (+ at 1) sc2) + (or colon3 sc3))) + (and colon3 + (string->number + (substring str (+ colon3 1) sc3))) + (and slash + (decode + (substring str slash (or quest pound len)))) + (and quest + (decode-query + (substring str (+ quest 1) + (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len))) + )))))))))) + +(define (string->uri str . o) + (apply string->path-uri #f str o)) + +(define (uri->string uri . o) + (define encode? (and (pair? o) (car o))) + (define encode (if encode? uri-encode (lambda (x) x))) + (if (string? uri) + uri + (let ((fragment (uri-fragment uri)) + (query (uri-query uri)) + (path (uri-path uri)) + (port (uri-port uri)) + (host (uri-host uri)) + (user (uri-user uri))) + (string-append + (symbol->string (uri-scheme uri)) ":" + (if (or user host port) "//" "") + (if user (encode user) "") (if user "@" "") + (or host "") ; host shouldn't need encoding + (if port ":" "") (if port (number->string port) "") + (if path (encode path) "") + (if query "?" "") + (if (pair? query) (uri-alist->query query) (or query "")) + (if fragment "#" "") (if fragment (encode fragment) ""))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; query encoding and decoding + +(define (uri-safe-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (case ch + ((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t) + (else #f)))) + +(define (collect str from to res) + (if (>= from to) + res + (cons (substring str from to) res))) + +(define (uri-encode str . o) + (define (encode-1-space ch) + (if (eqv? ch #\space) + "+" + (encode-1-normal ch))) + (define (encode-1-normal ch) + (let* ((i (char->integer ch)) + (hex (number->string i 16))) + (if (< i 16) + (string-append "%0" hex) + (string-append "%" hex)))) + (let ((start 0) + (end (string-length str)) + (encode-1 (if (and (pair? o) (car o)) + encode-1-space + encode-1-normal))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (if (uri-safe-char? ch) + (lp from next res) + (lp next next (cons (encode-1 ch) + (collect str from to res))))))))) + +(define (uri-decode str . o) + (let ((space-as-plus? (and (pair? o) (car o))) + (start 0) + (end (string-length str))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (cond + ((eqv? ch #\%) + (if (>= next end) + (lp next next (collect str from to res)) + (let ((next2 (+ next 1))) + (if (>= next2 end) + (lp next2 next2 (collect str from to res)) + (let* ((next3 (+ next2 1)) + (hex (substring str next next3)) + (i (string->number hex 16))) + (lp next3 next3 (cons (string (integer->char i)) + (collect str from to res)))))))) + ((and space-as-plus? (eqv? ch #\+)) + (lp next next (cons " " (collect str from to res)))) + (else + (lp from next res)))))))) + +(define (uri-query->alist str . o) + (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;))) + (let ((len (string-length str)) + (plus? (and (pair? o) (car o)))) + (let lp ((i 0) (res '())) + (if (>= i len) + (reverse res) + (let* ((j (or (string-index-of str split-char? i) len)) + (k (string-scan str #\= i j)) + (cell (if k + (cons (uri-decode (substring str i k) plus?) + (uri-decode (substring str (+ k 1) j) plus?)) + (cons (uri-decode (substring str i j) plus?) #f)))) + (lp (+ j 1) (cons cell res))))))) + +(define (uri-alist->query ls . o) + (define plus? (and (pair? o) (car o))) + (define (encode key val res) + (let ((res (cons (uri-encode key plus?) res))) + (if val (cons (uri-encode val plus?) (cons "=" res)) res))) + (if (null? ls) + "" + (let lp ((x (car ls)) (ls (cdr ls)) (res '())) + (let ((res (encode (car x) (cdr x) res))) + (if (null? ls) + (string-concatenate (reverse res)) + (lp (car ls) (cdr ls) (cons "&" res))))))) diff --git a/lib/config.scm b/lib/config.scm new file mode 100644 index 00000000..1254360d --- /dev/null +++ b/lib/config.scm @@ -0,0 +1,174 @@ +;; config.scm -- configuration module +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *this-module* '()) + +(define (make-module exports env meta) (vector exports env meta)) +(define (%module-exports mod) (vector-ref mod 0)) +(define (module-env mod) (vector-ref mod 1)) +(define (module-meta-data mod) (vector-ref mod 2)) +(define (module-env-set! mod env) (vector-set! mod 1 env)) + +(define (module-exports mod) + (or (%module-exports mod) (env-exports (module-env mod)))) + +(define (module-name->strings ls res) + (if (null? ls) + res + (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls))) + ((number? (car ls)) (number->string (car ls))) + ((string? (car ls)) (car ls)) + (else (error "invalid module name" (car ls)))))) + (module-name->strings (cdr ls) (cons "/" (cons str res)))))) + +(define (module-name->file name) + (string-concatenate + (reverse (cons ".module" (cdr (module-name->strings name '())))))) + +(define (module-name-prefix name) + (string-concatenate (reverse (cdr (cdr (module-name->strings name '())))))) + +(define (load-module-definition name) + (let* ((file (module-name->file name)) + (path (find-module-file file))) + (if path (load path *config-env*)))) + +(define (find-module name) + (cond + ((assoc name *modules*) => cdr) + (else + (load-module-definition name) + (cond ((assoc name *modules*) => cdr) + (else #f))))) + +(define (symbol-append a b) + (string->symbol (string-append (symbol->string a) (symbol->string b)))) + +(define (to-id id) (if (pair? id) (car id) id)) +(define (from-id id) (if (pair? id) (cdr id) id)) +(define (id-filter pred ls) + (cond ((null? ls) '()) + ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls)))) + (else (id-filter pred (cdr ls))))) + +(define (resolve-import x) + (cond + ((not (and (pair? x) (list? x))) + (error "invalid module syntax" x)) + ((and (pair? (cdr x)) (pair? (cadr x))) + (if (memq (car x) '(only except rename)) + (let* ((mod-name+imports (resolve-import (cadr x))) + (imp-ids (cdr mod-name+imports)) + (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x)))) + (begin + (set-cdr! mod-name+imports + (module-exports + (find-module (car mod-name+imports)))) + (cdr mod-name+imports)) + imp-ids))) + (cons (car mod-name+imports) + (case (car x) + ((only) + (if (not imp-ids) + (cddr x) + (id-filter (lambda (i) (memq i (cddr x))) imp-ids))) + ((except) + (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids)) + ((rename) + (map (lambda (i) + (let ((rename (assq (to-id i) (cddr x)))) + (if rename (cons (cdr rename) (from-id i)) i))) + imp-ids))))) + (error "invalid import modifier" x))) + ((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x))) + (let ((mod-name+imports (resolve-import (caddr x)))) + (cons (car mod-name+imports) + (map (lambda (i) + (cons (symbol-append (cadr x) (if (pair? i) (car i) i)) + (if (pair? i) (cdr i) i))) + (cdr mod-name+imports))))) + ((find-module x) + => (lambda (mod) (cons x (%module-exports mod)))) + (else + (error "couldn't find import" x)))) + +(define (eval-module name mod) + (let ((env (make-environment)) + (dir (module-name-prefix name))) + (for-each + (lambda (x) + (case (and (pair? x) (car x)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2 (load-module (car mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports) + (eq? (car x) 'import-immutable)))) + (cdr x))) + ((include include-shared) + (for-each + (lambda (f) + (let ((f (string-append + dir f + (if (eq? (car x) 'include) "" *shared-object-extension*)))) + (cond + ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + (cdr x))) + ((body) + (for-each (lambda (expr) (eval expr env)) (cdr x))))) + (module-meta-data mod)) + env)) + +(define (load-module name) + (let ((mod (find-module name))) + (if (and mod (not (module-env mod))) + (module-env-set! mod (eval-module name mod))) + mod)) + +(define-syntax define-module + (er-macro-transformer + (lambda (expr rename compare) + (let ((name (cadr expr)) + (body (cddr expr))) + `(let ((tmp *this-module*)) + (set! *this-module* '()) + ,@body + (set! *this-module* (reverse *this-module*)) + (let ((exports + (cond ((assq 'export *this-module*) => cdr) + (else '())))) + (set! *modules* + (cons (cons ',name (make-module exports #f *this-module*)) + *modules*))) + (set! *this-module* tmp)))))) + +(define-syntax define-config-primitive + (er-macro-transformer + (lambda (expr rename compare) + `(define-syntax ,(cadr expr) + (er-macro-transformer + (lambda (expr rename compare) + `(set! *this-module* (cons ',expr *this-module*)))))))) + +(define-config-primitive import) +(define-config-primitive import-immutable) +(define-config-primitive export) +(define-config-primitive include) +(define-config-primitive include-shared) +(define-config-primitive body) + +(define *modules* + (list (cons '(scheme) (make-module #f (interaction-environment) '())) + (cons '(srfi 0) (make-module (list 'cond-expand) + (interaction-environment) + (list (list 'export 'cond-expand)))) + (cons '(srfi 46) (make-module (list 'syntax-rules) + (interaction-environment) + (list (list 'export 'syntax-rules)))))) + diff --git a/lib/init.scm b/lib/init.scm new file mode 100644 index 00000000..cd50ad37 --- /dev/null +++ b/lib/init.scm @@ -0,0 +1,881 @@ +;; init.scm -- R5RS library procedures +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; 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 f ls . lol) + (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls))))) + (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f)))) + +(define (any pred ls) + (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f)) + +(define (every pred ls) + (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t)) + +(define (delq x ls) + (if (pair? ls) + (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls)))) + '())) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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) + (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 (rename 'else) (car cl)) + (if (pair? (cddr expr)) + (error "non-final else in cond" expr) + (cons (rename 'begin) (cdr cl))) + (if (if (null? (cdr cl)) #t (compare (rename '=>) (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 + ((compare (rename 'unquote) (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((compare (rename '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))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (compare (rename '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 (null? (cdr expr)) (error "empty let" expr)) + (if (null? (cddr expr)) (error "no let body" expr)) + ((lambda (bindings) + (if (list? bindings) #f (error "bad let bindings")) + (if (every (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + bindings) + (if (identifier? (cadr expr)) + `(,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,(map car bindings) + ,@(cdddr expr)))) + ,(cons (cadr expr) (map cadr bindings))) + `((,(rename 'lambda) ,(map car bindings) ,@(cddr expr)) + ,@(map cadr bindings))) + (error "bad let syntax" expr))) + (if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let*" expr)) + (if (null? (cddr expr)) (error "no let* body" expr)) + (if (null? (cadr expr)) + `(,(rename 'let) () ,@(cddr expr)) + (if (if (list? (cadr expr)) + (every + (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + (cadr expr)) + #f) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))) + (error "bad let* syntax")))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare (rename '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)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; promises + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exceptions + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f))) + +(define (with-exception-handler handler thunk) + (letrec ((orig-handler (current-exception-handler)) + (self (lambda (exn) + (current-exception-handler orig-handler) + (let ((res (handler exn))) + (current-exception-handler self) + res)))) + (current-exception-handler self) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; library functions + +;; 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 . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (and (pair? ls) (if (eq obj (car ls)) ls (lp (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 (if (bignum? 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 (numerator x) + (if (integer? x) x (numerator (* x 10)))) +(define (denominator x) + (if (exact? x) + 1 + (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10)))))) + +(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) + (if (<= n 9) + (integer->char (+ n (char->integer #\0))) + (integer->char (+ (- n 10) (char->integer #\A))))) +(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)) + (if (null? res) "0" (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 (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-output-port)) + (tmp-out (open-output-file file))) + (current-output-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)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dynamic-wind + +(define *dk* (list #f)) + +(define (dynamic-wind before thunk after) + (let ((dk *dk*)) + (set-dk! (cons (cons before after) dk)) + (let ((res (thunk))) (set-dk! dk) res))) + +(define (set-dk! dk) + (if (not (eq? dk *dk*)) + (begin + (set-dk! (cdr dk)) + (let ((before (car (car dk))) (dk dk)) + (set-car! *dk* (cons (cdr (car dk)) before)) + (set-cdr! *dk* dk) + (set-car! dk #f) + (set-cdr! dk '()) + (set! *dk* dk) + (before))))) + +(define (call-with-current-continuation proc) + (let ((dk *dk*)) + (%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((ellipse-specified? (identifier? (cadr 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 'syntax-quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_len (rename'len)) (_length (rename 'length)) + (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error)) + (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define ellipse (rename (if ellipse-specified? (cadr expr) '...))) + (define lits (if ellipse-specified? (caddr expr) (cadr expr))) + (define forms (if ellipse-specified? (cdddr expr) (cddr expr))) + (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))) + (cond + ((not (list? (cddr p))) + (error "dotted ellipse" p)) + ((any (lambda (x) (and (identifier? x) (compare x ellipse))) + (cddr p)) + (error "multiple ellipses" p)) + (else + (let ((len (length (cdr (cdr p))))) + `(,_let ((,_len (,_length ,v))) + (,_and (,_>= ,_len ,len) + (,_let ,_lp ((,_ls ,v) + (,_i (,_- ,_len ,len)) + (,_res (,_quote ()))) + (,_if (,_>= 0 ,_i) + ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p))) + `(,_append ,_ls (,_reverse ,_res)) + dim + vars + k) + (,_lp (,_cdr ,_ls) + (,_- ,_i 1) + (,_cons (,_car ,_ls) ,_res)))))))))) + ((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-escape? x) (and (pair? x) (compare ellipse (car x)))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare ellipse (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 (any (lambda (lit) (compare x lit)) 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 + ((any (lambda (v) (compare t (car v))) vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (cond + ((ellipse-escape? t) + (if (pair? (cdr t)) + (if (pair? (cddr t)) (cddr t) (cadr t)) + (cdr t))) + ((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))))))) + (else (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 for" + (list (rename 'strip-syntactic-closures) _expr))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *config-env* #f) + +(define-syntax import + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (res '())) + (cond + ((null? ls) + (cons 'begin (reverse res))) + (else + (let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*))) + (if (pair? mod+imps) + (lp (cdr ls) + (cons `(%env-copy! + #f + (vector-ref + (eval '(load-module ',(car mod+imps)) *config-env*) + 1) + ',(cdr mod+imps) + #f) + res)) + (error "couldn't find module" (car ls)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SRFI-0 + +(define-syntax cond-expand + (er-macro-transformer + (lambda (expr rename compare) + (define (check x) + (if (pair? x) + (case (car x) + ((and) (every check (cdr x))) + ((or) (any check (cdr x))) + ((not) (not (check (cadr x)))) + (else (error "cond-expand: bad feature" x))) + (memq (identifier->symbol x) *features*))) + (let expand ((ls (cdr expr))) + (cond ((null? ls) (error "cond-expand: no expansions" expr)) + ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) + ((eq? 'else (identifier->symbol (caar ls))) + (if (pair? (cdr ls)) + (error "cond-expand: else in non-final position") + `(,(rename 'begin) ,@(cdar ls)))) + ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) + (else (expand (cdr ls)))))))) + diff --git a/lib/srfi/1.module b/lib/srfi/1.module new file mode 100644 index 00000000..3d3da044 --- /dev/null +++ b/lib/srfi/1.module @@ -0,0 +1,31 @@ + +(define-module (srfi 1) + (export + xcons cons* make-list list-tabulate list-copy circular-list iota + proper-list? circular-list? dotted-list? not-pair? null-list? list= + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr take drop take-right drop-right take! drop-right! split-at split-at! + last last-pair length+ concatenate append! concatenate! reverse! + append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 count + fold unfold pair-fold reduce fold-right unfold-right + pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter partition remove filter! partition! remove! find find-tail any every + list-index take-while drop-while take-while! span break span! break! + delete delete-duplicates delete! delete-duplicates! + alist-cons alist-copy alist-delete alist-delete! + lset<= lset= lset-adjoin lset-union lset-union! lset-intersection + lset-intersection! lset-difference lset-difference! lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection!) + (import (scheme)) + (include "1/predicates.scm" + "1/selectors.scm" + "1/search.scm" + "1/misc.scm" + "1/constructors.scm" + "1/fold.scm" + "1/deletion.scm" + "1/alists.scm" + "1/lset.scm")) + diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm new file mode 100644 index 00000000..a35db42c --- /dev/null +++ b/lib/srfi/1/alists.scm @@ -0,0 +1,14 @@ +;; alist.scm -- association list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (alist-cons key value ls) (cons (cons key value) ls)) + +(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls)) + +(define (alist-delete key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (remove (lambda (x) (eq (car x) key)) ls))) + +(define alist-delete! alist-delete) + diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm new file mode 100644 index 00000000..e205cee0 --- /dev/null +++ b/lib/srfi/1/constructors.scm @@ -0,0 +1,36 @@ +;; constructors.scm -- list construction utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (xcons a b) (cons b a)) + +(define (cons* x . args) + (let lp ((rev '()) (x x) (ls args)) + (if (null? ls) + (append-reverse rev x) + (lp (cons x rev) (car ls) (cdr ls))))) + +(define (make-list n . o) + (let ((default (if (pair? o) (car o)))) + (let lp ((n n) (res '())) + (if (<= n 0) res (lp (- n 1) (cons default res)))))) + +(define (list-tabulate n proc) + (let lp ((n n) (res '())) + (if (< n 0) res (lp (- n 1) (cons (proc n) res))))) + +(define (list-copy ls) (reverse! (reverse ls))) + +(define (circular-list x . args) + (let ((res (cons x args))) + (set-cdr! (last-pair res) res) + res)) + +(define (iota count . o) + (let ((start (if (pair? o) (car o) count)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) + (let lp ((i count) (n (- start step)) (res '())) + (if (<= i 0) + res + (lp (- i 1) (- n step) (cons n res)))))) + diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm new file mode 100644 index 00000000..70ee5cc5 --- /dev/null +++ b/lib/srfi/1/deletion.scm @@ -0,0 +1,25 @@ +;; deletion.scm -- list deletion utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (delete x ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (if (eq? eq eq?) + (let lp ((ls ls) (rev '())) ;; fast path for delq + (let ((tail (memq x ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls)))) + (filter (lambda (y) (eq x y)) ls)))) + +(define delete! delete) + +(define (delete-duplicates ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res))) + (reverse! res))))) + +(define delete-duplicates! delete-duplicates) + diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm new file mode 100644 index 00000000..892b075c --- /dev/null +++ b/lib/srfi/1/fold.scm @@ -0,0 +1,115 @@ +;; fold.scm -- list fold/reduce utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (map-onto car lists (list acc)))) + acc)))) + +(define (fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (map-onto car lists (lp (map cdr lists)))) + knil)))) + +(define (pair-fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (append lists (list acc)))) + acc)))) + +(define (pair-fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (append lists (lp (map cdr lists)))) + knil)))) + +(define (reduce f identity ls) + (if (null? ls) identity (fold f (car ls) (cdr ls)))) + +(define (reduce-right f identity ls) + (if (null? ls) identity (fold-right f (car ls) (cdr ls)))) + +(define (unfold p f g seed . o) + (let lp ((seed seed)) + (if (p seed) + (if (pair? o) ((car o) seed) '()) + (cons (f seed) (lp (g seed)))))) + +(define (unfold-right p f g seed . o) + (let lp ((seed seed) (res (if (pair? o) (car o) '()))) + (if (p seed) res (lp (g seed) (cons (f seed) res))))) + +(define (append-map-helper append f ls lists) + (if (null? lists) + (if (null? ls) + '() + (let ((rev-ls (reverse ls))) + (let lp ((ls (cdr rev-ls)) (res (car rev-ls))) + (if (null? ls) res (lp (cdr ls) (append (f (car ls) res)))) + ))) + (if (and (pair? ls) (every pair? lists)) + (let lp ((lists (cons ls lists))) + (let ((vals (apply f (map car lists))) + (cdrs (map cdr lists))) + (if (every pair? cdrs) (append vals (lp cdrs)) vals))) + '()))) + +(define (append-map f ls . lists) + (append-map-helper append f ls lists)) + +(define (append-map! f ls . lists) + (append-map-helper append! f ls lists)) + +(define map! map) +(define map-in-order map) + +(define (pair-for-each f ls . lists) + (apply pair-fold (lambda (x _) (f x)) ls lists)) + +(define (filter-map f ls . lists) + (if (null? lists) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res))) + (reverse! res))) + (filter (lambda (x) x) (apply map f ls lists)))) + +(define (take-up-to-reverse from to init) + (if (eq? from to) + init + (take-up-to-reverse (cdr from) to (cons (car from) init)))) + +(define (remove pred ls) + (let lp ((ls ls) (rev '())) + (let ((tail (find-tail pred ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls))))) + +(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls)) + +(define (partition pred ls) + (let lp ((ls ls) (good '()) (bad '())) + (cond ((null? ls) (values (reverse! good) (reverse! bad))) + ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad)) + (else (lp (cdr ls) good (cons (car ls) bad)))))) + +(define filter! filter) +(define remove! remove) +(define partition! partition) + diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm new file mode 100644 index 00000000..f2ffc4ae --- /dev/null +++ b/lib/srfi/1/lset.scm @@ -0,0 +1,51 @@ +;; lset.scm -- list set library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (lset<= eq . sets) + (if (null? sets) + #t + (let lp1 ((set1 (car sets)) (sets (cdr sets))) + (if (null? sets) + #t + (let ((set2 (car sets))) + (let lp2 ((ls set1)) + (if (pair? ls) + (and (member (car set1) set2 eq) (lp2 (cdr ls))) + (lp1 set2 (cdr sets))))))))) + +(define (lset= eq . sets) + (and (apply lset<= eq sets) (apply lset<= eq (reverse sets)))) + +(define (lset-adjoin eq set . elts) + (lset-union2 eq elts set)) + +(define (lset-union2 eq a b) + (if (null? b) + a + (lset-union2 (cdr b) (if (member (car b) a eq) a (cons (car b) a))))) + +(define (lset-union eq . sets) + (reduce (lambda (a b) (lset-union2 eq a b)) '() sets)) + +(define (lset-intersection eq . sets) + (reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-difference eq . sets) + (reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-xor eq . sets) + (reduce (lambda (a b) + (append (filter (lambda (x) (member x b eq)) a) + (filter (lambda (x) (member x a eq)) b))) + '() + sets)) + +(define (lset-diff+intersection eq . sets) + (values (apply lset-difference eq sets) (apply lset-intersection eq sets))) + +(define lset-diff+intersection! lset-diff+intersection) +(define lset-xor! lset-xor) +(define lset-difference! lset-difference) +(define lset-intersection! lset-intersection) +(define lset-union! lset-union) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm new file mode 100644 index 00000000..1e7568df --- /dev/null +++ b/lib/srfi/1/misc.scm @@ -0,0 +1,54 @@ +;; misc.scm -- miscellaneous list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (map-onto proc ls init) + (let lp ((ls ls) (res init)) + (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res))))) + +(define (append! . lists) (concatenate! lists)) + +(define (concatenate lists) + (let lp ((ls (reverse lists)) (res '())) + (if (null? ls) res (lp (cdr ls) (append (car ls) res))))) + +(define (concatenate! lists) + (if (null? lists) + '() + (let lp ((ls lists)) + (cond ((not (pair? (cdr ls))) + lists) + (else + (set-cdr! (last-pair (car ls)) (cadr ls)) + (lp (cdr ls))))))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define (append-reverse! rev tail) + (if (null? rev) + tail + (let ((head (reverse! rev))) + (set-cdr! rev tail) + head))) + +(define (zip . lists) (apply map list lists)) + +(define (unzip1 ls) (map car ls)) +(define (unzip2 ls) (values (map car ls) (map cadr ls))) +(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls))) +(define (unzip4 ls) + (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) +(define (unzip5 ls) + (values (map car ls) (map cadr ls) (map caddr ls) + (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls))) + +(define (count pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (res 0)) + (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res)) + (let lp ((lists (cons ls lists)) (res 0)) + (if (every pair? lists) + (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res)) + res)))) + diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm new file mode 100644 index 00000000..be84e085 --- /dev/null +++ b/lib/srfi/1/predicates.scm @@ -0,0 +1,42 @@ +;; predicates.scm -- list prediates +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (proper-list? x) + (cond ((null? x) #t) + ((pair? x) (proper-list? (cdr x))) + (else #f))) + +(define (circular-list? x) + (and (pair? x) (pair? (cdr x)) + (let race ((hare (cdr x)) (tortoise x)) + (or (eq? hare tortoise) + (and (pair? hare) (pair? (cdr hare)) + (race (cddr hare) (cdr tortoise))))))) + +(define (dotted-list? x) + (not (proper-list? x))) + +(define (not-pair? x) (not (pair? x))) + +(define (null-list? x) (null? x)) ; no error + +(define (list= eq . lists) + (let lp1 ((lists lists)) + (or (null? lists) + (null? (cdr lists)) + (let lp2 ((ls1 (car lists)) (ls2 (cadr lists))) + (if (null? ls1) + (and (null? ls2) + (lp1 (cdr lists))) + (and (eq (car ls1) (car ls2)) + (lp2 (cdr ls1) (cdr ls2)))))))) + +(define (length+ x) + (if (not (pair? x)) + 0 + (let lp ((hare (cdr x)) (tortoise x) (res 0)) + (and (not (eq? hare tortoise)) + (if (pair? hare) + (lp (cddr hare) (cdr tortoise) (+ res 1)) + res))))) diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm new file mode 100644 index 00000000..ea31d931 --- /dev/null +++ b/lib/srfi/1/search.scm @@ -0,0 +1,54 @@ +;; search.scm -- list searching and splitting +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (find pred ls) + (cond ((find-tail pred ls) => car) (else #f))) + +(define (find-tail pred ls) + (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls))))) + +(define (take-while pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (reverse! res)))) + +(define take-while! take-while) + +(define (drop-while pred ls) + (or (find-tail (lambda (x) (not (pred x))) ls) '())) + +(define (span pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (values (reverse! res) ls)))) + +(define span! span) + +(define (break pred ls) (span (lambda (x) (not (pred x))) ls)) + +(define break! break) + +(define (any pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls))))) + (let lp ((lists (cons ls lists))) + (and (every pair? lists) + (let ((args (map car lists))) + (if (apply pred args) args (lp (map cdr lists)))))))) + +(define (every pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t)) + (not (apply any (lambda (x) (not (pred x))) ls lists)))) + +(define (list-index pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (n 0)) + (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1))))) + (let lp ((lists (cons ls lists)) (n 0)) + (and (every pair? lists) + (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1))) + )))) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm new file mode 100644 index 00000000..74ef7119 --- /dev/null +++ b/lib/srfi/1/selectors.scm @@ -0,0 +1,59 @@ +;; selectors.scm -- extended list selectors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth ls) (car (cdr (cdr (cdr (cdr ls)))))) +(define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls))))))) +(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (eighth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (ninth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))) +(define (tenth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))) + +(define (car+cdr x) (values (car x) (cdr x))) + +(define (take ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (reverse! res) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (take! ls i) + (if (<= i 0) + '() + (let ((tail (list-tail ls (- i 1)))) + (set-cdr! tail '()) + ls))) + +(define (drop ls i) + (if (<= i 0) ls (drop (cdr ls) (- i 1)))) + +(define (take-right ls i) + (drop ls (- (length+ ls) i))) + +(define (drop-right ls i) + (take ls (- (length+ ls) i))) + +(define (drop-right! ls i) + (take! ls (- (length+ ls) i))) + +(define (split-at ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (values (reverse! res) ls) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (split-at! ls i) + (if (<= i 0) + (values '() ls) + (let* ((tail (list-tail ls (- i 1))) + (right (cdr tail))) + (set-cdr! tail '()) + (values ls right)))) + +(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls)))) +(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls)))) + diff --git a/lib/srfi/11.module b/lib/srfi/11.module new file mode 100644 index 00000000..f3c91df8 --- /dev/null +++ b/lib/srfi/11.module @@ -0,0 +1,28 @@ + +(define-module (srfi 11) + (export let-values let*-values) + (import-immutable (scheme)) + (body + (define-syntax let*-values + (syntax-rules () + ((let*-values () . body) + (begin . body)) + ((let*-values (((a) expr) . rest) . body) + (let ((a expr)) (let*-values rest . body))) + ((let*-values ((params expr) . rest) . body) + (call-with-values (lambda () expr) + (lambda params (let*-values rest . body)))))) + (define-syntax let-values + (syntax-rules () + ((let-values ("step") (binds ...) bind expr maps () () . body) + (let*-values (binds ... (bind expr)) (let maps . body))) + ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body) + (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body) + (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body) + (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body)) + ((let-values ((params expr) . rest) . body) + (let-values ("step") () () expr () params rest . body)) + )))) + diff --git a/lib/srfi/16.module b/lib/srfi/16.module new file mode 100644 index 00000000..f931a376 --- /dev/null +++ b/lib/srfi/16.module @@ -0,0 +1,24 @@ + +(define-module (srfi 16) + (export case-lambda) + (import-immutable (scheme)) + (body + (define-syntax %case + (syntax-rules () + ((%case args len n p ((params ...) . body) . rest) + (if (= len (length '(params ...))) + (apply (lambda (params ...) . body) args) + (%case args len 0 () . rest))) + ((%case args len n (p ...) ((x . y) . body) . rest) + (%case args len (+ n 1) (p ... x) (y . body) . rest)) + ((%case args len n (p ...) (y . body) . rest) + (if (>= len n) + (apply (lambda (p ... y) . body) args) + (%case args len 0 () . rest))) + ((%case args len n p) + (error "case-lambda: no cases matched")))) + (define-syntax case-lambda + (syntax-rules () + ((case-lambda . clauses) + (lambda args (let ((len (length args))) (%case args len 0 () . clauses)))))))) + diff --git a/lib/srfi/2.module b/lib/srfi/2.module new file mode 100644 index 00000000..4ceb8b6b --- /dev/null +++ b/lib/srfi/2.module @@ -0,0 +1,16 @@ + +(define-module (srfi 2) + (export and-let*) + (import-immutable (scheme)) + (body + (define-syntax and-let* + (syntax-rules () + ((and-let* () . body) + (begin . body)) + ((and-let* ((var expr) . rest) . body) + (let ((var expr)) + (and var (and-let* rest . body)))) + ((and-let* ((expr) . rest) . body) + (let ((tmp expr)) + (and tmp (and-let* rest . body)))))))) + diff --git a/lib/srfi/26.module b/lib/srfi/26.module new file mode 100644 index 00000000..f97ab783 --- /dev/null +++ b/lib/srfi/26.module @@ -0,0 +1,24 @@ + +(define-module (srfi 26) + (export cut cute) + (import-immutable (scheme)) + (body + (define-syntax %cut + (syntax-rules (<> <...>) + ((%cut e? params args) + (lambda params args)) + ((%cut e? (params ...) (args ...) <> . rest) + (%cut e? (params ... tmp) (args ... tmp) . rest)) + ((%cut e? (params ...) (args ...) <...>) + (%cut e? (params ... . tmp) (apply args ... tmp))) + ((%cut e? (params ...) (args ...) <...> . rest) + (error "cut: non-terminal <...>")) + ((%cut #t (params ...) (args ...) x . rest) + (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest))) + ((%cut #f (params ...) (args ...) x . rest) + (%cut #t (params ...) (args ... x) . rest)))) + (define-syntax cut + (syntax-rules () ((cut args ...) (%cut #f () () args ...)))) + (define-syntax cute + (syntax-rules () ((cute args ...) (%cut #t () () args ...)))))) + diff --git a/lib/srfi/27.module b/lib/srfi/27.module new file mode 100644 index 00000000..5c451629 --- /dev/null +++ b/lib/srfi/27.module @@ -0,0 +1,11 @@ + +(define-module (srfi 27) + (export random-integer random-real default-random-source + make-random-source random-source? + random-source-state-ref random-source-state-set! + random-source-randomize! random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals) + (import-immutable (scheme)) + (include-shared "27/rand") + (include "27/constructors.scm")) + diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm new file mode 100644 index 00000000..dbd0a8c6 --- /dev/null +++ b/lib/srfi/27/constructors.scm @@ -0,0 +1,10 @@ +;; constructors.scm -- random function constructors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (random-source-make-integers rs) + (lambda (n) (%random-integer rs n))) + +(define (random-source-make-reals rs . o) + (lambda () (%random-real rs))) + diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c new file mode 100644 index 00000000..d5d3d984 --- /dev/null +++ b/lib/srfi/27/rand.c @@ -0,0 +1,204 @@ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include + +#define SEXP_RANDOM_STATE_SIZE 128 + +#define ZERO sexp_make_fixnum(0) +#define ONE sexp_make_fixnum(1) +#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE) + +#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id) + +#define sexp_random_init(x, seed) \ + initstate_r(seed, \ + sexp_string_data(sexp_random_state(x)), \ + SEXP_RANDOM_STATE_SIZE, \ + sexp_random_data(x)) + +#if SEXP_BSD +typedef unsigned int sexp_random_t; +#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs))) +#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n) +#else +typedef struct random_data sexp_random_t; +#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst) +#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs)) +#endif + +#define sexp_random_state(x) (sexp_slot_ref((x), 0)) +#define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1))) + +#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp)) + +static sexp_uint_t rs_type_id; +static sexp default_random_source; + +static sexp sexp_rs_random_integer (sexp ctx, sexp rs, sexp bound) { + sexp res; + int32_t n; +#if SEXP_USE_BIGNUMS + int32_t hi, mod, len, i, *data; +#endif + if (! sexp_random_source_p(rs)) + res = sexp_type_exception(ctx, "not a random-source", rs); + if (sexp_fixnump(bound)) { + sexp_call_random(rs, n); + res = sexp_make_fixnum(n % sexp_unbox_fixnum(bound)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(bound)) { + hi = sexp_bignum_hi(bound); + len = hi * sizeof(sexp_uint_t) / sizeof(int32_t); + res = sexp_make_bignum(ctx, hi); + data = (int32_t*) sexp_bignum_data(res); + for (i=0; i +#include + +#if SEXP_USE_BIGNUMS +#include +#else +#define sexp_bignum_normalize(x) x +#endif + +static sexp sexp_bit_and (sexp ctx, sexp x, sexp y) { + sexp res; +#if SEXP_USE_BIGNUMS + sexp_sint_t len, i; +#endif + if (sexp_fixnump(x)) { + if (sexp_fixnump(y)) + res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(y)) + res = sexp_bit_and(ctx, y, x); +#endif + else + res = sexp_type_exception(ctx, "bitwise-and: not an integer", y); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + if (sexp_fixnump(y)) { + res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); + } else if (sexp_bignump(y)) { + if (sexp_bignum_length(x) < sexp_bignum_length(y)) + res = sexp_copy_bignum(ctx, NULL, x, 0); + else + res = sexp_copy_bignum(ctx, NULL, y, 0); + for (i=0, len=sexp_bignum_length(res); i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i> -c); + } else { + tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c; +#if SEXP_USE_BIGNUMS + if (((tmp >> c) == sexp_unbox_fixnum(i)) + && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) { +#endif + res = sexp_make_fixnum(tmp); +#if SEXP_USE_BIGNUMS + } else { + sexp_gc_preserve1(ctx, res); + res = sexp_fixnum_to_bignum(ctx, i); + res = sexp_arithmetic_shift(ctx, res, count); + sexp_gc_release1(ctx); + } +#endif + } +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(i)) { + len = sexp_bignum_hi(i); + if (c < 0) { + c = -c; + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + if (len < offset) { + res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1); + } else { + res = sexp_make_bignum(ctx, len - offset + 1); + for (j=len-offset, tmp=0; j>=0; j--) { + sexp_bignum_data(res)[j] + = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp; + tmp = sexp_bignum_data(i)[j+offset] + << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + } + } else { + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + res = sexp_make_bignum(ctx, len + offset + 1); + for (j=tmp=0; j> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + sexp_bignum_data(res)[len+offset] = tmp; + } +#endif + } else { + res = sexp_type_exception(ctx, "arithmetic-shift: not an integer", i); + } + return sexp_bignum_normalize(res); +} + +/* bit-count and integer-length were adapted from: */ +/* http://graphics.stanford.edu/~seander/bithacks.html */ +static sexp_uint_t bit_count (sexp_uint_t i) { + i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3); + i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3) + + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3)); + i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15; + return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255)) + >> (sizeof(i) - 1) * CHAR_BIT); +} + +static sexp sexp_bit_count (sexp ctx, sexp x) { + sexp res; + sexp_sint_t i; +#if SEXP_USE_BIGNUMS + sexp_uint_t count; +#endif + if (sexp_fixnump(x)) { + i = sexp_unbox_fixnum(x); + res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + for (i=count=0; i> 32)) + return integer_log2(tt) + 32; + else +#endif + if ((tt = x >> 16)) + return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt]; + else + return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; +} + +static sexp sexp_integer_length (sexp ctx, sexp x) { + sexp_sint_t tmp; +#if SEXP_USE_BIGNUMS + sexp_sint_t hi; +#endif + if (sexp_fixnump(x)) { + tmp = sexp_unbox_fixnum(x); + return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + hi = sexp_bignum_hi(x); + return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi]) + + hi*sizeof(sexp_uint_t)); +#endif + } else { + return sexp_type_exception(ctx, "integer-length: not an integer", x); + } +} + +static sexp sexp_bit_set_p (sexp ctx, sexp i, sexp x) { +#if SEXP_USE_BIGNUMS + sexp_uint_t pos; +#endif + if (! sexp_fixnump(i)) + return sexp_type_exception(ctx, "bit-set?: not an integer", i); + if (sexp_fixnump(x)) { + return sexp_make_boolean(sexp_unbox_fixnum(x) & (1<hash-table + hash-table-equivalence-function hash-table-hash-function + hash-table-ref hash-table-ref/default hash-table-set! + hash-table-delete! hash-table-exists? + hash-table-update! hash-table-update!/default + hash-table-size hash-table-keys hash-table-values + hash-table-walk hash-table-fold hash-table->alist + hash-table-copy hash-table-merge! + hash string-hash string-ci-hash hash-by-identity) + (import-immutable (scheme) + (srfi 9)) + (include-shared "69/hash") + (include "69/type.scm" "69/interface.scm")) + diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c new file mode 100644 index 00000000..e38c23c0 --- /dev/null +++ b/lib/srfi/69/hash.c @@ -0,0 +1,242 @@ +/* hash.c -- type-general hashing */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define HASH_DEPTH 5 +#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM) + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0) +#define sexp_hash_table_size(x) sexp_slot_ref(x, 1) +#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2) +#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3) + +#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2)) + +static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc % bound; +} + +static sexp sexp_string_hash (sexp ctx, sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string-hash: not a string", str); + else if (! sexp_integerp(bound)) + return sexp_type_exception(ctx, "string-hash: not an integer", bound); + return sexp_make_fixnum(string_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= tolower(*str++);} + return acc % bound; +} + +static sexp sexp_string_ci_hash (sexp ctx, sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string-ci-hash: not a string", str); + else if (! sexp_integerp(bound)) + return sexp_type_exception(ctx, "string-ci-hash: not an integer", bound); + return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) { + sexp_uint_t acc = FNV_OFFSET_BASIS, size; + sexp_sint_t i, len; + sexp t, *p; + char *p0; + loop: +#if SEXP_USE_FLONUMS + if (sexp_flonump(obj)) + acc ^= (sexp_sint_t) sexp_flonum_value(obj); + else +#endif + if (sexp_pointerp(obj)) { + if (depth) { + t = sexp_object_type(ctx, obj); + p = (sexp*) (((char*)obj) + sexp_type_field_base(t)); + p0 = ((char*)obj) + offsetof(struct sexp_struct, value); + if ((sexp)p == obj) p=(sexp*)p0; + /* hash trailing non-object data */ + size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp)); + if (((char*)obj + size) > p0) + for (i=0; i 0) { + depth--; + for (i=0; ialist table) + (hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '())) + +(define (hash-table-keys table) + (hash-table-fold table (lambda (k v a) (cons k a)) '())) + +(define (hash-table-values table) + (hash-table-fold table (lambda (k v a) (cons v a)) '())) + +(define (alist->hash-table ls . o) + (let ((res (apply make-hash-table o))) + (for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls) + res)) + +(define (hash-table-merge! a b) + (hash-table-walk b (lambda (k v) (hash-table-set! a k v))) + a) + +(define (hash-table-copy table) + (assert-hash-table "hash-table-copy" table) + (let ((res (make-hash-table (hash-table-equivalence-function table)))) + (hash-table-merge! res table) + res)) + diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm new file mode 100644 index 00000000..1fca9953 --- /dev/null +++ b/lib/srfi/69/type.scm @@ -0,0 +1,12 @@ +;; types.scm -- the hash-table record type +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type hash-table + (%make-hash-table buckets size hash-fn eq-fn) + hash-table? + (buckets hash-table-buckets hash-table-buckets-set!) + (size hash-table-size hash-table-size-set!) + (hash-fn %hash-table-hash-function) + (eq-fn %hash-table-equivalence-function)) + diff --git a/lib/srfi/8.module b/lib/srfi/8.module new file mode 100644 index 00000000..64a3e6e2 --- /dev/null +++ b/lib/srfi/8.module @@ -0,0 +1,10 @@ + +(define-module (srfi 8) + (export receive) + (import-immutable (scheme)) + (body + (define-syntax receive + (syntax-rules () + ((receive params expr . body) + (call-with-values (lambda () expr) (lambda params . body))))))) + diff --git a/lib/srfi/9.module b/lib/srfi/9.module new file mode 100644 index 00000000..0516b201 --- /dev/null +++ b/lib/srfi/9.module @@ -0,0 +1,82 @@ + +(define-module (srfi 9) + (export define-record-type) + (import-immutable (scheme)) + (body + (define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((name (cadr expr)) + (make (caaddr expr)) + (make-fields (cdaddr expr)) + (pred (cadddr expr)) + (fields (cddddr expr)) + (num-fields (length fields)) + (index (register-simple-type (symbol->string name) num-fields)) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let))) + (define (index-of field ls) + (let lp ((ls ls) (i 0)) + (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) + `(,(rename 'begin) + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string pred) + ,index)) + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string (cadar ls)) + ,index + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string (caddar ls)) + ,index + ,i)) + res) + res))))) + (,_define ,make + ,(let lp ((ls make-fields) (sets '()) (set-defs '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string make) + ,index)) + ,@set-defs) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets) + set-defs)) + (else + (let* ((setter-name + (string-append "%" (symbol->string name) "-" + (symbol->string (car ls)) "-set!")) + (setter (rename (string->symbol setter-name))) + (i (index-of (car ls) fields))) + (lp (cdr ls) + (cons (list setter 'res (car ls)) sets) + (cons (list setter + (list (rename 'make-setter) + setter-name + index + (index-of (car ls) fields))) + set-defs))))))))))))))))) + diff --git a/lib/srfi/95.module b/lib/srfi/95.module new file mode 100644 index 00000000..25e0d3ff --- /dev/null +++ b/lib/srfi/95.module @@ -0,0 +1,7 @@ + +(define-module (srfi 95) + (export sorted? merge merge! sort sort!) + (import-immutable (scheme)) + (include-shared "95/qsort") + (include "95/sort.scm")) + diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c new file mode 100644 index 00000000..6b304e54 --- /dev/null +++ b/lib/srfi/95/qsort.c @@ -0,0 +1,170 @@ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var) + +static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) { + sexp_sint_t i; + sexp ls, *data=sexp_vector_data(vec); + for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls)) + sexp_car(ls) = data[i]; + return seq; +} + +static sexp sexp_vector_nreverse (sexp ctx, sexp vec) { + int i, j; + sexp tmp, *data=sexp_vector_data(vec); + for (i=0, j=sexp_vector_length(vec)-1; i 2) { + sexp_qsort(ctx, vec, lo, j-1); + lo = j+1; + goto loop; + } + } +} + +static sexp sexp_qsort_less (sexp ctx, sexp *vec, + sexp_sint_t lo, sexp_sint_t hi, + sexp less, sexp key) { + sexp_sint_t mid, i, j; + sexp tmp, res, args1; + sexp_gc_var3(a, b, args2); + sexp_gc_preserve3(ctx, a, b, args2); + args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID); + args1 = sexp_cdr(args2); + loop: + if (lo >= hi) { + res = SEXP_VOID; + } else { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + sexp_car(args1) = tmp; + b = sexp_apply(ctx, key, args1); + for (i=j=lo; i < hi; i++) { + sexp_car(args1) = vec[i]; + a = sexp_apply(ctx, key, args1); + sexp_car(args2) = a; + sexp_car(args1) = b; + res = sexp_apply(ctx, less, args2); + if (sexp_exceptionp(res)) + goto done; + else if (sexp_truep(res)) + swap(res, vec[i], vec[j]), j++; + } + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + res = sexp_qsort_less(ctx, vec, lo, j-1, less, key); + if (sexp_exceptionp(res)) + goto done; + lo = j+1; + goto loop; + } + } + done: + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_sort_x (sexp ctx, sexp seq, sexp less, sexp key) { + sexp_sint_t len; + sexp res, *data; + sexp_gc_var1(vec); + + if (sexp_nullp(seq)) return seq; + + sexp_gc_preserve1(ctx, vec); + + vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); + + if (! sexp_vectorp(vec)) { + res = sexp_type_exception(ctx, "sort: not a vector", vec); + } else { + data = sexp_vector_data(vec); + len = sexp_vector_length(vec); + if (sexp_not(key) && sexp_basic_comparator(less)) { + sexp_qsort(ctx, data, 0, len-1); + if (sexp_opcodep(less) && sexp_opcode_inverse(less)) + sexp_vector_nreverse(ctx, vec); + } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { + res = sexp_type_exception(ctx, "sort: not a procedure", less); + } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { + res = sexp_type_exception(ctx, "sort: not a procedure", less); + } else { + res = sexp_qsort_less(ctx, data, 0, len-1, less, key); + } + } + + if (sexp_pairp(seq)) + res = sexp_vector_copy_to_list(ctx, vec, seq); + else if (! sexp_exceptionp(res)) + res = vec; + + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE); + return SEXP_VOID; +} diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm new file mode 100644 index 00000000..38273199 --- /dev/null +++ b/lib/srfi/95/sort.scm @@ -0,0 +1,70 @@ +;; sort.scm -- SRFI-95 sorting utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (copy seq) + (if (vector? seq) + (let* ((len (vector-length seq)) + (res (make-vector len))) + (do ((i (- len 1) (- i 1))) + ((< i 0) res) + (vector-set! res i (vector-ref seq i)))) + (map (lambda (x) x) seq))) + +(define (sort seq . o) + (let ((less (and (pair? o) (car o))) + (key (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (sort! (copy seq) less key))) + +(define (sorted? seq less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (cond + ((vector? seq) + (let ((len (- (vector-length seq) 1))) + (let lp ((i 0)) + (cond + ((>= i len) #t) + ((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f) + (else (lp (+ i 1))))))) + ((null? seq) + #f) + (else + (let lp ((ls1 seq) (ls2 (cdr seq))) + (cond ((null? ls2) #t) + ((less (key (car ls2)) (key (car ls1))) #f) + (else (lp ls2 (cdr ls2))))))))) + +(define (merge! ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (define (lp prev ls1 ls2 a b less key) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))) + (else + (set-cdr! prev ls2) + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))))) + (cond + ((null? ls1) ls2) + ((null? ls2) ls1) + (else + (let ((a (key (car ls1))) + (b (key (car ls2)))) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)) + ls1) + (else + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)) + ls2))))))) + +(define (merge ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (merge! (copy ls1) (copy ls2) less key))) diff --git a/lib/srfi/98.module b/lib/srfi/98.module new file mode 100644 index 00000000..9d124d66 --- /dev/null +++ b/lib/srfi/98.module @@ -0,0 +1,5 @@ + +(define-module (srfi 98) + (export get-environment-variable get-environment-variables) + (include-shared "98/env")) + diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c new file mode 100644 index 00000000..38f8b883 --- /dev/null +++ b/lib/srfi/98/env.c @@ -0,0 +1,48 @@ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifdef __APPLE__ +#include +#define environ (*_NSGetEnviron()) +#else +extern char **environ; +#endif + +#include + +sexp sexp_get_environment_variable (sexp ctx, sexp str) { + char *cstr; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "get-environment-variable: not a string", str); + cstr = getenv(sexp_string_data(str)); + return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE; +} + +sexp sexp_get_environment_variables (sexp ctx) { + int i; + char **env, *cname, *cval; + sexp_gc_var3(res, name, val); + sexp_gc_preserve3(ctx, res, name, val); + res = SEXP_NULL; + env = environ; + for (i=0; env[i]; i++) { + cname = env[i]; + cval = strchr(cname, '='); + if (cval) { + name = sexp_c_string(ctx, cname, cval-cname); + val = sexp_c_string(ctx, cval+1, -1); + val = sexp_cons(ctx, name, val); + res = sexp_cons(ctx, val, res); + } + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable); + sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables); + return SEXP_VOID; +} + diff --git a/main.c b/main.c new file mode 100644 index 00000000..6edd9185 --- /dev/null +++ b/main.c @@ -0,0 +1,193 @@ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define sexp_argv_symbol "*command-line-arguments*" +#define sexp_argv_proc "(define (command-line-arguments) "sexp_argv_symbol")" + +#define sexp_import_prefix "(import (" +#define sexp_import_suffix "))" + +#ifdef PLAN9 +#define exit_failure() exits("ERROR") +#else +#define exit_failure() exit(70) +#endif + +static void repl (sexp ctx) { + sexp in, out, err; + sexp_gc_var4(obj, tmp, res, env); + sexp_gc_preserve4(ctx, obj, tmp, res, env); + env = sexp_context_env(ctx); + sexp_context_tracep(ctx) = 1; + in = sexp_eval_string(ctx, "(current-input-port)", env); + out = sexp_eval_string(ctx, "(current-output-port)", env); + err = sexp_eval_string(ctx, "(current-error-port)", env); + 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, env); + if (sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, err); + } else { +#if SEXP_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_release4(ctx); +} + +static sexp check_exception (sexp ctx, sexp res) { + sexp err; + if (res && sexp_exceptionp(res)) { + err = sexp_current_error_port(ctx); + if (! sexp_oportp(err)) + err = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_print_exception(ctx, res, err); + exit_failure(); + } + return res; +} + +#define init_context() if (! ctx) do { \ + ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \ + env = sexp_context_env(ctx); \ + sexp_gc_preserve2(ctx, tmp, args); \ + } while (0) + +#define load_init() if (! init_loaded++) do { \ + init_context(); \ + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \ + } while (0) + +void run_main (int argc, char **argv) { + char *arg, *impmod, *p; + sexp env, out=SEXP_FALSE, res=SEXP_VOID, ctx=NULL; + sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0; + sexp_uint_t heap_size=0; + sexp_gc_var2(tmp, args); + args = SEXP_NULL; + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + case 'p': + load_init(); + print = (argv[i][1] == 'p'); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + res = check_exception(ctx, sexp_read_from_string(ctx, arg)); + res = check_exception(ctx, sexp_eval(ctx, res, env)); + if (print) { + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", env); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + quit = 1; + i++; + break; + case 'l': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_exception(ctx, sexp_load_module_file(ctx, argv[++i], env)); + break; + case 'm': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); + impmod = (char*) malloc(len+1); + strcpy(impmod, sexp_import_prefix); + strcpy(impmod+strlen(sexp_import_prefix), arg); + strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix); + impmod[len] = '\0'; + for (p=impmod; *p; p++) + if (*p == '.') *p=' '; + check_exception(ctx, sexp_eval_string(ctx, impmod, env)); + free(impmod); + break; + case 'q': + init_context(); + if (! init_loaded++) sexp_load_standard_parameters(ctx, env); + break; + case 'A': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); + break; + case 'I': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); + break; + case '-': + i++; + goto done_options; + case 'h': + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + heap_size = atol(arg); + len = strlen(arg); + if (heap_size && isalpha(arg[len-1])) { + switch (tolower(arg[len-1])) { + case 'k': heap_size *= 1024; break; + case 'm': heap_size *= (1024*1024); break; + } + } + break; + case 'V': + printf("chibi-scheme 0.3\n"); + return; + default: + fprintf(stderr, "unknown option: %s\n", argv[i]); + exit_failure(); + } + } + + done_options: + if (! quit) { + load_init(); + if (i < argc) + for (j=argc-1; j>i; j--) + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); + else + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); + sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol), args); + sexp_eval_string(ctx, sexp_argv_proc, env); + if (i < argc) { /* script usage */ + check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); + tmp = sexp_intern(ctx, "main"); + tmp = sexp_env_ref(env, tmp, SEXP_FALSE); + if (sexp_procedurep(tmp)) { + args = sexp_list1(ctx, args); + check_exception(ctx, sexp_apply(ctx, tmp, args)); + } + } else { + repl(ctx); + } + } + + sexp_gc_release2(ctx); +} + +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..fdce3e9f --- /dev/null +++ b/mkfile @@ -0,0 +1,26 @@ + include/chibi/install.h + echo '#define sexp_platform "plan9"' >> include/chibi/install.h + +install:V: $BIN/$TARG + test -d $MODDIR || mkdir -p $MODDIR + cp -r lib/* $MODDIR/ + +test:V: + ./$O.out tests/r5rs-tests.scm + +sexp.c:N: gc.c opt/bignum.c diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..d3c77865 --- /dev/null +++ b/opcodes.c @@ -0,0 +1,153 @@ + +#define _OP(c,o,n,m,t,u,i,s,d,f) \ + {.tag=SEXP_OPCODE, \ + .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}} +#define _FN(o,n,m,t,u,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f) +#define _FN0(s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, 0, 0, s, d, f) +#define _FN1(t, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, t, 0, s, d, f) +#define _FN1OPT(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, t, u, s, d, f) +#define _FN1OPTP(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, t, 0, s, d, f) +#define _FN2(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, t, u, s, d, f) +#define _FN2OPT(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, t, u, s, d, f) +#define _FN2OPTP(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, t, u, s, d, f) +#define _FN3(t, u, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, t, u, s, d, f) +#define _FN4(t, u, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, t, u, s, d, f) +#define _FN5(t, u, s, d, f) _FN(SEXP_OP_FCALL5, 5, 0, t, u, s, d, f) +#define _FN6(t, u, s, d, f) _FN(SEXP_OP_FCALL6, 6, 0, t, u, s, d, f) +#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, 0, 0, n, a, 0) + +static struct sexp_struct opcodes[] = { +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_fixnum(0), NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_fixnum(1), NULL), +_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_SUB, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_NEGATIVE, "-", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_DIV, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_INVERSE, "/", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), +#if SEXP_USE_IMMEDIATE_FLONUMS +_FN1(0, "flonum?", 0, sexp_flonum_predicate), +#else +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), +#endif +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read), +_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write), +_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display), +_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output), +_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), +_FN0("make-environment", 0, sexp_make_env), +_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), +_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), +_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval), +_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load), +_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), +_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), +_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), +_FN1(0, "strip-syntactic-closures", 0, sexp_strip_synclos), +_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), +_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 SEXP_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), +#endif +_FN2(0, 0, "expt", 0, sexp_expt), +#if SEXP_USE_TYPE_DEFS +_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter), +#endif +#if PLAN9 +#include "opt/plan9-opcodes.c" +#endif +#if SEXP_USE_MODULES +_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports), +_FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), +_FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), +_FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory), +#endif +}; + diff --git a/opt/bignum.c b/opt/bignum.c new file mode 100644 index 00000000..60215de8 --- /dev/null +++ b/opt/bignum.c @@ -0,0 +1,751 @@ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_INIT_BIGNUM_SIZE 2 + +#define sexp_negate(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_fixnump(x)) \ + x = sexp_fx_neg(x); + +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { + sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + sexp_bignum_length(res) = len; + sexp_bignum_sign(res) = 1; + return res; +} + +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { + sexp res = sexp_make_bignum(ctx, 1); + sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a)); + sexp_bignum_sign(res) = sexp_fx_sign(a); + return res; +} + +sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { + sexp res; + if ((SEXP_MIN_FIXNUM < x) && (x < SEXP_MAX_FIXNUM)) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + if (x < 0) { + sexp_bignum_sign(res) = -1; + sexp_bignum_data(res)[0] = -x; + } else { + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + } + return res; +} + +sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { + sexp res; + if (x < SEXP_MAX_FIXNUM) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + return res; +} + +#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) +#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) + +sexp sexp_double_to_bignum (sexp ctx, double f) { + int sign; + sexp_gc_var3(res, scale, tmp); + sexp_gc_preserve3(ctx, res, scale, tmp); + res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0)); + scale = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + sign = (f < 0 ? -1 : 1); + for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { + tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); + res = sexp_bignum_add(ctx, res, res, tmp); + scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); + } + sexp_bignum_sign(res) = sign; + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { + sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size; + size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + if (! dst || sexp_bignum_length(dst) < len) { + dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + memcpy(dst, a, size); + sexp_bignum_length(dst) = len; + } else { + memset(dst->value.bignum.data, 0, + sexp_bignum_length(dst)*sizeof(sexp_uint_t)); + memcpy(dst->value.bignum.data, a->value.bignum.data, + sexp_bignum_length(a)*sizeof(sexp_uint_t)); + } + return dst; +} + +int sexp_bignum_zerop (sexp a) { + int i; + sexp_uint_t *data = sexp_bignum_data(a); + for (i=sexp_bignum_length(a)-1; i>=0; i--) + if (data[i]) + return 0; + return 1; +} + +sexp_uint_t sexp_bignum_hi (sexp a) { + sexp_uint_t i=sexp_bignum_length(a)-1; + while ((i>0) && ! sexp_bignum_data(a)[i]) + i--; + return i+1; +} + +sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) { + int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b); + sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b); + if (ai != bi) + return ai - bi; + for (--ai; ai >= 0; ai--) { + if (adata[ai] > bdata[ai]) + return 1; + else if (adata[ai] < bdata[ai]) + return -1; + } + return 0; +} + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { + if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) + return sexp_bignum_sign(a); + return sexp_bignum_compare_abs(a, b); +} + +sexp sexp_bignum_normalize (sexp a) { + sexp_uint_t *data; + if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) + return a; + data = sexp_bignum_data(a); + if ((data[0] > SEXP_MAX_FIXNUM) + && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1))) + return a; + return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a)); +} + +double sexp_bignum_to_double (sexp a) { + double res = 0; + sexp_uint_t i, *data=sexp_bignum_data(a); + for (i=0; i (SEXP_UINT_T_MAX - carry)); + } while (++i> (sizeof(sexp_uint_t)*8); + } + if (carry) { + if (sexp_bignum_length(d)+offset <= len) + d = sexp_copy_bignum(ctx, NULL, d, len+offset+1); + sexp_bignum_data(d)[len+offset] = carry; + } + return d; +} + +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0; + int i; + sexp_luint_t n = 0; + for (i=len-1; i>=offset; i--) { + n = (n << sizeof(sexp_uint_t)*8) + data[i]; + q = n / b; + r = n - (sexp_luint_t)q * b; + data[i] = q; + n = r; + } + return r; +} + +sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, + char sign, sexp_uint_t base) { + int c, digit; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE); + sexp_bignum_sign(res) = sign; + sexp_bignum_data(res)[0] = init; + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + res = sexp_bignum_fxmul(ctx, res, res, base, 0); + res = sexp_bignum_fxadd(ctx, res, digit); + } + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); + } else if ((c!=EOF) && ! is_separator(c)) { + res = sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + } + sexp_push_char(ctx, c, in); + sexp_gc_release1(ctx); + return sexp_bignum_normalize(res); +} + +static int log2i(int v) { + int i; + for (i = 0; i < sizeof(v)*8; i++) + if ((1<<(i+1)) > v) + break; + return i; +} + +sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { + int i, str_len, lg_base = log2i(base); + char *data; + sexp_gc_var2(b, str); + sexp_gc_preserve2(ctx, b, str); + b = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(b) = 1; + i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) + / lg_base + 1; + str = sexp_make_string(ctx, sexp_make_fixnum(str_len), + sexp_make_character(' ')); + data = sexp_string_data(str); + while (! sexp_bignum_zerop(b)) + data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0)); + if (i == str_len) + data[--i] = '0'; + else if (sexp_bignum_sign(a) == -1) + data[--i] = '-'; + sexp_write_string(ctx, data + i, out); + sexp_gc_release2(ctx); + return SEXP_VOID; +} + +/****************** bignum arithmetic *************************/ + +sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(c); + sexp_gc_preserve1(ctx, c); + c = sexp_copy_bignum(ctx, NULL, a, 0); + if (sexp_bignum_sign(c) == sexp_fx_sign(b)) + c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + else + c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + sexp_gc_release1(ctx); + return c; +} + +sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), + borrow=0, i, *adata, *bdata, *cdata; + sexp_gc_var1(c); + if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) + return sexp_bignum_sub_digits(ctx, dst, b, a); + sexp_gc_preserve1(ctx, c); + c = ((dst && sexp_bignum_hi(dst) >= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0); + } + for ( ; carry && (i= 0 ? a : b); + } + return res; +} + +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { + sexp res; + if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { + res = sexp_bignum_sub_digits(ctx, dst, a, b); + sexp_bignum_sign(res) + = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a) + : -sexp_bignum_sign(a)); + } else { + res = sexp_bignum_add_digits(ctx, dst, a, b); + sexp_bignum_sign(res) = sexp_bignum_sign(a); + } + return res; +} + +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, + *bdata=sexp_bignum_data(b); + sexp_gc_var2(c, d); + if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); + sexp_gc_preserve2(ctx, c, d); + c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); + d = sexp_make_bignum(ctx, alen+blen+1); + for (i=0; i 0) { + *rem = a; + return sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0)); + } + sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); + k2 = sexp_bignum_double(ctx, k); + i2 = sexp_bignum_double(ctx, i); + x = quot_step(ctx, rem, a, b, k2, i2); + prod = sexp_bignum_mul(ctx, NULL, x, b); + diff = sexp_bignum_sub_digits(ctx, NULL, a, prod); + if (sexp_bignum_compare(diff, k) >= 0) { + *rem = sexp_bignum_sub_digits(ctx, NULL, diff, k); + res = sexp_bignum_add_digits(ctx, NULL, x, i); + } else { + *rem = diff; + res = x; + } + sexp_gc_release5(ctx); + return res; +} + +sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { + sexp res; + sexp_gc_var4(k, i, a1, b1); + sexp_gc_preserve4(ctx, k, i, a1, b1); + a1 = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(a1) = 1; + b1 = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_bignum_sign(b1) = 1; + k = sexp_copy_bignum(ctx, NULL, b1, 0); + i = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + res = quot_step(ctx, rem, a1, b1, k, i); + sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); + if (sexp_bignum_sign(a) < 0) { + sexp_negate(*rem); + } + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { + sexp res; + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + res = sexp_bignum_quot_rem(ctx, &rem, a, b); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { + sexp rem; + sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */ + return rem; +} + +sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { + sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b)); + sexp_gc_var2(res, acc); + sexp_gc_preserve2(ctx, res, acc); + res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + acc = sexp_copy_bignum(ctx, NULL, a, 0); + for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) + if (e & 1) + res = sexp_bignum_mul(ctx, NULL, res, acc); + sexp_gc_release2(ctx); + return res; +} + +/****************** generic arithmetic ************************/ + +enum sexp_number_types { + SEXP_NUM_NOT = 0, + SEXP_NUM_FIX, + SEXP_NUM_FLO, + SEXP_NUM_BIG +}; + +enum sexp_number_combs { + SEXP_NUM_NOT_NOT = 0, + SEXP_NUM_NOT_FIX, + SEXP_NUM_NOT_FLO, + SEXP_NUM_NOT_BIG, + SEXP_NUM_FIX_NOT, + SEXP_NUM_FIX_FIX, + SEXP_NUM_FIX_FLO, + SEXP_NUM_FIX_BIG, + SEXP_NUM_FLO_NOT, + SEXP_NUM_FLO_FIX, + SEXP_NUM_FLO_FLO, + SEXP_NUM_FLO_BIG, + SEXP_NUM_BIG_NOT, + SEXP_NUM_BIG_FIX, + SEXP_NUM_BIG_FLO, + SEXP_NUM_BIG_BIG +}; + +static int sexp_number_types[] = + {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, 0}; + +static int sexp_number_type (sexp a) { + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] +#if SEXP_USE_IMMEDIATE_FLONUMS + : sexp_flonump(a) ? 2 +#endif + : sexp_fixnump(a); +} + +sexp sexp_add (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "+: not a number", a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_add(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_add(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_add(ctx, NULL, b, a)); + break; + } + return r; +} + +sexp sexp_sub (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "-: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "-: not a number", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_sub(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a)); + sexp_negate(r); + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)+sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_sub(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, sexp_fixnum_to_bignum(ctx, b))); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_flonum_value(b) - sexp_bignum_to_double(a)); + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); + break; + } + return r; +} + +sexp sexp_mul (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "*: not a number", a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_mul(a, b); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0); + sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_mul(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_mul(ctx, NULL, a, b); + break; + } + return r; +} + +sexp sexp_div (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + double f; + sexp r=SEXP_VOID, rem; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "/: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "/: not a number", b); + break; + case SEXP_NUM_FIX_FIX: + f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b); + r = ((f == trunc(f)) ? sexp_make_fixnum((sexp_sint_t)f) + : sexp_make_flonum(ctx, f)); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)/sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_div(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_quot_rem(ctx, &rem, a, b); + if (sexp_bignum_normalize(rem) != sexp_make_fixnum(0)) + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) + / sexp_fixnum_to_double(b)); + else + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b)); + break; + } + return r; +} + +sexp sexp_quotient (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "quotient: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "quotient: not a number", b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_div(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(0); + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b)); + break; + } + return r; +} + +sexp sexp_remainder (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "remainder: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "remainder: not a number", b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_rem(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = a; + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b)); + break; + } + return r; +} + +sexp sexp_compare (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + double f; + if (at > bt) { + r = sexp_compare(ctx, b, a); + sexp_negate(r); + } else { + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "compare: not a number", a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); + break; + case SEXP_NUM_FIX_FLO: + f = sexp_fixnum_to_double(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(-1); + break; + case SEXP_NUM_FLO_FLO: + f = sexp_flonum_value(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FLO_BIG: + f = sexp_flonum_value(a) - sexp_bignum_to_double(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_make_fixnum(sexp_bignum_compare(a, b)); + break; + } + } + return r; +} + diff --git a/opt/plan9-opcodes.c b/opt/plan9-opcodes.c new file mode 100644 index 00000000..9f7cac33 --- /dev/null +++ b/opt/plan9-opcodes.c @@ -0,0 +1,19 @@ +_FN0("random-integer", 0, sexp_rand), +_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), +_FN0("current-directory", 0, sexp_getwd), +_FN0("current-user", 0, sexp_getuser), +_FN0("system-name", 0, sexp_sysname), +_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), +_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), +_FN0("fork", 0, sexp_fork), +_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), +_FN1(SEXP_STRING, "exits", 0, sexp_exits), +_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), +_FN0("pipe", 0, sexp_pipe), +_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), +_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), +_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), +_FN0("wait", 0, sexp_wait), +_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), +_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), +_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), diff --git a/opt/plan9.c b/opt/plan9.c new file mode 100644 index 00000000..b103912a --- /dev/null +++ b/opt/plan9.c @@ -0,0 +1,351 @@ +/* plan9.c -- extended Plan 9 system utils */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +sexp sexp_rand (sexp ctx) { + return sexp_make_fixnum(rand()); +} + +sexp sexp_srand (sexp ctx, sexp seed) { + srand(sexp_unbox_fixnum(seed)); + return SEXP_VOID; +} + +sexp sexp_file_exists_p (sexp ctx, sexp path) { + int res; + uchar statbuf[STATMAX]; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "file-exists?: not a string", path); + res = stat(sexp_string_data(path), statbuf, sizeof(statbuf)); + return (res < 0) ? SEXP_FALSE : SEXP_TRUE; +} + +sexp sexp_fdopen (sexp ctx, sexp fd, sexp mode) { + FILE *f; + if (! sexp_integerp(fd)) + return sexp_type_exception(ctx, "fdopen: not an integer", fd); + if (! sexp_stringp(mode)) + return sexp_type_exception(ctx, "fdopen: not a mode string", mode); + f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode)); + if (! f) + return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd); + /* maybe use fd2path to get the name of the fd */ + if (sexp_string_data(mode)[0] == 'w') + return sexp_make_output_port(ctx, f, SEXP_FALSE); + else + return sexp_make_input_port(ctx, f, SEXP_FALSE); +} + +sexp sexp_fileno (sexp ctx, sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "fileno: not a port", port); + return sexp_make_fixnum(fileno(sexp_port_stream(port))); +} + +sexp sexp_fork (sexp ctx) { + return sexp_make_fixnum(fork()); +} + +sexp sexp_exec (sexp ctx, sexp name, sexp args) { + int i, len = sexp_unbox_fixnum(sexp_length(ctx, args)); + char **argv = malloc((len+1)*sizeof(char*)); + for (i=0; imsg, -1); + res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg); + sexp_gc_release(ctx, msg, s_msg); + return res; +} + +sexp sexp_postnote (sexp ctx, sexp pid, sexp note) { + if (! sexp_integerp(pid)) + return sexp_type_exception(ctx, "postnote: not an integer", pid); + if (! sexp_stringp(note)) + return sexp_type_exception(ctx, "postnote: not a string", note); + postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note)); + return SEXP_VOID; +} + +/**********************************************************************/ +/* 9p interface */ + +typedef struct sexp_plan9_srv { + sexp context, auth, attach, walk, walk1, clone, open, create, remove, + read, write, stat, wstat, flush, destroyfid, destroyreq, end; +} *sexp_plan9_srv; + +void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) { + s->context = ctx; + s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open + = s->create = s->remove = s->read = s->write = s->stat = s->wstat + = s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE; + for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) { + if (sexp_car(ls) == sexp_intern(ctx, "auth:")) { + s->auth = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "attach:")) { + s->attach = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk:")) { + s->walk = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:")) { + s->walk1 = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "clone:")) { + s->clone = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "open:")) { + s->open = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "create:")) { + s->create = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "remove:")) { + s->remove = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "read:")) { + s->read = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "write:")) { + s->write = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "stat:")) { + s->stat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:")) { + s->wstat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "flush:")) { + s->flush = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:")) { + s->destroyfid = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:")) { + s->destroyreq = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "end:")) { + s->end = sexp_cadr(ls); + } + } +} + +void sexp_run_9p_handler (Req *r, sexp handler) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, handler, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +#define sexp_def_9p_handler(name, field) \ + void name (Req *r) { \ + sexp_run_9p_handler(r, ((sexp_plan9_srv)r->srv->aux)->field); \ + } + +sexp_def_9p_handler(sexp_9p_auth, auth) +sexp_def_9p_handler(sexp_9p_attach, attach) +sexp_def_9p_handler(sexp_9p_walk, walk) +sexp_def_9p_handler(sexp_9p_open, open) +sexp_def_9p_handler(sexp_9p_create, create) +sexp_def_9p_handler(sexp_9p_remove, remove) +sexp_def_9p_handler(sexp_9p_read, read) +sexp_def_9p_handler(sexp_9p_write, write) +sexp_def_9p_handler(sexp_9p_stat, stat) +sexp_def_9p_handler(sexp_9p_wstat, wstat) +sexp_def_9p_handler(sexp_9p_flush, flush) + +char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_c_string(ctx, name, -1); + args = sexp_cons(ctx, ptr, args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->walk1, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +char* sexp_9p_clone (Fid *oldfid, Fid *newfid) { + sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->clone, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +void sexp_9p_destroyfid (Fid *fid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyfid, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_destroyreq (Req *r) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyreq, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_end (Srv *srv) { + sexp_plan9_srv s = (sexp_plan9_srv)srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->end, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +sexp sexp_postmountsrv (sexp ctx, sexp ls, sexp name, sexp mtpt, sexp flags) { + Srv s; + struct sexp_plan9_srv p9s; + if (! sexp_listp(ctx, ls)) + return sexp_type_exception(ctx, "postmountsrv: not a list", ls); + if (! sexp_stringp(name)) + return sexp_type_exception(ctx, "postmountsrv: not a string", name); + if (! sexp_stringp(mtpt)) + return sexp_type_exception(ctx, "postmountsrv: not a string", mtpt); + if (! sexp_integerp(flags)) + return sexp_type_exception(ctx, "postmountsrv: not an integer", flags); + sexp_build_srv(ctx, &p9s, ls); + s.aux = &p9s; + s.auth = &sexp_9p_auth; + s.attach = &sexp_9p_attach; + s.walk = &sexp_9p_walk; + s.walk1 = &sexp_9p_walk1; + s.clone = &sexp_9p_clone; + s.open = &sexp_9p_open; + s.create = &sexp_9p_create; + s.remove = &sexp_9p_remove; + s.read = &sexp_9p_read; + s.write = &sexp_9p_write; + s.stat = &sexp_9p_stat; + s.wstat = &sexp_9p_wstat; + s.flush = &sexp_9p_flush; + s.destroyfid = &sexp_9p_destroyfid; + s.destroyreq = &sexp_9p_destroyreq; + s.end = &sexp_9p_end; + postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt), + sexp_unbox_fixnum(flags)); + return SEXP_UNDEF; +} + +sexp sexp_9p_req_offset (sexp ctx, sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset); +} + +sexp sexp_9p_req_count (sexp ctx, sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count); +} + +#if 0 +sexp sexp_9p_req_path (sexp ctx, sexp req) { + return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1); +} +#endif + +sexp sexp_9p_req_fid (sexp ctx, sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0); +} + +sexp sexp_9p_req_newfid (sexp ctx, sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0); +} + +sexp sexp_9p_respond (sexp ctx, sexp req, sexp err) { + char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil; + respond(sexp_cpointer_value(req), cerr); + return SEXP_VOID; +} + +sexp sexp_9p_responderror (sexp ctx, sexp req) { + responderror(sexp_cpointer_value(req)); + return SEXP_VOID; +} + 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/opt/simplify.c b/opt/simplify.c new file mode 100644 index 00000000..d4ac576d --- /dev/null +++ b/opt/simplify.c @@ -0,0 +1,135 @@ +/* simplify.c -- basic simplification pass */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda)) + +static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { + int check; + sexp ls1, ls2, p1, p2, sv, ctx2; + sexp_gc_var4(res, substs, tmp, app); + sexp_gc_preserve4(ctx, res, substs, tmp, app); + res = ast; /* return the ast as-is by default */ + substs = init_substs; + + loop: + switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) { + + case SEXP_PAIR: + /* don't simplify the operator if it's a lambda because we + simplify that as a special case below, with the appropriate + substs list */ + app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res) + : (tmp=simplify(ctx, sexp_car(res), substs, lambda))); + for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); + app = sexp_nreverse(ctx, app); + if (sexp_opcodep(sexp_car(app))) { + if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) { + for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { + if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { + check = 0; + break; + } + } + if (check) { + ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0); + generate(ctx2, app); + app = finalize_bytecode(ctx2); + if (! sexp_exceptionp(app)) { + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + app = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, app, tmp); + if (! sexp_exceptionp(app)) + app = sexp_apply(ctx2, app, SEXP_NULL); + } + } + } + } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */ + p1 = NULL; + p2 = sexp_lambda_params(sexp_car(app)); + ls1 = app; + ls2 = sexp_cdr(app); + sv = sexp_lambda_sv(sexp_car(app)); + for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) { + if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv)) + && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2)) + || (sexp_refp(sexp_car(ls2)) + && sexp_lambdap(sexp_ref_loc(sexp_car(ls2)))))) { + tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2)); + tmp = sexp_cons(ctx, sexp_car(p2), tmp); + sexp_push(ctx, substs, tmp); + sexp_cdr(ls1) = sexp_cdr(ls2); + if (p1) + sexp_cdr(p1) = sexp_cdr(p2); + else + sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2); + } else { + p1 = p2; + ls1 = ls2; + } + } + sexp_lambda_body(sexp_car(app)) + = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app)); + if (sexp_nullp(sexp_cdr(app)) + && sexp_nullp(sexp_lambda_params(sexp_car(app))) + && sexp_nullp(sexp_lambda_defs(sexp_car(app)))) + app = sexp_lambda_body(sexp_car(app)); + } + res = app; + break; + + case SEXP_LAMBDA: + sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res); + break; + + case SEXP_CND: + tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda); + if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) { + res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp)) + ? sexp_cnd_fail(res) : sexp_cnd_pass(res); + goto loop; + } else { + sexp_cnd_test(res) = tmp; + simplify_it(sexp_cnd_pass(res)); + simplify_it(sexp_cnd_fail(res)); + } + break; + + case SEXP_REF: + tmp = sexp_ref_name(res); + for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) { + res = sexp_cddar(ls1); + break; + } + break; + + case SEXP_SET: + simplify_it(sexp_set_value(res)); + break; + + case SEXP_SEQ: + app = SEXP_NULL; + for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { + tmp = simplify(ctx, sexp_car(ls2), substs, lambda); + if (! (sexp_pairp(sexp_cdr(ls2)) + && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) + || sexp_lambdap(tmp)))) + sexp_push(ctx, app, tmp); + } + if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app))) + res = sexp_car(app); + else + sexp_seq_ls(res) = sexp_nreverse(ctx, app); + break; + + } + + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_simplify (sexp ctx, sexp ast) { + return simplify(ctx, ast, SEXP_NULL, NULL); +} + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..a4aa5efc --- /dev/null +++ b/sexp.c @@ -0,0 +1,1662 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* optional huffman-compressed immediate symbols */ +struct sexp_huff_entry { + unsigned char len; + unsigned short bits; +}; + +#if SEXP_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; + +sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp); + +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 (int c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int hex_digit (int n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + +static int is_separator(int c) { + return 0= SEXP_MAXIMUM_TYPES) { + res = sexp_user_exception(ctx, SEXP_FALSE, "register-type: exceeded maximum type limit", name); + } else if (! sexp_stringp(name)) { + res = sexp_type_exception(ctx, "register-type: not a string", name); + } else { + if (num_types >= type_array_size) { + len = type_array_size*2; + if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES; +#if SEXP_USE_GLOBAL_TYPES + new = malloc(len * sizeof(_sexp_type_specs[0])); + for (i=0; i num_types) free(tmp); + sexp_type_array_size = len; +#else + res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID); + v1 = sexp_vector_data(res); + v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)); + for (i=0; i= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(sexp_exception_message(exn))) + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); + else + sexp_write(ctx, 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_var4(sym, name, str, irr); + sexp_gc_preserve4(ctx, sym, name, str, irr); + name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); + name = sexp_cons(ctx, name, sexp_make_fixnum(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, sym = sexp_intern(ctx, "read"), + str, irr, SEXP_FALSE, name); + sexp_gc_release4(ctx); + return res; +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons (sexp ctx, sexp head, sexp tail) { + sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); + if (sexp_exceptionp(pair)) return 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_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release1(ctx); + 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_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(ctx, sexp_car(ls), res); + sexp_gc_release1(ctx); + 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_type_exception(ctx, "not a list", ls); + } 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_var2(a1, b1); + sexp_gc_preserve2(ctx, a1, 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_release2(ctx); + 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_fixnum(res); +} + +sexp sexp_equalp (sexp ctx, sexp a, sexp b) { + sexp_uint_t size; + sexp_sint_t i, len; + sexp t, *p, *q; + char *p0, *q0; + + loop: + if (a == b) + return SEXP_TRUE; + else if ((! sexp_pointerp(a)) || (! sexp_pointerp(b)) + || (sexp_pointer_tag(a) != sexp_pointer_tag(b))) + return SEXP_FALSE; + + /* a and b are both pointers of the same type */ +#if SEXP_USE_BIGNUMS + if (sexp_pointer_tag(a) == SEXP_BIGNUM) + return sexp_make_boolean(!sexp_bignum_compare(a, b)); +#endif +#if SEXP_USE_FLONUMS && ! SEXP_USE_IMMEDIATE_FLONUMS + if (sexp_pointer_tag(a) == SEXP_FLONUM) + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); +#endif + t = sexp_object_type(ctx, a); + p0 = ((char*)a) + offsetof(struct sexp_struct, value); + p = (sexp*) (((char*)a) + sexp_type_field_base(t)); + q0 = ((char*)b) + offsetof(struct sexp_struct, value); + q = (sexp*) (((char*)b) + sexp_type_field_base(t)); + if ((sexp)p == a) {p=(sexp*)p0; q=(sexp*)q0;} + /* check preliminary non-object data */ + if ((p0 < (char*)p) && memcmp(p0, q0, ((char*)p - p0))) + return SEXP_FALSE; + /* check trailing non-object data */ + size = sexp_type_size_of_object(t, a) - offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,a)*sizeof(sexp)); + if (((char*)a + size) > p0) { + q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp)); + if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value)) + return SEXP_FALSE; + if (memcmp(p0, q0, size)) + return SEXP_FALSE; + } + /* check eq-object slots */ + len = sexp_type_num_eq_slots_of_object(t, a); + if (len > 0) { + for (i=0; i> 32; + return r.flonum; +} +sexp sexp_make_flonum (sexp ctx, float f) { + union sexp_flonum_conv x; + x.flonum = f; + return (sexp)(((sexp_uint_t)(x.bits) << 32) + SEXP_IFLONUM_TAG); +} +#endif +#endif + +sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { + sexp_sint_t clen = sexp_unbox_fixnum(len); + sexp s; + if (! sexp_fixnump(len)) return sexp_type_exception(ctx, "bad length", len); + if (clen < 0) return sexp_type_exception(ctx, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); + if (sexp_exceptionp(s)) return s; + 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_fixnum(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_fixnump(start)) + return sexp_type_exception(ctx, "not a number", start); + if (sexp_not(end)) + end = sexp_make_fixnum(sexp_string_length(str)); + if (! sexp_fixnump(end)) + return sexp_type_exception(ctx, "not a number", end); + if ((sexp_unbox_fixnum(start) < 0) + || (sexp_unbox_fixnum(start) > sexp_string_length(str)) + || (sexp_unbox_fixnum(end) < 0) + || (sexp_unbox_fixnum(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_fixnum(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_fixnum(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 SEXP_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) { +#if SEXP_USE_HUFF_SYMS + struct sexp_huff_entry he; + sexp_uint_t space=3, newbits; + char c; +#endif + sexp_uint_t len, res=FNV_OFFSET_BASIS, bucket; + char *p=str; + sexp ls; + sexp_gc_var1(sym); + +#if SEXP_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); + + normal_intern: +#endif +#if SEXP_USE_HASH_SYMS + bucket = (sexp_string_hash(p, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + len = strlen(str) + 1; /* include the trailing NULL in the comparison */ + for (ls=sexp_context_symbols(ctx)[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_preserve1(ctx, sym); + sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); + if (sexp_exceptionp(sym)) return sym; + sexp_symbol_string(sym) = sexp_c_string(ctx, str, len-1); + sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); + sexp_gc_release1(ctx); + return sym; +} + +sexp sexp_string_to_symbol (sexp ctx, sexp str) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string->symbol: not a string", str); + return sexp_intern(ctx, sexp_string_data(str)); +} + +sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { + sexp vec, *x; + int i, clen = sexp_unbox_fixnum(len); + if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR); + vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); + if (sexp_exceptionp(vec)) return vec; + x = sexp_vector_data(vec); + 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_fixnum(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_fixnum(sexp_stream_size(vec)); + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_stream_ctx(vec), + sexp_make_fixnum(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_fixnum(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_fixnum(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_fixnum(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_fixnum(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_fixnum(pos); + return pos; +} + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + FILE *in; + sexp res; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = str; + sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str)); + sexp_stream_pos(cookie) = SEXP_ZERO; + 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_release1(ctx); + return res; +} + +sexp sexp_make_output_string_port (sexp ctx) { + FILE *out; + sexp res, size; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + size = sexp_make_fixnum(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(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_ZERO; + 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_release1(ctx); + 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_ZERO, + sexp_stream_pos(cookie)); +} + +#else + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + FILE *in; + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "open-input-string: not a string", str); + in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + 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_var1(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_preserve1(ctx, tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_gc_release1(ctx); + } + sexp_port_offset(p) = 0; + return SEXP_VOID; + } +} + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "open-input-string: not a string", str); + res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + 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); + if (sexp_exceptionp(res)) return res; + 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_var2(ls, tmp); + sexp_gc_preserve2(ctx, ls, 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_release2(ctx); + return res; +} + +#endif + +sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { + sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); + if (sexp_exceptionp(p)) return p; + 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); + if (sexp_exceptionp(p)) return p; + sexp_pointer_tag(p) = SEXP_OPORT; + return p; +} + +sexp sexp_write (sexp ctx, sexp obj, sexp out) { +#if SEXP_USE_HUFF_SYMS + unsigned long res, c; +#endif + unsigned long len; + 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; +#if SEXP_USE_BIGNUMS + case SEXP_BIGNUM: + sexp_write_bignum(ctx, obj, out, 10); + break; +#endif + default: + i = sexp_pointer_tag(obj); + sexp_write_string(ctx, "#<", out); + sexp_write_string(ctx, + (i < sexp_context_num_types(ctx)) + ? sexp_type_name_by_index(ctx, i) : "invalid", + out); + sexp_write_char(ctx, '>', out); + break; + } + } else if (sexp_fixnump(obj)) { + sprintf(numbuf, "%ld", sexp_unbox_fixnum(obj)); + sexp_write_string(ctx, numbuf, out); +#if SEXP_USE_IMMEDIATE_FLONUMS + } else if (sexp_flonump(obj)) { + f = sexp_flonum_value(obj); +#if SEXP_USE_INFINITIES + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else +#endif + { + i = sprintf(numbuf, "%.8g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + 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 SEXP_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); + } + } + return SEXP_VOID; +} + +sexp sexp_display (sexp ctx, sexp obj, sexp out) { + if (sexp_stringp(obj)) + sexp_write_string(ctx, sexp_string_data(obj), out); + else if (sexp_charp(obj)) + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else + sexp_write(ctx, obj, out); + return SEXP_VOID; +} + +sexp sexp_flush_output (sexp ctx, sexp out) { + sexp_flush(ctx, out); + return SEXP_VOID; +} + +#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 'r': c = '\r'; 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_uint_t whole, int negp) { + sexp exponent=SEXP_VOID; + 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; + if (c=='e' || c=='E') { + exponent = sexp_read_number(ctx, in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(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); + } else { + sexp_push_char(ctx, c, in); + } + res = ((double)whole + res) * pow(10, e); + if (negp) res *= -1; + if ((scale == 0.1) && (exponent != SEXP_VOID) && (res == round(res))) + return sexp_make_fixnum(res); + else + return sexp_make_flonum(ctx, res); +} + +sexp sexp_read_number(sexp ctx, sexp in, int base) { + sexp den; + sexp_uint_t res = 0, tmp; + int c, digit, negativep = 0; + + c = sexp_read_char(ctx, in); + if (c == '-') + negativep = 1; + else if (isdigit(c)) + res = digit_value(c); + + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + tmp = res * base + digit; +#if SEXP_USE_BIGNUMS + if ((tmp < res) || (tmp > SEXP_MAX_FIXNUM)) { + sexp_push_char(ctx, c, in); + return sexp_read_bignum(ctx, in, res, (negativep ? -1 : 1), base); + } +#endif + res = tmp; + } + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + return sexp_read_float_tail(ctx, in, res, negativep); + } else if (c=='/') { + den = sexp_read_number(ctx, in, base); + if (! sexp_fixnump(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_fixnum(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_fixnum(negativep ? -res : res); +} + +sexp sexp_read_raw (sexp ctx, sexp in) { + char *str; + int c1, c2, line; + sexp tmp2; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, 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); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res); + break; + case '`': + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res); + break; + case ',': + if ((c1 = sexp_read_char(ctx, in)) == '@') { + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_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)) { + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } + res = sexp_cons(ctx, tmp, res); + tmp = sexp_read_raw(ctx, in); + } + 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_fixnum(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_fixnum((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(ctx, in); + if (sexp_fixnump(res)) + res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res)); + break; + case 'f': case 'F': + case 't': case 'T': + c2 = sexp_read_char(ctx, in); + if (c2 == EOF || is_separator(c2)) { + res = (tolower(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; + break; + case '!': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + sexp_port_line(in)++; + 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, 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 SEXP_USE_FLONUMS + if (sexp_flonump(res)) +#if SEXP_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 +#if SEXP_USE_BIGNUMS + if (sexp_bignump(res)) + sexp_bignum_sign(res) = -sexp_bignum_sign(res); + else +#endif + res = sexp_fx_mul(res, SEXP_NEG_ONE); + } + } else { + sexp_push_char(ctx, c2, in); + res = sexp_read_symbol(ctx, in, c1, 1); +#if SEXP_USE_INFINITIES + if (res == sexp_intern(ctx, "+inf.0")) + res = sexp_make_flonum(ctx, 1.0/0.0); + else if (res == sexp_intern(ctx, "-inf.0")) + res = sexp_make_flonum(ctx, -1.0/0.0); + else if (res == sexp_intern(ctx, "+nan.0")) + res = sexp_make_flonum(ctx, 0.0/0.0); +#endif + } + 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_release2(ctx); + 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_var2(s, in); + sexp_gc_preserve2(ctx, s, in); + s = sexp_c_string(ctx, str, -1); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_write_to_string(sexp ctx, sexp obj) { + sexp str; + sexp_gc_var1(out); + sexp_gc_preserve1(ctx, out); + out = sexp_make_output_string_port(ctx); + sexp_write(ctx, obj, out); + str = sexp_get_output_string(ctx, out); + sexp_gc_release1(ctx); + return str; +} + +void sexp_init(void) { +#if SEXP_USE_GLOBAL_SYMBOLS + int i; +#endif + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if SEXP_USE_BOEHM + GC_init(); +#if SEXP_USE_GLOBAL_SYMBOLS + GC_add_roots((char*)&sexp_symbol_table, + ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); +#endif +#elif ! SEXP_USE_MALLOC + sexp_gc_init(); +#endif +#if SEXP_USE_GLOBAL_SYMBOLS + 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..820020c1 --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,48 @@ + +(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)))) 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/build/build-opts.txt b/tests/build/build-opts.txt new file mode 100644 index 00000000..e6bcd056 --- /dev/null +++ b/tests/build/build-opts.txt @@ -0,0 +1,21 @@ +CPPFLAGS=-DSEXP_USE_MODULES=0 +CPPFLAGS=-DSEXP_USE_DL=0 +CPPFLAGS=-DSEXP_USE_SIMPLIFY=0 +CPPFLAGS=-DSEXP_USE_TYPE_DEFS=0 +SEXP_USE_BOEHM=1 +CPPFLAGS=-DSEXP_USE_DEBUG_GC=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_HEAP=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_TYPES=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_SYMBOLS=1 +CPPFLAGS=-DSEXP_USE_FLONUMS=0 +CPPFLAGS=-DSEXP_USE_IMMEDIATE_FLONUMS=1 +CPPFLAGS=-DSEXP_USE_BIGNUMS=0 +CPPFLAGS=-DSEXP_USE_MATH=0 +CPPFLAGS=-DSEXP_WARN_UNDEFS=0 +CPPFLAGS=-DSEXP_USE_HUFF_SYMS=0 +CPPFLAGS=-DSEXP_USE_HASH_SYMS=0 +CPPFLAGS=-DSEXP_USE_STRING_STREAMS=0 +CPPFLAGS=-DSEXP_USE_AUTOCLOSE_PORTS=0 +CPPFLAGS=-DSEXP_USE_2010_EPOCH=0 +CPPFLAGS=-DSEXP_USE_CHECK_STACK=0 +CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 diff --git a/tests/build/build-tests.sh b/tests/build/build-tests.sh new file mode 100755 index 00000000..1d239629 --- /dev/null +++ b/tests/build/build-tests.sh @@ -0,0 +1,37 @@ +#! /bin/bash + +# test basic build options + +# for bootstrapping reasons this is a shell script, instead of a +# scheme script using (chibi process) + +# we just check each build against r5rs-tests.scm - +# some of the libraries will fail to build (notably +# if modules or user-defined types are disabled). + +BUILDDIR=tests/build +FAILURES=0 +i=0 + +for opts in `cat ${BUILDDIR}/build-opts.txt`; do + make cleaner 2>&1 >/dev/null + if make $opts chibi-scheme 2>&1 >${BUILDDIR}/build${i}-make.out; then + if make test 2>&1 | tee ${BUILDDIR}/build${i}-test.out | grep -q -E 'FAIL|ERROR'; then + echo "[FAIL] ${i}: tests failed with $opts" + FAILURES=$((FAILURES + 1)) + else + echo "[PASS] ${i}: tests passed with $opts" + fi + else + echo "[FAIL] ${i}: couldn't build with $opts" + FAILURES=$((FAILURES + 1)) + fi + i=$((i+1)) +done + +if (( FAILURES == 0 )); then + echo "build-tests: all tests passed" +else + echo "build-tests: ${FAILURES} tests failed" +fi + diff --git a/tests/install/install-tests.pl b/tests/install/install-tests.pl new file mode 100755 index 00000000..63681324 --- /dev/null +++ b/tests/install/install-tests.pl @@ -0,0 +1,57 @@ +#! /usr/bin/env perl + +use strict; +use warnings; + +my $ROOT="tests/install/root"; +my $USER=$ENV{USER}; + +my $ignore = qr!/lib\d*/modules|/X11|alsa-lib|aspell|dosemu|emacs|erlang|/perl|python|ruby|lisp|sbcl|/ghc-|ocaml|evolution|office|gimp|gtk|mysql|postgres|wordnet|xulrunner!; + +sub linkdir ($$$) { + my ($FROM, $TO, $DEPTH) = @_; + mkdir $TO; + for my $f (`ls $FROM`) { + chomp $f; + if (-d "$FROM/$f") { + if (($DEPTH > 0) && ($FROM !~ $ignore)) { + linkdir("$FROM/$f", "$TO/$f", $DEPTH-1); + } + } else { + link "$FROM/$f", "$TO/$f"; + } + } +} + +mkdir "$ROOT"; +mkdir "$ROOT/bin"; +mkdir "$ROOT/sbin"; +mkdir "$ROOT/dev"; +mkdir "$ROOT/etc"; +mkdir "$ROOT/etc/alternatives"; +mkdir "$ROOT/lib"; +mkdir "$ROOT/lib64"; +mkdir "$ROOT/usr"; +mkdir "$ROOT/usr/bin"; +mkdir "$ROOT/usr/include"; +mkdir "$ROOT/usr/lib"; +mkdir "$ROOT/usr/lib/gcc"; + +linkdir "/bin", "$ROOT/bin", 1; +linkdir "/sbin", "$ROOT/sbin", 1; +link "/etc/passwd", "$ROOT/etc/passwd"; +linkdir "/etc/alternatives", "$ROOT/etc/alternatives", 1; +linkdir "/lib", "$ROOT/lib", 3; +linkdir "/lib64", "$ROOT/lib64", 3; +linkdir "/usr/bin", "$ROOT/usr/bin", 3; +linkdir "/usr/include", "$ROOT/usr/include", 2; +linkdir "/usr/lib", "$ROOT/usr/lib", 3; +linkdir "/usr/lib/gcc", "$ROOT/usr/lib/gcc", 3; + +`make dist`; +my $VERSION=`cat VERSION`; +chomp $VERSION; +`cp chibi-scheme-$VERSION.tgz $ROOT/`; +`sed -e 's/\@VERSION\@/$VERSION/g' $ROOT/bin/run-install-test.sh`; +`chmod 755 $ROOT/bin/run-install-test.sh`; +exec "sudo chroot $ROOT run-install-test.sh"; diff --git a/tests/install/run-install-test.sh b/tests/install/run-install-test.sh new file mode 100755 index 00000000..c558e7cd --- /dev/null +++ b/tests/install/run-install-test.sh @@ -0,0 +1,12 @@ +#! /bin/bash + +export PATH=/usr/local/bin:$PATH +export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH + +tar xzvf chibi-scheme-@VERSION@.tgz +cd chibi-scheme-@VERSION@ +make +make install +cp tests/r5rs-tests.scm .. +cd .. +chibi-scheme r5rs-tests.scm | tee r5rs-tests.out diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm new file mode 100644 index 00000000..1c49d48f --- /dev/null +++ b/tests/loop-tests.scm @@ -0,0 +1,202 @@ + +(import (chibi loop)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test + "stepping" + '(0 1 2) + (loop lp ((with i 0 (+ i 1)) + (with res '() (cons i res))) + (if (= i 3) + (reverse res) + (lp)))) + +(test + "basic in-list" + '(c b a) + (let ((res '())) + (loop ((for x (in-list '(a b c)))) + (set! res (cons x res))) + res)) + +(test + "in-list with result" + '(c b a) + (loop ((for x (in-list '(a b c))) + (with res '() (cons x res))) + => res)) + +(test + "in-list with listing" + '(a b c) + (loop ((for x (in-list '(a b c))) (for res (listing x))) => res)) + +(test + "in-list with listing-reverse" + '(c b a) + (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res)) + +(test + "uneven length in-list's" + '((a . 1) (b . 2) (c . 3)) + (loop ((for x (in-list '(a b c))) + (for y (in-list '(1 2 3 4))) + (for res (listing (cons x y)))) + => res)) + +(test + "in-lists" + '((a 1) (b 2) (c 3)) + (loop ((for ls (in-lists '((a b c) (1 2 3)))) + (for res (listing ls))) + => res)) + +(define (flatten ls) + (reverse + (loop lp ((for x ls (in-list ls)) (with res '())) + => res + (if (pair? x) + (lp (=> res (lp (=> ls x)))) + (lp (=> res (cons x res))))))) + +(test + "flatten (recursion test)" + '(1 2 3 4 5 6 7) + (flatten '(1 (2) (3 (4 (5)) 6) 7))) + +(test + "in-string" + '(#\h #\e #\l #\l #\o) + (loop ((for c (in-string "hello")) (for res (listing c))) => res)) + +(test + "in-string with start" + '(#\l #\o) + (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res)) + +(test + "in-string with start and end" + '(#\h #\e #\l #\l) + (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res)) + +(test + "in-string with start, end and step" + '(#\e #\l) + (loop ((for c (in-string "hello" 1 4 2)) (for res (listing c))) => res)) + +(test + "in-string-reverse" + '(#\o #\l #\l #\e #\h) + (loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res)) + +(test + "in-vector" + '(1 2 3) + (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res)) + +(test "up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 8))) + (for res (listing i))) + => res)) + +(test "up-from by" '(5 10 15) + (loop ((for i (up-from 5 (to 20) (by 5))) + (for res (listing i))) + => res)) + +(test "up-from listing if" '(10 12 14 16 18) + (loop ((for i (up-from 10 (to 20))) + (for res (listing i (if (even? i))))) + => res)) + +(test "down-from" '(7 6 5) + (loop ((for i (down-from 8 (to 5))) + (for res (listing i))) + => res)) + +(test "down-from by" '(15 10 5) + (loop ((for i (down-from 20 (to 5) (by 5))) + (for res (listing i))) + => res)) + +(test "down-from listing if" '(18 16 14 12 10) + (loop ((for i (down-from 20 (to 10))) + (for res (listing i (if (even? i))))) + => res)) + +(test "appending" '(1 2 3 4 5 6 7 8 9) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending ls))) + => res)) + +(test "appending-reverse" '(9 8 7 6 5 4 3 2 1) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending-reverse ls))) + => res)) + +(test "while + up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 10))) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "up-from by, open-ended" '(5 7 9) + (loop ((for i (up-from 5 (by 2))) + (while (< i 10)) + (for res (listing i))) + => res)) + +(test "up-from open-ended" '(5 6 7) + (loop ((for i (up-from 5)) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "down-from by, open-ended" '(5 3 1) + (loop ((for i (down-from 7 (by 2))) + (until (< i 1)) + (for res (listing i))) + => res)) + +(test "down-from open-ended" '(4 3 2) + (loop ((for i (down-from 5)) + (until (< i 2)) + (for res (listing i))) + => res)) + +(test-report) + diff --git a/tests/match-tests.scm b/tests/match-tests.scm new file mode 100644 index 00000000..a223e729 --- /dev/null +++ b/tests/match-tests.scm @@ -0,0 +1,196 @@ + +(import (chibi match)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test "any" (match 'any (_ 'ok)) 'ok) +(test "symbol" (match 'ok (x x)) 'ok) +(test "number" (match 28 (28 'ok)) 'ok) +(test "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok) +(test "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok) +(test "null" (match '() (() 'ok)) 'ok) +(test "pair" (match '(ok) ((x) x)) 'ok) +(test "vector" (match '#(ok) (#(x) x)) 'ok) +(test "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok) +(test "and empty" (match '(o k) ((and) 'ok)) 'ok) +(test "and single" (match 'ok ((and x) x)) 'ok) +(test "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok) +(test "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok) +(test "or single" (match 'ok ((or x) 'ok)) 'ok) +(test "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok) +(test "not" (match 28 ((not (a . b)) 'ok)) 'ok) +(test "pred" (match 28 ((? number?) 'ok)) 'ok) +(test "named pred" (match 28 ((? number? x) (+ x 1))) 29) + +(test "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok) +(test "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok) +(test "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok) + +(test "ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ___) (list x y))) + '((a b c) (1 2 3))) + +(test "real ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ...) (list x y))) + '((a b c) (1 2 3))) + +(test "vector ellipses" + (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) + (#(a b c (hd . tl) ...) (list a b c hd tl))) + '(1 2 3 (a b c) (1 2 3))) + +(test "pred ellipses" + (match '(1 2 3) + (((? odd? n) ___) n) + (((? number? n) ___) n)) + '(1 2 3)) + +(test "failure continuation" + (match '(1 2) + ((a . b) (=> next) (if (even? a) 'fail (next))) + ((a . b) 'ok)) + 'ok) + +(test "let" + (match-let ((x 'ok) (y '(o k))) + y) + '(o k)) + +(test "let*" + (match-let* ((x 'f) (y 'o) ((z w) (list y x))) + (list x y z w)) + '(f o o f)) + +(test "getter car" + (match '(1 . 2) (((get! a) . b) (list (a) b))) + '(1 2)) + +(test "getter cdr" + (match '(1 . 2) ((a . (get! b)) (list a (b)))) + '(1 2)) + +(test "getter vector" + (match '#(1 2 3) (#((get! a) b c) (list (a) b c))) + '(1 2 3)) + +(test "setter car" + (let ((x (cons 1 2))) + (match x (((set! a) . b) (a 3))) + x) + '(3 . 2)) + +(test "setter cdr" + (let ((x (cons 1 2))) + (match x ((a . (set! b)) (b 3))) + x) + '(1 . 3)) + +(test "setter vector" + (let ((x (vector 1 2 3))) + (match x (#(a (set! b) c) (b 0))) + x) + '#(1 0 3)) + +(test "single tail" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) (c . 3))) + +(test "single tail 2" + (match '((a . 1) (b . 2) 3) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) 3)) + +(test "multiple tail" + (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) + (((x . y) ... u v w) (list x y u v w))) + '((a b) (1 2) (c . 3) (d . 4) (e . 5))) + +(test "Riastradh quasiquote" + (match '(1 2 3) (`(1 ,b ,c) (list b c))) + '(2 3)) + +(test "trivial tree search" + (match '(1 2 3) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "simple tree search" + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "deep tree search" + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "non-tail tree search" + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "restricted tree search" + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "fail restricted tree search" + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f)) + #f) + +(test "sxml tree search" + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f)) + '(((href . "http://synthcode.com/")) ("synthcode"))) + +(test "failed sxml tree search" + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f)) + #f) + +(test "collect tree search" + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f)) + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))) + +(test-report) + diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm new file mode 100644 index 00000000..76a783f0 --- /dev/null +++ b/tests/numeric-tests.scm @@ -0,0 +1,150 @@ + +;; these tests are only valid if chibi-scheme is compiled with full +;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-neighborhoods x) + (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) + +(test '(536870912 536870913 536870911 -536870912 -536870911 -536870913) + (integer-neighborhoods (expt 2 29))) + +(test '(1073741824 1073741825 1073741823 -1073741824 -1073741823 -1073741825) + (integer-neighborhoods (expt 2 30))) + +(test '(2147483648 2147483649 2147483647 -2147483648 -2147483647 -2147483649) + (integer-neighborhoods (expt 2 31))) + +(test '(4294967296 4294967297 4294967295 -4294967296 -4294967295 -4294967297) + (integer-neighborhoods (expt 2 32))) + +(test '(4611686018427387904 4611686018427387905 4611686018427387903 + -4611686018427387904 -4611686018427387903 -4611686018427387905) + (integer-neighborhoods (expt 2 62))) + +(test '(9223372036854775808 9223372036854775809 9223372036854775807 + -9223372036854775808 -9223372036854775807 -9223372036854775809) + (integer-neighborhoods (expt 2 63))) + +(test '(18446744073709551616 18446744073709551617 18446744073709551615 + -18446744073709551616 -18446744073709551615 -18446744073709551617) + (integer-neighborhoods (expt 2 64))) + +(test '(85070591730234615865843651857942052864 + 85070591730234615865843651857942052865 + 85070591730234615865843651857942052863 + -85070591730234615865843651857942052864 + -85070591730234615865843651857942052863 + -85070591730234615865843651857942052865) + (integer-neighborhoods (expt 2 126))) + +(test '(170141183460469231731687303715884105728 + 170141183460469231731687303715884105729 + 170141183460469231731687303715884105727 + -170141183460469231731687303715884105728 + -170141183460469231731687303715884105727 + -170141183460469231731687303715884105729) + (integer-neighborhoods (expt 2 127))) + +(test '(340282366920938463463374607431768211456 + 340282366920938463463374607431768211457 + 340282366920938463463374607431768211455 + -340282366920938463463374607431768211456 + -340282366920938463463374607431768211455 + -340282366920938463463374607431768211457) + (integer-neighborhoods (expt 2 128))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-arithmetic-combinations a b) + (list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b))) + +(define (sign-combinations a b) + (list (integer-arithmetic-combinations a b) + (integer-arithmetic-combinations (- a) b) + (integer-arithmetic-combinations a (- b)) + (integer-arithmetic-combinations (- a) (- b)))) + +;; fix x fix +(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0)) + (sign-combinations 0 1)) +(test '((2 0 1 1 0) (0 -2 -1 -1 0) (0 2 -1 -1 0) (-2 0 1 1 0)) + (sign-combinations 1 1)) +(test '((59 25 714 2 8) (-25 -59 -714 -2 -8) + (25 59 -714 -2 8) (-59 -25 714 2 -8)) + (sign-combinations 42 17)) + +;; fix x big +(test '((4294967338 -4294967254 180388626432 0 42) + (4294967254 -4294967338 -180388626432 0 -42) + (-4294967254 4294967338 -180388626432 0 42) + (-4294967338 4294967254 180388626432 0 -42)) + (sign-combinations 42 (expt 2 32))) + +;; big x fix +(test '((4294967338 4294967254 180388626432 102261126 4) + (-4294967254 -4294967338 -180388626432 -102261126 -4) + (4294967254 4294967338 -180388626432 -102261126 4) + (-4294967338 -4294967254 180388626432 102261126 -4)) + (sign-combinations (expt 2 32) 42)) + +;; big x bigger +(test '((12884901889 -4294967297 36893488151714070528 0 4294967296) + (4294967297 -12884901889 -36893488151714070528 0 -4294967296) + (-4294967297 12884901889 -36893488151714070528 0 4294967296) + (-12884901889 4294967297 36893488151714070528 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) + +(test '((18446744078004518913 -18446744069414584321 79228162514264337597838917632 0 4294967296) + (18446744069414584321 -18446744078004518913 -79228162514264337597838917632 0 -4294967296) + (-18446744069414584321 18446744078004518913 -79228162514264337597838917632 0 4294967296) + (-18446744078004518913 18446744069414584321 79228162514264337597838917632 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 64)))) + +;; bigger x big +(test '((12884901889 4294967297 36893488151714070528 2 1) + (-4294967297 -12884901889 -36893488151714070528 -2 -1) + (4294967297 12884901889 -36893488151714070528 -2 1) + (-12884901889 -4294967297 36893488151714070528 2 -1)) + (sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) + +(test '((18446744078004518913 18446744069414584321 79228162514264337597838917632 4294967296 1) + (-18446744069414584321 -18446744078004518913 -79228162514264337597838917632 -4294967296 -1) + (18446744069414584321 18446744078004518913 -79228162514264337597838917632 -4294967296 1) + (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1)) + (sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) + +(test-report) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..1b22acd2 --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,483 @@ + +(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) + (write *tests-run*) + (display ". ") + (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 -2 (let () + (define x 2) + (define f (lambda () (- x))) + (f))) + +(define let*-def 1) +(let* () (define let*-def 2) #f) +(test 1 let*-def) + +(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 4 16 9 8) + `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 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 #f (eqv? 2 2.0)) + +;;(test #f (equal? 2.0 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)) + +;;;; these will fail when compiled either without flonums or trig funcs + +;; (test #t (= -5 (floor -4.3))) + +;; (test #t (= -4 (ceiling -4.3))) + +;; (test #t (= -4 (truncate -4.3))) + +;; (test #t (= -4 (round -4.3))) + +;; (test #t (= 3 (floor 3.5))) + +;; (test #t (= 4 (ceiling 3.5))) + +;; (test #t (= 3 (truncate 3.5))) + +;; (test #t (= 4 (round 3.5))) + +(test 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 127 (string->number "177" 8)) + +(test 5 (string->number "101" 2)) + +(test 100 (string->number "1e2")) + +(test "100" (number->string 100)) + +(test "100" (number->string 256 16)) + +(test "FF" (number->string 255 16)) + +(test "177" (number->string 127 8)) + +(test "101" (number->string 5 2)) + +(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 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + +(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 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad)))) + +(test 'ok (let ((=> 1)) (cond (#t => 'ok)))) + +(test '(,foo) (let ((unquote 1)) `(,foo))) + +(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) + +(test 'ok + (let ((... 2)) + (let-syntax ((s (syntax-rules () + ((_ x ...) 'bad) + ((_ . r) 'ok)))) + (s a b c)))) + +(test 'ok (let () + (let-syntax () + (define internal-def 'ok)) + internal-def)) + +(test 'ok (let () + (letrec-syntax () + (define internal-def 'ok)) + internal-def)) + +(test '(2 1) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y)))))) + +(test '(2 2) + ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y)))))) + +(test '(1 2) + ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y)))))) + +(test '(2 3) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) + +(test '(a b c) + (let* ((path '()) + (add (lambda (s) (set! path (cons s path))))) + (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) + (reverse path))) + +(test '(connect talk1 disconnect connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + +(test 2 (let-syntax + ((foo (syntax-rules ::: () + ((foo ... args :::) + (args ::: ...))))) + (foo 3 - 5))) + +(test '(5 4 1 2 3) + (let-syntax + ((foo (syntax-rules () + ((foo args ... penultimate ultimate) + (list ultimate penultimate args ...))))) + (foo 1 2 3 4 5))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) diff --git a/tools/genstubs.scm b/tools/genstubs.scm new file mode 100755 index 00000000..4f248554 --- /dev/null +++ b/tools/genstubs.scm @@ -0,0 +1,1156 @@ +#! /usr/bin/env chibi-scheme + +;; Note: this evolved as a throw-away script to provide certain core +;; modules, and so is a mess. Tread carefully. + +;; Simple C FFI. "genstubs.scm file.stub" will read in the C function +;; FFI definitions from file.stub and output the appropriate C +;; wrappers into file.c. You can then compile that file with: +;; +;; cc -fPIC -shared file.c -lchibi-scheme +;; +;; (or using whatever flags are appropriate to generate shared libs on +;; your platform) and then the generated .so file can be loaded +;; directly with load, or portably using (include-shared "file") in a +;; module definition (note that include-shared uses no suffix). + +;; The goal of this interface is to make access to C types and +;; functions easy, without requiring the user to write any C code. +;; That means the stubber needs to be intelligent about various C +;; calling conventions and idioms, such as return values passed in +;; actual parameters. Writing C by hand is still possible, and +;; several of the core modules provide C interfaces directly without +;; using the stubber. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Struct Interface +;; +;; (define-c-struct struct-name +;; [predicate: predicate-name] +;; [constructor: constructor-name] +;; [finalizer: c_finalizer_name] +;; (type c_field_name getter-name setter-name) ...) +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Function Interface +;; +;; (define-c return-type name-spec (arg-type ...)) +;; +;; where name-space is either a symbol name, or a list of +;; (scheme-name c_name). If just a symbol, the C name is taken +;; to be the same with -'s replaced by _'s. +;; +;; arg-type is a type suitable for input validation and conversion. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Types +;; +;; Types +;; +;; Basic Types +;; void +;; boolean +;; char +;; sexp (no conversions) +;; +;; Integer Types: +;; signed-char short int long +;; unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t +;; time_t (in seconds, but using the chibi epoch of 2010/01/01) +;; errno (as a return type returns #f on error) +;; +;; Float Types: +;; float double long-double +;; +;; String Types: +;; string - a null-terminated char* +;; env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme +;; in addition you can use (array char) as a string +;; +;; Port Types: +;; input-port output-port +;; +;; Struct Types: +;; +;; Struct types are by default just referred to by the bare +;; struct-name from define-c-struct, and it is assumed you want a +;; pointer to that type. To refer to the full struct, use the struct +;; modifier, as in (struct struct-name). + +;; Type modifiers +;; +;; Any type may also be written as a list of modifiers followed by the +;; type itself. The supported modifiers are: +;; +;; const: prepends the "const" C type modifier +;; * as a return or result parameter, makes non-immediates immutable +;; +;; free: it's Scheme's responsibility to "free" this resource +;; * as a return or result parameter, registers the freep flag +;; this causes the type finalizer to be run when GCed +;; +;; maybe-null: this pointer type may be NULL +;; * as a result parameter, NULL is translated to #f +;; normally this would just return a wrapped NULL pointer +;; * as an input parameter, #f is translated to NULL +;; normally this would be a type error +;; +;; pointer: create a pointer to this type +;; * as a return parameter, wraps the result in a vanilla cpointer +;; * as a result parameter, boxes then unboxes the value +;; +;; struct: treat this struct type as a struct, not a pointer +;; * as an input parameter, dereferences the pointer +;; * as a type field, indicates a nested struct +;; +;; link: add a gc link +;; * as a field getter, link to the parent object, so the +;; parent won't be GCed so long as we have a reference +;; to the child. this behavior is automatic for nested +;; structs. +;; +;; result: return a result in this parameter +;; * if there are multiple results (including the return type), +;; they are all returned in a list +;; * if there are any result parameters, a return type +;; of errno returns #f on failure, and as eliminated +;; from the list of results otherwise +;; +;; (value ): specify a fixed value +;; * as an input parameter, this parameter is not provided +;; in the Scheme API but always passed as +;; +;; (default ): specify a default value +;; * as the final input parameter, makes the Scheme parameter +;; optional, defaulting to +;; +;; (array []) an array type +;; * length must be specified for return and result parameters +;; * if specified, length can be any of +;; ** an integer, for a fixed size +;; ** the symbol null, indicating a NULL-terminated array + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; globals + +(define *types* '()) +(define *funcs* '()) +(define *consts* '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type objects + +(define (parse-type type . o) + (cond + ((vector? type) + type) + (else + (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) + (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f) + (value #f) (default? #f)) + (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) + (case (and (pair? type) (car type)) + ((free) + (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) + ((const) + (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) + ((maybe-null) + (lp (next) free? const? #t ptr? struct? link? result? array value default?)) + ((pointer) + (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) + ((struct) + (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) + ((link) + (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) + ((result) + (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) + ((array) + (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) + ((value) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) + ((default) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) + (else + (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) + +(define (type-base type) (vector-ref type 0)) +(define (type-free? type) (vector-ref type 1)) +(define (type-const? type) (vector-ref type 2)) +(define (type-null? type) (vector-ref type 3)) +(define (type-pointer? type) (vector-ref type 4)) +(define (type-struct? type) (vector-ref type 5)) +(define (type-link? type) (vector-ref type 6)) +(define (type-result? type) (vector-ref type 7)) +(define (type-array type) (vector-ref type 8)) +(define (type-value type) (vector-ref type 9)) +(define (type-default? type) (vector-ref type 10)) +(define (type-index type) (vector-ref type 11)) + +(define (type-auto-expand? type) + (and (pair? (type-array type)) + (memq 'auto-expand (type-array type)))) + +(define (type-index-string type) + (if (integer? (type-index type)) + (number->string (type-index type)) + "")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type predicates + +(define (signed-int-type? type) + (memq type '(signed-char short int long boolean))) + +(define (unsigned-int-type? type) + (memq type '(unsigned-char unsigned-short unsigned-int unsigned-long + size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t + uid_t gid_t pid_t blksize_t blkcnt_t sigval_t))) + +(define (int-type? type) + (or (signed-int-type? type) (unsigned-int-type? type))) + +(define (float-type? type) + (memq type '(float double long-double long-long-double))) + +(define (string-type? type) + (or (memq type '(char* string env-string non-null-string)) + (and (vector? type) + (type-array type) + (not (type-pointer? type)) + (eq? 'char (type-base type))))) + +(define (error-type? type) + (memq type '(errno non-null-string non-null-pointer))) + +(define (array-type? type) + (and (type-array type) (not (eq? 'char (type-base type))))) + +(define (basic-type? type) + (let ((type (parse-type type))) + (and (not (type-array type)) + (not (assq (type-base type) *types*))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; function objects + +(define (parse-func func) + (if (not (and (= 3 (length func)) + (or (identifier? (cadr func)) (list (cadr func))) + (list (caddr func)))) + (error "bad function definition" func)) + (let* ((ret-type (parse-type (car func))) + (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) + (c-name (if (pair? (cadr func)) + (cadadr func) + (mangle scheme-name))) + (stub-name (if (and (pair? (cadr func)) (pair? (cddadr func))) + (car (cddadr func)) + (generate-stub-name scheme-name)))) + (let lp ((ls (caddr func)) + (i 0) + (results '()) + (c-args '()) + (s-args '())) + (cond + ((null? ls) + (if (>= i 6) + (error "FFI currently only supports up to 6 scheme args" func)) + (vector scheme-name c-name stub-name ret-type + (reverse results) (reverse c-args) (reverse s-args))) + (else + (let ((type (parse-type (car ls) i))) + (cond + ((type-result? type) + (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) + ((and (type-value type) (not (type-default? type))) + (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) + (else + (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) + ))))))) + +(define (func-scheme-name func) (vector-ref func 0)) +(define (func-c-name func) (vector-ref func 1)) +(define (func-stub-name func) (vector-ref func 2)) +(define (func-ret-type func) (vector-ref func 3)) +(define (func-results func) (vector-ref func 4)) +(define (func-c-args func) (vector-ref func 5)) +(define (func-scheme-args func) (vector-ref func 6)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (cat . args) + (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (filter pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (cons (car ls) (filter pred (cdr ls)))) + (else (filter pred (cdr ls))))) + +(define (remove pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (filter pred (cdr ls))) + (else (cons (car ls) (filter pred (cdr ls)))))) + +(define (strip-extension path) + (let lp ((i (- (string-length path) 1))) + (cond ((<= i 0) path) + ((eq? #\. (string-ref path i)) (substring path 0 i)) + (else (lp (- i 1)))))) + +(define (string-concatenate-reverse ls) + (cond ((null? ls) "") + ((null? (cdr ls)) (car ls)) + (else (string-concatenate (reverse ls))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase str) + (list->string (map char-downcase (string->list str)))) + +(define (with-output-to-string thunk) + (call-with-output-string + (lambda (out) + (let ((old-out (current-output-port))) + (current-output-port out) + (thunk) + (current-output-port old-out))))) + +(define (definite-article x) + (define (vowel? c) + (memv c '(#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U))) + (define (vowel-exception? str) + (member (string-downcase str) + '("european" "ewe" "unicorn" "unicycle" "university" "user"))) + (define (consonant-exception? str) + ;; not "historic" according to elements of style + (member (string-downcase str) + '("heir" "herb" "herbal" "herbivore" "honest" "honor" "hour"))) + (let* ((full-str (with-output-to-string (lambda () (cat x)))) + (i (string-scan #\space full-str)) + (str (if i (substring full-str 0 i) full-str))) + (string-append + (cond + ((equal? str "") "a ") + ((vowel? (string-ref str 0)) (if (vowel-exception? str) "a " "an ")) + (else (if (consonant-exception? str) "an " "a "))) + full-str))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; naming + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +(define (generate-stub-name sym) + (string-append "sexp_" (mangle sym) "_stub")) + +(define (type-id-name sym) + (string-append "sexp_" (mangle sym) "_type_id")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; .stub file interface + +(define (c-declare . args) + (apply cat args) + (newline)) + +(define (c-include header) + (cat "\n#include \"" header "\"\n")) + +(define (c-system-include header) + (cat "\n#include <" header ">\n")) + +(define (parse-struct-like ls) + (map (lambda (x) (if (pair? x) (cons (parse-type (car x)) (cdr x)) x)) ls)) + +(define-syntax define-struct-like + (er-macro-transformer + (lambda (expr rename compare) + (set! *types* + `((,(cadr expr) + ,@(parse-struct-like (cddr expr))) + ,@*types*)) + `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) + +(define-syntax define-c-struct + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr))))) + +(define-syntax define-c-class + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) + +(define-syntax define-c-type + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) ,@(cddr expr))))) + +(define-syntax define-c + (er-macro-transformer + (lambda (expr rename compare) + (set! *funcs* (cons (parse-func (cdr expr)) *funcs*)) + #f))) + +(define-syntax define-c-const + (er-macro-transformer + (lambda (expr rename compare) + (set! *consts* + (cons (cons (parse-type (cadr expr)) (cddr expr)) *consts*))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; C code generation + +(define (c->scheme-converter type val . o) + (let ((base (type-base type))) + (cond + ((eq? base 'void) + (cat "((" val "), SEXP_VOID)")) + ((or (eq? base 'sexp) (error-type? base)) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_make_boolean(" val ")")) + ((eq? base 'time_t) + (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) + ((unsigned-int-type? base) + (cat "sexp_make_unsigned_integer(ctx, " val ")")) + ((signed-int-type? base) + (cat "sexp_make_integer(ctx, " val ")")) + ((eq? base 'char) + (if (type-array type) + (cat "sexp_c_string(ctx, " val ", -1)") + (cat "sexp_make_character(ctx, " val ")"))) + ((eq? 'env-string base) + (cat "(p=strchr(" val ", '=') ? " + "sexp_cons(ctx, str=sexp_c_string(ctx, " val ", p - " val "), str=sexp_c_string(ctx, p, -1))" + " : sexp_cons(ctx, str=" val ", SEXP_FALSE)")) + ((string-type? base) + (cat "sexp_c_string(ctx, " val ", -1)")) + ((eq? 'input-port base) + (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)")) + ((eq? 'output-port base) + (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) + (else + (let ((ctype (assq base *types*))) + (cond + (ctype + (cat "sexp_make_cpointer(ctx, " (type-id-name base) ", " + val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " + (if (or (type-free? type) + (and (type-result? type) (not (basic-type? type)))) + 1 + 0) + ")")) + (else + (error "unknown type" base)))))))) + +(define (scheme->c-converter type val) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'sexp) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_truep(" val ")")) + ((eq? base 'time_t) + (cat "sexp_unshift_epoch(sexp_uint_value(" val "))")) + ((signed-int-type? base) + (cat "sexp_sint_value(" val ")")) + ((unsigned-int-type? base) + (cat "sexp_uint_value(" val ")")) + ((eq? base 'char) + (cat "sexp_unbox_character(" val ")")) + ((eq? base 'env-string) + (cat "sexp_concat_env_string(" val ")")) + ((string-type? base) + (cat "sexp_string_data(" val ")")) + (else + (let ((ctype (assq base *types*))) + (cond + (ctype + (cat "(" (type-c-name type) ")" + (if (type-null? type) + "sexp_cpointer_maybe_null_value" + "sexp_cpointer_value") + "(" val ")")) + (else + (error "unknown type" base)))))))) + +(define (type-predicate type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "sexp_exact_integerp") + ((float-type? base) "sexp_flonump") + ((string-type? base) "sexp_stringp") + ((eq? base 'char) "sexp_charp") + ((eq? base 'boolean) "sexp_booleanp") + (else #f)))) + +(define (type-name type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "integer") + ((float-type? base) "flonum") + ((eq? 'boolean base) "int") + (else base)))) + +(define (base-type-c-name base) + (case base + ((string env-string non-null-string) "char*") + (else (symbol->string base)))) + +(define (type-struct-type type) + (let ((type-spec (assq (if (vector? type) (type-base type) type) *types*))) + (cond ((and type-spec (memq 'type: type-spec)) => cadr) + (else #f)))) + +(define (type-c-name type) + (let* ((type (parse-type type)) + (base (type-base type)) + (type-spec (assq base *types*)) + (struct-type (type-struct-type type))) + (string-append + (if (type-const? type) "const " "") + (if struct-type (string-append (symbol->string struct-type) " ") "") + (string-replace (base-type-c-name base) #\- " ") + (if type-spec "*" "") + (if (type-pointer? type) "*" "")))) + +(define (check-type arg type) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'env-string) + (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg + ")) && sexp_stringp(sexp_cdr(" arg ")))")) + ((or (int-type? base) (float-type? base) (string-type? base)) + (cat (type-predicate type) "(" arg ")")) + (else + (cond + ((assq base *types*) + (cat + (if (type-null? type) "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " (type-id-name base) "))" + (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) + (else + (display "WARNING: don't know how to check: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (cat "1"))))))) + +(define (write-validator arg type) + (let* ((type (parse-type type)) + (array (type-array type)) + (base-type (type-base type))) + (cond + ((and array (not (string-type? type))) + (cond + ((number? array) + (cat " if (!sexp_listp(ctx, " arg ")" + " || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n" + " return sexp_type_exception(ctx, \"not a list\", " arg ");\n"))) + (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" + " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" + " return sexp_type_exception(ctx, \"not a list of " + (type-name type) "s\", " arg ");\n") + (if (not (number? array)) + (cat " if (! sexp_nullp(res))\n" + " return sexp_type_exception(ctx, \"not a list of " + (type-name type) "s\", " arg ");\n"))) + ((or (int-type? base-type) + (float-type? base-type) + (string-type? base-type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, \"not " + (definite-article (type-name type)) "\", " + arg ");\n")) + (else + (cond + ((assq base-type *types*) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, \"not " + (definite-article (type-name type)) "\", " arg ");\n")) + ((eq? 'sexp base-type)) + ((string-type? type) + (write-validator arg 'string)) + (else + (display "WARNING: don't know how to validate: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (write type))))))) + +(define (write-parameters args) + (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) + +(define (get-array-length func x) + (let ((len (if (pair? (type-array x)) + (car (reverse (type-array x))) + (type-array x)))) + (if (number? len) + len + (and (symbol? len) + (let* ((str (symbol->string len)) + (len (string-length str))) + (and (> len 3) + (string=? "arg" (substring str 0 3)) + (let ((i (string->number (substring str 3 len)))) + (if i + (let ((y (list-ref (func-c-args func) i))) + (or (type-value y) y)))))))))) + +(define (write-locals func) + (define (arg-res x) + (string-append "res" (type-index-string x))) + (let* ((ret-type (func-ret-type func)) + (results (func-results func)) + (scheme-args (func-scheme-args func)) + (return-res? (not (error-type? (type-base ret-type)))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons ret-type results))) + (gc-vars (map arg-res results)) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (sexps (if preserve-res? '() '("res"))) + (num-gc-vars (length gc-vars)) + (ints (if (or return-res? + (memq (type-base ret-type) + '(non-null-string non-null-pointer))) + '() + '("err"))) + (ints (if (or (array-type? ret-type) + (any array-type? results) + (any array-type? scheme-args)) + (cons "i" ints) + ints))) + (case (type-base ret-type) + ((non-null-string) (cat " char *err;\n")) + ((non-null-pointer) (cat " void *err;\n"))) + (cond + ((pair? ints) + (cat " int " (car ints)) + (for-each (lambda (x) (display ", ") (display x)) (cdr ints)) + (cat ";\n"))) + (if (any (lambda (a) (eq? 'env-string (type-base a))) + (cons ret-type results)) + (cat " char *p;\n")) + (for-each + (lambda (x) + (let ((len (get-array-length func x))) + (cat " " (type-c-name (type-base x)) " ") + (if (and (type-array x) (not (number? len))) + (cat "*")) + (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) + (if (number? len) + (cat "[" len "]")) + (cat ";\n") + (if (or (vector? len) (type-auto-expand? x)) + (cat " int len" (type-index x) ";\n")) + (if (type-auto-expand? x) + (cat " " (type-c-name (type-base x)) + " *tmp" (type-index-string x) ";\n")))) + (append (if (type-array ret-type) (list ret-type) '()) + results + (remove type-result? (filter type-array scheme-args)))) + (for-each + (lambda (arg) + (cond + ((and (type-pointer? arg) (basic-type? arg)) + (cat " " (type-c-name (type-base arg)) + " tmp" (type-index arg) ";\n")))) + scheme-args) + (cond + ((pair? sexps) + (cat " sexp " (car sexps)) + (for-each (lambda (x) (display ", ") (display x)) (cdr sexps)) + (cat ";\n"))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_var" num-gc-vars "(") + (display (car gc-vars)) + (for-each (lambda (x) (display ", ") (display x)) (cdr gc-vars)) + (cat ");\n") + (cat " sexp_gc_preserve" num-gc-vars "(ctx") + (for-each (lambda (x) (display ", ") (display x)) gc-vars) + (cat ");\n"))))) + +(define (write-validators args) + (for-each + (lambda (a) + (write-validator (string-append "arg" (type-index-string a)) a)) + args)) + +(define (write-temporaries func) + (for-each + (lambda (a) + (let ((len (and (type-array a) (get-array-length func a)))) + (cond + ((and (type-array a) (or (vector? len) (type-auto-expand? a))) + (cat " len" (type-index a) " = " + (lambda () + (if (number? len) (cat len) (scheme->c-converter 'int len))) + ";\n" + " tmp" (type-index a) " = buf" (type-index a) ";\n")))) + (cond + ((and (not (type-result? a)) (type-array a) (not (string-type? a))) + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) + " = (" (type-c-name (type-base a)) "*) malloc(" + "(sexp_unbox_fixnum(sexp_length(ctx, arg" (type-index a) + "))+1) * sizeof(tmp" (type-index a) "[0]));\n")) + (cat " for (i=0, res=arg" (type-index a) + "; sexp_pairp(res); res=sexp_cdr(res), i++) {\n" + " tmp" (type-index a) "[i] = " + (lambda () (scheme->c-converter (type-base a) "sexp_car(res)")) + ";\n" + " }\n") + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) "[i] = NULL;\n"))) + ((and (type-result? a) (not (basic-type? a)) + (not (type-free? a)) (not (type-pointer? a)) + (not (type-auto-expand? a)) + (or (not (type-array a)) + (not (integer? (get-array-length func a))))) + (cat " tmp" (type-index a) " = malloc(sizeof(tmp" (type-index a) + "[0]));\n")) + ((and (type-pointer? a) (basic-type? a)) + (cat " tmp" (type-index a) " = " + (lambda () + (scheme->c-converter + a + (string-append "arg" (type-index-string a)))) + ";\n")))) + (func-c-args func))) + +(define (write-actual-parameter func arg) + (cond + ((and (not (type-default? arg)) (type-value arg)) + => (lambda (x) + (cond + ((any (lambda (y) + (and (type-array y) + (type-auto-expand? y) + (eq? x (get-array-length func y)))) + (func-c-args func)) + => (lambda (y) (cat "len" (type-index y)))) + (else (write x))))) + ((or (type-result? arg) (type-array arg)) + (cat (if (or (type-pointer? arg) (type-free? arg) (basic-type? arg)) + "&" + "") + "tmp" (type-index arg))) + ((and (type-pointer? arg) (basic-type? arg)) + (cat "&tmp" (type-index arg))) + (else + (scheme->c-converter + arg + (string-append "arg" (type-index-string arg)))))) + +(define (write-call func) + (let ((ret-type (func-ret-type func)) + (c-name (func-c-name func)) + (c-args (func-c-args func))) + (if (any type-auto-expand? (func-c-args func)) + (cat " loop:\n")) + (cat (cond ((error-type? (type-base ret-type)) " err = ") + ((type-array ret-type) " tmp = ") + (else " res = "))) + ((if (type-array ret-type) + (lambda (t f x) (f)) + c->scheme-converter) + ret-type + (lambda () + (cat c-name "(") + (for-each + (lambda (arg) + (if (> (type-index arg) 0) (cat ", ")) + (write-actual-parameter func arg)) + c-args) + (cat ")")) + (cond + ((any type-link? (func-c-args func)) + => (lambda (a) (string-append "arg" (type-index-string a)))) + (else #f))) + (cat ";\n") + (if (type-array ret-type) + (write-result ret-type)))) + +(define (write-result result) + (let ((res (string-append "res" (type-index-string result))) + (tmp (string-append "tmp" (type-index-string result)))) + (cond + ((and (type-array result) (eq? 'char (type-base result))) + (cat " " res " = " (lambda () (c->scheme-converter result tmp)) ";\n")) + ((type-array result) + (cat " " res " = SEXP_NULL;\n") + (let ((auto-expand? + (and (pair? (type-array result)) + (memq 'auto-expand (type-array result)))) + (len (if (pair? (type-array result)) + (car (reverse (type-array result))) + (type-array result)))) + (cond + ((eq? 'null len) + (cat " for (i=0; " tmp "[i]; i++) {\n" + " sexp_push(ctx, " res ", " + (if (eq? 'string (type-base result)) + "str=" + (lambda () (cat "SEXP_VOID);\n sexp_car(" res ") = "))) + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ");\n" + " }\n" + " " res " = sexp_nreverse(ctx, " res ");\n")) + (else + (cat " for (i=" len "-1; i>=0; i--) {\n" + " sexp_push(ctx, " res ", SEXP_VOID);\n" + " sexp_car(" res ") = " + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ";\n" + " }\n"))))) + (else + (cat " " res " = ") + (c->scheme-converter + result + (string-append "tmp" (type-index-string result))) + (cat ";\n"))))) + +(define (write-results func) + (let ((error-res? (error-type? (type-base (func-ret-type func)))) + (results (func-results func))) + (if error-res? + (cat " if (" + (if (memq (type-base (func-ret-type func)) + '(non-null-string non-null-pointer)) + "!" + "") + "err) {\n" + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (lambda () + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")) + (cat " len" i " *= 2;\n" + " tmp" i + " = malloc(len" i "*sizeof(tmp" i "[0]));\n" + " goto loop;\n"))))) + (else + " res = SEXP_FALSE;\n")) + " } else {\n")) + (if (null? results) + (if error-res? + (cat " res = SEXP_TRUE;\n")) + (for-each write-result results)) + (cond + ((> (length results) (if error-res? 1 0)) + (if error-res? + (cat " res = SEXP_NULL;\n") + (cat " res = sexp_cons(ctx, res, SEXP_NULL);\n")) + (for-each + (lambda (x) + (if error-res? + (cat " sexp_push(ctx, res, res" (type-index x) ");\n") + (cat " sexp_push(ctx, res, sexp_car(res));\n" + " sexp_cadr(res) = res" (type-index x) ";\n"))) + (reverse results))) + ((pair? results) + (cat " res = res" (type-index (car results)) ";\n"))) + (if error-res? + (cat " }\n")))) + +(define (write-free type) + (if (type-array type) + (cat " free(tmp" (type-index-string type) ");\n"))) + +(define (write-cleanup func) + (for-each write-free (func-scheme-args func)) + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n"))))) + (else + " res = SEXP_FALSE;\n")) + (let* ((results (func-results func)) + (return-res? (not (error-type? (type-base (func-ret-type func))))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons (func-ret-type func) + (func-results func)))) + (gc-vars results) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (num-gc-vars (length gc-vars))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_release" num-gc-vars "(ctx);\n"))))) + +(define (write-func func) + (cat "static sexp " (func-stub-name func) + " (sexp ctx" (write-parameters (func-scheme-args func)) ") {\n") + (write-locals func) + (write-validators (func-scheme-args func)) + (write-temporaries func) + (write-call func) + (write-results func) + (write-cleanup func) + (cat " return res;\n" + "}\n\n")) + +(define (write-func-binding func) + (let ((default (and (pair? (func-scheme-args func)) + (type-default? (car (reverse (func-scheme-args func)))) + (car (reverse (func-scheme-args func)))))) + (cat (if default + " sexp_define_foreign_opt(ctx, env, " + " sexp_define_foreign(ctx, env, ") + (lambda () (write (symbol->string (func-scheme-name func)))) + ", " (length (func-scheme-args func)) ", " + (func-stub-name func) + (if default ", " "") + (if default + (lambda () + (c->scheme-converter default (type-value default))) + "") + ");\n"))) + +(define (write-type type) + (let ((name (car type)) + (type (cdr type))) + (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" + " " (type-id-name name) + " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, " + (cond ((memq 'finalizer: type) + => (lambda (x) (generate-stub-name (cadr x)))) + (else "sexp_finalize_c_type")) + "));\n") + (cond + ((memq 'predicate: type) + => (lambda (x) + (let ((pred (cadr x))) + (cat " tmp = sexp_make_type_predicate(ctx, name, " + "sexp_make_fixnum(" (type-id-name name) "));\n" + " name = sexp_intern(ctx, \"" pred "\");\n" + " sexp_env_define(ctx, env, name, tmp);\n"))))))) + +(define (type-getter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_get_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-getter type name field) + (cat "static sexp " (type-getter-name type name field) + " (sexp ctx, sexp x) {\n" + (lambda () (write-validator "x" name)) + " return " + (lambda () + (c->scheme-converter + (car field) + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (x->string (cadr field))) + (and (or (type-struct? (car field)) (type-link? (car field))) "x"))) + ";\n" + "}\n\n")) + +(define (type-setter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_set_" (x->string (type-base (parse-type (car field)))))) + +(define (write-type-setter type name field) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx, sexp x, sexp v) {\n" + (lambda () (write-validator "x" name)) + (lambda () (write-validator "v" (car field))) + " " + (lambda () (c->scheme-converter + (car field) + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (x->string (cadr field))))) + " = v;\n" + " return SEXP_VOID;" + "}\n\n")) + +(define (write-type-funcs type) + (let ((name (car type)) + (type (cdr type))) + ;; maybe write finalizer + (cond + ((memq 'finalizer: type) + => (lambda (x) + (cat "static sexp " (generate-stub-name (cadr x)) + " (sexp ctx, sexp x) {\n" + " if (sexp_cpointer_freep(x))\n" + " " (cadr x) "(sexp_cpointer_value(x));\n" + " return SEXP_VOID;\n" + "}\n\n")))) + ;; maybe write constructor + (cond + ((memq 'constructor: type) + => (lambda (x) + (let ((make (caadr x)) + (args (cdadr x))) + (cat "static sexp " (generate-stub-name make) + " (sexp ctx" + (lambda () (for-each (lambda (x) (cat ", sexp " x)) args)) + ") {\n" + " struct " (type-name name) " *r;\n" + " sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + (type-id-name name) + ");\n" + " sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " r = sexp_cpointer_value(res);\n" + " return res;\n" + "}\n\n") + (set! *funcs* + (cons (parse-func `(void ,make ,args)) *funcs*)))))) + ;; write field accessors + (for-each + (lambda (field) + (cond + ((and (pair? field) (pair? (cdr field))) + (cond + ((and (pair? (cddr field)) (caddr field)) + (write-type-getter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(caddr field) + #f + ,(type-getter-name type name field)) + (,name))) + *funcs*)))) + (cond + ((and (pair? (cddr field)) + (pair? (cdddr field)) + (car (cdddr field))) + (write-type-setter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(car (cdddr field)) + #f + ,(type-setter-name type name field)) + (,name ,(car field)))) + *funcs*))))))) + type))) + +(define (write-const const) + (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) + (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) + (cat " name = sexp_intern(ctx, \"" scheme-name "\");\n" + " sexp_env_define(ctx, env, name, tmp=" + (lambda () (c->scheme-converter (car const) c-name)) ");\n"))) + +(define (write-utilities) + (define (input-env-string? x) + (and (eq? 'env-string (type-base x)) (not (type-result? x)))) + (cond + ((any (lambda (f) + (or (any input-env-string? (func-results f)) + (any input-env-string? (func-scheme-args f)))) + *funcs*) + (cat "static char* sexp_concat_env_string (sexp x) {\n" + " int klen=sexp_string_length(sexp_car(x)), vlen=sexp_string_length(sexp_cdr(x));\n" + " char *res = (char*) malloc(klen+vlen+2);\n" + " strncpy(res, sexp_string_data(sexp_car(x)), klen);\n" + " res[sexp_string_length(sexp_car(x))] = '=';\n" + " strncpy(res+sexp_string_length(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n" + " res[len-1] = '\\0';\n" + " return res;\n" + "}\n\n")))) + +(define (write-init) + (newline) + (write-utilities) + (for-each write-func *funcs*) + (for-each write-type-funcs *types*) + (cat "sexp sexp_init_library (sexp ctx, sexp env) {\n" + " sexp_gc_var2(name, tmp);\n" + " sexp_gc_preserve2(ctx, name, tmp);\n") + (for-each write-const *consts*) + (for-each write-type *types*) + (for-each write-func-binding *funcs*) + (cat " sexp_gc_release2(ctx);\n" + " return SEXP_VOID;\n" + "}\n\n")) + +(define (generate file) + (display "/* automatically generated by chibi genstubs */\n") + (c-system-include "chibi/eval.h") + (load file) + (write-init)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main + +(define (main args) + (case (length args) + ((1) + (with-output-to-file (string-append (strip-extension (car args)) ".c") + (lambda () (generate (car args))))) + ((2) + (if (equal? "-" (cadr args)) + (generate (car args)) + (with-output-to-file (cadr args) (lambda () (generate (car args)))))) + (else + (error "usage: genstubs []")))) From 351bf36ecf4134e9b361a6cd557c5cd3d150eefc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Dec 2009 19:16:15 +0900 Subject: [PATCH 319/535] heaps allocate an extra cell to be safe (re: issue #10) --- gc.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/gc.c b/gc.c index 1130c15b..5e2a4d23 100644 --- a/gc.c +++ b/gc.c @@ -171,7 +171,8 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) { sexp_heap sexp_make_heap (size_t size) { sexp_free_list free, next; - sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size); + sexp_heap h + = (sexp_heap) malloc(sizeof(struct sexp_heap) + size + sexp_heap_align(1)); if (! h) return NULL; h->size = size; h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); From e2d7291269354121b83c72a429ae96f1c339bd71 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Dec 2009 20:12:09 +0900 Subject: [PATCH 320/535] belatedly adding type checks on read/write/display --- eval.c | 2 +- sexp.c | 45 ++++++++++++++++++++++++++++++--------------- 2 files changed, 31 insertions(+), 16 deletions(-) diff --git a/eval.c b/eval.c index 6d0ed08e..f58c4739 100644 --- a/eval.c +++ b/eval.c @@ -2025,7 +2025,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, path); + return sexp_make_output_port(ctx, out, path); } static sexp sexp_close_port (sexp ctx, sexp port) { diff --git a/sexp.c b/sexp.c index a4aa5efc..221e674d 100644 --- a/sexp.c +++ b/sexp.c @@ -1017,7 +1017,7 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { return p; } -sexp sexp_write (sexp ctx, sexp obj, sexp out) { +sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { #if SEXP_USE_HUFF_SYMS unsigned long res, c; #endif @@ -1033,14 +1033,14 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) { switch (sexp_pointer_tag(obj)) { case SEXP_PAIR: sexp_write_char(ctx, '(', out); - sexp_write(ctx, sexp_car(obj), out); + sexp_write_one(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); + sexp_write_one(ctx, sexp_car(x), out); } if (! sexp_nullp(x)) { sexp_write_string(ctx, " . ", out); - sexp_write(ctx, x, out); + sexp_write_one(ctx, x, out); } sexp_write_char(ctx, ')', out); break; @@ -1051,10 +1051,10 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) { sexp_write_string(ctx, "#()", out); } else { sexp_write_string(ctx, "#(", out); - sexp_write(ctx, elts[0], out); + sexp_write_one(ctx, elts[0], out); for (i=1; i", out); break; case SEXP_STRING: @@ -1192,14 +1192,24 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) { return SEXP_VOID; } +sexp sexp_write (sexp ctx, sexp obj, sexp out) { + if (! sexp_oportp(out)) + return sexp_type_exception(ctx, "write: not an output-port", out); + else + return sexp_write_one(ctx, obj, out); +} + sexp sexp_display (sexp ctx, sexp obj, sexp out) { - if (sexp_stringp(obj)) + sexp res=SEXP_VOID; + if (! sexp_oportp(out)) + res = sexp_type_exception(ctx, "display: not an output-port", out); + else if (sexp_stringp(obj)) sexp_write_string(ctx, sexp_string_data(obj), out); else if (sexp_charp(obj)) sexp_write_char(ctx, sexp_unbox_character(obj), out); else - sexp_write(ctx, obj, out); - return SEXP_VOID; + res = sexp_write_one(ctx, obj, out); + return res; } sexp sexp_flush_output (sexp ctx, sexp out) { @@ -1608,11 +1618,15 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } sexp sexp_read (sexp ctx, sexp in) { - sexp res = sexp_read_raw(ctx, in); + sexp res; + if (sexp_iportp(in)) + res = sexp_read_raw(ctx, in); + else + res = sexp_type_exception(ctx, "read: not an input-port", in); if (res == SEXP_CLOSE) - return sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); + res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); if (res == SEXP_RAWDOT) - return sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); + res = sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); return res; } @@ -1632,8 +1646,9 @@ sexp sexp_write_to_string(sexp ctx, sexp obj) { sexp_gc_var1(out); sexp_gc_preserve1(ctx, out); out = sexp_make_output_string_port(ctx); - sexp_write(ctx, obj, out); - str = sexp_get_output_string(ctx, out); + str = sexp_write(ctx, obj, out); + if (! sexp_exceptionp(str)) + str = sexp_get_output_string(ctx, out); sexp_gc_release1(ctx); return str; } From 3087302be6b703b9c188a1103e35a27f090eb6e9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Dec 2009 22:19:08 +0900 Subject: [PATCH 321/535] string-concatenate now takes an optional argument --- include/chibi/sexp.h | 2 +- opcodes.c | 2 +- sexp.c | 18 +++++++++++++----- 3 files changed, 15 insertions(+), 7 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 687daefb..369e3b65 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -810,7 +810,7 @@ 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_string_concatenate (sexp ctx, sexp str_ls); +SEXP_API sexp sexp_string_concatenate (sexp ctx, sexp str_ls, sexp sep); 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); diff --git a/opcodes.c b/opcodes.c index d3c77865..85a35afc 100644 --- a/opcodes.c +++ b/opcodes.c @@ -104,7 +104,7 @@ _FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_ma _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), +_FN2OPT(SEXP_PAIR, SEXP_STRING, "string-concatenate", SEXP_FALSE, 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), diff --git a/sexp.c b/sexp.c index 221e674d..2a3ff0f6 100644 --- a/sexp.c +++ b/sexp.c @@ -646,21 +646,29 @@ sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { return res; } -sexp sexp_string_concatenate (sexp ctx, sexp str_ls) { +sexp sexp_string_concatenate (sexp ctx, sexp str_ls, sexp sep) { sexp res, ls; - sexp_uint_t len=0; - char *p; - for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_uint_t len=0, i=0, sep_len=0; + char *p, *csep; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls), i++) 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)); + if (sexp_stringp(sep) && ((sep_len=sexp_string_length(sep)) > 0)) { + csep = sexp_string_data(sep); + len += sep_len*(i-1); + } res = sexp_make_string(ctx, sexp_make_fixnum(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; + if (sep_len && sexp_pairp(sexp_cdr(ls))) { + memcpy(p, csep, sep_len); + p += sep_len; + } } *p = '\0'; return res; @@ -990,7 +998,7 @@ sexp sexp_get_output_string (sexp ctx, sexp out) { } else { ls = sexp_port_cookie(out); } - res = sexp_string_concatenate(ctx, ls); + res = sexp_string_concatenate(ctx, ls, SEXP_FALSE); sexp_gc_release2(ctx); return res; } From b77d102a706417f42863311cc0f629f3587f5bbe Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Dec 2009 23:32:29 +0900 Subject: [PATCH 322/535] fixing non-tail-call optimization in some conditional cases --- eval.c | 13 +++++++++++++ include/chibi/eval.h | 2 ++ 2 files changed, 15 insertions(+) diff --git a/eval.c b/eval.c index f58c4739..de858f87 100644 --- a/eval.c +++ b/eval.c @@ -837,6 +837,7 @@ static void generate_cnd (sexp ctx, sexp cnd) { sexp_context_depth(ctx)--; label1 = sexp_context_make_label(ctx); generate(ctx, sexp_cnd_pass(cnd)); + sexp_context_tailp(ctx) = tailp; emit(ctx, SEXP_OP_JUMP); sexp_context_depth(ctx)--; label2 = sexp_context_make_label(ctx); @@ -2354,6 +2355,18 @@ sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, return res; } +sexp sexp_define_foreign_param (sexp ctx, sexp env, char *name, int num_args, + sexp_proc1 f, char *param) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_intern(ctx, param); + tmp = sexp_env_cell(env, tmp); + res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); + sexp_gc_release1(ctx); + return res; +} + #if SEXP_USE_TYPE_DEFS sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 60201c61..7ce70433 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -152,6 +152,8 @@ SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_a #define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL) #define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d) +SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, char *name, int num_args, sexp_proc1 f, char *param); + #if SEXP_USE_TYPE_DEFS SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); SEXP_API sexp sexp_make_constructor (sexp ctx, sexp name, sexp type); From c94490872ced89f35f69ece6d4fc4cf16dbfe741 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Dec 2009 23:45:40 +0900 Subject: [PATCH 323/535] fixing bug in string->number for hex strings (issue #21) --- lib/init.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/init.scm b/lib/init.scm index d448a650..e1b7b256 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -486,7 +486,7 @@ (if (char-numeric? ch) (- (char->integer ch) (char->integer #\0)) (and (<= 65 (char->integer (char-upcase ch)) 70) - (- (char->integer (char-upcase ch)) 65)))) + (- (char->integer (char-upcase ch)) 55)))) (define (number->string n . o) (if (if (null? o) #t (eq? 10 (car o))) From 1dba7fb8fdec3888c9bec72dc84b8cbc62396983 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 30 Dec 2009 03:49:21 +0900 Subject: [PATCH 324/535] forgot to preserve some gc vars in the bignum lib --- eval.c | 6 ++++++ opt/bignum.c | 33 +++++++++++++++++++++++++-------- 2 files changed, 31 insertions(+), 8 deletions(-) diff --git a/eval.c b/eval.c index de858f87..d74812a6 100644 --- a/eval.c +++ b/eval.c @@ -1663,6 +1663,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_ADD: #if SEXP_USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = top; if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) @@ -1690,6 +1691,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_SUB: #if SEXP_USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = top; if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) @@ -1717,6 +1719,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_MUL: #if SEXP_USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = top; if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) @@ -1742,6 +1745,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case SEXP_OP_DIV: + sexp_context_top(ctx) = top; if (_ARG2 == SEXP_ZERO) { #if SEXP_USE_FLONUMS if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) @@ -1785,6 +1789,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { } #if SEXP_USE_BIGNUMS else { + sexp_context_top(ctx) = top; _ARG2 = sexp_quotient(ctx, _ARG1, _ARG2); top--; } @@ -1802,6 +1807,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { } #if SEXP_USE_BIGNUMS else { + sexp_context_top(ctx) = top; _ARG2 = sexp_remainder(ctx, _ARG1, _ARG2); top--; } diff --git a/opt/bignum.c b/opt/bignum.c index 60215de8..fb211725 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -173,8 +173,10 @@ sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset) { sexp_uint_t len=sexp_bignum_length(a), *data, *adata=sexp_bignum_data(a), carry=0, i; sexp_luint_t n; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); if ((! d) || (sexp_bignum_length(d)+offset < len)) - d = sexp_make_bignum(ctx, len); + d = tmp = sexp_make_bignum(ctx, len); data = sexp_bignum_data(d); for (i=0; i Date: Thu, 31 Dec 2009 00:24:19 +0900 Subject: [PATCH 325/535] adding (chibi io) w/ interface to fgets, fread, fwrite, etc. --- .hgignore | 21 + COPYING | 24 + Makefile | 193 ++ README | 424 ++++ RELEASE | 1 + TODO | 148 ++ VERSION | 1 + doc/chibi-scheme.1 | 133 ++ eval.c | 2737 ++++++++++++++++++++++++ gc.c | 250 +++ include/chibi/bignum.h | 43 + include/chibi/eval.h | 165 ++ include/chibi/features.h | 297 +++ include/chibi/sexp.h | 862 ++++++++ lib/chibi/ast.c | 80 + lib/chibi/ast.module | 14 + lib/chibi/disasm.c | 116 + lib/chibi/disasm.module | 5 + lib/chibi/filesystem.module | 27 + lib/chibi/filesystem.scm | 43 + lib/chibi/filesystem.stub | 115 + lib/chibi/heap-stats.c | 129 ++ lib/chibi/heap-stats.module | 5 + lib/chibi/io.module | 6 + lib/chibi/io/io.scm | 6 + lib/chibi/io/io.stub | 13 + lib/chibi/loop.module | 9 + lib/chibi/loop/loop.scm | 365 ++++ lib/chibi/macroexpand.module | 6 + lib/chibi/macroexpand.scm | 85 + lib/chibi/match.module | 6 + lib/chibi/match/match.scm | 670 ++++++ lib/chibi/net.module | 10 + lib/chibi/net.scm | 23 + lib/chibi/net.stub | 25 + lib/chibi/pathname.module | 7 + lib/chibi/pathname.scm | 180 ++ lib/chibi/process.module | 17 + lib/chibi/process.stub | 72 + lib/chibi/signal.c | 62 + lib/chibi/system.module | 15 + lib/chibi/system.stub | 34 + lib/chibi/time.module | 11 + lib/chibi/time.stub | 45 + lib/chibi/uri.module | 10 + lib/chibi/uri.scm | 306 +++ lib/config.scm | 174 ++ lib/init.scm | 881 ++++++++ lib/srfi/1.module | 31 + lib/srfi/1/alists.scm | 14 + lib/srfi/1/constructors.scm | 36 + lib/srfi/1/deletion.scm | 25 + lib/srfi/1/fold.scm | 115 + lib/srfi/1/lset.scm | 51 + lib/srfi/1/misc.scm | 54 + lib/srfi/1/predicates.scm | 42 + lib/srfi/1/search.scm | 54 + lib/srfi/1/selectors.scm | 59 + lib/srfi/11.module | 28 + lib/srfi/16.module | 24 + lib/srfi/2.module | 16 + lib/srfi/26.module | 24 + lib/srfi/27.module | 11 + lib/srfi/27/constructors.scm | 10 + lib/srfi/27/rand.c | 204 ++ lib/srfi/33.module | 17 + lib/srfi/33/bit.c | 303 +++ lib/srfi/33/bitwise.scm | 61 + lib/srfi/39.module | 25 + lib/srfi/6.module | 5 + lib/srfi/69.module | 17 + lib/srfi/69/hash.c | 242 +++ lib/srfi/69/interface.scm | 115 + lib/srfi/69/type.scm | 12 + lib/srfi/8.module | 10 + lib/srfi/9.module | 82 + lib/srfi/95.module | 7 + lib/srfi/95/qsort.c | 170 ++ lib/srfi/95/sort.scm | 70 + lib/srfi/98.module | 5 + lib/srfi/98/env.c | 48 + main.c | 193 ++ mkfile | 26 + opcodes.c | 153 ++ opt/bignum.c | 751 +++++++ opt/plan9-opcodes.c | 19 + opt/plan9.c | 351 +++ opt/sexp-huff.c | 128 ++ opt/sexp-hufftabs.c | 92 + opt/sexp-unhuff.c | 71 + opt/simplify.c | 135 ++ sexp.c | 1685 +++++++++++++++ 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 | 48 + tests/basic/test10-unhygiene.res | 6 + tests/basic/test10-unhygiene.scm | 49 + tests/build/build-opts.txt | 21 + tests/build/build-tests.sh | 37 + tests/install/install-tests.pl | 57 + tests/install/run-install-test.sh | 12 + tests/loop-tests.scm | 202 ++ tests/match-tests.scm | 196 ++ tests/numeric-tests.scm | 150 ++ tests/r5rs-tests.scm | 483 +++++ tools/genstubs.scm | 1194 +++++++++++ 123 files changed, 17079 insertions(+) create mode 100644 .hgignore create mode 100644 COPYING create mode 100644 Makefile create mode 100644 README create mode 100644 RELEASE create mode 100644 TODO create mode 100644 VERSION create mode 100644 doc/chibi-scheme.1 create mode 100644 eval.c create mode 100644 gc.c create mode 100644 include/chibi/bignum.h create mode 100644 include/chibi/eval.h create mode 100644 include/chibi/features.h create mode 100644 include/chibi/sexp.h create mode 100644 lib/chibi/ast.c create mode 100644 lib/chibi/ast.module create mode 100644 lib/chibi/disasm.c create mode 100644 lib/chibi/disasm.module create mode 100644 lib/chibi/filesystem.module create mode 100644 lib/chibi/filesystem.scm create mode 100644 lib/chibi/filesystem.stub create mode 100644 lib/chibi/heap-stats.c create mode 100644 lib/chibi/heap-stats.module create mode 100644 lib/chibi/io.module create mode 100644 lib/chibi/io/io.scm create mode 100644 lib/chibi/io/io.stub create mode 100644 lib/chibi/loop.module create mode 100644 lib/chibi/loop/loop.scm create mode 100644 lib/chibi/macroexpand.module create mode 100644 lib/chibi/macroexpand.scm create mode 100644 lib/chibi/match.module create mode 100644 lib/chibi/match/match.scm create mode 100644 lib/chibi/net.module create mode 100644 lib/chibi/net.scm create mode 100644 lib/chibi/net.stub create mode 100644 lib/chibi/pathname.module create mode 100644 lib/chibi/pathname.scm create mode 100644 lib/chibi/process.module create mode 100644 lib/chibi/process.stub create mode 100644 lib/chibi/signal.c create mode 100644 lib/chibi/system.module create mode 100644 lib/chibi/system.stub create mode 100644 lib/chibi/time.module create mode 100644 lib/chibi/time.stub create mode 100644 lib/chibi/uri.module create mode 100644 lib/chibi/uri.scm create mode 100644 lib/config.scm create mode 100644 lib/init.scm create mode 100644 lib/srfi/1.module create mode 100644 lib/srfi/1/alists.scm create mode 100644 lib/srfi/1/constructors.scm create mode 100644 lib/srfi/1/deletion.scm create mode 100644 lib/srfi/1/fold.scm create mode 100644 lib/srfi/1/lset.scm create mode 100644 lib/srfi/1/misc.scm create mode 100644 lib/srfi/1/predicates.scm create mode 100644 lib/srfi/1/search.scm create mode 100644 lib/srfi/1/selectors.scm create mode 100644 lib/srfi/11.module create mode 100644 lib/srfi/16.module create mode 100644 lib/srfi/2.module create mode 100644 lib/srfi/26.module create mode 100644 lib/srfi/27.module create mode 100644 lib/srfi/27/constructors.scm create mode 100644 lib/srfi/27/rand.c create mode 100644 lib/srfi/33.module create mode 100644 lib/srfi/33/bit.c create mode 100644 lib/srfi/33/bitwise.scm create mode 100644 lib/srfi/39.module create mode 100644 lib/srfi/6.module create mode 100644 lib/srfi/69.module create mode 100644 lib/srfi/69/hash.c create mode 100644 lib/srfi/69/interface.scm create mode 100644 lib/srfi/69/type.scm create mode 100644 lib/srfi/8.module create mode 100644 lib/srfi/9.module create mode 100644 lib/srfi/95.module create mode 100644 lib/srfi/95/qsort.c create mode 100644 lib/srfi/95/sort.scm create mode 100644 lib/srfi/98.module create mode 100644 lib/srfi/98/env.c create mode 100644 main.c create mode 100644 mkfile create mode 100644 opcodes.c create mode 100644 opt/bignum.c create mode 100644 opt/plan9-opcodes.c create mode 100644 opt/plan9.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 opt/simplify.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/build/build-opts.txt create mode 100755 tests/build/build-tests.sh create mode 100755 tests/install/install-tests.pl create mode 100755 tests/install/run-install-test.sh create mode 100644 tests/loop-tests.scm create mode 100644 tests/match-tests.scm create mode 100644 tests/numeric-tests.scm create mode 100644 tests/r5rs-tests.scm create mode 100755 tools/genstubs.scm diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..babe41d2 --- /dev/null +++ b/.hgignore @@ -0,0 +1,21 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dylib +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +chibi-scheme +chibi-scheme-static +include/chibi/install.h diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..1fcee28e --- /dev/null +++ b/COPYING @@ -0,0 +1,24 @@ +Copyright (c) 2009 Alex Shinn +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..ddfc56e3 --- /dev/null +++ b/Makefile @@ -0,0 +1,193 @@ +# -*- makefile-gmake -*- + +.PHONY: all libs doc dist clean cleaner test install uninstall +.PRECIOUS: %.c + +# install configuration + +CC ?= cc +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +SOLIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi +LIBDIR ?= $(PREFIX)/lib/chibi +MANDIR ?= $(PREFIX)/share/man/man1 + +DESTDIR ?= + +GENSTUBS ?= ./tools/genstubs.scm + +######################################################################## +# system configuration - if not using GNU make, set PLATFORM and the +# following flags as necessary. + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +PLATFORM=unix +endif +endif +endif + +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0 +else +ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL -DSEXP_USE_DEBUG=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static -DSEXP_USE_DL=0 +endif +endif + +ifeq ($(USE_BOEHM),1) +SEXP_USE_BOEHM = 1 +endif + +ifeq ($(SEXP_USE_BOEHM),1) +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DSEXP_USE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude +endif + +ifeq ($(SEXP_USE_DL),0) +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS) +else +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -ldl -lm +XCFLAGS := -Wall -g3 $(CFLAGS) +endif + +######################################################################## + +all: chibi-scheme$(EXE) libs + +COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ + lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \ + lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \ + lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \ + lib/chibi/io/io$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + +libs: $(COMPILED_LIBS) + +INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h + +include/chibi/install.h: Makefile + echo '#define sexp_so_extension "'$(SO)'"' > $@ + echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@ + echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ + echo '#define sexp_version "'`cat VERSION`'"' >> $@ + echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@ + +sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +eval.o: eval.c opcodes.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +main.o: main.c $(INCLUDES) include/chibi/eval.h 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) + +%.c: %.stub $(GENSTUBS) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) PATH=.:$(PATH) $(GENSTUBS) $< + +lib/%$(SO): lib/%.c $(INCLUDES) + -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +clean: + rm -f *.o *.i *.s *.8 + find lib -name \*$(SO) -exec rm -f '{}' \; + rm -f tests/basic/*.out tests/basic/*.err + +cleaner: clean + rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h + rm -rf *.dSYM + +test-basic: chibi-scheme$(EXE) + @for f in tests/basic/*.scm; do \ + ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + +test-build: + ./tests/build/build-tests.sh + +test-numbers: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/numeric-tests.scm + +test-hash: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/hash-tests.scm + +test-match: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/match-tests.scm + +test-loop: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/loop-tests.scm + +test: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/r5rs-tests.scm + +install: chibi-scheme$(EXE) + mkdir -p $(DESTDIR)$(BINDIR) + cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ + mkdir -p $(DESTDIR)$(MODDIR) + cp lib/init.scm lib/config.scm $(DESTDIR)$(MODDIR)/ + cp -r lib/ $(DESTDIR)$(MODDIR)/ + mkdir -p $(DESTDIR)$(INCDIR) + cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ + mkdir -p $(DESTDIR)$(LIBDIR) + mkdir -p $(DESTDIR)$(SOLIBDIR) + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ + mkdir -p $(DESTDIR)$(MANDIR) + cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/ + if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + +uninstall: + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE) + rm -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO) + rm -f $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a + cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -rf $(DESTDIR)$(MODDIR) + +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..172c476d --- /dev/null +++ b/README @@ -0,0 +1,424 @@ + + 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. + +------------------------------------------------------------------------ +INSTALLING + +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 chibi/features.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 CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 + +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 features.h file, or +directly from make with: + + make SEXP_USE_BOEHM=1 + +------------------------------------------------------------------------ +CHIBI-SCHEME LANGUAGE + +The default language is mostly compatible with the R5RS, with all +differences made by design, not through difficulty of implementation. +The following procedures are omitted: + + transcript-on and transcript-off (because they're silly) + rationalize (pending the addition of rational numbers) + +Apart from this, chibi-scheme is case-sensitive, unlike the R5RS. +The default configuration includes fixnums, flonums and bignums +but no exact rationals or complex numbers. + +Full continuations are supported, but currently continuations don't +take C code into account. The only higher-order C functions in the +standard environment are LOAD and EVAL. + +LOAD is extended to accept an optional environment argument, like +EVAL. You can also LOAD shared libraries in addition to Scheme source +files - in this case the function sexp_init_library is automatically +called with the following signature: + + sexp_init_library(sexp context, sexp environment) + +SYNTAX-RULES macros are provided by default, with the extensions from +SRFI-46. In addition, low-level hygienic macros are provided with +a syntactic-closures interface, including SC-MACRO-TRANSFORMER, +RSC-MACRO-TRANSFORMER, and ER-MACRO-TRANSFORMER. A good introduction +to syntactic-closures can be found at: + + http://community.schemewiki.org/?syntactic-closures + +IDENTIFIER?, IDENTIFIER->SYMBOL, IDENTIFIER=?, and +MAKE-SYNTACTIC-CLOSURE and STRIP-SYNTACTIC-CLOSURES are provided. + +SRFI-0's COND-EXPAND is provided, with the feature `chibi'. + +STRING-CONCATENATE concatenates a list of strings. + +------------------------------------------------------------------------ +TYPES + +You can define new data types with SRFI-9. This is just syntactic +sugar for the following more primitive type constructors: + +(register-simple-type ) + => ; a fixnum + +(make-type-predicate ) + => ; takes 1 arg, returns #t iff that arg is of the type + +(make-constructor ) + => ; takes 0 args, returns a newly allocated instance of type + +(make-getter ) + => ; takes 1 args, retrieves the field located at the index + +(make-setter ) + => ; takes 2 args, sets the field located at the index + +------------------------------------------------------------------------ +MODULE SYSTEM + +A configurable module system, in the style of the Scheme48 module +system, is provided by default. + +Modules names are hierarchical lists of symbols or numbers. The +definition of the module (foo bar baz) is searched for in the file +foo/bar/baz.module. This file should contain an expression of the +form: + + (define-module (foo bar baz) + ...) + +where can be any of + + (export ...) - specify an export list + (import ...) - specify one or more imports + (import-immutable ...) - specify an immutable import + (body ...) - inline Scheme code + (include ...) - load one or more files + (include-shared ...) - dynamic load a library + + can either be a module name or any of + + (only ...) + (except ...) + (rename ( ) ...) + (prefix ) + +The can be composed and perform basic selection and renaming of +individual identifiers from the given module. + +Files are loaded relative to the .module file, and are written with +their extension (so you can use whatever suffix you prefer - .scm, +.ss, .sls, etc.). + +Shared modules, on the other hand, should be specified _without_ the +extension - the correct suffix will be added portably (e.g. .so for +Unix and .dylib for OS X). + +You may also use COND-EXPAND and arbitrary macro expansions in a +module definition to generate . + +------------------------------------------------------------------------ +MODULES + +The default environment is (scheme) - you almost always want to import +this. + +Currently you can load the following SRFIs with (import (srfi N)): + + (srfi 0) - cond-expand + (srfi 1) - list library + (srfi 2) - and-let* + (srfi 6) - basic string ports + (srfi 8) - receive + (srfi 9) - define-record-type + (srfi 11) - let-values/let*-values + (srfi 16) - case-lambda + (srfi 22) - running scheme scripts on Unix + (srfi 23) - error reporting mechanism + (srfi 26) - cut/cute partial application + (srfi 27) - sources of random bits + (srfi 33) - bitwise operators + (srfi 39) - prameter objects + (srfi 46) - basic syntax-rules extensions + (srfi 62) - s-expression comments + (srfi 69) - basic hash tables + (srfi 95) - sorting and merging + (srfi 98) - environment access + +although 0, 22, 23, 46 and 62 are built into the default environment +so there's no need to import them. + +Included non-standard modules are put in the (chibi) module namespace. +The following additional modules are available: + + (chibi net) - networking interface + (chibi filesystem) - local filesystem and file descriptor interface + (chibi process) - processes and signals + (chibi system) - host system and user information + (chibi time) - time and date library + (chibi match) - pattern-matching library + (chibi loop) - extensible loop syntax + (chibi pathname) - pathname manipulation utilities + (chibi uri) - URI parsing and construction utilities + (chibi macroexpand) - macro expansion utility + (chibi ast) - interface to the internal Abstract Syntax Tree + (chibi disasm) - disassembly utility for the chibi VM + (chibi heap-stats) - debugging tool to analyze or dump the heap + +------------------------------------------------------------------------ +C INTERFACE + +See the file main.c for an example of using chibi-scheme as a library. + +The basic usage involves creating a context for evaluation and loading +or evaluating Scheme source with it. Begin by including the eval.h +header file: + + #include + +then call + + sexp_scheme_init(); + +with no parameters to initialize any globals (this actually does +nothing in the standard configuration but is a good idea to call +anyway). + +Then you can use the following to create and manipulate contexts: + + sexp_make_eval_context(context, stack, environment, heap_size) + Creates a new context with the given stack and environment. + If context is non-NULL, this will be the "parent" context and + the two contexts will share a heap. Otherwise, a new heap + will be allocated with heap_size, or a default size if heap_size + is zero. stack and environment may both also be NULL (and _must_ + be NULL if context is NULL) and will be given standard defaults. + + Thus the to create your first context you generally call: + + sexp_make_eval_context(NULL, NULL, NULL, 0) + + You can create as many contexts as you want, and other than those + sharing a heap they are all independent and thread-safe. + + sexp_load_standard_env(context, env, version) + Loads the init.scm file in the environment env. Version refers + to the RnRS version number and should always be SEXP_FIVE. The + environment created with sexp_make_eval_context only contains + core syntactic forms and C primitives (thus for example it has + CAR but not CADR or LIST), so to get a full featured + environment, plus a module system with which to load additional + modules, you want to use this. + + sexp_destroy_context(context) + Signals that you no longer need context, or any other context + sharing the heap. It will thus free() the context and heap and + all associated memory. Does nothing if using the Boehm GC. + +Environments can be handled with the following: + + sexp_context_env(context) + A macro returning the default environment associated with context. + + sexp_env_define(context, env, symbol, value) + Define a variable in an environment. + + sexp_env_ref(env, symbol, dflt) + Fetch the binding for symbol from the environment env, + returning the default dflt if the symbol is unbound. + +You can evaluate code with the following utility: + + sexp_eval(context, expr, env) + Evaluates an s-expression in an environment. + env can be NULL to use the context's default env. + + sexp_eval_string(context, str, env) + Reads an s-expression from str and evaluates it in env. + + sexp_load(context, file, env) + Read and eval all top-level forms from file in environment env. + As described in LOAD above, file may be a shared library. + +To define new primitive functions from C, use sexp_define_foreign, +which takes a Scheme environment, a name, a number of arguments the C +function takes (not counting the context argument), and a C function. + + /* sexp_define_foreign(context, env, name, num_args, f) */ + + sexp add (sexp context, sexp x, sexp y) { + return sexp_fx_add(x, y); + } + + sexp_define_foreign(context, env, "add", 2, add); + +You can also define functions with a single optional argument: + + sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); + +See the SRFI-69 implementation for more detailed examples of this. + +------------------------------------------------------------------------ +FFI + +Simple C FFI. "genstubs.scm file.stub" will read in the C function +FFI definitions from file.stub and output the appropriate C +wrappers into file.c. You can then compile that file with: + + cc -fPIC -shared file.c -lchibi-scheme + +(or using whatever flags are appropriate to generate shared libs on +your platform) and then the generated .so file can be loaded +directly with LOAD, or portably using (include-shared "file") in a +module definition (note that include-shared uses no suffix). + +The goal of this interface is to make access to C types and +functions easy, without requiring the user to write any C code. +That means the stubber needs to be intelligent about various C +calling conventions and idioms, such as return values passed in +actual parameters. Writing C by hand is still possible, and +several of the core modules provide C interfaces directly without +using the stubber. + +================================ + +Struct Interface + +(define-c-struct struct-name + [predicate: predicate-name] + [constructor: constructor-name] + [finalizer: c_finalizer_name] + (type c_field_name getter-name setter-name) ...) + + +================================ + + +Function Interface + +(define-c return-type name-spec (arg-type ...)) + +where name-space is either a symbol name, or a list of +(scheme-name c_name). If just a symbol, the C name is taken +to be the same with -'s replaced by _'s. + +arg-type is a type suitable for input validation and conversion. + +================================ + + +Types + +Types + +Basic Types + void + boolean + char + sexp (no conversions) + +Integer Types: + signed-char short int long + unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t + time_t (in seconds, but using the chibi epoch of 2010/01/01) + errno (as a return type returns #f on error) + +Float Types: + float double long-double + +String Types: + string - a null-terminated char* + env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme + in addition you can use (array char) as a string + +Port Types: + input-port output-port + +Struct Types: + +Struct types are by default just referred to by the bare +struct-name from define-c-struct, and it is assumed you want a +pointer to that type. To refer to the full struct, use the struct +modifier, as in (struct struct-name). + +Type modifiers + +Any type may also be written as a list of modifiers followed by the +type itself. The supported modifiers are: + +const: prepends the "const" C type modifier + * as a return or result parameter, makes non-immediates immutable + +free: it's Scheme's responsibility to "free" this resource + * as a return or result parameter, registers the freep flag + this causes the type finalizer to be run when GCed + +maybe-null: this pointer type may be NULL + * as a result parameter, NULL is translated to #f + normally this would just return a wrapped NULL pointer + * as an input parameter, #f is translated to NULL + normally this would be a type error + +pointer: create a pointer to this type + * as a return parameter, wraps the result in a vanilla cpointer + * as a result parameter, boxes then unboxes the value + +struct: treat this struct type as a struct, not a pointer + * as an input parameter, dereferences the pointer + * as a type field, indicates a nested struct + +link: add a gc link + * as a field getter, link to the parent object, so the + parent won't be GCed so long as we have a reference + to the child. this behavior is automatic for nested + structs. + +result: return a result in this parameter + * if there are multiple results (including the return type), + they are all returned in a list + * if there are any result parameters, a return type + of errno returns #f on failure, and as eliminated + from the list of results otherwise + +(value ): specify a fixed value + * as an input parameter, this parameter is not provided + in the Scheme API but always passed as + +(default ): specify a default value + * as the final input parameter, makes the Scheme parameter + optional, defaulting to + +(array []) an array type + * length must be specified for return and result parameters + * if specified, length can be any of + ** an integer, for a fixed size + ** the symbol null, indicating a NULL-terminated array diff --git a/RELEASE b/RELEASE new file mode 100644 index 00000000..35f6fb33 --- /dev/null +++ b/RELEASE @@ -0,0 +1 @@ +lithium diff --git a/TODO b/TODO new file mode 100644 index 00000000..93f7c837 --- /dev/null +++ b/TODO @@ -0,0 +1,148 @@ +-*- org -*- + +* compiler +** DONE ast rewrite + - State "DONE" [2009-04-09 Thu 14:32] +** DONE call/cc support + - State "DONE" [2009-04-09 Thu 14:36] +** DONE exceptions + - State "DONE" [2009-04-09 Thu 14:45] +** TODO native x86 backend +** TODO fasl/image files +** DONE shared stack on EVAL + - State "DONE" [2009-12-26 Sat 08:22] + +* compiler optimizations +** DONE constant folding + - State "DONE" [2009-12-16 Wed 23:25] +** DONE simplification pass, dead-code elimination + - State "DONE" [2009-12-18 Fri 14:14] + This is important in particular for the output generated by + syntax-rules. +** TODO lambda lift + The current closure representation is not very efficient, so this + would help a lot. +** TODO inlining (and disabling primitive inlining) + Being able to redefine procedures is important though. +** TODO unsafe operations + Possibly, don't want to make things too complicated or unstable. +** TODO plugin infrastructure +** TODO type inference with warnings + +* macros +** DONE hygiene + - State "DONE" [2009-04-09 Thu 14:41] +** DONE hygienic nested let-syntax + - State "DONE" [2009-12-08 Tue 14:41] +** DONE macroexpand utility + - State "DONE" [2009-12-08 Tue 14:41] +** DONE SRFI-46 basic syntax-rules extensions + - State "DONE" [2009-12-26 Sat 07:59] +** DONE (... ...) support + - State "DONE" [2009-12-26 Sat 02:06] +** TODO compiler macros +** TODO syntax-rules common pattern reduction +** TODO syntax-rules loop optimization + +* garbage collection +** DONE precise gc rewrite + - State "DONE" [2009-06-22 Mon 14:27] +** DONE fix heap growing + - State "DONE" [2009-06-22 Mon 14:29] +** DONE separate gc heaps + - State "DONE" [2009-12-08 Tue 14:29] +** DONE add finalizers + - State "DONE" [2009-12-08 Tue 14:29] +** TODO support weak references + +* runtime +** DONE bignums + - State "DONE" [2009-07-07 Tue 14:42] +** TODO unicode +** TODO threads +** TODO virtual ports +** DONE dynamic-wind + - State "DONE" [2009-12-26 Sat 01:51] + Adapted a version from Scheme48. +** DONE recursive disasm + - State "DONE" [2009-12-18 Fri 14:15] + +* FFI +** DONE libdl support + - State "DONE" [2009-12-08 Tue 14:45] +** DONE opcode generation interface + - State "DONE" [2009-11-15 Sun 14:45] +** DONE stub generator + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE define-c-struct + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE define-c + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE array return types + - State "DONE" [2009-12-26 Sat 01:49] +*** DONE pre-buffered string types (like getcwd) + - State "DONE" [2009-12-26 Sat 01:49] + +* module system +** DONE scheme48-like config language + - State "DONE" [2009-10-13 Tue 14:38] +** DONE shared library includes + - State "DONE" [2009-12-08 Tue 14:39] +** DONE only/except/rename/prefix modifiers + - State "DONE" [2009-12-16 Wed 18:57] +** TODO scheme-complete.el support +** DONE access individual modules from repl + - State "DONE" [2009-12-26 Sat 01:49] + +* core modules +** DONE SRFI-0 cond-expand + - State "DONE" [2009-12-16 Wed 20:12] +** DONE SRFI-9 define-record-type + - State "DONE" [2009-12-08 Tue 14:50] +** DONE SRFI-69 hash-tables + - State "DONE" [2009-11-15 Sun 14:50] +** DONE match library + - State "DONE" [2009-12-08 Tue 14:54] +** DONE loop library + - State "DONE" [2009-12-08 Tue 14:54] +** TODO network interface +** TODO posix interface + Splitting this into several parts. +*** DONE filesystem interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE process interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE time interface + - State "DONE" [2009-12-26 Sat 01:50] +*** TODO host system interface +** DONE pathname library + - State "DONE" [2009-12-16 Wed 18:58] +** DONE uri library + - State "DONE" [2009-12-16 Wed 18:58] +** TODO http library +** TODO show (formatting) library +** TODO zip library +** TODO tar library +** TODO md5sum library + +* ports +** DONE basic mingw support + - State "DONE" [2009-06-22 Mon 14:36] +** DONE Plan 9 support + - State "DONE" [2009-08-10 Mon 14:37] +** DONE 64-bit support + - State "DONE" [2009-11-01 Sun 14:37] +** TODO iPhone support +** TODO bare-metal support + +* miscellaneous +** TODO overall cleanup +** TODO user documentation +** TODO thorough source documentation +** TODO full test suite for libraries + +* distribution +** TODO packaging format +** TODO code repository with fetch+install tool +** TODO translator to/from other implementations + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..be586341 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.3 diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1 new file mode 100644 index 00000000..f20c50e5 --- /dev/null +++ b/doc/chibi-scheme.1 @@ -0,0 +1,133 @@ +.TH "chibi-scheme" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-scheme \- a tiny Scheme interpreter + +.SH SYNOPSIS +.B chibi-scheme +[-qV] +[-I +.I path +] +[-A +.I path +] +[-u +.I module +] +[-l +.I file +] +[-e +.I expr +] +[-p +.I expr +] +[--] +[ +.I script argument ... +] +.br +.sp 0.3 + +.SH DESCRIPTION +.I chibi-scheme +is a sample interactive Scheme interpreter for the +.I chibi-scheme +library. It serves as an example of how to embed +.I chibi-scheme +in applications, and can be useful on its own for writing +scripts and interactive development. + +When +.I script +is given, the script will be loaded with SRFI-22 semantics, +calling the procedure +.I main +(if defined) with a single parameter as a list of the +command-line arguments beginning with the script name. + +Otherwise, if no script is given and no -e or -p options +are given an interactive repl is entered, reading, evaluating, +then printing expressions until EOF is reached. The repl +provided is very minimal - if you want readline +completion you may want to wrap it with the +.I rlwrap(1) +program. Signals aren't caught either - to enable handling keyboard +interrupts you can use the (chibi process) module. + +.SH OPTIONS +.TP 5 +.BI -V +Prints the version information and exits. +.TP +.BI -q +Don't load the initialization file. The resulting +environment will only contain the core syntactic forms +and primitives coded in C. +.TP +.BI -h size +Specifies the initial size of the heap, in bytes. +.I size +can be any integer value, optionally suffixed by +"K" for kilobytes, or "M" for megabytes. +.I -h +must be specified before any options which load or +evaluate Scheme code. +.TP +.BI -I path +Inserts +.I path +on front of the load path list. +.TP +.BI -A path +Appends +.I path +to the load path list. +.TP +.BI -m module +Imports +.I module +as though "(import +.I module +)" were evaluated. However, to reduce the need for shell +escapes, modules are written in a dot notation, so that the module +.I (foo bar) +is written as +.I foo.bar +.TP +.BI -l file +Loads the Scheme source from the file +.I file +searched for in the default load path. +.TP +.BI -e expr +Evaluates the Scheme expression +.I expr. +.TP +.BI -p expr +Evaluates the Scheme expression +.I expr +then prints the result to stdout. + +.SH ENVIRONMENT +.TP +.B CHIBI_MODULE_PATH +.TQ +A colon separated list of directories to search for module +files, inserted before the system default load paths. + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +More detailed information can be found in the README file +included in the distribution. + +The chibi-scheme home-page: +.br +http://code.google.com/p/chibi-scheme/ diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..de858f87 --- /dev/null +++ b/eval.c @@ -0,0 +1,2737 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +#if SEXP_USE_DEBUG_VM +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { + int i; + if (! sexp_oport(out)) out = sexp_current_error_port(ctx); + 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, NULL); + } else if (sexp_synclop(x)) { + tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(tmp) = sexp_synclo_env(x); + sexp_context_fv(tmp) = sexp_append2(tmp, + sexp_synclo_free_vars(x), + sexp_context_fv(tmp)); + x = sexp_synclo_expr(x); + res = analyze(tmp, x); + } else { + res = x; + } + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res)) + && sexp_pairp(x)) + sexp_exception_source(res) = sexp_pair_source(x); + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} + +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 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, SEXP_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, SEXP_OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, SEXP_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, SEXP_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, SEXP_OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, SEXP_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) + ? SEXP_OP_GLOBAL_REF : SEXP_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, SEXP_OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, SEXP_OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, SEXP_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_var1(ls); + sexp_gc_preserve1(ctx, ls); + + num_args = sexp_unbox_fixnum(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_data(op) + && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) + emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* push the arguments onto the stack in reverse order */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != SEXP_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 SEXP_OPC_ARITHMETIC: + if (num_args > 1) + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_INV: + emit(ctx, (num_args==1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + emit(ctx, SEXP_OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_FOREIGN: + emit(ctx, sexp_opcode_code(op)); + emit_word(ctx, (sexp_uint_t)op); + break; + case SEXP_OPC_TYPE_PREDICATE: + case SEXP_OPC_ACCESSOR: + case SEXP_OPC_CONSTRUCTOR: + emit(ctx, sexp_opcode_code(op)); + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE) { + if (sexp_opcode_data(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); + if (sexp_opcode_data2(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + } + break; + case SEXP_OPC_PARAMETER: + emit_push(ctx, sexp_opcode_data(op)); + emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + /* emit optional folding of operator */ + if ((num_args > 2) + && (sexp_opcode_class(op) == SEXP_OPC_ARITHMETIC + || sexp_opcode_class(op) == SEXP_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_release1(ctx); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, 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 ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); + + sexp_context_tailp(ctx) = tailp; + sexp_context_depth(ctx) -= len; + sexp_gc_release1(ctx); +} + +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_var2(tmp, bc); + sexp_gc_preserve2(ctx, tmp, 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_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); + 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, SEXP_OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, SEXP_OP_CONS); + emit(ctx2, SEXP_OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, SEXP_OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_fixnum((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_ZERO, 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, SEXP_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_fixnum(k)); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_VECTOR_SET); + emit(ctx, SEXP_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, SEXP_OP_MAKE_PROCEDURE); + } + sexp_gc_release2(ctx); +} + +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_var1(res); + if (sexp_nullp(fv2)) + return fv1; + sexp_gc_preserve1(ctx, res); + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, 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_release1(ctx); + return res; +} + +static sexp free_vars (sexp ctx, sexp x, sexp fv) { + sexp_gc_var2(fv1, fv2); + sexp_gc_preserve2(ctx, fv1, 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_release2(ctx); + return fv1; +} + +static sexp make_param_list (sexp ctx, sexp_uint_t i) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_fixnum(i), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ls, bc, res, env; + sexp_gc_var5(params, ref, refs, lambda, ctx2); + if (i == sexp_opcode_num_args(op)) { /* return before preserving */ + if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); + } else if (i < sexp_opcode_num_args(op)) { + return sexp_compile_error(ctx, "not enough args for opcode", op); + } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ + return sexp_compile_error(ctx, "too many args for opcode", op); + } + sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = sexp_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), sexp_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_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + sexp_gc_release5(ctx); + 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_fixnum(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= SEXP_INIT_STACK_SIZE) { + _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); + goto end_loop; + } +#endif + i = sexp_unbox_fixnum(_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_fixnum(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_fixnum(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_fixnum(i); + stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + stack[top+1] = self; + stack[top+2] = sexp_make_fixnum(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 SEXP_OP_FCALL0: + sexp_context_top(ctx) = top; + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx)); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL1: + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx, _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL2: + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL3: + sexp_context_top(ctx) = top; + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL4: + sexp_context_top(ctx) = top; + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL5: + sexp_context_top(ctx) = top; + _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL6: + sexp_context_top(ctx) = top; + _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_JUMP_UNLESS: + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case SEXP_OP_JUMP: + ip += _SWORD0; + break; + case SEXP_OP_PUSH: + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case SEXP_OP_DROP: + top--; + break; + case SEXP_OP_GLOBAL_REF: + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case SEXP_OP_GLOBAL_KNOWN_REF: + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_STACK_REF: /* `pick' in forth */ + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_REF: + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_SET: + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case SEXP_OP_CLOSURE_REF: + _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); + ip += sizeof(sexp); + break; + case SEXP_OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_VECTOR_LENGTH: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); + break; + case SEXP_OP_STRING_REF: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_string_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2)); + else if (! sexp_charp(_ARG3)) + sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_string_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_STRING_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); + break; + case SEXP_OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; + _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case SEXP_OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; + if (! sexp_fixnump(_ARG1)) + sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); + _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_MAKE_EXCEPTION: + _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + break; + case SEXP_OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case SEXP_OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case SEXP_OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case SEXP_OP_FIXNUMP: + _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; + case SEXP_OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case SEXP_OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case SEXP_OP_TYPEP: + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_MAKE: + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_REF: + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_SET: + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); + sexp_slot_set(_ARG1, _UWORD1, _ARG2); + _ARG2 = SEXP_VOID; + ip += sizeof(sexp)*2; + top--; + break; + case SEXP_OP_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case SEXP_OP_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case SEXP_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 SEXP_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 SEXP_OP_CONS: + sexp_context_top(ctx) = top; + _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_ADD: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(j); + } + else + _ARG2 = sexp_add(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_add(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) + sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_SUB: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(j); + } + else + _ARG2 = sexp_sub(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_sub(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) - sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_MUL: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); + if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(prod); + } + else + _ARG2 = sexp_mul(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_mul(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) * sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_DIV: + if (_ARG2 == SEXP_ZERO) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) + _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { +#if SEXP_USE_FLONUMS + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); + _ARG2 = sexp_fixnum_to_flonum(ctx, _ARG2); + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + if (sexp_flonum_value(_ARG2) == trunc(sexp_flonum_value(_ARG2))) + _ARG2 = sexp_make_fixnum(sexp_flonum_value(_ARG2)); +#else + _ARG2 = sexp_fx_div(_ARG1, _ARG2); +#endif + } +#if SEXP_USE_BIGNUMS + else + _ARG2 = sexp_div(ctx, _ARG1, _ARG2); +#else +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) / sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_QUOTIENT: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG2 = sexp_fx_div(_ARG1, _ARG2); + top--; + } +#if SEXP_USE_BIGNUMS + else { + _ARG2 = sexp_quotient(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case SEXP_OP_REMAINDER: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + tmp1 = sexp_fx_rem(_ARG1, _ARG2); + top--; + _ARG1 = tmp1; + } +#if SEXP_USE_BIGNUMS + else { + _ARG2 = sexp_remainder(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case SEXP_OP_NEGATIVE: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_make_fixnum(-sexp_unbox_fixnum(_ARG1)); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) { + _ARG1 = sexp_copy_bignum(ctx, NULL, _ARG1, 0); + sexp_bignum_sign(_ARG1) = -sexp_bignum_sign(_ARG1); + } +#endif +#if SEXP_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 SEXP_OP_INVERSE: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, 1/(double)sexp_unbox_fixnum(_ARG1)); +#if SEXP_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 SEXP_OP_LT: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) < 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) < sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_LE: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) <= 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) <= sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_EQN: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = _ARG1 == _ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) == 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) == sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case SEXP_OP_FIX2FLO: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); +#endif + else if (! sexp_flonump(_ARG1)) + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case SEXP_OP_FLO2FIX: + if (sexp_flonump(_ARG1)) { + if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { + sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_BIGNUMS + } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { + _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); +#endif + } else { + _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); + } + } else if (! sexp_fixnump(_ARG1) && ! sexp_bignump(_ARG1)) { + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + } + break; + case SEXP_OP_CHAR2INT: + if (! sexp_charp(_ARG1)) + sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); + break; + case SEXP_OP_INT2CHAR: + if (! sexp_fixnump(_ARG1)) + sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); + break; + case SEXP_OP_CHAR_UPCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_CHAR_DOWNCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_WRITE_CHAR: + if (! sexp_charp(_ARG1)) + sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_NEWLINE: + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case SEXP_OP_READ_CHAR: + i = sexp_read_char(ctx, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_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 SEXP_OP_RET: + i = sexp_unbox_fixnum(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_fixnum(stack[fp+1]); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_fixnum(stack[fp+3]); + break; + case SEXP_OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); + } + goto loop; + + end_loop: + sexp_gc_release3(ctx); + 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_output_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_stream(port)) + fclose(sexp_port_stream(port)); +#if ! SEXP_USE_STRING_STREAMS + if (sexp_port_buf(port) && sexp_oportp(port)) + free(sexp_port_buf(port)); +#endif + 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); + } +} + +#if SEXP_USE_DL +sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); + if (! handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = dlsym(handle, "sexp_init_library"); + if (! init) { + dlclose(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx, env); +} +#endif + +sexp sexp_load (sexp ctx, sexp source, sexp env) { +#if SEXP_USE_DL + char *suffix; +#endif + sexp tmp, out=SEXP_FALSE; + sexp_gc_var4(ctx2, x, in, res); + if (! sexp_stringp(source)) + return sexp_type_exception(ctx, "not a string", source); + if (! sexp_envp(env)) + return sexp_type_exception(ctx, "not an environment", env); +#if SEXP_USE_DL + suffix = sexp_string_data(source) + + sexp_string_length(source) - strlen(sexp_so_extension); + if (strcmp(suffix, sexp_so_extension) == 0) { + res = sexp_load_dl(ctx, source, env); + } else { +#endif + sexp_gc_preserve4(ctx, ctx2, x, in, res); + res = SEXP_VOID; + in = sexp_open_input_file(ctx, source); + out = sexp_current_error_port(ctx); + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0); + sexp_context_parent(ctx2) = ctx; + tmp = sexp_env_bindings(env); + sexp_context_tailp(ctx2) = 0; + if (sexp_exceptionp(in)) { + if (sexp_not(out)) out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) + 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, env); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); + } + sexp_gc_release4(ctx); +#if SEXP_USE_DL + } +#endif +#if SEXP_USE_WARN_UNDEFS + if (sexp_oportp(out) && ! sexp_exceptionp(res)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out); +#endif + return res; +} + +#if SEXP_USE_MATH + +#if SEXP_USE_BIGNUMS +#define maybe_convert_bignum(z) \ + else if (sexp_bignump(z)) d = sexp_bignum_to_double(z); +#else +#define maybe_convert_bignum(z) +#endif + +#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_fixnump(z)) \ + d = (double)sexp_unbox_fixnum(z); \ + maybe_convert_bignum(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_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +static sexp sexp_sqrt (sexp ctx, sexp z) { + double d, r; + if (sexp_flonump(z)) + d = sexp_flonum_value(z); + else if (sexp_fixnump(z)) + d = (double)sexp_unbox_fixnum(z); + maybe_convert_bignum(z) /* XXXX add bignum sqrt */ + else + return sexp_type_exception(ctx, "not a number", z); + r = sqrt(d); + if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) + return sexp_make_fixnum(round(r)); + else + return sexp_make_flonum(ctx, r); +} + +#endif + +static sexp sexp_expt (sexp ctx, sexp x, sexp e) { + long double f, x1, e1; + sexp res; +#if SEXP_USE_BIGNUMS + if (sexp_bignump(e)) { /* bignum exponent needs special handling */ + if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) + res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ + else if (x == SEXP_ONE) + res = SEXP_ONE; /* 1.0 */ + else if (sexp_flonump(x)) + res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); + else + res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */ + } else if (sexp_bignump(x)) { + res = sexp_bignum_expt(ctx, x, e); + } else { +#endif + if (sexp_fixnump(x)) + x1 = sexp_unbox_fixnum(x); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception(ctx, "expt: not a number", x); + if (sexp_fixnump(e)) + e1 = sexp_unbox_fixnum(e); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception(ctx, "expt: not a number", e); + f = pow(x1, e1); + if ((f > SEXP_MAX_FIXNUM) || (f < SEXP_MIN_FIXNUM) +#if SEXP_USE_FLONUMS + || (! sexp_fixnump(x)) || (! sexp_fixnump(e)) +#endif + ) { +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(x) && sexp_fixnump(e)) + res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); + else +#endif +#if SEXP_USE_FLONUMS + res = sexp_make_flonum(ctx, f); +#else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#endif + } else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#if SEXP_USE_BIGNUMS + } +#endif + 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)) + 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 = ((len1= SEXP_OPC_NUM_OP_CLASSES)) + res = sexp_type_exception(ctx, "make-opcode: bad opcode class", op_class); + else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) + || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) + res = sexp_type_exception(ctx, "make-opcode: bad opcode", code); + else if (! sexp_fixnump(num_args)) + res = sexp_type_exception(ctx, "make-opcode: bad num_args", num_args); + else if (! sexp_fixnump(flags)) + res = sexp_type_exception(ctx, "make-opcode: bad flags", flags); + else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_arg1_type(res) = sexp_unbox_fixnum(arg1t); + sexp_opcode_arg2_type(res) = sexp_unbox_fixnum(arg2t); + sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_data(res) = data; + sexp_opcode_data2(res) = data2; + sexp_opcode_func(res) = func; + sexp_opcode_name(res) = strdup(sexp_string_data(name)); + } + return res; +} + +sexp sexp_make_foreign (sexp ctx, char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res; + if (num_args > 6) { + res = sexp_type_exception(ctx, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); + } else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; + sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1; + if (flags & 1) num_args--; + sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; + sexp_opcode_name(res) = name; + sexp_opcode_data(res) = data; + sexp_opcode_func(res) = f; + } + return res; +} + +sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp_gc_var1(op); + sexp_gc_preserve1(ctx, op); + sexp res = SEXP_VOID; + op = sexp_make_foreign(ctx, name, num_args, flags, f, data); + if (sexp_exceptionp(op)) + res = op; + else + sexp_env_define(ctx, env, sexp_intern(ctx, name), op); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_define_foreign_param (sexp ctx, sexp env, char *name, int num_args, + sexp_proc1 f, char *param) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_intern(ctx, param); + tmp = sexp_env_cell(env, tmp); + res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_TYPE_DEFS + +sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { + if (! sexp_fixnump(type)) + return sexp_type_exception(ctx, "make-type-predicate: bad type", type); + return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), + sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); +} + +sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { + sexp_uint_t type_size; + if (! sexp_fixnump(type)) + return sexp_type_exception(ctx, "make-constructor: bad type", type); + type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); + return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), + sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, + sexp_make_fixnum(type_size), NULL); +} + +sexp sexp_make_accessor (sexp ctx, sexp name, sexp type, sexp index, sexp code) { + if (! sexp_fixnump(type)) + return sexp_type_exception(ctx, "make-accessor: bad type", type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, "make-accessor: bad index", index); + return + sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_ACCESSOR), code, + sexp_make_fixnum(sexp_unbox_fixnum(code)==SEXP_OP_SLOT_REF?1:2), + SEXP_ZERO, type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(SEXP_OP_SLOT_REF)); +} +sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index) { + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(SEXP_OP_SLOT_SET)); +} + +#endif + +/*********************** standard environment *************************/ + +static struct sexp_struct core_forms[] = { + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE, "define"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SET, "set!"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LAMBDA, "lambda"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_IF, "if"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_BEGIN, "begin"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_QUOTE, "quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LET_SYNTAX, "let-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}}}, +}; + +sexp sexp_make_env (sexp ctx) { + 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; + return e; +} + +sexp sexp_make_null_env (sexp ctx, sexp version) { + sexp_uint_t i; + sexp e = sexp_make_env(ctx); + for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i])), + sexp_copy_core(ctx, &core_forms[i])); + return e; +} + +sexp sexp_make_primitive_env (sexp ctx, sexp version) { + int i; + sexp_gc_var3(e, op, sym); + sexp_gc_preserve3(ctx, e, op, sym); + e = sexp_make_null_env(ctx, version); + for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { + op = sexp_copy_opcode(ctx, &opcodes[i]); + if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op)); + sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); + } + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); + } + sexp_gc_release3(ctx); + return e; +} + +sexp sexp_find_module_file (sexp ctx, char *file) { + sexp res=SEXP_FALSE, ls; + char *dir, *path; + sexp_uint_t slash, dirlen, filelen, len; +#ifdef PLAN9 +#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0) + unsigned char buf[128]; +#else +#define file_exists_p(path, buf) (! stat(path, buf)) + struct stat buf_str; + struct stat *buf = &buf_str; +#endif + + filelen = strlen(file); + + ls = sexp_global(ctx, SEXP_G_MODULE_PATH); + for ( ; sexp_pairp(ls) && sexp_not(res); ls=sexp_cdr(ls)) { + dir = sexp_string_data(sexp_car(ls)); + dirlen = sexp_string_length(sexp_car(ls)); + slash = dir[dirlen-1] == '/'; + len = dirlen+filelen+2-slash; + path = (char*) malloc(len); + memcpy(path, dir, dirlen); + if (! slash) path[dirlen] = '/'; + memcpy(path+len-filelen-1, file, filelen); + path[len-1] = '\0'; + if (file_exists_p(path, buf)) + res = sexp_c_string(ctx, path, len-1); + free(path); + } + + return res; +} + +#define sexp_file_not_found "couldn't find file in module path" + +sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { + sexp res; + sexp_gc_var1(path); + sexp_gc_preserve1(ctx, path); + path = sexp_find_module_file(ctx, file); + if (sexp_stringp(path)) { + res = sexp_load(ctx, path, env); + } else { + path = sexp_c_string(ctx, file, -1); + res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path); + } + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_MODULES +static sexp sexp_find_module_file_op (sexp ctx, sexp file) { + if (! sexp_stringp(file)) + return sexp_type_exception(ctx, "not a string", file); + else + return sexp_find_module_file(ctx, sexp_string_data(file)); +} +sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env) { + if (! sexp_stringp(file)) + return sexp_type_exception(ctx, "not a string", file); + else if (! sexp_envp(env)) + return sexp_type_exception(ctx, "not an environment", env); + return sexp_load_module_file(ctx, sexp_string_data(file), env); +} +#endif + +sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp) { + sexp ls; + if (! sexp_stringp(dir)) + return sexp_type_exception(ctx, "not a string", dir); + if (sexp_truep(appendp)) { + if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { + for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) + ; + sexp_cdr(ls) = sexp_list1(ctx, dir); + } else { + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir); + } + } else { + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir); + } + return SEXP_VOID; +} + +sexp sexp_load_standard_parameters (sexp ctx, sexp e) { + /* add io port and interaction env parameters */ + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), + sexp_make_input_port(ctx, stdin, SEXP_FALSE)); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + sexp_make_output_port(ctx, stdout, SEXP_FALSE)); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), + sexp_make_output_port(ctx, stderr, SEXP_FALSE)); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); + return SEXP_VOID; +} + +sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { + sexp_gc_var3(op, tmp, sym); + sexp_gc_preserve3(ctx, op, tmp, sym); + sexp_load_standard_parameters(ctx, e); +#if SEXP_USE_DL + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*"), + tmp=sexp_c_string(ctx, sexp_so_extension, -1)); +#endif + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform)); +#if SEXP_USE_DL + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading")); +#endif +#if SEXP_USE_MODULES + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules")); +#endif +#if SEXP_USE_BOEHM + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc")); +#endif + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp); + sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; +#if SEXP_USE_SIMPLIFY + op = sexp_make_foreign(ctx, "simplify", 1, 0, + (sexp_proc1)sexp_simplify, SEXP_VOID); + tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); +#endif + /* load init.scm */ + tmp = sexp_load_module_file(ctx, sexp_init_file, e); + /* load and bind config env */ +#if SEXP_USE_MODULES + if (! sexp_exceptionp(tmp)) { + sym = sexp_intern(ctx, "*config-env*"); + if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { + tmp = sexp_make_env(ctx); + if (! sexp_exceptionp(tmp)) { + sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; + sexp_env_parent(tmp) = e; + op = sexp_load_module_file(ctx, sexp_config_file, tmp); + if (sexp_exceptionp(op)) + sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); + sexp_env_define(ctx, tmp, sym, tmp); + } + } + sexp_env_define(ctx, e, sym, tmp); + } +#endif + sexp_gc_release3(ctx); + return sexp_exceptionp(tmp) ? tmp : e; +} + +sexp sexp_make_standard_env (sexp ctx, sexp version) { + sexp_gc_var1(env); + sexp_gc_preserve1(ctx, env); + env = sexp_make_primitive_env(ctx, version); + if (! sexp_exceptionp(env)) sexp_load_standard_env(ctx, env, version); + sexp_gc_release1(ctx); + return env; +} + +sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls, sexp immutp) { + sexp oldname, newname, value, out; + if (! sexp_envp(to)) to = sexp_context_env(ctx); + if (! sexp_envp(from)) from = sexp_context_env(ctx); + if (sexp_not(ls)) { + if (sexp_truep(immutp)) { + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_parent(to) = value; + sexp_immutablep(value) = 1; + sexp_env_bindings(value) = sexp_env_bindings(from); + } else { + for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls)); + } + } else { + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (sexp_pairp(sexp_car(ls))) { + newname = sexp_caar(ls); oldname = sexp_cdar(ls); + } else { + newname = oldname = sexp_car(ls); + } + value = sexp_env_ref(from, oldname, SEXP_UNDEF); + if (value != SEXP_UNDEF) { + sexp_env_define(ctx, to, newname, value); +#if SEXP_USE_WARN_UNDEFS + } else if (sexp_oportp(out=sexp_current_error_port(ctx))) { + sexp_write_string(ctx, "WARNING: importing undefined variable: ", out); + sexp_write(ctx, oldname, out); + sexp_write_char(ctx, '\n', out); +#endif + } + } + } + return SEXP_VOID; +} + +/************************** eval interface ****************************/ + +sexp sexp_apply (sexp ctx, sexp proc, sexp args) { + sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx), len, offset; + len = sexp_unbox_fixnum(sexp_length(ctx, args)); + if (sexp_opcodep(proc)) + proc = make_opcode_procedure(ctx, proc, len); + if (! sexp_procedurep(proc)) { + res = sexp_exceptionp(proc) ? proc : + sexp_type_exception(ctx, "apply: not a procedure", proc); + } else { + offset = top + len; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) + stack[--offset] = sexp_car(ls); + stack[top] = sexp_make_fixnum(len); + top++; + stack[top++] = SEXP_ZERO; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + stack[top++] = SEXP_ZERO; + sexp_context_top(ctx) = top; + res = sexp_vm(ctx, proc); + if (! res) res = SEXP_VOID; + } + return res; +} + +sexp sexp_compile (sexp ctx, sexp x) { + sexp_gc_var3(ast, vec, res); + sexp_gc_preserve3(ctx, ast, vec, res); + ast = sexp_analyze(ctx, x); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(res); res=sexp_cdr(res)) + ast = sexp_apply_optimization(ctx, sexp_cdar(res), ast); + free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + generate(ctx, ast); + res = finalize_bytecode(ctx); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec); + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_eval (sexp ctx, sexp obj, sexp env) { + sexp_sint_t top; + sexp ctx2; + sexp_gc_var2(res, err_handler); + sexp_gc_preserve2(ctx, res, err_handler); + top = sexp_context_top(ctx); + err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = SEXP_FALSE; + ctx2 = sexp_make_eval_context(ctx, + sexp_context_stack(ctx), + (env ? env : sexp_context_env(ctx)), + 0); + res = sexp_compile(ctx2, obj); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; + sexp_context_top(ctx) = top; + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_eval_string (sexp ctx, char *str, sexp env) { + sexp res; + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); + obj = sexp_read_from_string(ctx, str); + res = sexp_eval(ctx, obj, env); + sexp_gc_release1(ctx); + return res; +} + +void sexp_scheme_init (void) { + if (! scheme_initialized_p) { + scheme_initialized_p = 1; + sexp_init(); + } +} diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..5e2a4d23 --- /dev/null +++ b/gc.c @@ -0,0 +1,250 @@ +/* gc.c -- simple mark&sweep garbage collector */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* These settings are configurable but only recommended for */ +/* experienced users, so they're not in config.h. */ + +/* the initial heap size in bytes */ +#ifndef SEXP_INITIAL_HEAP_SIZE +#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) +#endif + +/* the maximum heap size in bytes - if 0 there is no limit */ +#ifndef SEXP_MAXIMUM_HEAP_SIZE +#define SEXP_MAXIMUM_HEAP_SIZE 0 +#endif +#ifndef SEXP_MINIMUM_HEAP_SIZE +#define SEXP_MINIMUM_HEAP_SIZE 512*1024 +#endif + +/* if after GC more than this percentage of memory is still in use, */ +/* and we've not exceeded the maximum size, grow the heap */ +#ifndef SEXP_GROW_HEAP_RATIO +#define SEXP_GROW_HEAP_RATIO 0.75 +#endif + +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair)) + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +#if SEXP_USE_GLOBAL_HEAP +sexp_heap sexp_global_heap; +#endif + +#if SEXP_USE_DEBUG_GC +static sexp* stack_base; +#endif + +static sexp_heap sexp_heap_last (sexp_heap h) { + while (h->next) h = h->next; + return h; +} + +sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) { + sexp_uint_t res; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) + return sexp_heap_align(1); + t = sexp_object_type(ctx, x); + res = sexp_type_size_of_object(t, x); + return res; +} + +void sexp_mark (sexp ctx, sexp x) { + 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(ctx, *(saves->var)); + t = sexp_object_type(ctx, x); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len = sexp_type_num_slots_of_object(t, x) - 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(ctx, p)); + if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + /* free p */ + finalizer = sexp_type_finalize(sexp_object_type(ctx, p)); + if (finalizer) finalizer(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_fixnum(max_freed); +} + +sexp sexp_gc (sexp ctx, size_t *sum_freed) { + sexp res; +#if SEXP_USE_GLOBAL_SYMBOLS + int i; + 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(sexp_context_heap(ctx)); + 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=sexp_context_heap(ctx); 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_fixnum(sexp_gc(ctx, &sum_freed)); + h = sexp_heap_last(sexp_context_heap(ctx)); + if (((max_freed < size) + || ((h->size - sum_freed) > (h->size*SEXP_GROW_HEAP_RATIO))) + && ((! SEXP_MAXIMUM_HEAP_SIZE) || (h->size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); + if (! res) + res = sexp_global(ctx, SEXP_G_OOM_ERROR); + } + return res; +} + +void sexp_gc_init (void) { +#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_DEBUG_GC + sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); +#endif +#if SEXP_USE_GLOBAL_HEAP + sexp_global_heap = sexp_make_heap(size); +#endif +#if SEXP_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/bignum.h b/include/chibi/bignum.h new file mode 100644 index 00000000..580b0a7d --- /dev/null +++ b/include/chibi/bignum.h @@ -0,0 +1,43 @@ +/* bignum.h -- header for bignum utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_BIGNUM_H +#define SEXP_BIGNUM_H + +#if (SEXP_64_BIT) +typedef unsigned int uint128_t __attribute__((mode(TI))); +typedef int sint128_t __attribute__((mode(TI))); +typedef uint128_t sexp_luint_t; +typedef sint128_t sexp_lsint_t; +#else +typedef unsigned long long sexp_luint_t; +typedef long long sexp_lsint_t; +#endif + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b); +sexp sexp_compare (sexp ctx, sexp a, sexp b); +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len); +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len); +sexp sexp_bignum_normalize (sexp a); +sexp_uint_t sexp_bignum_hi (sexp a); +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a); +double sexp_bignum_to_double (sexp a); +sexp sexp_double_to_bignum (sexp ctx, double f); +sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b); +sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset); +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset); +sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_div (sexp ctx, sexp dst, sexp a, sexp b); +sexp sexp_bignum_expt (sexp ctx, sexp n, sexp e); +sexp sexp_add (sexp ctx, sexp a, sexp b); +sexp sexp_sub (sexp ctx, sexp a, sexp b); +sexp sexp_mul (sexp ctx, sexp a, sexp b); +sexp sexp_div (sexp ctx, sexp a, sexp b); +sexp sexp_quotient (sexp ctx, sexp a, sexp b); +sexp sexp_remainder (sexp ctx, sexp a, sexp b); + +#endif /* ! SEXP_BIGNUM_H */ + diff --git a/include/chibi/eval.h b/include/chibi/eval.h new file mode 100644 index 00000000..7ce70433 --- /dev/null +++ b/include/chibi/eval.h @@ -0,0 +1,165 @@ +/* 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 SEXP_INIT_BCODE_SIZE 128 +#define SEXP_INIT_STACK_SIZE 8192 + +#define sexp_init_file "init.scm" +#define sexp_config_file "config.scm" + +enum sexp_core_form_names { + SEXP_CORE_DEFINE = 1, + SEXP_CORE_SET, + SEXP_CORE_LAMBDA, + SEXP_CORE_IF, + SEXP_CORE_BEGIN, + SEXP_CORE_QUOTE, + SEXP_CORE_SYNTAX_QUOTE, + SEXP_CORE_DEFINE_SYNTAX, + SEXP_CORE_LET_SYNTAX, + SEXP_CORE_LETREC_SYNTAX +}; + +enum sexp_opcode_classes { + SEXP_OPC_GENERIC = 1, + SEXP_OPC_TYPE_PREDICATE, + SEXP_OPC_PREDICATE, + SEXP_OPC_ARITHMETIC, + SEXP_OPC_ARITHMETIC_INV, + SEXP_OPC_ARITHMETIC_CMP, + SEXP_OPC_IO, + SEXP_OPC_CONSTRUCTOR, + SEXP_OPC_ACCESSOR, + SEXP_OPC_PARAMETER, + SEXP_OPC_FOREIGN, + SEXP_OPC_NUM_OP_CLASSES +}; + +enum sexp_opcode_names { + SEXP_OP_NOOP, + SEXP_OP_RAISE, + SEXP_OP_RESUMECC, + SEXP_OP_CALLCC, + SEXP_OP_APPLY1, + SEXP_OP_TAIL_CALL, + SEXP_OP_CALL, + SEXP_OP_FCALL0, + SEXP_OP_FCALL1, + SEXP_OP_FCALL2, + SEXP_OP_FCALL3, + SEXP_OP_FCALL4, + SEXP_OP_FCALL5, + SEXP_OP_FCALL6, + SEXP_OP_JUMP_UNLESS, + SEXP_OP_JUMP, + SEXP_OP_PUSH, + SEXP_OP_DROP, + SEXP_OP_GLOBAL_REF, + SEXP_OP_GLOBAL_KNOWN_REF, + SEXP_OP_STACK_REF, + SEXP_OP_LOCAL_REF, + SEXP_OP_LOCAL_SET, + SEXP_OP_CLOSURE_REF, + SEXP_OP_VECTOR_REF, + SEXP_OP_VECTOR_SET, + SEXP_OP_VECTOR_LENGTH, + SEXP_OP_STRING_REF, + SEXP_OP_STRING_SET, + SEXP_OP_STRING_LENGTH, + SEXP_OP_MAKE_PROCEDURE, + SEXP_OP_MAKE_VECTOR, + SEXP_OP_MAKE_EXCEPTION, + SEXP_OP_AND, + SEXP_OP_NULLP, + SEXP_OP_FIXNUMP, + SEXP_OP_SYMBOLP, + SEXP_OP_CHARP, + SEXP_OP_EOFP, + SEXP_OP_TYPEP, + SEXP_OP_MAKE, + SEXP_OP_SLOT_REF, + SEXP_OP_SLOT_SET, + SEXP_OP_CAR, + SEXP_OP_CDR, + SEXP_OP_SET_CAR, + SEXP_OP_SET_CDR, + SEXP_OP_CONS, + SEXP_OP_ADD, + SEXP_OP_SUB, + SEXP_OP_MUL, + SEXP_OP_DIV, + SEXP_OP_QUOTIENT, + SEXP_OP_REMAINDER, + SEXP_OP_NEGATIVE, + SEXP_OP_INVERSE, + SEXP_OP_LT, + SEXP_OP_LE, + SEXP_OP_EQN, + SEXP_OP_EQ, + SEXP_OP_FIX2FLO, + SEXP_OP_FLO2FIX, + SEXP_OP_CHAR2INT, + SEXP_OP_INT2CHAR, + SEXP_OP_CHAR_UPCASE, + SEXP_OP_CHAR_DOWNCASE, + SEXP_OP_WRITE_CHAR, + SEXP_OP_NEWLINE, + SEXP_OP_READ_CHAR, + SEXP_OP_PEEK_CHAR, + SEXP_OP_RET, + SEXP_OP_DONE, + SEXP_OP_NUM_OPCODES +}; + +/**************************** prototypes ******************************/ + +SEXP_API void sexp_scheme_init (void); +SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size); +SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); +SEXP_API sexp sexp_analyze (sexp context, sexp x); +SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); +SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); +SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); +SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); +SEXP_API sexp sexp_make_env (sexp context); +SEXP_API sexp sexp_make_null_env (sexp context, sexp version); +SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version); +SEXP_API sexp sexp_make_standard_env (sexp context, sexp version); +SEXP_API sexp sexp_load_standard_parameters (sexp context, sexp env); +SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version); +SEXP_API sexp sexp_find_module_file (sexp ctx, char *file); +SEXP_API sexp sexp_load_module_file (sexp ctx, char *file, sexp env); +SEXP_API sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp); +SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); +SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls, sexp immutp); +SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val); +SEXP_API sexp sexp_env_cell (sexp env, sexp sym); +SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); +SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); +SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); +SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); +SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data); +SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, int flags, sexp_proc1 f, sexp data); + +#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL) +#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d) + +SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, char *name, int num_args, sexp_proc1 f, char *param); + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); +SEXP_API sexp sexp_make_constructor (sexp ctx, sexp name, sexp type); +SEXP_API sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index); +SEXP_API sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index); +#endif + +#endif /* ! SEXP_EVAL_H */ + diff --git a/include/chibi/features.h b/include/chibi/features.h new file mode 100644 index 00000000..9143a071 --- /dev/null +++ b/include/chibi/features.h @@ -0,0 +1,297 @@ +/* features.h -- general feature configuration */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +/* uncomment this to disable most features */ +/* Most features are enabled by default, but setting this */ +/* option will disable any not explicitly enabled. */ +/* #define SEXP_USE_NO_FEATURES 1 */ + +/* uncomment this to disable the module system */ +/* Currently this just loads the config.scm from main and */ +/* sets up an (import (module name)) macro. */ +/* #define SEXP_USE_MODULES 0 */ + +/* uncomment this to disable dynamic loading */ +/* If enabled, you can LOAD .so files with a */ +/* sexp_init_library(ctx, env) function provided. */ +/* #define SEXP_USE_DL 0 */ + +/* uncomment this to disable a simplifying optimization pass */ +/* This performs some simple optimizations such as dead-code */ +/* elimination, constant-folding, and directly propagating */ +/* non-mutated let values bound to constants or non-mutated */ +/* references. More than performance, this is aimed at reducing the */ +/* size of the compiled code, especially as the result of macro */ +/* expansions, so it's a good idea to leave it enabled. */ +/* #define SEXP_USE_SIMPLIFY 0 */ + +/* uncomment this to disable dynamic type definitions */ +/* This enables register-simple-type and related */ +/* opcodes for defining types, needed by the default */ +/* implementation of (srfi 9). */ +/* #define SEXP_USE_TYPE_DEFS 0 */ + +/* uncomment this to use the Boehm conservative GC */ +/* Conservative GCs make it easier to write extensions, */ +/* since you don't have to keep track of intermediate */ +/* variables, but can leak memory. Boehm is also a */ +/* very large library to link in. You may want to */ +/* enable this when debugging your own extensions, or */ +/* if you suspect a bug in the native GC. */ +/* #define SEXP_USE_BOEHM 1 */ + +/* uncomment this to just malloc manually instead of any GC */ +/* Mostly for debugging purposes, this is the no GC option. */ +/* You can use just the read/write API and */ +/* explicitly free sexps, though. */ +/* #define SEXP_USE_MALLOC 1 */ + +/* uncomment this to add conservative checks to the native GC */ +/* Please mail the author if enabling this makes a bug */ +/* go away and you're not working on your own C extension. */ +/* #define SEXP_USE_DEBUG_GC 1 */ + +/* uncomment this to make the heap common to all contexts */ +/* By default separate contexts can have separate heaps, */ +/* and are thus thread-safe and independant. */ +/* #define SEXP_USE_GLOBAL_HEAP 1 */ + +/* uncomment this to make type definitions common to all contexts */ +/* By default types are only global if you don't allow user type */ +/* definitions, so new types will be local to a given set of */ +/* contexts sharing thei heap. */ +/* #define SEXP_USE_GLOBAL_TYPES 1 */ + +/* uncomment this to make the symbol table common to all contexts */ +/* Will still be restricted to all contexts sharing the same */ +/* heap, of course. */ +/* #define SEXP_USE_GLOBAL_SYMBOLS 1 */ + +/* uncomment this if you don't need flonum support */ +/* This is only for EVAL - you'll still be able to read */ +/* and write flonums directly through the sexp API. */ +/* #define SEXP_USE_FLONUMS 0 */ + +/* uncomment this to disable reading/writing IEEE infinities */ +/* By default you can read/write +inf.0, -inf.0 and +nan.0 */ +/* #define SEXP_USE_INFINITIES 0 */ + +/* uncomment this if you want immediate flonums */ +/* This is experimental, enable at your own risk. */ +/* #define SEXP_USE_IMMEDIATE_FLONUMS 1 */ + +/* uncomment this if you don't want bignum support */ +/* Bignums are implemented with a small, custom library */ +/* in opt/bignum.c. */ +/* #define SEXP_USE_BIGNUMS 0 */ + +/* uncomment this if you don't need extended math operations */ +/* This includes the trigonometric and expt functions. */ +/* Automatically disabled if you've disabled flonums. */ +/* #define SEXP_USE_MATH 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* This is something of a hack, but can be quite useful. */ +/* It's very fast and doesn't involve any separate analysis */ +/* passes. */ +/* #define SEXP_USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* By default (this may change) small symbols are represented */ +/* as immediates using a simple huffman encoding. This keeps */ +/* the symbol table small, and minimizes hashing when doing a */ +/* lot of reading. */ +/* #define SEXP_USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* You can trade off some space in exchange for longer read */ +/* times by disabling hashing and just putting all */ +/* non-immediate symbols in a single list. */ +/* #define SEXP_USE_HASH_SYMS 0 */ + +/* uncomment this to disable string ports */ +/* If disabled some basic functionality such as number->string */ +/* will not be available by default. */ +/* #define SEXP_USE_STRING_STREAMS 0 */ + +/* uncomment this to disable automatic closing of ports */ +/* If enabled, the underlying FILE* for file ports will be */ +/* automatically closed when they're garbage collected. Doesn't */ +/* apply to stdin/stdout/stderr. */ +/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */ + +/* uncomment this to use the normal 1970 unix epoch */ +/* By default chibi uses an datetime epoch starting at */ +/* 2010/01/01 00:00:00 in order to be able to represent */ +/* more common times as fixnums. */ +/* #define SEXP_USE_2010_EPOCH 0 */ + +/* uncomment this to disable stack overflow checks */ +/* By default stacks are fairly small, so it's good to leave */ +/* this enabled. */ +/* #define SEXP_USE_CHECK_STACK 0 */ + +/* #define SEXP_USE_DEBUG_VM 0 */ +/* Experts only. */ +/* For *very* verbose output on every VM operation. */ + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#ifndef SEXP_64_BIT +#if defined(__amd64) || defined(__x86_64) +#define SEXP_64_BIT 1 +#else +#define SEXP_64_BIT 0 +#endif +#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 SEXP_USE_NO_FEATURES +#define SEXP_USE_NO_FEATURES 0 +#endif + +#ifndef SEXP_USE_MODULES +#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_TYPE_DEFS +#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_MAXIMUM_TYPES +#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1) +#endif + +#ifndef SEXP_USE_DL +#ifdef PLAN9 +#define SEXP_USE_DL 0 +#else +#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 0 +#endif + +#ifndef SEXP_USE_MALLOC +#define SEXP_USE_MALLOC 0 +#endif + +#ifndef SEXP_USE_DEBUG_GC +#define SEXP_USE_DEBUG_GC 0 +#endif + +#ifndef SEXP_USE_GLOBAL_HEAP +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_HEAP 1 +#else +#define SEXP_USE_GLOBAL_HEAP 0 +#endif +#endif + +#ifndef SEXP_USE_GLOBAL_TYPES +#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS) +#endif + +#ifndef SEXP_USE_GLOBAL_SYMBOLS +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_SYMBOLS 1 +#else +#define SEXP_USE_GLOBAL_SYMBOLS 0 +#endif +#endif + +#ifndef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_INFINITIES +#if defined(PLAN9) || ! SEXP_USE_FLONUMS +#define SEXP_USE_INFINITIES 0 +#else +#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_IMMEDIATE_FLONUMS +#define SEXP_USE_IMMEDIATE_FLONUMS 0 +#endif + +#ifndef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MATH +#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_WARN_UNDEFS +#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HUFF_SYMS +#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HASH_SYMS +#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_DEBUG_VM +#define SEXP_USE_DEBUG_VM 0 +#endif + +#ifndef SEXP_USE_STRING_STREAMS +#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_AUTOCLOSE_PORTS +#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_2010_EPOCH +#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_EPOCH_OFFSET +#if SEXP_USE_2010_EPOCH +#define SEXP_EPOCH_OFFSET 1262271600 +#else +#define SEXP_EPOCH_OFFSET 0 +#endif +#endif + +#ifndef SEXP_USE_CHECK_STACK +#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES +#endif + +#ifdef PLAN9 +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#endif + +#ifdef __MINGW32__ +#ifdef BUILDING_DLL +#define SEXP_API __declspec(dllexport) +#else +#define SEXP_API __declspec(dllimport) +#endif +#else +#define SEXP_API +#endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h new file mode 100644 index 00000000..369e3b65 --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,862 @@ +/* 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 + +#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" + +#include "chibi/features.h" +#include "chibi/install.h" + +#include +#include + +#if SEXP_USE_DL +#include +#endif + +#ifdef PLAN9 +#include +#include +#include +#include +#include <9p.h> +typedef unsigned long size_t; +#else +#include +#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 + +#if SEXP_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_CPOINTER, + 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_CORE_TYPES +}; + +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +#if SEXP_64_BIT +typedef unsigned int sexp_tag_t; +#else +typedef unsigned short sexp_tag_t; +#endif +typedef struct sexp_struct *sexp; + +#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2)) +#define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type)) +#define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type)) + +#define SEXP_UINT_T_MAX ((sexp_uint_t)-1) +#define SEXP_UINT_T_MIN (0) +#define SEXP_SINT_T_MAX __MAX_SIGNED(sexp_sint_t) +#define SEXP_SINT_T_MIN __MIN_SIGNED(sexp_sint_t) + +#define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1) +#define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1) + +/* procedure types */ +typedef sexp (*sexp_proc0) (void); +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 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 free_list; + sexp_heap next; + char *data; +}; + +struct sexp_gc_var_t { + sexp *var; + /* char *name; */ + struct sexp_gc_var_t *next; +}; + +struct sexp_struct { + sexp_tag_t tag; + char gc_mark; + unsigned int immutablep:1; + unsigned int freep:1; + union { + /* basic types */ + double flonum; + struct { + sexp_tag_t tag; + short field_base, field_eq_len_base, field_len_base, field_len_off; + unsigned short field_len_scale; + short size_base, size_off; + unsigned short size_scale; + char *name; + sexp_proc2 finalize; + } 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; + char openp, sourcep; + sexp_uint_t offset, line; + size_t size; + 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; + struct { + sexp_uint_t length; + void *value; + sexp parent; + char body[]; + } cpointer; + /* runtime types */ + struct { + unsigned int syntacticp:1; + 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, data2, proc; + sexp_proc1 func; + } opcode; + struct { + char code; + char *name; + } core; + /* ast types */ + struct { + sexp name, params, body, defs, locals, flags, 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_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp_heap heap; + struct sexp_gc_var_t *saves; + sexp_uint_t pos, depth, tailp, tracep; + sexp bc, lambda, stack, env, fv, parent, globals; + } 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_offsetof_slot0 (offsetof(struct sexp_struct, value)) + +#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double)) + +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) +#define sexp_alloc_bytecode(ctx, i) sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE) + +#if SEXP_USE_BIGNUMS +#include "chibi/bignum.h" +#endif + +/***************************** 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_fixnump(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_flags(x) ((x)->flags) +#define sexp_immutablep(x) ((x)->immutablep) +#define sexp_freep(x) ((x)->freep) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) +#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) + +#if SEXP_USE_IMMEDIATE_FLONUMS +union sexp_flonum_conv { + float flonum; + unsigned int bits; +}; +#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x); +#if SEXP_64_BIT +SEXP_API float sexp_flonum_value (sexp x); +SEXP_API sexp sexp_make_flonum(sexp ctx, float f); +#else +#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)(((unsigned int)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) +#endif +#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_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) +#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER)) +#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)) + +#if SEXP_USE_HUFF_SYMS +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +#else +#define sexp_symbolp(x) (sexp_lsymbolp(x)) +#endif + +#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_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) + +#define SEXP_NEG_ONE sexp_make_fixnum(-1) +#define SEXP_ZERO sexp_make_fixnum(0) +#define SEXP_ONE sexp_make_fixnum(1) +#define SEXP_TWO sexp_make_fixnum(2) +#define SEXP_THREE sexp_make_fixnum(3) +#define SEXP_FOUR sexp_make_fixnum(4) +#define SEXP_FIVE sexp_make_fixnum(5) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) + +#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x))) +#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x)) +#else +#define _or_integer_flonump(x) +#endif + +#if SEXP_USE_BIGNUMS +SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x); +SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); +#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) +#else +#define sexp_make_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_make_unsigned_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_exact_integerp(x) sexp_fixnump(x) +#endif + +#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) +#else +#define sexp_fixnum_to_flonum(ctx, x) (x) +#endif + +#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS +#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0])) +#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0])) +#else +#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x)) +#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x)) +#endif + +#define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET) +#define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET) + +/*************************** 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_fixnum(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_fixnum(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_fixnum(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_fixnum(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(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_cpointer_freep(p) (sexp_freep(p)) +#define sexp_cpointer_length(p) ((p)->value.cpointer.length) +#define sexp_cpointer_body(p) ((p)->value.cpointer.body) +#define sexp_cpointer_parent(p) ((p)->value.cpointer.parent) +#define sexp_cpointer_value(p) ((p)->value.cpointer.value) +#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p)) + +#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_syntactic_p(x) ((x)->value.env.syntacticp) +#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_data(x) ((x)->value.opcode.data) +#define sexp_opcode_data2(x) ((x)->value.opcode.data2) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) +#define sexp_opcode_func(x) ((x)->value.opcode.func) + +#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_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) + +#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_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_globals(x) ((x)->value.context.globals) + +#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) + +#if SEXP_USE_GLOBAL_HEAP +#if ! SEXP_USE_BOEHM +SEXP_API sexp_heap sexp_global_heap; +#endif +#define sexp_context_heap(ctx) sexp_global_heap +#else +#define sexp_context_heap(ctx) ((ctx)->value.context.heap) +#endif + +#if SEXP_USE_GLOBAL_SYMBOLS +#define sexp_context_symbols(ctx) sexp_symbol_table +#else +#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) +#endif + +#if SEXP_USE_GLOBAL_TYPES +SEXP_API struct sexp_struct *sexp_type_specs; +#define sexp_context_types(ctx) sexp_type_specs +#define sexp_type_by_index(ctx,i) (&(sexp_context_types(ctx)[i])) +#define sexp_context_num_types(ctx) sexp_num_types +#define sexp_context_type_array_size(ctx) sexp_type_array_size +#else +#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#define sexp_type_by_index(ctx,i) (sexp_context_types(ctx)[i]) +#define sexp_context_num_types(ctx) \ + sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES)) +#define sexp_context_type_array_size(ctx) \ + sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES)) +#endif + +#define sexp_object_type(ctx,x) (sexp_type_by_index(ctx, ((x)->tag))) +#define sexp_object_type_name(ctx,x) (sexp_type_name(sexp_object_type(ctx, x))) +#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i))) + +#define sexp_type_size_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \ + * sexp_type_size_scale(t) \ + + sexp_type_size_base(t)) +#define sexp_type_num_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_len_base(t)) +#define sexp_type_num_eq_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_eq_len_base(t)) + +#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_eq_len_base(x) ((x)->value.type.field_eq_len_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_type_finalize(x) ((x)->value.type.finalize) + +#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_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b))) +#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b))) +#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1))) +#define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a)))) +#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) + +#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 *****************************/ + +enum sexp_context_globals { +#if ! SEXP_USE_GLOBAL_SYMBOLS + SEXP_G_SYMBOLS, +#endif +#if ! SEXP_USE_GLOBAL_TYPES + SEXP_G_TYPES, + SEXP_G_NUM_TYPES, +#endif + SEXP_G_OOM_ERROR, /* out of memory exception object */ + SEXP_G_OOS_ERROR, /* out of stack exception object */ + SEXP_G_OPTIMIZATIONS, + SEXP_G_SIGNAL_HANDLERS, + SEXP_G_CONFIG_ENV, + SEXP_G_MODULE_PATH, + SEXP_G_QUOTE_SYMBOL, + SEXP_G_QUASIQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SPLICING_SYMBOL, + SEXP_G_EMPTY_VECTOR, + SEXP_G_CUR_IN_SYMBOL, + SEXP_G_CUR_OUT_SYMBOL, + SEXP_G_CUR_ERR_SYMBOL, + SEXP_G_INTERACTION_ENV_SYMBOL, + SEXP_G_ERR_HANDLER, + SEXP_G_RESUMECC_BYTECODE, + SEXP_G_FINAL_RESUMER, + SEXP_G_NUM_GLOBALS +}; + +#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(ctx, (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 SEXP_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)) + +SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); +SEXP_API sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p); +SEXP_API sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p); +SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) + +SEXP_API sexp sexp_make_context(sexp ctx, sexp_uint_t size); +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_string_concatenate (sexp ctx, sexp str_ls, sexp sep); +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_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, sexp parent, int freep); +SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_flush_output(sexp ctx, 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_write_to_string(sexp ctx, sexp obj); +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 source); +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(void); + +#if SEXP_USE_GLOBAL_HEAP +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_destroy_context(sexp ctx); +#endif + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots); +SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); +SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp obj); +#define sexp_register_c_type(ctx, name, finalizer) \ + sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ + SEXP_ZERO, SEXP_ZERO, finalizer) +#endif + +#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) +#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))) + +#endif /* ! SEXP_H */ + diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c new file mode 100644 index 00000000..19721c10 --- /dev/null +++ b/lib/chibi/ast.c @@ -0,0 +1,80 @@ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +static void sexp_define_type_predicate (sexp ctx, sexp env, + char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname), op); + sexp_gc_release2(ctx); +} + +static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, + sexp_uint_t cindex, char* get, char *set) { + sexp type, index; + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + type = sexp_make_fixnum(ctype); + index = sexp_make_fixnum(cindex); + op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, get), op); + op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, set), op); + sexp_gc_release2(ctx); +} + +static sexp sexp_get_env_cell (sexp ctx, sexp env, sexp id) { + sexp cell = sexp_env_cell(env, id); + while ((! cell) && sexp_synclop(id)) { + env = sexp_synclo_env(id); + id = sexp_synclo_expr(id); + } + return cell ? cell : SEXP_FALSE; +} + +static sexp sexp_get_opcode_name (sexp ctx, sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, "not an opcode", op); + else if (! sexp_opcode_name(op)) + return SEXP_FALSE; + else + return sexp_intern(ctx, sexp_opcode_name(op)); +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); + sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); + sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); + sexp_define_type_predicate(ctx, env, "set?", SEXP_SET); + sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF); + sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ); + sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); + sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); + sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); + sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); + sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze); + sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); + sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); + sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + return SEXP_VOID; +} + diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module new file mode 100644 index 00000000..57068ece --- /dev/null +++ b/lib/chibi/ast.module @@ -0,0 +1,14 @@ + +(define-module (chibi ast) + (export analyze env-cell opcode-name + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + lambda-name lambda-params lambda-body lambda-defs + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + cnd-test cnd-pass cnd-fail + cnd-test-set! cnd-pass-set! cnd-fail-set! + set-var set-value set-var-set! set-value-set! + ref-name ref-cell ref-name-set! ref-cell-set! + seq-ls seq-ls-set! lit-value lit-value-set!) + (include-shared "ast")) + diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c new file mode 100644 index 00000000..89fde159 --- /dev/null +++ b/lib/chibi/disasm.c @@ -0,0 +1,116 @@ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define SEXP_DISASM_MAX_DEPTH 8 +#define SEXP_DISASM_PAD_WIDTH 4 + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", + "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", + "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "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", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", + }; + +static sexp disasm (sexp ctx, sexp bc, sexp out, int depth) { + sexp tmp; + unsigned char *ip, opcode, i; + + if (sexp_procedurep(bc)) { + bc = sexp_procedure_code(bc); + } else if (sexp_opcodep(bc)) { + sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); + return SEXP_VOID; + } else if (! sexp_bytecodep(bc)) { + return sexp_type_exception(ctx, "not a procedure", bc); + } + if (! sexp_oportp(out)) { + return sexp_type_exception(ctx, "not an output-port", out); + } + + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + sexp_write_string(ctx, "-------------- ", out); + if (sexp_truep(sexp_bytecode_name(bc))) { + sexp_write(ctx, sexp_bytecode_name(bc), out); + sexp_write_char(ctx, ' ', out); + } + sexp_printf(ctx, out, "%p\n", bc); + + ip = sexp_bytecode_data(bc); + + loop: + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + 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 SEXP_OP_STACK_REF: + case SEXP_OP_LOCAL_REF: + case SEXP_OP_LOCAL_SET: + case SEXP_OP_CLOSURE_REF: + case SEXP_OP_JUMP: + case SEXP_OP_JUMP_UNLESS: + case SEXP_OP_TYPEP: + case SEXP_OP_FCALL0: + case SEXP_OP_FCALL1: + case SEXP_OP_FCALL2: + case SEXP_OP_FCALL3: + case SEXP_OP_FCALL4: + case SEXP_OP_FCALL5: + case SEXP_OP_FCALL6: + sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case SEXP_OP_SLOT_REF: + case SEXP_OP_SLOT_SET: + case SEXP_OP_MAKE: + ip += sizeof(sexp)*2; + break; + case SEXP_OP_GLOBAL_REF: + case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_TAIL_CALL: + case SEXP_OP_CALL: + case SEXP_OP_PUSH: + tmp = ((sexp*)ip)[0]; + if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF)) + && sexp_pairp(tmp)) + tmp = sexp_car(tmp); + else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) + sexp_write_char(ctx, '\'', out); + sexp_write(ctx, tmp, out); + ip += sizeof(sexp); + break; + } + sexp_write_char(ctx, '\n', out); + if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) + && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) + disasm(ctx, tmp, out, depth+1); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { + return disasm(ctx, bc, out, 0); +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "*current-output-port*"); + return SEXP_VOID; +} diff --git a/lib/chibi/disasm.module b/lib/chibi/disasm.module new file mode 100644 index 00000000..9017a4bc --- /dev/null +++ b/lib/chibi/disasm.module @@ -0,0 +1,5 @@ + +(define-module (chibi disasm) + (export disasm) + (import-immutable (scheme)) + (include-shared "disasm")) diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module new file mode 100644 index 00000000..38a8fab1 --- /dev/null +++ b/lib/chibi/filesystem.module @@ -0,0 +1,27 @@ + +(define-module (chibi filesystem) + (export open-input-file-descriptor open-output-file-descriptor + duplicate-file-descriptor duplicate-file-descriptor-to + close-file-descriptor renumber-file-descriptor + delete-file link-file symbolic-link-file rename-file + directory-files create-directory delete-directory + file-status + file-device file-inode + file-mode file-num-links + file-owner file-group + file-represented-device file-size + file-block-size file-num-blocks + file-access-time file-modification-time file-change-time + file-regular? file-directory? file-character? + file-block? file-fifo? file-link? + file-socket? file-exists? + get-file-descriptor-flags set-file-descriptor-flags! + get-file-descriptor-status set-file-descriptor-status! + open/read open/write open/read-write + open/create open/exclusive open/truncate + open/append open/non-block + ) + (import-immutable (scheme)) + (include-shared "filesystem") + (include "filesystem.scm")) + diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm new file mode 100644 index 00000000..aa3fc69f --- /dev/null +++ b/lib/chibi/filesystem.scm @@ -0,0 +1,43 @@ +;; filesystem.scm -- additional filesystem utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (let lp ((res knil)) + (let ((file (readdir dir))) + (if file (lp (kons (dirent-name file) res)) res))))) + +(define (directory-files dir) + (directory-fold dir cons '())) + +(define (renumber-file-descriptor old new) + (and (duplicate-file-descriptor-to old new) + (close-file-descriptor old))) + +(define (file-status file) + (if (string? file) (stat file) (fstat file))) + +(define (file-device x) (stat-dev (if (stat? x) x (file-status x)))) +(define (file-inode x) (stat-ino (if (stat? x) x (file-status x)))) +(define (file-mode x) (stat-mode (if (stat? x) x (file-status x)))) +(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x)))) +(define (file-owner x) (stat-uid (if (stat? x) x (file-status x)))) +(define (file-group x) (stat-gid (if (stat? x) x (file-status x)))) +(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x)))) +(define (file-size x) (stat-size (if (stat? x) x (file-status x)))) +(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x)))) +(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x)))) +(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x)))) +(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x)))) +(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x)))) + +(define (file-regular? x) (S_ISREG (file-mode x))) +(define (file-directory? x) (S_ISDIR (file-mode x))) +(define (file-character? x) (S_ISCHR (file-mode x))) +(define (file-block? x) (S_ISBLK (file-mode x))) +(define (file-fifo? x) (S_ISFIFO (file-mode x))) +(define (file-link? x) (S_ISLNK (file-mode x))) +(define (file-socket? x) (S_ISSOCK (file-mode x))) + +(define (file-exists? x) (and (file-status x) #t)) diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub new file mode 100644 index 00000000..8c42466f --- /dev/null +++ b/lib/chibi/filesystem.stub @@ -0,0 +1,115 @@ + +(c-system-include "sys/types.h") +(c-system-include "unistd.h") +(c-system-include "dirent.h") +(c-system-include "fcntl.h") + +(define-c-type DIR + finalizer: closedir) + +(define-c-struct dirent + (string d_name dirent-name)) + +(define-c-struct stat + predicate: stat? + (dev_t st_dev stat-dev) + (ino_t st_ino stat-ino) + (mode_t st_mode stat-mode) + (nlink_t st_nlink stat-nlinks) + (uid_t st_uid stat-uid) + (gid_t st_gid stat-gid) + (dev_t st_rdev stat-rdev) + (off_t st_size stat-size) + (blksize_t st_blksize stat-blksize) + (blkcnt_t st_blocks stat-blocks) + (time_t st_atime stat-atime) + (time_t st_mtime stat-mtime) + (time_t st_ctime stat-ctime)) + +(define-c boolean S_ISREG (mode_t)) +(define-c boolean S_ISDIR (mode_t)) +(define-c boolean S_ISCHR (mode_t)) +(define-c boolean S_ISBLK (mode_t)) +(define-c boolean S_ISFIFO (mode_t)) +(define-c boolean S_ISLNK (mode_t)) +(define-c boolean S_ISSOCK (mode_t)) + +;;(define-c-const int ("S_IFMT")) +(define-c-const int (file/socket "S_IFSOCK")) +(define-c-const int (file/link "S_IFLNK")) +(define-c-const int (file/regular "S_IFREG")) +(define-c-const int (file/block "S_IFBLK")) +(define-c-const int (file/directory "S_IFDIR")) +(define-c-const int (file/character "S_IFCHR")) +(define-c-const int (file/fifo "S_IFIFO")) +(define-c-const int (file/suid "S_ISUID")) +(define-c-const int (file/sgid "S_ISGID")) +(define-c-const int (file/sticky "S_ISVTX")) +;;(define-c-const int ("S_IRWXU")) +(define-c-const int (perm/user-read "S_IRUSR")) +(define-c-const int (perm/user-write "S_IWUSR")) +(define-c-const int (perm/user-execute "S_IXUSR")) +;;(define-c-const int ("S_IRWXG")) +(define-c-const int (perm/group-read "S_IRGRP")) +(define-c-const int (perm/group-write "S_IWGRP")) +(define-c-const int (perm/group-execute "S_IXGRP")) +;;(define-c-const int ("S_IRWXO")) +(define-c-const int (perm/others-read "S_IROTH")) +(define-c-const int (perm/others-write "S_IWOTH")) +(define-c-const int (perm/others-execute "S_IXOTH")) + +(define-c errno stat (string (result stat))) +(define-c errno fstat (int (result stat))) +(define-c errno (file-link-status "lstat") (string (result stat))) + +(define-c input-port (open-input-file-descriptor "fdopen") + (int (value "r" string))) +(define-c output-port (open-output-file-descriptor "fdopen") + (int (value "w" string))) + +(define-c errno (delete-file "unlink") (string)) +(define-c errno (link-file "link") (string string)) +(define-c errno (symbolic-link-file "symlink") (string string)) +(define-c errno (rename-file "rename") (string string)) + +(define-c non-null-string (current-directory "getcwd") + ((result (array char (auto-expand arg1))) (value 256 int))) + +(define-c errno (create-directory "mkdir") (string int)) +(define-c errno (delete-directory "rmdir") (string)) + +(define-c (free DIR) opendir (string)) +(define-c dirent readdir ((link DIR))) + +(define-c int (duplicate-file-descriptor "dup") (int)) +(define-c errno (duplicate-file-descriptor-to "dup2") (int int)) +(define-c errno (close-file-descriptor "close") (int)) + +(define-c errno (open-pipe "pipe") ((result (array int 2)))) +(define-c errno (make-fifo "mkfifo") (string (default #o644 int))) + +(define-c int (get-file-descriptor-flags "fcntl") + (int (value F_GETFD int))) +(define-c errno (set-file-descriptor-flags! "fcntl") + (int (value F_SETFD int) long)) + +(define-c int (get-file-descriptor-status "fcntl") + (int (value F_GETFL int))) +(define-c errno (set-file-descriptor-status! "fcntl") + (int (value F_SETFL int) long)) + +;; (define-c int (get-file-descriptor-lock "fcntl") +;; (int (value F_GETLK int) flock)) +;; (define-c errno (set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLK int) flock)) +;; (define-c errno (try-set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLKW int) flock)) + +(define-c-const int (open/read "O_RDONLY")) +(define-c-const int (open/write "O_WRONLY")) +(define-c-const int (open/read-write "O_RDWR")) +(define-c-const int (open/create "O_CREAT")) +(define-c-const int (open/exclusive "O_EXCL")) +(define-c-const int (open/truncate "O_TRUNC")) +(define-c-const int (open/append "O_APPEND")) +(define-c-const int (open/non-block "O_NONBLOCK")) diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c new file mode 100644 index 00000000..34e415c1 --- /dev/null +++ b/lib/chibi/heap-stats.c @@ -0,0 +1,129 @@ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define SEXP_HEAP_VECTOR_DEPTH 1 + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); + +#if SEXP_USE_GLOBAL_HEAP +#endif + +static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { + int i; + if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x) + || sexp_flonump(x) || sexp_bignump(x)) { + sexp_write(ctx, x, out); + } else if (depth <= 0) { + goto print_name; + } else if (sexp_synclop(x)) { + sexp_write_string(ctx, "#", out); + } else if (sexp_pairp(x)) { + sexp_write_char(ctx, '(', out); + sexp_print_simple(ctx, sexp_car(x), out, depth-1); + sexp_write_string(ctx, " . ", out); + sexp_print_simple(ctx, sexp_cdr(x), out, depth-1); + sexp_write_char(ctx, ')', out); + } else if (sexp_vectorp(x)) { + sexp_write_string(ctx, "#(", out); + for (i=0; i0) + sexp_write_char(ctx, ' ', out); + sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); + } + if (i", out); + } +} + +static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { + size_t freed; + sexp_uint_t stats[256], hi_type=0, i; + sexp_heap h = sexp_context_heap(ctx); + sexp p, out=SEXP_FALSE; + sexp_free_list q, r; + char *end; + sexp_gc_var3(res, tmp, name); + + if (printp) + out = sexp_env_global_ref(sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + SEXP_FALSE); + + /* run gc once to remove unused variables */ + sexp_gc(ctx, &freed); + + /* initialize stats */ + for (i=0; i<256; i++) stats[i]=0; + + /* loop over each heap chunk */ + for ( ; h; h=h->next) { + 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) { /* this is a free block, skip */ + p = (sexp) (((char*)p) + r->size); + continue; + } + /* otherwise maybe print, then increment the stat and continue */ + if (sexp_oportp(out)) { + sexp_print_simple(ctx, p, out, depth); + sexp_write_char(ctx, '\n', out); + } + stats[sexp_pointer_tag(p)]++; + if (sexp_pointer_tag(p) > hi_type) + hi_type = sexp_pointer_tag(p); + p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p))); + } + } + + /* build and return results */ + sexp_gc_preserve3(ctx, res, tmp, name); + res = SEXP_NULL; + for (i=hi_type; i>0; i--) + if (stats[i]) { + name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i)); + tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); + res = sexp_cons(ctx, tmp, res); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_heap_stats (sexp ctx) { + return sexp_heap_walk(ctx, 0, 0); +} + +static sexp sexp_heap_dump (sexp ctx, sexp depth) { + if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) + return sexp_type_exception(ctx, "bad heap-dump depth", depth); + return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats); + sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE); + return SEXP_VOID; +} + diff --git a/lib/chibi/heap-stats.module b/lib/chibi/heap-stats.module new file mode 100644 index 00000000..af84ca44 --- /dev/null +++ b/lib/chibi/heap-stats.module @@ -0,0 +1,5 @@ + +(define-module (chibi heap-stats) + (export heap-stats heap-dump) + (include-shared "heap-stats")) + diff --git a/lib/chibi/io.module b/lib/chibi/io.module new file mode 100644 index 00000000..f20b5b31 --- /dev/null +++ b/lib/chibi/io.module @@ -0,0 +1,6 @@ + +(define-module (chibi io) + (export read-string read-string! write-string read-line write-line) + (import-immutable (scheme)) + (include-shared "io/io") + (include "io/io.scm")) diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm new file mode 100644 index 00000000..3ffa8a98 --- /dev/null +++ b/lib/chibi/io/io.scm @@ -0,0 +1,6 @@ + +(define (write-line str . o) + (let ((out (if (pair? o) (car o) (current-output-port)))) + (display str out) + (newline out))) + diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub new file mode 100644 index 00000000..665d1bb5 --- /dev/null +++ b/lib/chibi/io/io.stub @@ -0,0 +1,13 @@ + +(define-c non-null-string (read-line "fgets") + ((result (array char arg1)) int (default (current-input-port) input-port))) + +(define-c size_t (read-string "fread") + ((result (array char arg1)) size_t (value 1 size_t) (default (current-input-port) input-port))) + +(define-c size_t (read-string! "fread") + (string size_t (value 1 size_t) (default (current-input-port) input-port))) + +(define-c size_t (write-string "fwrite") + (string size_t (value 1 size_t) (default (current-output-port) output-port))) + diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module new file mode 100644 index 00000000..5b76daf8 --- /dev/null +++ b/lib/chibi/loop.module @@ -0,0 +1,9 @@ + +(define-module (chibi loop) + (export loop in-list in-lists in-port in-file up-from down-from + listing listing-reverse appending appending-reverse + summing multiplying in-string in-string-reverse + in-vector in-vector-reverse) + (import-immutable (scheme)) + (include "loop/loop.scm")) + diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm new file mode 100644 index 00000000..09e12856 --- /dev/null +++ b/lib/chibi/loop/loop.scm @@ -0,0 +1,365 @@ +;;;; loop.scm - the chibi loop (aka foof-loop) +;; +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; The loop API is compatible with Taylor Campbell's foof-loop, but +;; the iterator API is different and subject to change. All loop +;; variables may be implicitly destructured with MATCH semantics. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (assoc-pred equal elt ls) + (and (pair? ls) + (if (equal elt (car (car ls))) + (car ls) + (assoc-pred equal elt (cdr ls))))) + +(define-syntax let-keyword-form + (syntax-rules () + ((let-keyword-form + ((labeled-arg-macro-name (positional-name . params))) + . body) + (let-syntax + ((labeled-arg-macro-name + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (named '()) (posns '())) + (cond + ((pair? ls) + (if (and (list? (car ls)) (compare (caar ls) (rename '=>))) + (lp (cdr ls) (cons (cdar ls) named) posns) + (lp (cdr ls) named (cons (car ls) posns)))) + (else + (let lp ((ls (syntax-quote params)) + (posns (reverse posns)) + (args '())) + (cond + ((null? ls) + (if (pair? posns) + (error "let-keyword-form: too many args" expr) + (cons (syntax-quote positional-name) (reverse args)))) + ((assoc-pred compare (caar ls) named) + => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args)))) + ((pair? posns) + (lp (cdr ls) (cdr posns) (cons (car posns) args))) + (else + (lp (cdr ls) posns (cons (cadar ls) args)))))))))))) + . body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax loop + (syntax-rules () + ;; unnamed, implicit recursion + ((loop (vars ...) body ...) + (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop))) + ;; named, explicit recursion + ((loop name (vars ...) body ...) + (%loop name () () () () () (vars ...) body ...)))) + +;; Main LOOP macro. Separate the variables from the iterator and +;; parameters, then walk through each parameter expanding the +;; bindings, and build the final form. + +(define-syntax %loop + (syntax-rules (=> for with let while until) + ;; automatic iteration + ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body) + (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ;; do equivalents, with optional guards + ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body) + (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init step) rest ...) . body) + (%loop name l (vars ... (var init step)) c r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init) rest ...) . body) + (%loop name l (vars ... (var init var)) c r f (rest ...) . body)) + ;; user-specified terminators + ((_ name l vars (checks ...) r f ((until expr) rest ...) . body) + (%loop name l vars (checks ... expr) r f (rest ...) . body)) + ((_ name l vars (checks ...) r f ((while expr) rest ...) . body) + (%loop name l vars (checks ... (not expr)) r f (rest ...) . body)) + ;; specify a default done? + ((_ name l v c r f ()) + (%loop name l v c r f () (#f #f))) + ((_ name l v c r f () () . body) + (%loop name l v c r f () (#f #f) . body)) + ;; final expansion + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => result + . body) + (let* (lets ...) + (letrec ((tmp (lambda (var ...) + (if (or checks ...) + (let-keyword-form ((name (tmp (var step) ...))) + (let (finals ...) result)) + (let (refs ...) + (let-keyword-form ((name (tmp (var step) ...))) + (if #f #f) + . body)))))) + (tmp init ...)))) + ;; unspecified return value case + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + . body) + (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => (if #f #f) . body)) + )) + +(define-syntax %loop-next + (syntax-rules () + ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...) + name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...) + . rest) + (%loop name (lets ... new-lets ...) (vars ... new-vars ...) + (checks ... new-checks ...) (refs ... new-refs ...) + (finals ... new-finals ...) + . rest)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Iterators + +;; Each gets passed two lists, those items left of the <- and those to +;; the right, followed by a NEXT and REST continuation. + +;; Should finish with +;; +;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...) +;; (loop-vars ...) (final-vars ...) . rest) +;; +;; OUTER-VARS: bound once outside the loop in a LET* +;; CURSOR-VARS: DO-style bindings of the form (name init update) +;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t +;; LOOP-VARS: inner variables, updated in parallel after the cursors +;; FINAL-VARS: final variables, bound only in the => result + +(define-syntax in-list ; called just "IN" in ITER + (syntax-rules () + ((in-list ((var) source) next . rest) + (in-list ((var cursor) source) next . rest)) + ((in-list ((var cursor) source) next . rest) + (in-list ((var cursor succ) source) next . rest)) + ((in-list ((var cursor succ) (source)) next . rest) + (next () ; outer let bindings + ((cursor source succ)) ; iterator, init, step + ((not (pair? cursor))) ; finish tests for iterator vars + ;; step variables and values + ((var (car cursor)) + (succ (cdr cursor))) + () ; final result bindings + . rest)) + ((in-list ((var cursor succ) (source step)) next . rest) + (next () + ((cursor source succ)) + ((not (pair? cursor))) + ((var (car cursor)) + (succ (step cursor))) + () + . rest)))) + +;; Iterator from Taylor R. Campbell. If you know the number of lists +;; ahead of time it's much more efficient to iterate over each one +;; separately. +(define-syntax in-lists + (syntax-rules () + ((in-lists ((elts) lol) next . rest) + (in-lists ((elts pairs) lol) next . rest)) + ((in-lists ((elts pairs) lol) next . rest) + (in-lists ((elts pairs succ) lol) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol step)) next . rest) + (in-lists ((elts pairs succ) (lol step null?)) next . rest)) + ((in-lists ((elts pairs succ) (lol step done?)) next . rest) + (next () + ((pairs lol succ)) + ((let lp ((ls pairs)) ; an in-lined ANY + (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls)))))) + ((elts (map car pairs)) + (succ (map step pairs))) + () + . rest)) + )) + +(define-syntax define-in-indexed + (syntax-rules () + ((define-in-indexed in-type in-type-reverse length ref) + (begin + (define-syntax in-type + (syntax-rules () + ((in-type ls next . rest) + (%in-idx >= + 0 (length tmp) ref tmp ls next . rest)))) + (define-syntax in-type-reverse + (syntax-rules () + ((in-type-reverse ls next . rest) + (%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest)))) + )))) + +(define-in-indexed in-string in-string-reverse string-length string-ref) +(define-in-indexed in-vector in-vector-reverse vector-length vector-ref) + +;; helper for the above string and vector iterators +(define-syntax %in-idx + (syntax-rules () + ;; cmp inc start end ref + ((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest) + (%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest) + (next ((tmp-vec vec) (end to)) + ((index from (+ index step))) + ((ge index end)) + ((var (r tmp-vec index))) + () + . rest)) + )) + +(define-syntax in-port + (syntax-rules () + ((in-port ((var) source) next . rest) + (in-port ((var p) source) next . rest)) + ((in-port ((var p) ()) next . rest) + (in-port ((var p) ((current-input-port))) next . rest)) + ((in-port ((var p) (port)) next . rest) + (in-port ((var p) (port read-char)) next . rest)) + ((in-port ((var p) (port read-char)) next . rest) + (in-port ((var p) (port read-char eof-object?)) next . rest)) + ((in-port ((var p) (port reader eof?)) next . rest) + (next ((p port) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + () + . rest)))) + +(define-syntax in-file + (syntax-rules () + ((in-file ((var) source) next . rest) + (in-file ((var p) source) next . rest)) + ((in-file ((var p) (file)) next . rest) + (in-file ((var p) (file read-char)) next . rest)) + ((in-file ((var p) (file reader)) next . rest) + (in-file ((var p) (file reader eof-object?)) next . rest)) + ((in-file ((var p) (file reader eof?)) next . rest) + (next ((p (open-input-file file)) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + ((dummy (close-input-port p))) + . rest)))) + +(define-syntax up-from + (syntax-rules (to by) + ((up-from (() . args) next . rest) + (up-from ((var) . args) next . rest)) + ((up-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var s (+ var e))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var s (+ var 1))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var s (+ var e))) () () () . rest)) + ((up-from ((var) (start)) next . rest) + (next ((s start)) ((var s (+ var 1))) () () () . rest)) + )) + +(define-syntax down-from + (syntax-rules (to by) + ((down-from (() . args) next . rest) + (down-from ((var) . args) next . rest)) + ((down-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var (- s e) (- var e))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var (- s 1) (- var 1))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var (- s e) (- var e))) () () () + . rest)) + ((down-from ((var) (start)) next . rest) + (next ((s start)) ((var (- s 1) (- var 1))) () () () + . rest)) + )) + +(define-syntax accumulating + (syntax-rules (initial if) + ((accumulating (kons final init) ((var) . x) next . rest) + (accumulating (kons final init) ((var cursor) . x) next . rest)) + ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest) + (accumulating (kons final i) ((var cursor) x) n . rest)) + ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (if check (tmp-kons expr cursor) cursor))) + () + () + ((var (final cursor))) + . rest)) + ((accumulating (kons final init) ((var cursor) (expr)) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (tmp-kons expr cursor))) + () + () + ((var (final cursor))) + . rest)))) + +(define-syntax listing + (syntax-rules () + ((listing args next . rest) + (accumulating (cons reverse '()) args next . rest)))) + +(define-syntax listing-reverse + (syntax-rules () + ((listing-reverse args next . rest) + (accumulating (cons (lambda (x) x) '()) args next . rest)))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define-syntax appending + (syntax-rules () + ((appending args next . rest) + (accumulating (append-reverse reverse '()) args next . rest)))) + +(define-syntax appending-reverse + (syntax-rules () + ((appending-reverse args next . rest) + (accumulating (append-reverse (lambda (x) x) '()) args next . rest)))) + +(define-syntax summing + (syntax-rules () + ((summing args next . rest) + (accumulating (+ (lambda (x) x) 0) args next . rest)))) + +(define-syntax multiplying + (syntax-rules () + ((multiplying args next . rest) + (accumulating (* (lambda (x) x) 1) args next . rest)))) diff --git a/lib/chibi/macroexpand.module b/lib/chibi/macroexpand.module new file mode 100644 index 00000000..47b0e7d4 --- /dev/null +++ b/lib/chibi/macroexpand.module @@ -0,0 +1,6 @@ + +(define-module (chibi macroexpand) + (import-immutable (scheme)) + (import (chibi ast)) + (export macroexpand) + (include "macroexpand.scm")) diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm new file mode 100644 index 00000000..a040855a --- /dev/null +++ b/lib/chibi/macroexpand.scm @@ -0,0 +1,85 @@ +;; macroexpand.scm -- macro expansion utility +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; This actually analyzes the expression then reverse-engineers an +;; sexp from the result, generating a minimal amount of renames. + +(define (macroexpand x) + (ast->sexp (analyze x))) + +(define (ast-renames ast) + (define i 0) + (define renames '()) + (define (rename-symbol id) + (set! i (+ i 1)) + (string->symbol + (string-append (symbol->string (identifier->symbol id)) + "." (number->string i)))) + (define (rename-lambda lam) + (or (assq lam renames) + (let ((res (list lam))) + (set! renames (cons res renames)) + res))) + (define (rename! id lam) + (let ((cell (rename-lambda lam))) + (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell))))) + (define (check-ref id lam env) + (let ((sym (identifier->symbol id))) + (let lp1 ((ls env)) + (cond + ((pair? ls) + (let lp2 ((ls2 (car ls)) (found? #f)) + (cond + ((null? ls2) + (if (not found?) (lp1 (cdr ls)))) + ((and (eq? id (caar ls2)) (eq? lam (cdar ls2))) + (lp2 (cdr ls2) #t)) + ((eq? sym (identifier->symbol (caar ls2))) + (rename! (caar ls2) (cdar ls2)) + (lp2 (cdr ls2) found?)) + (else + (lp2 (cdr ls2) found?))))))))) + (define (flatten-dot x) + (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) + ((null? x) x) + (else (list x)))) + (define (extend-env lam env) + (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env)) + (let lp ((x ast) (env '())) + (cond + ((lambda? x) (lp (lambda-body x) (extend-env x env))) + ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env)) + ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env)) + ((set? x) (lp (set-var x) env) (lp (set-value x) env)) + ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x))) + ((pair? x) (for-each (lambda (x) (lp x env)) x)))) + renames) + +(define (get-rename id lam renames) + (let ((ls (assq lam renames))) + (if (not ls) + (identifier->symbol id) + (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id)))))) + +(define (ast->sexp ast) + (let ((renames (ast-renames ast))) + (let a2s ((x ast)) + (cond + ((lambda? x) + `(lambda ,(map (lambda (id) (get-rename id x renames)) (lambda-params x)) + ,@(map (lambda (d) `(define ,(identifier->symbol (cadr d)) #f)) (lambda-defs x)) + ,@(if (seq? (lambda-body x)) + (map a2s (seq-ls (lambda-body x))) + (list (a2s (lambda-body x)))))) + ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) + ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) + ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) + ((seq? x) `(begin ,@(map a2s (seq-ls x)))) + ((lit? x) + (let ((v (lit-value x))) + (if (or (pair? v) (null? v) (symbol? v)) `',v v))) + ((pair? x) (cons (a2s (car x)) (a2s (cdr x)))) + ((opcode? x) (or (opcode-name x) x)) + (else x))))) + diff --git a/lib/chibi/match.module b/lib/chibi/match.module new file mode 100644 index 00000000..1366176a --- /dev/null +++ b/lib/chibi/match.module @@ -0,0 +1,6 @@ + +(define-module (chibi match) + (export match match-lambda match-lambda* match-let match-letrec match-let*) + (import-immutable (scheme)) + (include "match/match.scm")) + diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm new file mode 100644 index 00000000..963b89ff --- /dev/null +++ b/lib/chibi/match/match.scm @@ -0,0 +1,670 @@ +;;;; match.scm -- portable hygienic pattern matcher +;; +;; This code is written by Alex Shinn and placed in the +;; Public Domain. All warranties are disclaimed. + +;; This is a full superset of the popular MATCH package by Andrew +;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks +;; in R6RS SYNTAX-RULES), and thus preserving hygiene. + +;; This is a simple generative pattern matcher - each pattern is +;; expanded into the required tests, calling a failure continuation if +;; the tests fail. This makes the logic easy to follow and extend, +;; but produces sub-optimal code in cases where you have many similar +;; clauses due to repeating the same tests. Nonetheless a smart +;; compiler should be able to remove the redundant tests. For +;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance +;; hit. + +;; The original version was written on 2006/11/29 and described in the +;; following Usenet post: +;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd +;; and is still available at +;; http://synthcode.com/scheme/match-simple.scm +;; It's just 80 lines for the core MATCH, and an extra 40 lines for +;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar. +;; +;; A variant of this file which uses COND-EXPAND in a few places for +;; performance can be found at +;; http://synthcode.com/scheme/match-cond-expand.scm +;; +;; 2009/11/25 - adding `***' tree search patterns +;; 2008/03/20 - fixing bug where (a ...) matched non-lists +;; 2008/03/15 - removing redundant check in vector patterns +;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) +;; 2007/09/04 - fixing quasiquote patterns +;; 2007/07/21 - allowing ellipse patterns in non-final list positions +;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse +;; (thanks to Taylor Campbell) +;; 2007/04/08 - clean up, commenting +;; 2006/12/24 - bugfixes +;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; force compile-time syntax errors with useful messages + +(define-syntax match-syntax-error + (syntax-rules () + ((_) (match-syntax-error "invalid match-syntax-error usage")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The basic interface. MATCH just performs some basic syntax +;; validation, binds the match expression to a temporary variable `v', +;; and passes it on to MATCH-NEXT. It's a constant throughout the +;; code below that the binding `v' is a direct variable reference, not +;; an expression. + +(define-syntax match + (syntax-rules () + ((match) + (match-syntax-error "missing match expression")) + ((match atom) + (match-syntax-error "no match clauses")) + ((match (app ...) (pat . body) ...) + (let ((v (app ...))) + (match-next v ((app ...) (set! (app ...))) (pat . body) ...))) + ((match #(vec ...) (pat . body) ...) + (let ((v #(vec ...))) + (match-next v (v (set! v)) (pat . body) ...))) + ((match atom (pat . body) ...) + (match-next atom (atom (set! atom)) (pat . body) ...)) + )) + +;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure +;; thunk, which is expanded by recursing MATCH-NEXT on the remaining +;; clauses. `g+s' is a list of two elements, the get! and set! +;; expressions respectively. + +(define-syntax match-next + (syntax-rules (=>) + ;; no more clauses, the match failed + ((match-next v g+s) + (error 'match "no matching pattern")) + ;; named failure continuation + ((match-next v g+s (pat (=> failure) . body) . rest) + (let ((failure (lambda () (match-next v g+s . rest)))) + ;; match-one analyzes the pattern for us + (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ()))) + ;; anonymous failure continuation, give it a dummy name + ((match-next v g+s (pat . body) . rest) + (match-next v g+s (pat (=> failure) . body) . rest)))) + +;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to +;; MATCH-TWO. + +(define-syntax match-one + (syntax-rules () + ;; If it's a list of two or more values, check to see if the + ;; second one is an ellipse and handle accordingly, otherwise go + ;; to MATCH-TWO. + ((match-one v (p q . r) g+s sk fk i) + (match-check-ellipse + q + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()) + (match-two v (p q . r) g+s sk fk i))) + ;; Go directly to MATCH-TWO. + ((match-one . x) + (match-two . x)))) + +;; This is the guts of the pattern matcher. We are passed a lot of +;; information in the form: +;; +;; (match-two var pattern getter setter success-k fail-k (ids ...)) +;; +;; usually abbreviated +;; +;; (match-two v p g+s sk fk i) +;; +;; where VAR is the symbol name of the current variable we are +;; matching, PATTERN is the current pattern, getter and setter are the +;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding +;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure +;; continuation (which is just a thunk call and is thus safe to expand +;; multiple times) and IDS are the list of identifiers bound in the +;; pattern so far. + +(define-syntax match-two + (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!) + ((match-two v () g+s (sk ...) fk i) + (if (null? v) (sk ... i) fk)) + ((match-two v (quote p) g+s (sk ...) fk i) + (if (equal? v 'p) (sk ... i) fk)) + ((match-two v (quasiquote p) . x) + (match-quasiquote v p . x)) + ((match-two v (and) g+s (sk ...) fk i) (sk ... i)) + ((match-two v (and p q ...) g+s sk fk i) + (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i)) + ((match-two v (or) g+s sk fk i) fk) + ((match-two v (or p) . x) + (match-one v p . x)) + ((match-two v (or p ...) g+s sk fk i) + (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ())) + ((match-two v (not p) g+s (sk ...) fk i) + (match-one v p g+s (match-drop-ids fk) (sk ... i) i)) + ((match-two v (get! getter) (g s) (sk ...) fk i) + (let ((getter (lambda () g))) (sk ... i))) + ((match-two v (set! setter) (g (s ...)) (sk ...) fk i) + (let ((setter (lambda (x) (s ... x)))) (sk ... i))) + ((match-two v (? pred . p) g+s sk fk i) + (if (pred v) (match-one v (and . p) g+s sk fk i) fk)) + ((match-two v (= proc p) . x) + (let ((w (proc v))) (match-one w p . x))) + ((match-two v (p ___ . r) g+s sk fk i) + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())) + ((match-two v (p) g+s sk fk i) + (if (and (pair? v) (null? (cdr v))) + (let ((w (car v))) + (match-one w p ((car v) (set-car! v)) sk fk i)) + fk)) + ((match-two v (p *** q) g+s sk fk i) + (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) + ((match-two v (p *** . q) g+s sk fk i) + (match-syntax-error "invalid use of ***" (p *** . q))) + ((match-two v (p . q) g+s sk fk i) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-one w p ((car v) (set-car! v)) + (match-one x q ((cdr v) (set-cdr! v)) sk fk) + fk + i)) + fk)) + ((match-two v #(p ...) g+s . x) + (match-vector v 0 () (p ...) . x)) + ((match-two v _ g+s (sk ...) fk i) (sk ... i)) + ;; Not a pair or vector or special literal, test to see if it's a + ;; new symbol, in which case we just bind it, or if it's an + ;; already bound symbol or some other literal, in which case we + ;; compare it with EQUAL?. + ((match-two v x g+s (sk ...) fk (id ...)) + (let-syntax + ((new-sym? + (syntax-rules (id ...) + ((new-sym? x sk2 fk2) sk2) + ((new-sym? y sk2 fk2) fk2)))) + (new-sym? random-sym-to-match + (let ((x v)) (sk ... (id ... x))) + (if (equal? v x) (sk ... (id ...)) fk)))) + )) + +;; QUASIQUOTE patterns + +(define-syntax match-quasiquote + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ v (unquote p) g+s sk fk i) + (match-one v p g+s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g+s sk fk i) + (if (pair? v) + (match-one v + (p . tmp) + (match-quasiquote tmp rest g+s sk fk) + fk + i) + fk)) + ((_ v (quasiquote p) g+s sk fk i . depth) + (match-quasiquote v p g+s sk fk i #f . depth)) + ((_ v (unquote p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (unquote-splicing p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (p . q) g+s sk fk i . depth) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-quasiquote + w p g+s + (match-quasiquote-step x q g+s sk fk depth) + fk i . depth)) + fk)) + ((_ v #(elt ...) g+s sk fk i . depth) + (if (vector? v) + (let ((ls (vector->list v))) + (match-quasiquote ls (elt ...) g+s sk fk i . depth)) + fk)) + ((_ v x g+s sk fk i . depth) + (match-one v 'x g+s sk fk i)))) + +(define-syntax match-quasiquote-step + (syntax-rules () + ((match-quasiquote-step x q g+s sk fk depth i) + (match-quasiquote x q g+s sk fk i . depth)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities + +;; Takes two values and just expands into the first. +(define-syntax match-drop-ids + (syntax-rules () + ((_ expr ids ...) expr))) + +(define-syntax match-drop-first-arg + (syntax-rules () + ((_ arg expr) expr))) + +;; To expand an OR group we try each clause in succession, passing the +;; first that succeeds to the success continuation. On failure for +;; any clause, we just try the next clause, finally resorting to the +;; failure continuation fk if all clauses fail. The only trick is +;; that we want to unify the identifiers, so that the success +;; continuation can refer to a variable from any of the OR clauses. + +(define-syntax match-gen-or + (syntax-rules () + ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...)) + (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) + (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...)))))) + +(define-syntax match-gen-or-step + (syntax-rules () + ((_ v () g+s sk fk . x) + ;; no OR clauses, call the failure continuation + fk) + ((_ v (p) . x) + ;; last (or only) OR clause, just expand normally + (match-one v p . x)) + ((_ v (p . q) g+s sk fk i) + ;; match one and try the remaining on failure + (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) + )) + +;; We match a pattern (p ...) by matching the pattern p in a loop on +;; each element of the variable, accumulating the bound ids into lists. + +;; Look at the body of the simple case - it's just a named let loop, +;; matching each element in turn to the same pattern. The only trick +;; is that we want to keep track of the lists of each extracted id, so +;; when the loop recurses we cons the ids onto their respective list +;; variables, and on success we bind the ids (what the user input and +;; expects to see in the success body) to the reversed accumulated +;; list IDs. + +(define-syntax match-gen-ellipses + (syntax-rules () + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to (p ...), just bind the list + (let ((p v)) + (if (list? p) + (sk ... i) + fk)) + ;; simple case, match all elements of the list + (let loop ((ls v) (id-ls '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) + fk i))) + (else + fk))))) + ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking + (match-verify-no-ellipses + r + (let* ((tail-len (length 'r)) + (ls v) + (len (length ls))) + (if (< len tail-len) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond + ((= n tail-len) + (let ((id (reverse id-ls)) ...) + (match-one ls r (#f #f) (sk ... i) fk i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids + (loop (cdr ls) (- n 1) (cons id id-ls) ...)) + fk + i))) + (else + fk))))))))) + +;; This is just a safety check. Although unlike syntax-rules we allow +;; trailing patterns after an ellipses, we explicitly disable multiple +;; ellipses at the same level. This is because in the general case +;; such patterns are exponential in the number of ellipses, and we +;; don't want to make it easy to construct very expensive operations +;; with simple looking patterns. For example, it would be O(n^2) for +;; patterns like (a ... b ...) because we must consider every trailing +;; element for every possible break for the leading "a ...". + +(define-syntax match-verify-no-ellipses + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipse + x + (match-syntax-error + "multiple ellipse patterns not allowed at same level") + (match-verify-no-ellipses y sk))) + ((_ () sk) + sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipse" x)))) + +;; Matching a tree search pattern is only slightly more complicated. +;; Here we allow patterns of the form +;; +;; (x *** y) +;; +;; to represent the pattern y located somewhere in a tree where the +;; path from the current object to y can be seen as a list of the form +;; (X ...). Y can immediately match the current object in which case +;; the path is the empty list. In a sense it's a 2-dimensional +;; version of the ... pattern. +;; +;; As a common case the pattern (_ *** y) can be used to search for Y +;; anywhere in a tree, regardless of the path used. +;; +;; To implement the search, we use two recursive procedures. TRY +;; attempts to match Y once, and on success it calls the normal SK on +;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we +;; call NEXT which first checks if the current value is a list +;; beginning with X, then calls TRY on each remaining element of the +;; list. Since TRY will recursively call NEXT again on failure, this +;; effects a full depth-first search. +;; +;; The failure continuation throughout is a jump to the next step in +;; the tree search, initialized with the original failure continuation +;; FK. + +(define-syntax match-gen-search + (syntax-rules () + ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) + (letrec ((try (lambda (w fail id-ls ...) + (match-one w q g+s + (match-drop-ids + (let ((id (reverse id-ls)) ...) + sk)) + (next w fail id-ls ...) i))) + (next (lambda (w fail id-ls ...) + (if (not (pair? w)) + (fail) + (let ((u (car w))) + (match-one + u p ((car w) (set-car! w)) + (match-drop-ids + ;; accumulate the head variables from + ;; the p pattern, and loop over the tail + (let ((id-ls (cons id id-ls)) ...) + (let lp ((ls (cdr w))) + (if (pair? ls) + (try (car ls) + (lambda () (lp (cdr ls))) + id-ls ...) + (fail))))) + (fail) i)))))) + ;; the initial id-ls binding here is a dummy to get the right + ;; number of '()s + (let ((id-ls '()) ...) + (try v (lambda () fk) id-ls ...)))))) + +;; Vector patterns are just more of the same, with the slight +;; exception that we pass around the current vector index being +;; matched. + +(define-syntax match-vector + (syntax-rules (___) + ((_ v n pats (p q) . x) + (match-check-ellipse q + (match-gen-vector-ellipses v n pats p . x) + (match-vector-two v n pats (p q) . x))) + ((_ v n pats (p ___) sk fk i) + (match-gen-vector-ellipses v n pats p sk fk i)) + ((_ . x) + (match-vector-two . x)))) + +;; Check the exact vector length, then check each element in turn. + +(define-syntax match-vector-two + (syntax-rules () + ((_ v n ((pat index) ...) () sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (= len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) . x) + (match-vector v (+ n 1) (pats ... (p n)) q . x)))) + +(define-syntax match-vector-step + (syntax-rules () + ((_ v () (sk ...) fk i) (sk ... i)) + ((_ v ((pat index) . rest) sk fk i) + (let ((w (vector-ref v index))) + (match-one w pat ((vector-ref v index) (vector-set! v index)) + (match-vector-step v rest sk fk) + fk i))))) + +;; With a vector ellipse pattern we first check to see if the vector +;; length is at least the required length. + +(define-syntax match-gen-vector-ellipses + (syntax-rules () + ((_ v n ((pat index) ...) p sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (>= len n) + (match-vector-step v ((pat index) ...) + (match-vector-tail v p n len sk fk) + fk i) + fk)) + fk)))) + +(define-syntax match-vector-tail + (syntax-rules () + ((_ v p n len sk fk i) + (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())))) + +(define-syntax match-vector-tail-two + (syntax-rules () + ((_ v p n len (sk ...) fk i ((id id-ls) ...)) + (let loop ((j n) (id-ls '()) ...) + (if (>= j len) + (let ((id (reverse id-ls)) ...) (sk ... i)) + (let ((w (vector-ref v j))) + (match-one w p ((vector-ref v j) (vetor-set! v j)) + (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) + fk i))))))) + +;; Extract all identifiers in a pattern. A little more complicated +;; than just looking for symbols, we need to ignore special keywords +;; and non-pattern forms (such as the predicate expression in ? +;; patterns), and also ignore previously bound identifiers. +;; +;; Calls the continuation with all new vars as a list of the form +;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely +;; pair with the original variable (e.g. it's used in the ellipse +;; generation for list variables). +;; +;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) + +(define-syntax match-extract-vars + (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!) + ((match-extract-vars (? pred . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars ($ rec . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (= proc p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (quote x) (k ...) i v) + (k ... v)) + ((match-extract-vars (quasiquote x) k i v) + (match-extract-quasiquote-vars x k i v (#t))) + ((match-extract-vars (and . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (or . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (not . p) . x) + (match-extract-vars p . x)) + ;; A non-keyword pair, expand the CAR with a continuation to + ;; expand the CDR. + ((match-extract-vars (p q . r) k i v) + (match-check-ellipse + q + (match-extract-vars (p . r) k i v) + (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) + ((match-extract-vars (p . q) k i v) + (match-extract-vars p (match-extract-vars-step q k i v) i ())) + ((match-extract-vars #(p ...) . x) + (match-extract-vars (p ...) . x)) + ((match-extract-vars _ (k ...) i v) (k ... v)) + ((match-extract-vars ___ (k ...) i v) (k ... v)) + ((match-extract-vars *** (k ...) i v) (k ... v)) + ;; This is the main part, the only place where we might add a new + ;; var if it's an unbound symbol. + ((match-extract-vars p (k ...) (i ...) v) + (let-syntax + ((new-sym? + (syntax-rules (i ...) + ((new-sym? p sk fk) sk) + ((new-sym? x sk fk) fk)))) + (new-sym? random-sym-to-match + (k ... ((p p-ls) . v)) + (k ... v)))) + )) + +;; Stepper used in the above so it can expand the CAR and CDR +;; separately. + +(define-syntax match-extract-vars-step + (syntax-rules () + ((_ p k i v ((v2 v2-ls) ...)) + (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) + )) + +(define-syntax match-extract-quasiquote-vars + (syntax-rules (quasiquote unquote unquote-splicing) + ((match-extract-quasiquote-vars (quasiquote x) k i v d) + (match-extract-quasiquote-vars x k i v (#t . d))) + ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) + (match-extract-quasiquote-vars (unquote x) k i v d)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t)) + (match-extract-vars x k i v)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) + (match-extract-quasiquote-vars x k i v d)) + ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) + (match-extract-quasiquote-vars + x + (match-extract-quasiquote-vars-step y k i v d) i ())) + ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) + (match-extract-quasiquote-vars (x ...) k i v d)) + ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) + (k ... v)) + )) + +(define-syntax match-extract-quasiquote-vars-step + (syntax-rules () + ((_ x k i v d ((v2 v2-ls) ...)) + (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d)) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gimme some sugar baby. + +(define-syntax match-lambda + (syntax-rules () + ((_ clause ...) (lambda (expr) (match expr clause ...))))) + +(define-syntax match-lambda* + (syntax-rules () + ((_ clause ...) (lambda expr (match expr clause ...))))) + +(define-syntax match-let + (syntax-rules () + ((_ (vars ...) . body) + (match-let/helper let () () (vars ...) . body)) + ((_ loop . rest) + (match-named-let loop () . rest)))) + +(define-syntax match-letrec + (syntax-rules () + ((_ vars . body) (match-let/helper letrec () () vars . body)))) + +(define-syntax match-let/helper + (syntax-rules () + ((_ let ((var expr) ...) () () . body) + (let ((var expr) ...) . body)) + ((_ let ((var expr) ...) ((pat tmp) ...) () . body) + (let ((var expr) ...) + (match-let* ((pat tmp) ...) + . body))) + ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((a expr) . rest) . body) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)))) + +(define-syntax match-named-let + (syntax-rules () + ((_ loop ((pat expr var) ...) () . body) + (let loop ((var expr) ...) + (match-let ((pat var) ...) + . body))) + ((_ loop (v ...) ((pat expr) . rest) . body) + (match-named-let loop (v ... (pat expr tmp)) rest . body)))) + +(define-syntax match-let* + (syntax-rules () + ((_ () . body) + (begin . body)) + ((_ ((pat expr) . rest) . body) + (match expr (pat (match-let* rest . body)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Otherwise COND-EXPANDed bits. + +;; This *should* work, but doesn't :( +;; (define-syntax match-check-ellipse +;; (syntax-rules (...) +;; ((_ ... sk fk) sk) +;; ((_ x sk fk) fk))) + +;; This is a little more complicated, and introduces a new let-syntax, +;; but should work portably in any R[56]RS Scheme. Taylor Campbell +;; originally came up with the idea. +(define-syntax match-check-ellipse + (syntax-rules () + ;; these two aren't necessary but provide fast-case failures + ((match-check-ellipse (a . b) success-k failure-k) failure-k) + ((match-check-ellipse #(a ...) success-k failure-k) failure-k) + ;; matching an atom + ((match-check-ellipse id success-k failure-k) + (let-syntax ((ellipse? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipse? (foo id) sk fk) sk) + ((ellipse? other sk fk) fk)))) + ;; this list of three elements will only many the (foo id) list + ;; above if `id' is `...' + (ellipse? (a b c) success-k failure-k))))) + + +;; This is portable but can be more efficient with non-portable +;; extensions. This trick was originally discovered by Oleg Kiselyov. + +(define-syntax match-check-identifier + (syntax-rules () + ;; fast-case failures, lists and vectors are not identifiers + ((_ (x . y) success-k failure-k) failure-k) + ((_ #(x ...) success-k failure-k) failure-k) + ;; x is an atom + ((_ x success-k failure-k) + (let-syntax + ((sym? + (syntax-rules () + ;; if the symbol `abracadabra' matches x, then x is a + ;; symbol + ((sym? x sk fk) sk) + ;; otherwise x is a non-symbol datum + ((sym? y sk fk) fk)))) + (sym? abracadabra success-k failure-k))))) diff --git a/lib/chibi/net.module b/lib/chibi/net.module new file mode 100644 index 00000000..41cdafe4 --- /dev/null +++ b/lib/chibi/net.module @@ -0,0 +1,10 @@ + +(define-module (chibi net) + (export sockaddr? address-info? get-address-info socket connect with-net-io + address-info-family address-info-socket-type address-info-protocol + address-info-address address-info-address-length address-info-next) + (import-immutable (scheme)) + (import (chibi filesystem)) + (include-shared "net") + (include "net.scm")) + diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm new file mode 100644 index 00000000..85ed756a --- /dev/null +++ b/lib/chibi/net.scm @@ -0,0 +1,23 @@ +;; net.scm -- the high-level network interface +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (with-net-io host service proc) + (let lp ((addr (get-address-info host service #f))) + (if (not addr) + (error "couldn't find address" host service) + (let ((sock (socket (address-info-family addr) + (address-info-socket-type addr) + (address-info-protocol addr)))) + (if (negative? sock) + (lp (address-info-next addr)) + (if (negative? + (connect sock + (address-info-address addr) + (address-info-address-length addr))) + (lp (address-info-next addr)) + (let ((in (open-input-file-descriptor sock)) + (out (open-output-file-descriptor sock))) + (let ((res (proc in out))) + (close-input-port in) + res)))))))) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub new file mode 100644 index 00000000..0d72bc90 --- /dev/null +++ b/lib/chibi/net.stub @@ -0,0 +1,25 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/socket.h") +(c-system-include "netdb.h") + +(define-c-struct sockaddr + predicate: sockaddr?) + +(define-c-struct addrinfo + finalizer: freeaddrinfo + predicate: address-info? + (int ai_family address-info-family) + (int ai_socktype address-info-socket-type) + (int ai_protocol address-info-protocol) + ((link sockaddr) ai_addr address-info-address) + (size_t ai_addrlen address-info-address-length) + ((link addrinfo) ai_next address-info-next)) + +(define-c errno (get-address-info getaddrinfo) + (string string (maybe-null addrinfo) (result free addrinfo))) + +(define-c int bind (int sockaddr int)) +(define-c int listen (int int)) +(define-c int socket (int int int)) +(define-c int connect (int sockaddr int)) diff --git a/lib/chibi/pathname.module b/lib/chibi/pathname.module new file mode 100644 index 00000000..765ee189 --- /dev/null +++ b/lib/chibi/pathname.module @@ -0,0 +1,7 @@ + +(define-module (chibi pathname) + (export path-strip-directory path-directory path-extension-pos + path-extension path-strip-extension path-replace-extension + path-absolute? path-relative? path-normalize make-path) + (import-immutable (scheme)) + (include "pathname.scm")) diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm new file mode 100644 index 00000000..de27ad61 --- /dev/null +++ b/lib/chibi/pathname.scm @@ -0,0 +1,180 @@ +;; pathname.scm -- a general, non-host-specific path lib +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-scan-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (- i 1)))))) + +(define (string-skip c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (+ i 1))))))) + +(define (string-skip-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (- i 1)))))) + +;; POSIX basename +;; (define (path-strip-directory path) +;; (if (string=? path "") +;; path +;; (let ((end (string-skip-right #\/ path))) +;; (if (not end) +;; "/" +;; (let ((start (string-scan-right #\/ path (- end 1)))) +;; (substring path (if start (+ start 1) 0) (+ end 1))))))) + +;; GNU basename +(define (path-strip-directory path) + (if (string=? path "") + path + (let ((len (string-length path))) + (if (eqv? #\/ (string-ref path (- len 1))) + "" + (let ((slash (string-scan-right #\/ path))) + (if (not slash) + path + (substring path (+ slash 1) len))))))) + +(define (path-directory path) + (if (string=? path "") + "." + (let ((end (string-skip-right #\/ path))) + (if (not end) + "/" + (let ((start (string-scan-right #\/ path (- end 1)))) + (if (not start) + "." + (let ((start (string-skip-right #\/ path start))) + (if (not start) "/" (substring path 0 (+ start 1)))))))))) + +(define (path-extension-pos path) (string-scan-right #\. path)) + +(define (path-extension path) + (let ((i (path-extension-pos path))) + (and i + (let ((start (+ i 1)) (end (string-length path))) + (and (< start end) (substring path start end)))))) + +(define (path-strip-extension path) + (let ((i (path-extension-pos path))) + (if (and i (< (+ i 1) (string-length path))) + (substring path 0 i) + path))) + +(define (path-replace-extension path ext) + (string-append (path-strip-extension path) "." ext)) + +(define (path-absolute? path) + (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0)))) + +(define (path-relative? path) (not (path-absolute? path))) + +;; This looks big and hairy, but it's mutation-free and guarantees: +;; (string=? s (path-normalize s)) <=> (eq? s (path-normalize s)) +;; i.e. fast and simple for already normalized paths. + +(define (path-normalize path) + (let* ((len (string-length path)) (len-1 (- len 1))) + (define (collect i j res) + (if (>= i j) res (cons (substring path i j) res))) + (define (finish i res) + (if (zero? i) + path + (apply string-append (reverse (collect i len res))))) + ;; loop invariants: + ;; - res is a list such that (string-concatenate-reverse res) + ;; is always the normalized string up to j + ;; - the tail of the string from j onward can be concatenated to + ;; the above value to get a partially normalized path referring + ;; to the same location as the original path + (define (inside i j res) + (if (>= j len) + (finish i res) + (if (eqv? #\/ (string-ref path j)) + (boundary i (+ j 1) res) + (inside i (+ j 1) res)))) + (define (boundary i j res) + (if (>= j len-1) + (finish i res) + (case (string-ref path j) + ((#\.) + (case (string-ref path (+ j 1)) + ((#\.) + (if (or (>= j (- len 2)) (eqv? #\/ (string-ref path (+ j 2)))) + (if (>= i (- j 1)) + (if (null? res) + (backup j "" '()) + (backup j (car res) (cdr res))) + (backup j (substring path i j) res)) + (inside i (+ j 2) res))) + ((#\/) + (if (= i j) + (boundary (+ j 2) (+ j 2) res) + (let ((s (substring path i j))) + (boundary (+ j 2) (+ j 2) (cons s res))))) + (else (inside i (+ j 1) res)))) + ((#\/) (boundary (+ j 1) (+ j 1) (collect i j res))) + (else (inside i (+ j 1) res))))) + (define (backup j s res) + (let ((pos (+ j 3))) + (cond + ;; case 1: we're reduced to accumulating parents of the cwd + ((or (string=? s "/..") (string=? s "..")) + (boundary pos pos (cons "/.." (cons s res)))) + ;; case 2: the string isn't a component itself, skip it + ((or (string=? s "") (string=? s ".") (string=? s "/")) + (if (pair? res) + (backup j (car res) (cdr res)) + (boundary pos pos (if (string=? s "/") '("/") '(".."))))) + ;; case3: just take the directory of the string + (else + (let ((d (path-directory s))) + (cond + ((string=? d "/") + (boundary pos pos (if (null? res) '("/") res))) + ((string=? d ".") + (boundary pos pos res)) + (else (boundary pos pos (cons "/" (cons d res)))))))))) + ;; start with boundary if abs path, otherwise inside + (if (zero? len) + path + ((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '())))) + +(define (make-path . args) + (define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "not a valid path component" x)))) + (define (trim-trailing-slash s) + (let ((i (string-skip-right #\/ s))) + (if i (substring s 0 (+ i 1)) ""))) + (if (null? args) + "" + (let ((start (trim-trailing-slash (x->string (car args))))) + (let lp ((ls (cdr args)) + (res (if (string=? "" start) '() (list start)))) + (cond + ((null? ls) + (apply string-append (reverse res))) + ((pair? (car ls)) + (lp (append (car ls) (cdr ls)) res)) + (else + (let ((x (trim-trailing-slash (x->string (car ls))))) + (lp (cdr ls) + (if (string=? x "") res (cons x (cons "/" res))))))))))) diff --git a/lib/chibi/process.module b/lib/chibi/process.module new file mode 100644 index 00000000..fe03c2e5 --- /dev/null +++ b/lib/chibi/process.module @@ -0,0 +1,17 @@ + +(define-module (chibi process) + (export exit sleep alarm fork kill execute waitpid + set-signal-action! make-signal-set signal-set-contains? + signal-set-fill! signal-set-add! signal-set-delete! + current-signal-mask + signal-mask-block! signal-mask-unblock! signal-mask-set! + signal/hang-up signal/interrupt signal/quit + signal/illegal signal/abort signal/fpe + signal/kill signal/segv signal/pipe + signal/alarm signal/term signal/user1 + signal/user2 signal/child signal/continue + signal/stop signal/tty-stop signal/tty-input + signal/tty-output) + (import-immutable (scheme)) + (include-shared "process")) + diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub new file mode 100644 index 00000000..7dbca7eb --- /dev/null +++ b/lib/chibi/process.stub @@ -0,0 +1,72 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/wait.h") +(c-system-include "signal.h") +(c-system-include "unistd.h") + +(define-c-type siginfo_t + predicate: signal-info? + (int si_signo signal-number) + (int si_errno signal-error-number) + (int si_code signal-code) + (pid_t si_pid signal-pid) + (uid_t si_uid signal-uid) + (int si_status signal-status) + ;;(clock_t si_utime signal-user-time) + ;;(clock_t si_stime signal-system-time) + ) + +(define-c-type sigset_t + predicate: signal-set?) + +(define-c-const int (signal/hang-up "SIGHUP")) +(define-c-const int (signal/interrupt "SIGINT")) +(define-c-const int (signal/quit "SIGQUIT")) +(define-c-const int (signal/illegal "SIGILL")) +(define-c-const int (signal/abort "SIGABRT")) +(define-c-const int (signal/fpe "SIGFPE")) +(define-c-const int (signal/kill "SIGKILL")) +(define-c-const int (signal/segv "SIGSEGV")) +(define-c-const int (signal/pipe "SIGPIPE")) +(define-c-const int (signal/alarm "SIGALRM")) +(define-c-const int (signal/term "SIGTERM")) +(define-c-const int (signal/user1"SIGUSR1")) +(define-c-const int (signal/user2 "SIGUSR2")) +(define-c-const int (signal/child "SIGCHLD")) +(define-c-const int (signal/continue "SIGCONT")) +(define-c-const int (signal/stop "SIGSTOP")) +(define-c-const int (signal/tty-stop "SIGTSTP")) +(define-c-const int (signal/tty-input "SIGTTIN")) +(define-c-const int (signal/tty-output "SIGTTOU")) + +(c-include "signal.c") + +(define-c sexp (set-signal-action! "sexp_set_signal_action") + ((value ctx sexp) sexp sexp)) + +(define-c errno (make-signal-set "sigemptyset") ((result sigset_t))) +(define-c errno (signal-set-fill! "sigfillset") (sigset_t)) +(define-c errno (signal-set-add! "sigaddset") (sigset_t int)) +(define-c errno (signal-set-delete! "sigaddset") (sigset_t int)) +(define-c boolean (signal-set-contains? "sigismember") (sigset_t int)) + +(define-c errno (signal-mask-block! "sigprocmask") + ((value SIG_BLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-unblock! "sigprocmask") + ((value SIG_UNBLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-set! "sigprocmask") + ((value SIG_SETMASK int) sigset_t (value NULL sigset_t))) +(define-c errno (current-signal-mask "sigprocmask") + ((value SIG_BLOCK int) (value NULL sigset_t) (result sigset_t))) + +(define-c unsigned-int alarm (unsigned-int)) +(define-c unsigned-int sleep (unsigned-int)) + +(define-c pid_t fork ()) +;;(define-c pid_t wait ((result int))) +(define-c pid_t waitpid (int (result int) int)) +(define-c errno kill (int int)) +;;(define-c errno raise (int)) +(define-c void exit (int)) +(define-c int (execute execvp) (string (array string))) + diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c new file mode 100644 index 00000000..463e481d --- /dev/null +++ b/lib/chibi/signal.c @@ -0,0 +1,62 @@ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_MAX_SIGNUM 32 + +static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM]; + +static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { + sexp ctx, sigctx, handler; + sexp_gc_var1(args); + ctx = sexp_signal_contexts[signum]; + if (ctx) { + handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), + sexp_make_fixnum(signum)); + if (sexp_truep(handler)) { + sigctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve1(sigctx, args); + args = sexp_cons(sigctx, SEXP_FALSE, SEXP_NULL); + sexp_car(args) + = sexp_make_cpointer(sigctx, sexp_siginfo_t_type_id, info, SEXP_FALSE, 0); + args = sexp_cons(sigctx, SEXP_FALSE, args); + sexp_car(args) = sexp_make_fixnum(signum); + sexp_apply(sigctx, handler, args); + sexp_gc_release1(sigctx); + } + } +} + +static struct sigaction call_sigaction = { + .sa_sigaction = sexp_call_sigaction, + .sa_flags = SA_SIGINFO | SA_NODEFER +}; + +static struct sigaction call_sigdefault = {.sa_handler = SIG_DFL}; +static struct sigaction call_sigignore = {.sa_handler = SIG_IGN}; + +static sexp sexp_set_signal_action (sexp ctx, sexp signum, sexp newaction) { + int res; + sexp oldaction; + if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0 + && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) + return sexp_type_exception(ctx, "not a valid signal number", signum); + if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) + || sexp_booleanp(newaction))) + return sexp_type_exception(ctx, "not a procedure", newaction); + if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS))) + sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS) + = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE); + oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); + res = sigaction(sexp_unbox_fixnum(signum), + (sexp_booleanp(newaction) ? + (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore) + : &call_sigaction), + NULL); + if (res) + return sexp_user_exception(ctx, SEXP_FALSE, "couldn't set signal", signum); + sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction); + sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx; + return oldaction; +} + diff --git a/lib/chibi/system.module b/lib/chibi/system.module new file mode 100644 index 00000000..adc26ddc --- /dev/null +++ b/lib/chibi/system.module @@ -0,0 +1,15 @@ + +(define-module (chibi system) + (export user-information user-name user-password + user-id user-group-id user-gecos user-home user-shell + current-user-id current-group-id + current-effective-user-id current-effective-group-id + set-current-user-id! set-current-effective-user-id! + set-current-group-id! set-current-effective-group-id! + current-session-id create-session + set-root-directory!) + (import-immutable (scheme)) + (include-shared "system") + ;;(include "system.scm") + ) + diff --git a/lib/chibi/system.stub b/lib/chibi/system.stub new file mode 100644 index 00000000..7d4a836f --- /dev/null +++ b/lib/chibi/system.stub @@ -0,0 +1,34 @@ + +(c-system-include "unistd.h") +(c-system-include "pwd.h") +(c-system-include "sys/types.h") + +(define-c-struct passwd + predicate: user? + (string pw_name user-name) + (string pw_passwd user-password) + (uid_t pw_uid user-id) + (gid_t pw_gid user-group-id) + (string pw_gecos user-gecos) + (string pw_dir user-home) + (string pw_shell user-shell)) + +(define-c uid_t (current-user-id "getuid") ()) +(define-c gid_t (current-group-id "getgid") ()) +(define-c uid_t (current-effective-user-id "geteuid") ()) +(define-c gid_t (current-effective-group-id "getegid") ()) + +(define-c errno (set-current-user-id! "setuid") (uid_t)) +(define-c errno (set-current-effective-user-id! "seteuid") (uid_t)) +(define-c errno (set-current-group-id! "setgid") (gid_t)) +(define-c errno (set-current-effective-group-id! "setegid") (gid_t)) + +(define-c pid_t (current-session-id "getsid") ((default 0 pid_t))) +(define-c pid_t (create-session "setsid") ()) + +(define-c errno (set-root-directory! "chroot") (string)) + +;; (define-c errno getpwuid_r +;; (uid_t (result passwd) (result (array char arg3)) +;; (value 256 int) (result pointer passwd))) + diff --git a/lib/chibi/time.module b/lib/chibi/time.module new file mode 100644 index 00000000..84f2b800 --- /dev/null +++ b/lib/chibi/time.module @@ -0,0 +1,11 @@ + +(define-module (chibi time) + (export current-seconds get-time-of-day set-time-of-day! + seconds->time seconds->string time->seconds time->string + timeval-seconds timeval-microseconds + timezone-offset timezone-dst-time + time-second time-minute time-hour time-day time-month time-year + time-day-of-week time-day-of-year time-dst?) + (import-immutable (scheme)) + (include-shared "time")) + diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub new file mode 100644 index 00000000..bb5cd644 --- /dev/null +++ b/lib/chibi/time.stub @@ -0,0 +1,45 @@ + +(c-system-include "time.h") +(c-system-include "sys/time.h") + +(define-c-struct tm + (int tm_sec time-second) + (int tm_min time-minute) + (int tm_hour time-hour) + (int tm_mday time-day) + (int tm_mon time-month) + (int tm_year time-year) + (int tm_wday time-day-of-week) + (int tm_yday time-day-of-year) + (int tm_isdst time-dst?)) + +(define-c-struct timeval + predicate: timeval? + (time_t tv_sec timeval-seconds) + (int tv_usec timeval-microseconds)) + +(define-c-struct timezone + predicate: timezone? + (int tz_minuteswest timezone-offset) + (int tz_dsttime timezone-dst-time)) + +(define-c time_t (current-seconds "time") ((value NULL))) + +(define-c errno (get-time-of-day "gettimeofday") + ((result timeval) (result timezone))) + +(define-c errno (set-time-of-day! "settimeofday") + (timeval (maybe-null default NULL timezone))) + +(define-c non-null-pointer (seconds->time "localtime_r") + ((pointer time_t) (result tm))) + +(define-c time_t (time->seconds "mktime") + (tm)) + +(define-c non-null-string (seconds->string "ctime_r") + ((pointer time_t) (result (array char 64)))) + +(define-c non-null-string (time->string "asctime_r") + (tm (result (array char 64)))) + diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module new file mode 100644 index 00000000..2456dd9f --- /dev/null +++ b/lib/chibi/uri.module @@ -0,0 +1,10 @@ + +(define-module (chibi uri) + (export uri->string make-uri string->uri + uri-scheme uri-user uri-host uri-path uri-query uri-fragment + uri-with-scheme uri-with-user uri-with-host uri-with-path + uri-with-query uri-with-fragment + uri-encode uri-decode uri-query->alist uri-alist->query) + (import-immutable (scheme) + (srfi 9)) + (include "uri.scm")) diff --git a/lib/chibi/uri.scm b/lib/chibi/uri.scm new file mode 100644 index 00000000..41507961 --- /dev/null +++ b/lib/chibi/uri.scm @@ -0,0 +1,306 @@ +;; uri.scm -- URI parsing library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URI representation + +(define-record-type uri + (%make-uri scheme user host port path query fragment) + uri? + (scheme uri-scheme) + (user uri-user) + (host uri-host) + (port uri-port) + (path uri-path) + (query uri-query) + (fragment uri-fragment)) + +;; (make-uri scheme [user host port path query fragment]) +(define (make-uri scheme . o) + (let* ((user (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (host (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (port (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (path (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (query (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f))) + (%make-uri scheme user host port path query fragment))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils (don't feel like using SRFI-13 and these are more +;; specialised) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (string-scan-right str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i (- end 1))) + (and (>= i start) + (if (eqv? ch (string-ref str i)) + i + (lp (- i 1))))))) + +(define (string-index-of str pred . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond ((>= i end) #f) + ((pred (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase->symbol str) + (let ((len (string-length str))) + (let lp ((i 0)) + (cond + ((= i len) + (string->symbol str)) + ((char-upper-case? (string-ref str i)) + (let ((res (make-string len))) + (do ((j 0 (+ j 1))) + ((= j i)) + (string-set! res j (string-ref str j))) + (string-set! res i (char-downcase (string-ref str i))) + (do ((j (+ i 1) (+ j 1))) + ((= j len)) + (string-set! res j (char-downcase (string-ref str j)))) + (string->symbol res))) + (else + (lp (+ i 1))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; functional updaters (uses as much shared state as possible) + +(define (uri-with-scheme u scheme) + (%make-uri scheme (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-user u user) + (%make-uri (uri-scheme u) user (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-host u host) + (%make-uri (uri-scheme u) (uri-user u) host (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-port u port) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) port + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-path u path) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + path (uri-query u) (uri-fragment u))) + +(define (uri-with-query u query) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) query (uri-fragment u))) + +(define (uri-with-fragment u fragment) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) fragment)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parsing - without :// we just split into scheme & path + +(define (char-uri-scheme-unsafe? ch) + (not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\_ #\-))))) + +(define (string->path-uri scheme str . o) + (define decode? (and (pair? o) (car o))) + (define decode (if decode? uri-decode (lambda (x) x))) + (define decode-query + (if (and (pair? o) (pair? (cdr o)) (cadr o)) + uri-query->alist + decode)) + (if (pair? str) + str + (let* ((len (string-length str)) + (colon0 (string-scan str #\:)) + (colon + (and (not (string-index-of str char-uri-scheme-unsafe? + 0 (or colon0 len))) + colon0))) + (if (or (not colon) (zero? colon)) + (and scheme + (let* ((quest (string-scan str #\? 0)) + (pound (string-scan str #\# (or quest 0)))) + (make-uri scheme #f #f #f + (decode (substring str 0 (or quest pound len))) + (and quest + (decode-query + (substring str (+ quest 1) (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len)))))) + (let ((sc1 (+ colon 1)) + (scheme (string-downcase->symbol (substring str 0 colon)))) + (if (= sc1 len) + (make-uri scheme) + (if (or (>= (+ sc1 1) len) + (not (and (eqv? #\/ (string-ref str sc1)) + (eqv? #\/ (string-ref str (+ sc1 1)))))) + (make-uri scheme #f #f #f (substring str sc1 len)) + (if (>= (+ sc1 2) len) + (make-uri scheme #f "") + (let* ((sc2 (+ sc1 2)) + (slash (string-scan str #\/ sc2)) + (sc3 (or slash len)) + (at (string-scan-right str #\@ sc2 sc3)) + (colon3 (string-scan str #\: (or at sc2) sc3)) + (quest (string-scan str #\? sc3)) + (pound (string-scan str #\# (or quest sc3)))) + (%make-uri + scheme + (and at (decode (substring str sc2 at))) + (decode + (substring str + (if at (+ at 1) sc2) + (or colon3 sc3))) + (and colon3 + (string->number + (substring str (+ colon3 1) sc3))) + (and slash + (decode + (substring str slash (or quest pound len)))) + (and quest + (decode-query + (substring str (+ quest 1) + (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len))) + )))))))))) + +(define (string->uri str . o) + (apply string->path-uri #f str o)) + +(define (uri->string uri . o) + (define encode? (and (pair? o) (car o))) + (define encode (if encode? uri-encode (lambda (x) x))) + (if (string? uri) + uri + (let ((fragment (uri-fragment uri)) + (query (uri-query uri)) + (path (uri-path uri)) + (port (uri-port uri)) + (host (uri-host uri)) + (user (uri-user uri))) + (string-append + (symbol->string (uri-scheme uri)) ":" + (if (or user host port) "//" "") + (if user (encode user) "") (if user "@" "") + (or host "") ; host shouldn't need encoding + (if port ":" "") (if port (number->string port) "") + (if path (encode path) "") + (if query "?" "") + (if (pair? query) (uri-alist->query query) (or query "")) + (if fragment "#" "") (if fragment (encode fragment) ""))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; query encoding and decoding + +(define (uri-safe-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (case ch + ((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t) + (else #f)))) + +(define (collect str from to res) + (if (>= from to) + res + (cons (substring str from to) res))) + +(define (uri-encode str . o) + (define (encode-1-space ch) + (if (eqv? ch #\space) + "+" + (encode-1-normal ch))) + (define (encode-1-normal ch) + (let* ((i (char->integer ch)) + (hex (number->string i 16))) + (if (< i 16) + (string-append "%0" hex) + (string-append "%" hex)))) + (let ((start 0) + (end (string-length str)) + (encode-1 (if (and (pair? o) (car o)) + encode-1-space + encode-1-normal))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (if (uri-safe-char? ch) + (lp from next res) + (lp next next (cons (encode-1 ch) + (collect str from to res))))))))) + +(define (uri-decode str . o) + (let ((space-as-plus? (and (pair? o) (car o))) + (start 0) + (end (string-length str))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (cond + ((eqv? ch #\%) + (if (>= next end) + (lp next next (collect str from to res)) + (let ((next2 (+ next 1))) + (if (>= next2 end) + (lp next2 next2 (collect str from to res)) + (let* ((next3 (+ next2 1)) + (hex (substring str next next3)) + (i (string->number hex 16))) + (lp next3 next3 (cons (string (integer->char i)) + (collect str from to res)))))))) + ((and space-as-plus? (eqv? ch #\+)) + (lp next next (cons " " (collect str from to res)))) + (else + (lp from next res)))))))) + +(define (uri-query->alist str . o) + (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;))) + (let ((len (string-length str)) + (plus? (and (pair? o) (car o)))) + (let lp ((i 0) (res '())) + (if (>= i len) + (reverse res) + (let* ((j (or (string-index-of str split-char? i) len)) + (k (string-scan str #\= i j)) + (cell (if k + (cons (uri-decode (substring str i k) plus?) + (uri-decode (substring str (+ k 1) j) plus?)) + (cons (uri-decode (substring str i j) plus?) #f)))) + (lp (+ j 1) (cons cell res))))))) + +(define (uri-alist->query ls . o) + (define plus? (and (pair? o) (car o))) + (define (encode key val res) + (let ((res (cons (uri-encode key plus?) res))) + (if val (cons (uri-encode val plus?) (cons "=" res)) res))) + (if (null? ls) + "" + (let lp ((x (car ls)) (ls (cdr ls)) (res '())) + (let ((res (encode (car x) (cdr x) res))) + (if (null? ls) + (string-concatenate (reverse res)) + (lp (car ls) (cdr ls) (cons "&" res))))))) diff --git a/lib/config.scm b/lib/config.scm new file mode 100644 index 00000000..1254360d --- /dev/null +++ b/lib/config.scm @@ -0,0 +1,174 @@ +;; config.scm -- configuration module +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *this-module* '()) + +(define (make-module exports env meta) (vector exports env meta)) +(define (%module-exports mod) (vector-ref mod 0)) +(define (module-env mod) (vector-ref mod 1)) +(define (module-meta-data mod) (vector-ref mod 2)) +(define (module-env-set! mod env) (vector-set! mod 1 env)) + +(define (module-exports mod) + (or (%module-exports mod) (env-exports (module-env mod)))) + +(define (module-name->strings ls res) + (if (null? ls) + res + (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls))) + ((number? (car ls)) (number->string (car ls))) + ((string? (car ls)) (car ls)) + (else (error "invalid module name" (car ls)))))) + (module-name->strings (cdr ls) (cons "/" (cons str res)))))) + +(define (module-name->file name) + (string-concatenate + (reverse (cons ".module" (cdr (module-name->strings name '())))))) + +(define (module-name-prefix name) + (string-concatenate (reverse (cdr (cdr (module-name->strings name '())))))) + +(define (load-module-definition name) + (let* ((file (module-name->file name)) + (path (find-module-file file))) + (if path (load path *config-env*)))) + +(define (find-module name) + (cond + ((assoc name *modules*) => cdr) + (else + (load-module-definition name) + (cond ((assoc name *modules*) => cdr) + (else #f))))) + +(define (symbol-append a b) + (string->symbol (string-append (symbol->string a) (symbol->string b)))) + +(define (to-id id) (if (pair? id) (car id) id)) +(define (from-id id) (if (pair? id) (cdr id) id)) +(define (id-filter pred ls) + (cond ((null? ls) '()) + ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls)))) + (else (id-filter pred (cdr ls))))) + +(define (resolve-import x) + (cond + ((not (and (pair? x) (list? x))) + (error "invalid module syntax" x)) + ((and (pair? (cdr x)) (pair? (cadr x))) + (if (memq (car x) '(only except rename)) + (let* ((mod-name+imports (resolve-import (cadr x))) + (imp-ids (cdr mod-name+imports)) + (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x)))) + (begin + (set-cdr! mod-name+imports + (module-exports + (find-module (car mod-name+imports)))) + (cdr mod-name+imports)) + imp-ids))) + (cons (car mod-name+imports) + (case (car x) + ((only) + (if (not imp-ids) + (cddr x) + (id-filter (lambda (i) (memq i (cddr x))) imp-ids))) + ((except) + (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids)) + ((rename) + (map (lambda (i) + (let ((rename (assq (to-id i) (cddr x)))) + (if rename (cons (cdr rename) (from-id i)) i))) + imp-ids))))) + (error "invalid import modifier" x))) + ((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x))) + (let ((mod-name+imports (resolve-import (caddr x)))) + (cons (car mod-name+imports) + (map (lambda (i) + (cons (symbol-append (cadr x) (if (pair? i) (car i) i)) + (if (pair? i) (cdr i) i))) + (cdr mod-name+imports))))) + ((find-module x) + => (lambda (mod) (cons x (%module-exports mod)))) + (else + (error "couldn't find import" x)))) + +(define (eval-module name mod) + (let ((env (make-environment)) + (dir (module-name-prefix name))) + (for-each + (lambda (x) + (case (and (pair? x) (car x)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2 (load-module (car mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports) + (eq? (car x) 'import-immutable)))) + (cdr x))) + ((include include-shared) + (for-each + (lambda (f) + (let ((f (string-append + dir f + (if (eq? (car x) 'include) "" *shared-object-extension*)))) + (cond + ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + (cdr x))) + ((body) + (for-each (lambda (expr) (eval expr env)) (cdr x))))) + (module-meta-data mod)) + env)) + +(define (load-module name) + (let ((mod (find-module name))) + (if (and mod (not (module-env mod))) + (module-env-set! mod (eval-module name mod))) + mod)) + +(define-syntax define-module + (er-macro-transformer + (lambda (expr rename compare) + (let ((name (cadr expr)) + (body (cddr expr))) + `(let ((tmp *this-module*)) + (set! *this-module* '()) + ,@body + (set! *this-module* (reverse *this-module*)) + (let ((exports + (cond ((assq 'export *this-module*) => cdr) + (else '())))) + (set! *modules* + (cons (cons ',name (make-module exports #f *this-module*)) + *modules*))) + (set! *this-module* tmp)))))) + +(define-syntax define-config-primitive + (er-macro-transformer + (lambda (expr rename compare) + `(define-syntax ,(cadr expr) + (er-macro-transformer + (lambda (expr rename compare) + `(set! *this-module* (cons ',expr *this-module*)))))))) + +(define-config-primitive import) +(define-config-primitive import-immutable) +(define-config-primitive export) +(define-config-primitive include) +(define-config-primitive include-shared) +(define-config-primitive body) + +(define *modules* + (list (cons '(scheme) (make-module #f (interaction-environment) '())) + (cons '(srfi 0) (make-module (list 'cond-expand) + (interaction-environment) + (list (list 'export 'cond-expand)))) + (cons '(srfi 46) (make-module (list 'syntax-rules) + (interaction-environment) + (list (list 'export 'syntax-rules)))))) + diff --git a/lib/init.scm b/lib/init.scm new file mode 100644 index 00000000..e1b7b256 --- /dev/null +++ b/lib/init.scm @@ -0,0 +1,881 @@ +;; init.scm -- R5RS library procedures +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; 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 f ls . lol) + (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls))))) + (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f)))) + +(define (any pred ls) + (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f)) + +(define (every pred ls) + (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t)) + +(define (delq x ls) + (if (pair? ls) + (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls)))) + '())) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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) + (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 (rename 'else) (car cl)) + (if (pair? (cddr expr)) + (error "non-final else in cond" expr) + (cons (rename 'begin) (cdr cl))) + (if (if (null? (cdr cl)) #t (compare (rename '=>) (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 + ((compare (rename 'unquote) (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((compare (rename '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))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (compare (rename '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 (null? (cdr expr)) (error "empty let" expr)) + (if (null? (cddr expr)) (error "no let body" expr)) + ((lambda (bindings) + (if (list? bindings) #f (error "bad let bindings")) + (if (every (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + bindings) + (if (identifier? (cadr expr)) + `(,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,(map car bindings) + ,@(cdddr expr)))) + ,(cons (cadr expr) (map cadr bindings))) + `((,(rename 'lambda) ,(map car bindings) ,@(cddr expr)) + ,@(map cadr bindings))) + (error "bad let syntax" expr))) + (if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let*" expr)) + (if (null? (cddr expr)) (error "no let* body" expr)) + (if (null? (cadr expr)) + `(,(rename 'let) () ,@(cddr expr)) + (if (if (list? (cadr expr)) + (every + (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + (cadr expr)) + #f) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))) + (error "bad let* syntax")))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare (rename '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)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; promises + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exceptions + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f))) + +(define (with-exception-handler handler thunk) + (letrec ((orig-handler (current-exception-handler)) + (self (lambda (exn) + (current-exception-handler orig-handler) + (let ((res (handler exn))) + (current-exception-handler self) + res)))) + (current-exception-handler self) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; library functions + +;; 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 . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (and (pair? ls) (if (eq obj (car ls)) ls (lp (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 (if (bignum? 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 (if (bignum? 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 (numerator x) + (if (integer? x) x (numerator (* x 10)))) +(define (denominator x) + (if (exact? x) + 1 + (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10)))))) + +(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) + (if (<= n 9) + (integer->char (+ n (char->integer #\0))) + (integer->char (+ (- n 10) (char->integer #\A))))) +(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)) 55)))) + +(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)) + (if (null? res) "0" (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 (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-output-port)) + (tmp-out (open-output-file file))) + (current-output-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)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dynamic-wind + +(define *dk* (list #f)) + +(define (dynamic-wind before thunk after) + (let ((dk *dk*)) + (set-dk! (cons (cons before after) dk)) + (let ((res (thunk))) (set-dk! dk) res))) + +(define (set-dk! dk) + (if (not (eq? dk *dk*)) + (begin + (set-dk! (cdr dk)) + (let ((before (car (car dk))) (dk dk)) + (set-car! *dk* (cons (cdr (car dk)) before)) + (set-cdr! *dk* dk) + (set-car! dk #f) + (set-cdr! dk '()) + (set! *dk* dk) + (before))))) + +(define (call-with-current-continuation proc) + (let ((dk *dk*)) + (%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((ellipse-specified? (identifier? (cadr 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 'syntax-quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_len (rename'len)) (_length (rename 'length)) + (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error)) + (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define ellipse (rename (if ellipse-specified? (cadr expr) '...))) + (define lits (if ellipse-specified? (caddr expr) (cadr expr))) + (define forms (if ellipse-specified? (cdddr expr) (cddr expr))) + (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))) + (cond + ((not (list? (cddr p))) + (error "dotted ellipse" p)) + ((any (lambda (x) (and (identifier? x) (compare x ellipse))) + (cddr p)) + (error "multiple ellipses" p)) + (else + (let ((len (length (cdr (cdr p))))) + `(,_let ((,_len (,_length ,v))) + (,_and (,_>= ,_len ,len) + (,_let ,_lp ((,_ls ,v) + (,_i (,_- ,_len ,len)) + (,_res (,_quote ()))) + (,_if (,_>= 0 ,_i) + ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p))) + `(,_append ,_ls (,_reverse ,_res)) + dim + vars + k) + (,_lp (,_cdr ,_ls) + (,_- ,_i 1) + (,_cons (,_car ,_ls) ,_res)))))))))) + ((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-escape? x) (and (pair? x) (compare ellipse (car x)))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare ellipse (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 (any (lambda (lit) (compare x lit)) 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 + ((any (lambda (v) (compare t (car v))) vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (cond + ((ellipse-escape? t) + (if (pair? (cdr t)) + (if (pair? (cddr t)) (cddr t) (cadr t)) + (cdr t))) + ((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))))))) + (else (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 for" + (list (rename 'strip-syntactic-closures) _expr))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *config-env* #f) + +(define-syntax import + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (res '())) + (cond + ((null? ls) + (cons 'begin (reverse res))) + (else + (let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*))) + (if (pair? mod+imps) + (lp (cdr ls) + (cons `(%env-copy! + #f + (vector-ref + (eval '(load-module ',(car mod+imps)) *config-env*) + 1) + ',(cdr mod+imps) + #f) + res)) + (error "couldn't find module" (car ls)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SRFI-0 + +(define-syntax cond-expand + (er-macro-transformer + (lambda (expr rename compare) + (define (check x) + (if (pair? x) + (case (car x) + ((and) (every check (cdr x))) + ((or) (any check (cdr x))) + ((not) (not (check (cadr x)))) + (else (error "cond-expand: bad feature" x))) + (memq (identifier->symbol x) *features*))) + (let expand ((ls (cdr expr))) + (cond ((null? ls) (error "cond-expand: no expansions" expr)) + ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) + ((eq? 'else (identifier->symbol (caar ls))) + (if (pair? (cdr ls)) + (error "cond-expand: else in non-final position") + `(,(rename 'begin) ,@(cdar ls)))) + ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) + (else (expand (cdr ls)))))))) + diff --git a/lib/srfi/1.module b/lib/srfi/1.module new file mode 100644 index 00000000..3d3da044 --- /dev/null +++ b/lib/srfi/1.module @@ -0,0 +1,31 @@ + +(define-module (srfi 1) + (export + xcons cons* make-list list-tabulate list-copy circular-list iota + proper-list? circular-list? dotted-list? not-pair? null-list? list= + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr take drop take-right drop-right take! drop-right! split-at split-at! + last last-pair length+ concatenate append! concatenate! reverse! + append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 count + fold unfold pair-fold reduce fold-right unfold-right + pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter partition remove filter! partition! remove! find find-tail any every + list-index take-while drop-while take-while! span break span! break! + delete delete-duplicates delete! delete-duplicates! + alist-cons alist-copy alist-delete alist-delete! + lset<= lset= lset-adjoin lset-union lset-union! lset-intersection + lset-intersection! lset-difference lset-difference! lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection!) + (import (scheme)) + (include "1/predicates.scm" + "1/selectors.scm" + "1/search.scm" + "1/misc.scm" + "1/constructors.scm" + "1/fold.scm" + "1/deletion.scm" + "1/alists.scm" + "1/lset.scm")) + diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm new file mode 100644 index 00000000..a35db42c --- /dev/null +++ b/lib/srfi/1/alists.scm @@ -0,0 +1,14 @@ +;; alist.scm -- association list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (alist-cons key value ls) (cons (cons key value) ls)) + +(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls)) + +(define (alist-delete key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (remove (lambda (x) (eq (car x) key)) ls))) + +(define alist-delete! alist-delete) + diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm new file mode 100644 index 00000000..e205cee0 --- /dev/null +++ b/lib/srfi/1/constructors.scm @@ -0,0 +1,36 @@ +;; constructors.scm -- list construction utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (xcons a b) (cons b a)) + +(define (cons* x . args) + (let lp ((rev '()) (x x) (ls args)) + (if (null? ls) + (append-reverse rev x) + (lp (cons x rev) (car ls) (cdr ls))))) + +(define (make-list n . o) + (let ((default (if (pair? o) (car o)))) + (let lp ((n n) (res '())) + (if (<= n 0) res (lp (- n 1) (cons default res)))))) + +(define (list-tabulate n proc) + (let lp ((n n) (res '())) + (if (< n 0) res (lp (- n 1) (cons (proc n) res))))) + +(define (list-copy ls) (reverse! (reverse ls))) + +(define (circular-list x . args) + (let ((res (cons x args))) + (set-cdr! (last-pair res) res) + res)) + +(define (iota count . o) + (let ((start (if (pair? o) (car o) count)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) + (let lp ((i count) (n (- start step)) (res '())) + (if (<= i 0) + res + (lp (- i 1) (- n step) (cons n res)))))) + diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm new file mode 100644 index 00000000..70ee5cc5 --- /dev/null +++ b/lib/srfi/1/deletion.scm @@ -0,0 +1,25 @@ +;; deletion.scm -- list deletion utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (delete x ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (if (eq? eq eq?) + (let lp ((ls ls) (rev '())) ;; fast path for delq + (let ((tail (memq x ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls)))) + (filter (lambda (y) (eq x y)) ls)))) + +(define delete! delete) + +(define (delete-duplicates ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res))) + (reverse! res))))) + +(define delete-duplicates! delete-duplicates) + diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm new file mode 100644 index 00000000..892b075c --- /dev/null +++ b/lib/srfi/1/fold.scm @@ -0,0 +1,115 @@ +;; fold.scm -- list fold/reduce utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (map-onto car lists (list acc)))) + acc)))) + +(define (fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (map-onto car lists (lp (map cdr lists)))) + knil)))) + +(define (pair-fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (append lists (list acc)))) + acc)))) + +(define (pair-fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (append lists (lp (map cdr lists)))) + knil)))) + +(define (reduce f identity ls) + (if (null? ls) identity (fold f (car ls) (cdr ls)))) + +(define (reduce-right f identity ls) + (if (null? ls) identity (fold-right f (car ls) (cdr ls)))) + +(define (unfold p f g seed . o) + (let lp ((seed seed)) + (if (p seed) + (if (pair? o) ((car o) seed) '()) + (cons (f seed) (lp (g seed)))))) + +(define (unfold-right p f g seed . o) + (let lp ((seed seed) (res (if (pair? o) (car o) '()))) + (if (p seed) res (lp (g seed) (cons (f seed) res))))) + +(define (append-map-helper append f ls lists) + (if (null? lists) + (if (null? ls) + '() + (let ((rev-ls (reverse ls))) + (let lp ((ls (cdr rev-ls)) (res (car rev-ls))) + (if (null? ls) res (lp (cdr ls) (append (f (car ls) res)))) + ))) + (if (and (pair? ls) (every pair? lists)) + (let lp ((lists (cons ls lists))) + (let ((vals (apply f (map car lists))) + (cdrs (map cdr lists))) + (if (every pair? cdrs) (append vals (lp cdrs)) vals))) + '()))) + +(define (append-map f ls . lists) + (append-map-helper append f ls lists)) + +(define (append-map! f ls . lists) + (append-map-helper append! f ls lists)) + +(define map! map) +(define map-in-order map) + +(define (pair-for-each f ls . lists) + (apply pair-fold (lambda (x _) (f x)) ls lists)) + +(define (filter-map f ls . lists) + (if (null? lists) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res))) + (reverse! res))) + (filter (lambda (x) x) (apply map f ls lists)))) + +(define (take-up-to-reverse from to init) + (if (eq? from to) + init + (take-up-to-reverse (cdr from) to (cons (car from) init)))) + +(define (remove pred ls) + (let lp ((ls ls) (rev '())) + (let ((tail (find-tail pred ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls))))) + +(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls)) + +(define (partition pred ls) + (let lp ((ls ls) (good '()) (bad '())) + (cond ((null? ls) (values (reverse! good) (reverse! bad))) + ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad)) + (else (lp (cdr ls) good (cons (car ls) bad)))))) + +(define filter! filter) +(define remove! remove) +(define partition! partition) + diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm new file mode 100644 index 00000000..f2ffc4ae --- /dev/null +++ b/lib/srfi/1/lset.scm @@ -0,0 +1,51 @@ +;; lset.scm -- list set library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (lset<= eq . sets) + (if (null? sets) + #t + (let lp1 ((set1 (car sets)) (sets (cdr sets))) + (if (null? sets) + #t + (let ((set2 (car sets))) + (let lp2 ((ls set1)) + (if (pair? ls) + (and (member (car set1) set2 eq) (lp2 (cdr ls))) + (lp1 set2 (cdr sets))))))))) + +(define (lset= eq . sets) + (and (apply lset<= eq sets) (apply lset<= eq (reverse sets)))) + +(define (lset-adjoin eq set . elts) + (lset-union2 eq elts set)) + +(define (lset-union2 eq a b) + (if (null? b) + a + (lset-union2 (cdr b) (if (member (car b) a eq) a (cons (car b) a))))) + +(define (lset-union eq . sets) + (reduce (lambda (a b) (lset-union2 eq a b)) '() sets)) + +(define (lset-intersection eq . sets) + (reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-difference eq . sets) + (reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-xor eq . sets) + (reduce (lambda (a b) + (append (filter (lambda (x) (member x b eq)) a) + (filter (lambda (x) (member x a eq)) b))) + '() + sets)) + +(define (lset-diff+intersection eq . sets) + (values (apply lset-difference eq sets) (apply lset-intersection eq sets))) + +(define lset-diff+intersection! lset-diff+intersection) +(define lset-xor! lset-xor) +(define lset-difference! lset-difference) +(define lset-intersection! lset-intersection) +(define lset-union! lset-union) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm new file mode 100644 index 00000000..1e7568df --- /dev/null +++ b/lib/srfi/1/misc.scm @@ -0,0 +1,54 @@ +;; misc.scm -- miscellaneous list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (map-onto proc ls init) + (let lp ((ls ls) (res init)) + (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res))))) + +(define (append! . lists) (concatenate! lists)) + +(define (concatenate lists) + (let lp ((ls (reverse lists)) (res '())) + (if (null? ls) res (lp (cdr ls) (append (car ls) res))))) + +(define (concatenate! lists) + (if (null? lists) + '() + (let lp ((ls lists)) + (cond ((not (pair? (cdr ls))) + lists) + (else + (set-cdr! (last-pair (car ls)) (cadr ls)) + (lp (cdr ls))))))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define (append-reverse! rev tail) + (if (null? rev) + tail + (let ((head (reverse! rev))) + (set-cdr! rev tail) + head))) + +(define (zip . lists) (apply map list lists)) + +(define (unzip1 ls) (map car ls)) +(define (unzip2 ls) (values (map car ls) (map cadr ls))) +(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls))) +(define (unzip4 ls) + (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) +(define (unzip5 ls) + (values (map car ls) (map cadr ls) (map caddr ls) + (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls))) + +(define (count pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (res 0)) + (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res)) + (let lp ((lists (cons ls lists)) (res 0)) + (if (every pair? lists) + (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res)) + res)))) + diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm new file mode 100644 index 00000000..be84e085 --- /dev/null +++ b/lib/srfi/1/predicates.scm @@ -0,0 +1,42 @@ +;; predicates.scm -- list prediates +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (proper-list? x) + (cond ((null? x) #t) + ((pair? x) (proper-list? (cdr x))) + (else #f))) + +(define (circular-list? x) + (and (pair? x) (pair? (cdr x)) + (let race ((hare (cdr x)) (tortoise x)) + (or (eq? hare tortoise) + (and (pair? hare) (pair? (cdr hare)) + (race (cddr hare) (cdr tortoise))))))) + +(define (dotted-list? x) + (not (proper-list? x))) + +(define (not-pair? x) (not (pair? x))) + +(define (null-list? x) (null? x)) ; no error + +(define (list= eq . lists) + (let lp1 ((lists lists)) + (or (null? lists) + (null? (cdr lists)) + (let lp2 ((ls1 (car lists)) (ls2 (cadr lists))) + (if (null? ls1) + (and (null? ls2) + (lp1 (cdr lists))) + (and (eq (car ls1) (car ls2)) + (lp2 (cdr ls1) (cdr ls2)))))))) + +(define (length+ x) + (if (not (pair? x)) + 0 + (let lp ((hare (cdr x)) (tortoise x) (res 0)) + (and (not (eq? hare tortoise)) + (if (pair? hare) + (lp (cddr hare) (cdr tortoise) (+ res 1)) + res))))) diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm new file mode 100644 index 00000000..ea31d931 --- /dev/null +++ b/lib/srfi/1/search.scm @@ -0,0 +1,54 @@ +;; search.scm -- list searching and splitting +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (find pred ls) + (cond ((find-tail pred ls) => car) (else #f))) + +(define (find-tail pred ls) + (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls))))) + +(define (take-while pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (reverse! res)))) + +(define take-while! take-while) + +(define (drop-while pred ls) + (or (find-tail (lambda (x) (not (pred x))) ls) '())) + +(define (span pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (values (reverse! res) ls)))) + +(define span! span) + +(define (break pred ls) (span (lambda (x) (not (pred x))) ls)) + +(define break! break) + +(define (any pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls))))) + (let lp ((lists (cons ls lists))) + (and (every pair? lists) + (let ((args (map car lists))) + (if (apply pred args) args (lp (map cdr lists)))))))) + +(define (every pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t)) + (not (apply any (lambda (x) (not (pred x))) ls lists)))) + +(define (list-index pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (n 0)) + (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1))))) + (let lp ((lists (cons ls lists)) (n 0)) + (and (every pair? lists) + (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1))) + )))) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm new file mode 100644 index 00000000..74ef7119 --- /dev/null +++ b/lib/srfi/1/selectors.scm @@ -0,0 +1,59 @@ +;; selectors.scm -- extended list selectors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth ls) (car (cdr (cdr (cdr (cdr ls)))))) +(define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls))))))) +(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (eighth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (ninth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))) +(define (tenth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))) + +(define (car+cdr x) (values (car x) (cdr x))) + +(define (take ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (reverse! res) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (take! ls i) + (if (<= i 0) + '() + (let ((tail (list-tail ls (- i 1)))) + (set-cdr! tail '()) + ls))) + +(define (drop ls i) + (if (<= i 0) ls (drop (cdr ls) (- i 1)))) + +(define (take-right ls i) + (drop ls (- (length+ ls) i))) + +(define (drop-right ls i) + (take ls (- (length+ ls) i))) + +(define (drop-right! ls i) + (take! ls (- (length+ ls) i))) + +(define (split-at ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (values (reverse! res) ls) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (split-at! ls i) + (if (<= i 0) + (values '() ls) + (let* ((tail (list-tail ls (- i 1))) + (right (cdr tail))) + (set-cdr! tail '()) + (values ls right)))) + +(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls)))) +(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls)))) + diff --git a/lib/srfi/11.module b/lib/srfi/11.module new file mode 100644 index 00000000..f3c91df8 --- /dev/null +++ b/lib/srfi/11.module @@ -0,0 +1,28 @@ + +(define-module (srfi 11) + (export let-values let*-values) + (import-immutable (scheme)) + (body + (define-syntax let*-values + (syntax-rules () + ((let*-values () . body) + (begin . body)) + ((let*-values (((a) expr) . rest) . body) + (let ((a expr)) (let*-values rest . body))) + ((let*-values ((params expr) . rest) . body) + (call-with-values (lambda () expr) + (lambda params (let*-values rest . body)))))) + (define-syntax let-values + (syntax-rules () + ((let-values ("step") (binds ...) bind expr maps () () . body) + (let*-values (binds ... (bind expr)) (let maps . body))) + ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body) + (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body) + (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body) + (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body)) + ((let-values ((params expr) . rest) . body) + (let-values ("step") () () expr () params rest . body)) + )))) + diff --git a/lib/srfi/16.module b/lib/srfi/16.module new file mode 100644 index 00000000..f931a376 --- /dev/null +++ b/lib/srfi/16.module @@ -0,0 +1,24 @@ + +(define-module (srfi 16) + (export case-lambda) + (import-immutable (scheme)) + (body + (define-syntax %case + (syntax-rules () + ((%case args len n p ((params ...) . body) . rest) + (if (= len (length '(params ...))) + (apply (lambda (params ...) . body) args) + (%case args len 0 () . rest))) + ((%case args len n (p ...) ((x . y) . body) . rest) + (%case args len (+ n 1) (p ... x) (y . body) . rest)) + ((%case args len n (p ...) (y . body) . rest) + (if (>= len n) + (apply (lambda (p ... y) . body) args) + (%case args len 0 () . rest))) + ((%case args len n p) + (error "case-lambda: no cases matched")))) + (define-syntax case-lambda + (syntax-rules () + ((case-lambda . clauses) + (lambda args (let ((len (length args))) (%case args len 0 () . clauses)))))))) + diff --git a/lib/srfi/2.module b/lib/srfi/2.module new file mode 100644 index 00000000..4ceb8b6b --- /dev/null +++ b/lib/srfi/2.module @@ -0,0 +1,16 @@ + +(define-module (srfi 2) + (export and-let*) + (import-immutable (scheme)) + (body + (define-syntax and-let* + (syntax-rules () + ((and-let* () . body) + (begin . body)) + ((and-let* ((var expr) . rest) . body) + (let ((var expr)) + (and var (and-let* rest . body)))) + ((and-let* ((expr) . rest) . body) + (let ((tmp expr)) + (and tmp (and-let* rest . body)))))))) + diff --git a/lib/srfi/26.module b/lib/srfi/26.module new file mode 100644 index 00000000..f97ab783 --- /dev/null +++ b/lib/srfi/26.module @@ -0,0 +1,24 @@ + +(define-module (srfi 26) + (export cut cute) + (import-immutable (scheme)) + (body + (define-syntax %cut + (syntax-rules (<> <...>) + ((%cut e? params args) + (lambda params args)) + ((%cut e? (params ...) (args ...) <> . rest) + (%cut e? (params ... tmp) (args ... tmp) . rest)) + ((%cut e? (params ...) (args ...) <...>) + (%cut e? (params ... . tmp) (apply args ... tmp))) + ((%cut e? (params ...) (args ...) <...> . rest) + (error "cut: non-terminal <...>")) + ((%cut #t (params ...) (args ...) x . rest) + (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest))) + ((%cut #f (params ...) (args ...) x . rest) + (%cut #t (params ...) (args ... x) . rest)))) + (define-syntax cut + (syntax-rules () ((cut args ...) (%cut #f () () args ...)))) + (define-syntax cute + (syntax-rules () ((cute args ...) (%cut #t () () args ...)))))) + diff --git a/lib/srfi/27.module b/lib/srfi/27.module new file mode 100644 index 00000000..5c451629 --- /dev/null +++ b/lib/srfi/27.module @@ -0,0 +1,11 @@ + +(define-module (srfi 27) + (export random-integer random-real default-random-source + make-random-source random-source? + random-source-state-ref random-source-state-set! + random-source-randomize! random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals) + (import-immutable (scheme)) + (include-shared "27/rand") + (include "27/constructors.scm")) + diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm new file mode 100644 index 00000000..dbd0a8c6 --- /dev/null +++ b/lib/srfi/27/constructors.scm @@ -0,0 +1,10 @@ +;; constructors.scm -- random function constructors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (random-source-make-integers rs) + (lambda (n) (%random-integer rs n))) + +(define (random-source-make-reals rs . o) + (lambda () (%random-real rs))) + diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c new file mode 100644 index 00000000..d5d3d984 --- /dev/null +++ b/lib/srfi/27/rand.c @@ -0,0 +1,204 @@ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include + +#define SEXP_RANDOM_STATE_SIZE 128 + +#define ZERO sexp_make_fixnum(0) +#define ONE sexp_make_fixnum(1) +#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE) + +#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id) + +#define sexp_random_init(x, seed) \ + initstate_r(seed, \ + sexp_string_data(sexp_random_state(x)), \ + SEXP_RANDOM_STATE_SIZE, \ + sexp_random_data(x)) + +#if SEXP_BSD +typedef unsigned int sexp_random_t; +#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs))) +#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n) +#else +typedef struct random_data sexp_random_t; +#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst) +#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs)) +#endif + +#define sexp_random_state(x) (sexp_slot_ref((x), 0)) +#define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1))) + +#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp)) + +static sexp_uint_t rs_type_id; +static sexp default_random_source; + +static sexp sexp_rs_random_integer (sexp ctx, sexp rs, sexp bound) { + sexp res; + int32_t n; +#if SEXP_USE_BIGNUMS + int32_t hi, mod, len, i, *data; +#endif + if (! sexp_random_source_p(rs)) + res = sexp_type_exception(ctx, "not a random-source", rs); + if (sexp_fixnump(bound)) { + sexp_call_random(rs, n); + res = sexp_make_fixnum(n % sexp_unbox_fixnum(bound)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(bound)) { + hi = sexp_bignum_hi(bound); + len = hi * sizeof(sexp_uint_t) / sizeof(int32_t); + res = sexp_make_bignum(ctx, hi); + data = (int32_t*) sexp_bignum_data(res); + for (i=0; i +#include + +#if SEXP_USE_BIGNUMS +#include +#else +#define sexp_bignum_normalize(x) x +#endif + +static sexp sexp_bit_and (sexp ctx, sexp x, sexp y) { + sexp res; +#if SEXP_USE_BIGNUMS + sexp_sint_t len, i; +#endif + if (sexp_fixnump(x)) { + if (sexp_fixnump(y)) + res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(y)) + res = sexp_bit_and(ctx, y, x); +#endif + else + res = sexp_type_exception(ctx, "bitwise-and: not an integer", y); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + if (sexp_fixnump(y)) { + res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); + } else if (sexp_bignump(y)) { + if (sexp_bignum_length(x) < sexp_bignum_length(y)) + res = sexp_copy_bignum(ctx, NULL, x, 0); + else + res = sexp_copy_bignum(ctx, NULL, y, 0); + for (i=0, len=sexp_bignum_length(res); i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i> -c); + } else { + tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c; +#if SEXP_USE_BIGNUMS + if (((tmp >> c) == sexp_unbox_fixnum(i)) + && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) { +#endif + res = sexp_make_fixnum(tmp); +#if SEXP_USE_BIGNUMS + } else { + sexp_gc_preserve1(ctx, res); + res = sexp_fixnum_to_bignum(ctx, i); + res = sexp_arithmetic_shift(ctx, res, count); + sexp_gc_release1(ctx); + } +#endif + } +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(i)) { + len = sexp_bignum_hi(i); + if (c < 0) { + c = -c; + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + if (len < offset) { + res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1); + } else { + res = sexp_make_bignum(ctx, len - offset + 1); + for (j=len-offset, tmp=0; j>=0; j--) { + sexp_bignum_data(res)[j] + = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp; + tmp = sexp_bignum_data(i)[j+offset] + << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + } + } else { + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + res = sexp_make_bignum(ctx, len + offset + 1); + for (j=tmp=0; j> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + sexp_bignum_data(res)[len+offset] = tmp; + } +#endif + } else { + res = sexp_type_exception(ctx, "arithmetic-shift: not an integer", i); + } + return sexp_bignum_normalize(res); +} + +/* bit-count and integer-length were adapted from: */ +/* http://graphics.stanford.edu/~seander/bithacks.html */ +static sexp_uint_t bit_count (sexp_uint_t i) { + i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3); + i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3) + + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3)); + i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15; + return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255)) + >> (sizeof(i) - 1) * CHAR_BIT); +} + +static sexp sexp_bit_count (sexp ctx, sexp x) { + sexp res; + sexp_sint_t i; +#if SEXP_USE_BIGNUMS + sexp_uint_t count; +#endif + if (sexp_fixnump(x)) { + i = sexp_unbox_fixnum(x); + res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + for (i=count=0; i> 32)) + return integer_log2(tt) + 32; + else +#endif + if ((tt = x >> 16)) + return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt]; + else + return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; +} + +static sexp sexp_integer_length (sexp ctx, sexp x) { + sexp_sint_t tmp; +#if SEXP_USE_BIGNUMS + sexp_sint_t hi; +#endif + if (sexp_fixnump(x)) { + tmp = sexp_unbox_fixnum(x); + return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + hi = sexp_bignum_hi(x); + return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi]) + + hi*sizeof(sexp_uint_t)); +#endif + } else { + return sexp_type_exception(ctx, "integer-length: not an integer", x); + } +} + +static sexp sexp_bit_set_p (sexp ctx, sexp i, sexp x) { +#if SEXP_USE_BIGNUMS + sexp_uint_t pos; +#endif + if (! sexp_fixnump(i)) + return sexp_type_exception(ctx, "bit-set?: not an integer", i); + if (sexp_fixnump(x)) { + return sexp_make_boolean(sexp_unbox_fixnum(x) & (1<hash-table + hash-table-equivalence-function hash-table-hash-function + hash-table-ref hash-table-ref/default hash-table-set! + hash-table-delete! hash-table-exists? + hash-table-update! hash-table-update!/default + hash-table-size hash-table-keys hash-table-values + hash-table-walk hash-table-fold hash-table->alist + hash-table-copy hash-table-merge! + hash string-hash string-ci-hash hash-by-identity) + (import-immutable (scheme) + (srfi 9)) + (include-shared "69/hash") + (include "69/type.scm" "69/interface.scm")) + diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c new file mode 100644 index 00000000..e38c23c0 --- /dev/null +++ b/lib/srfi/69/hash.c @@ -0,0 +1,242 @@ +/* hash.c -- type-general hashing */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define HASH_DEPTH 5 +#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM) + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0) +#define sexp_hash_table_size(x) sexp_slot_ref(x, 1) +#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2) +#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3) + +#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2)) + +static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc % bound; +} + +static sexp sexp_string_hash (sexp ctx, sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string-hash: not a string", str); + else if (! sexp_integerp(bound)) + return sexp_type_exception(ctx, "string-hash: not an integer", bound); + return sexp_make_fixnum(string_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= tolower(*str++);} + return acc % bound; +} + +static sexp sexp_string_ci_hash (sexp ctx, sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string-ci-hash: not a string", str); + else if (! sexp_integerp(bound)) + return sexp_type_exception(ctx, "string-ci-hash: not an integer", bound); + return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) { + sexp_uint_t acc = FNV_OFFSET_BASIS, size; + sexp_sint_t i, len; + sexp t, *p; + char *p0; + loop: +#if SEXP_USE_FLONUMS + if (sexp_flonump(obj)) + acc ^= (sexp_sint_t) sexp_flonum_value(obj); + else +#endif + if (sexp_pointerp(obj)) { + if (depth) { + t = sexp_object_type(ctx, obj); + p = (sexp*) (((char*)obj) + sexp_type_field_base(t)); + p0 = ((char*)obj) + offsetof(struct sexp_struct, value); + if ((sexp)p == obj) p=(sexp*)p0; + /* hash trailing non-object data */ + size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp)); + if (((char*)obj + size) > p0) + for (i=0; i 0) { + depth--; + for (i=0; ialist table) + (hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '())) + +(define (hash-table-keys table) + (hash-table-fold table (lambda (k v a) (cons k a)) '())) + +(define (hash-table-values table) + (hash-table-fold table (lambda (k v a) (cons v a)) '())) + +(define (alist->hash-table ls . o) + (let ((res (apply make-hash-table o))) + (for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls) + res)) + +(define (hash-table-merge! a b) + (hash-table-walk b (lambda (k v) (hash-table-set! a k v))) + a) + +(define (hash-table-copy table) + (assert-hash-table "hash-table-copy" table) + (let ((res (make-hash-table (hash-table-equivalence-function table)))) + (hash-table-merge! res table) + res)) + diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm new file mode 100644 index 00000000..1fca9953 --- /dev/null +++ b/lib/srfi/69/type.scm @@ -0,0 +1,12 @@ +;; types.scm -- the hash-table record type +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type hash-table + (%make-hash-table buckets size hash-fn eq-fn) + hash-table? + (buckets hash-table-buckets hash-table-buckets-set!) + (size hash-table-size hash-table-size-set!) + (hash-fn %hash-table-hash-function) + (eq-fn %hash-table-equivalence-function)) + diff --git a/lib/srfi/8.module b/lib/srfi/8.module new file mode 100644 index 00000000..64a3e6e2 --- /dev/null +++ b/lib/srfi/8.module @@ -0,0 +1,10 @@ + +(define-module (srfi 8) + (export receive) + (import-immutable (scheme)) + (body + (define-syntax receive + (syntax-rules () + ((receive params expr . body) + (call-with-values (lambda () expr) (lambda params . body))))))) + diff --git a/lib/srfi/9.module b/lib/srfi/9.module new file mode 100644 index 00000000..0516b201 --- /dev/null +++ b/lib/srfi/9.module @@ -0,0 +1,82 @@ + +(define-module (srfi 9) + (export define-record-type) + (import-immutable (scheme)) + (body + (define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((name (cadr expr)) + (make (caaddr expr)) + (make-fields (cdaddr expr)) + (pred (cadddr expr)) + (fields (cddddr expr)) + (num-fields (length fields)) + (index (register-simple-type (symbol->string name) num-fields)) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let))) + (define (index-of field ls) + (let lp ((ls ls) (i 0)) + (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) + `(,(rename 'begin) + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string pred) + ,index)) + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string (cadar ls)) + ,index + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string (caddar ls)) + ,index + ,i)) + res) + res))))) + (,_define ,make + ,(let lp ((ls make-fields) (sets '()) (set-defs '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string make) + ,index)) + ,@set-defs) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets) + set-defs)) + (else + (let* ((setter-name + (string-append "%" (symbol->string name) "-" + (symbol->string (car ls)) "-set!")) + (setter (rename (string->symbol setter-name))) + (i (index-of (car ls) fields))) + (lp (cdr ls) + (cons (list setter 'res (car ls)) sets) + (cons (list setter + (list (rename 'make-setter) + setter-name + index + (index-of (car ls) fields))) + set-defs))))))))))))))))) + diff --git a/lib/srfi/95.module b/lib/srfi/95.module new file mode 100644 index 00000000..25e0d3ff --- /dev/null +++ b/lib/srfi/95.module @@ -0,0 +1,7 @@ + +(define-module (srfi 95) + (export sorted? merge merge! sort sort!) + (import-immutable (scheme)) + (include-shared "95/qsort") + (include "95/sort.scm")) + diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c new file mode 100644 index 00000000..6b304e54 --- /dev/null +++ b/lib/srfi/95/qsort.c @@ -0,0 +1,170 @@ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var) + +static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) { + sexp_sint_t i; + sexp ls, *data=sexp_vector_data(vec); + for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls)) + sexp_car(ls) = data[i]; + return seq; +} + +static sexp sexp_vector_nreverse (sexp ctx, sexp vec) { + int i, j; + sexp tmp, *data=sexp_vector_data(vec); + for (i=0, j=sexp_vector_length(vec)-1; i 2) { + sexp_qsort(ctx, vec, lo, j-1); + lo = j+1; + goto loop; + } + } +} + +static sexp sexp_qsort_less (sexp ctx, sexp *vec, + sexp_sint_t lo, sexp_sint_t hi, + sexp less, sexp key) { + sexp_sint_t mid, i, j; + sexp tmp, res, args1; + sexp_gc_var3(a, b, args2); + sexp_gc_preserve3(ctx, a, b, args2); + args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID); + args1 = sexp_cdr(args2); + loop: + if (lo >= hi) { + res = SEXP_VOID; + } else { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + sexp_car(args1) = tmp; + b = sexp_apply(ctx, key, args1); + for (i=j=lo; i < hi; i++) { + sexp_car(args1) = vec[i]; + a = sexp_apply(ctx, key, args1); + sexp_car(args2) = a; + sexp_car(args1) = b; + res = sexp_apply(ctx, less, args2); + if (sexp_exceptionp(res)) + goto done; + else if (sexp_truep(res)) + swap(res, vec[i], vec[j]), j++; + } + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + res = sexp_qsort_less(ctx, vec, lo, j-1, less, key); + if (sexp_exceptionp(res)) + goto done; + lo = j+1; + goto loop; + } + } + done: + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_sort_x (sexp ctx, sexp seq, sexp less, sexp key) { + sexp_sint_t len; + sexp res, *data; + sexp_gc_var1(vec); + + if (sexp_nullp(seq)) return seq; + + sexp_gc_preserve1(ctx, vec); + + vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); + + if (! sexp_vectorp(vec)) { + res = sexp_type_exception(ctx, "sort: not a vector", vec); + } else { + data = sexp_vector_data(vec); + len = sexp_vector_length(vec); + if (sexp_not(key) && sexp_basic_comparator(less)) { + sexp_qsort(ctx, data, 0, len-1); + if (sexp_opcodep(less) && sexp_opcode_inverse(less)) + sexp_vector_nreverse(ctx, vec); + } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { + res = sexp_type_exception(ctx, "sort: not a procedure", less); + } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { + res = sexp_type_exception(ctx, "sort: not a procedure", less); + } else { + res = sexp_qsort_less(ctx, data, 0, len-1, less, key); + } + } + + if (sexp_pairp(seq)) + res = sexp_vector_copy_to_list(ctx, vec, seq); + else if (! sexp_exceptionp(res)) + res = vec; + + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE); + return SEXP_VOID; +} diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm new file mode 100644 index 00000000..38273199 --- /dev/null +++ b/lib/srfi/95/sort.scm @@ -0,0 +1,70 @@ +;; sort.scm -- SRFI-95 sorting utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (copy seq) + (if (vector? seq) + (let* ((len (vector-length seq)) + (res (make-vector len))) + (do ((i (- len 1) (- i 1))) + ((< i 0) res) + (vector-set! res i (vector-ref seq i)))) + (map (lambda (x) x) seq))) + +(define (sort seq . o) + (let ((less (and (pair? o) (car o))) + (key (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (sort! (copy seq) less key))) + +(define (sorted? seq less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (cond + ((vector? seq) + (let ((len (- (vector-length seq) 1))) + (let lp ((i 0)) + (cond + ((>= i len) #t) + ((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f) + (else (lp (+ i 1))))))) + ((null? seq) + #f) + (else + (let lp ((ls1 seq) (ls2 (cdr seq))) + (cond ((null? ls2) #t) + ((less (key (car ls2)) (key (car ls1))) #f) + (else (lp ls2 (cdr ls2))))))))) + +(define (merge! ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (define (lp prev ls1 ls2 a b less key) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))) + (else + (set-cdr! prev ls2) + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))))) + (cond + ((null? ls1) ls2) + ((null? ls2) ls1) + (else + (let ((a (key (car ls1))) + (b (key (car ls2)))) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)) + ls1) + (else + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)) + ls2))))))) + +(define (merge ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (merge! (copy ls1) (copy ls2) less key))) diff --git a/lib/srfi/98.module b/lib/srfi/98.module new file mode 100644 index 00000000..9d124d66 --- /dev/null +++ b/lib/srfi/98.module @@ -0,0 +1,5 @@ + +(define-module (srfi 98) + (export get-environment-variable get-environment-variables) + (include-shared "98/env")) + diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c new file mode 100644 index 00000000..38f8b883 --- /dev/null +++ b/lib/srfi/98/env.c @@ -0,0 +1,48 @@ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifdef __APPLE__ +#include +#define environ (*_NSGetEnviron()) +#else +extern char **environ; +#endif + +#include + +sexp sexp_get_environment_variable (sexp ctx, sexp str) { + char *cstr; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "get-environment-variable: not a string", str); + cstr = getenv(sexp_string_data(str)); + return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE; +} + +sexp sexp_get_environment_variables (sexp ctx) { + int i; + char **env, *cname, *cval; + sexp_gc_var3(res, name, val); + sexp_gc_preserve3(ctx, res, name, val); + res = SEXP_NULL; + env = environ; + for (i=0; env[i]; i++) { + cname = env[i]; + cval = strchr(cname, '='); + if (cval) { + name = sexp_c_string(ctx, cname, cval-cname); + val = sexp_c_string(ctx, cval+1, -1); + val = sexp_cons(ctx, name, val); + res = sexp_cons(ctx, val, res); + } + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx, sexp env) { + sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable); + sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables); + return SEXP_VOID; +} + diff --git a/main.c b/main.c new file mode 100644 index 00000000..6edd9185 --- /dev/null +++ b/main.c @@ -0,0 +1,193 @@ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define sexp_argv_symbol "*command-line-arguments*" +#define sexp_argv_proc "(define (command-line-arguments) "sexp_argv_symbol")" + +#define sexp_import_prefix "(import (" +#define sexp_import_suffix "))" + +#ifdef PLAN9 +#define exit_failure() exits("ERROR") +#else +#define exit_failure() exit(70) +#endif + +static void repl (sexp ctx) { + sexp in, out, err; + sexp_gc_var4(obj, tmp, res, env); + sexp_gc_preserve4(ctx, obj, tmp, res, env); + env = sexp_context_env(ctx); + sexp_context_tracep(ctx) = 1; + in = sexp_eval_string(ctx, "(current-input-port)", env); + out = sexp_eval_string(ctx, "(current-output-port)", env); + err = sexp_eval_string(ctx, "(current-error-port)", env); + 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, env); + if (sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, err); + } else { +#if SEXP_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_release4(ctx); +} + +static sexp check_exception (sexp ctx, sexp res) { + sexp err; + if (res && sexp_exceptionp(res)) { + err = sexp_current_error_port(ctx); + if (! sexp_oportp(err)) + err = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_print_exception(ctx, res, err); + exit_failure(); + } + return res; +} + +#define init_context() if (! ctx) do { \ + ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \ + env = sexp_context_env(ctx); \ + sexp_gc_preserve2(ctx, tmp, args); \ + } while (0) + +#define load_init() if (! init_loaded++) do { \ + init_context(); \ + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \ + } while (0) + +void run_main (int argc, char **argv) { + char *arg, *impmod, *p; + sexp env, out=SEXP_FALSE, res=SEXP_VOID, ctx=NULL; + sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0; + sexp_uint_t heap_size=0; + sexp_gc_var2(tmp, args); + args = SEXP_NULL; + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + case 'p': + load_init(); + print = (argv[i][1] == 'p'); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + res = check_exception(ctx, sexp_read_from_string(ctx, arg)); + res = check_exception(ctx, sexp_eval(ctx, res, env)); + if (print) { + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", env); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + quit = 1; + i++; + break; + case 'l': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_exception(ctx, sexp_load_module_file(ctx, argv[++i], env)); + break; + case 'm': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); + impmod = (char*) malloc(len+1); + strcpy(impmod, sexp_import_prefix); + strcpy(impmod+strlen(sexp_import_prefix), arg); + strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix); + impmod[len] = '\0'; + for (p=impmod; *p; p++) + if (*p == '.') *p=' '; + check_exception(ctx, sexp_eval_string(ctx, impmod, env)); + free(impmod); + break; + case 'q': + init_context(); + if (! init_loaded++) sexp_load_standard_parameters(ctx, env); + break; + case 'A': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); + break; + case 'I': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); + break; + case '-': + i++; + goto done_options; + case 'h': + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + heap_size = atol(arg); + len = strlen(arg); + if (heap_size && isalpha(arg[len-1])) { + switch (tolower(arg[len-1])) { + case 'k': heap_size *= 1024; break; + case 'm': heap_size *= (1024*1024); break; + } + } + break; + case 'V': + printf("chibi-scheme 0.3\n"); + return; + default: + fprintf(stderr, "unknown option: %s\n", argv[i]); + exit_failure(); + } + } + + done_options: + if (! quit) { + load_init(); + if (i < argc) + for (j=argc-1; j>i; j--) + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); + else + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); + sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol), args); + sexp_eval_string(ctx, sexp_argv_proc, env); + if (i < argc) { /* script usage */ + check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); + tmp = sexp_intern(ctx, "main"); + tmp = sexp_env_ref(env, tmp, SEXP_FALSE); + if (sexp_procedurep(tmp)) { + args = sexp_list1(ctx, args); + check_exception(ctx, sexp_apply(ctx, tmp, args)); + } + } else { + repl(ctx); + } + } + + sexp_gc_release2(ctx); +} + +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..fdce3e9f --- /dev/null +++ b/mkfile @@ -0,0 +1,26 @@ + include/chibi/install.h + echo '#define sexp_platform "plan9"' >> include/chibi/install.h + +install:V: $BIN/$TARG + test -d $MODDIR || mkdir -p $MODDIR + cp -r lib/* $MODDIR/ + +test:V: + ./$O.out tests/r5rs-tests.scm + +sexp.c:N: gc.c opt/bignum.c diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..85a35afc --- /dev/null +++ b/opcodes.c @@ -0,0 +1,153 @@ + +#define _OP(c,o,n,m,t,u,i,s,d,f) \ + {.tag=SEXP_OPCODE, \ + .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}} +#define _FN(o,n,m,t,u,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f) +#define _FN0(s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, 0, 0, s, d, f) +#define _FN1(t, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, t, 0, s, d, f) +#define _FN1OPT(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, t, u, s, d, f) +#define _FN1OPTP(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, t, 0, s, d, f) +#define _FN2(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, t, u, s, d, f) +#define _FN2OPT(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, t, u, s, d, f) +#define _FN2OPTP(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, t, u, s, d, f) +#define _FN3(t, u, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, t, u, s, d, f) +#define _FN4(t, u, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, t, u, s, d, f) +#define _FN5(t, u, s, d, f) _FN(SEXP_OP_FCALL5, 5, 0, t, u, s, d, f) +#define _FN6(t, u, s, d, f) _FN(SEXP_OP_FCALL6, 6, 0, t, u, s, d, f) +#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, 0, 0, n, a, 0) + +static struct sexp_struct opcodes[] = { +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_fixnum(0), NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_fixnum(1), NULL), +_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_SUB, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_NEGATIVE, "-", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_DIV, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_INVERSE, "/", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), +#if SEXP_USE_IMMEDIATE_FLONUMS +_FN1(0, "flonum?", 0, sexp_flonum_predicate), +#else +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), +#endif +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read), +_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write), +_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display), +_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output), +_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), +_FN0("make-environment", 0, sexp_make_env), +_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), +_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), +_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval), +_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load), +_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), +_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), +_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), +_FN2OPT(SEXP_PAIR, SEXP_STRING, "string-concatenate", SEXP_FALSE, 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), +_FN1(0, "strip-syntactic-closures", 0, sexp_strip_synclos), +_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), +_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 SEXP_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), +#endif +_FN2(0, 0, "expt", 0, sexp_expt), +#if SEXP_USE_TYPE_DEFS +_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter), +#endif +#if PLAN9 +#include "opt/plan9-opcodes.c" +#endif +#if SEXP_USE_MODULES +_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports), +_FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), +_FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), +_FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory), +#endif +}; + diff --git a/opt/bignum.c b/opt/bignum.c new file mode 100644 index 00000000..60215de8 --- /dev/null +++ b/opt/bignum.c @@ -0,0 +1,751 @@ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_INIT_BIGNUM_SIZE 2 + +#define sexp_negate(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_fixnump(x)) \ + x = sexp_fx_neg(x); + +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { + sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + sexp_bignum_length(res) = len; + sexp_bignum_sign(res) = 1; + return res; +} + +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { + sexp res = sexp_make_bignum(ctx, 1); + sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a)); + sexp_bignum_sign(res) = sexp_fx_sign(a); + return res; +} + +sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { + sexp res; + if ((SEXP_MIN_FIXNUM < x) && (x < SEXP_MAX_FIXNUM)) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + if (x < 0) { + sexp_bignum_sign(res) = -1; + sexp_bignum_data(res)[0] = -x; + } else { + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + } + return res; +} + +sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { + sexp res; + if (x < SEXP_MAX_FIXNUM) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + return res; +} + +#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) +#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) + +sexp sexp_double_to_bignum (sexp ctx, double f) { + int sign; + sexp_gc_var3(res, scale, tmp); + sexp_gc_preserve3(ctx, res, scale, tmp); + res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0)); + scale = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + sign = (f < 0 ? -1 : 1); + for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { + tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); + res = sexp_bignum_add(ctx, res, res, tmp); + scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); + } + sexp_bignum_sign(res) = sign; + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { + sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size; + size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + if (! dst || sexp_bignum_length(dst) < len) { + dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + memcpy(dst, a, size); + sexp_bignum_length(dst) = len; + } else { + memset(dst->value.bignum.data, 0, + sexp_bignum_length(dst)*sizeof(sexp_uint_t)); + memcpy(dst->value.bignum.data, a->value.bignum.data, + sexp_bignum_length(a)*sizeof(sexp_uint_t)); + } + return dst; +} + +int sexp_bignum_zerop (sexp a) { + int i; + sexp_uint_t *data = sexp_bignum_data(a); + for (i=sexp_bignum_length(a)-1; i>=0; i--) + if (data[i]) + return 0; + return 1; +} + +sexp_uint_t sexp_bignum_hi (sexp a) { + sexp_uint_t i=sexp_bignum_length(a)-1; + while ((i>0) && ! sexp_bignum_data(a)[i]) + i--; + return i+1; +} + +sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) { + int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b); + sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b); + if (ai != bi) + return ai - bi; + for (--ai; ai >= 0; ai--) { + if (adata[ai] > bdata[ai]) + return 1; + else if (adata[ai] < bdata[ai]) + return -1; + } + return 0; +} + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { + if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) + return sexp_bignum_sign(a); + return sexp_bignum_compare_abs(a, b); +} + +sexp sexp_bignum_normalize (sexp a) { + sexp_uint_t *data; + if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) + return a; + data = sexp_bignum_data(a); + if ((data[0] > SEXP_MAX_FIXNUM) + && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1))) + return a; + return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a)); +} + +double sexp_bignum_to_double (sexp a) { + double res = 0; + sexp_uint_t i, *data=sexp_bignum_data(a); + for (i=0; i (SEXP_UINT_T_MAX - carry)); + } while (++i> (sizeof(sexp_uint_t)*8); + } + if (carry) { + if (sexp_bignum_length(d)+offset <= len) + d = sexp_copy_bignum(ctx, NULL, d, len+offset+1); + sexp_bignum_data(d)[len+offset] = carry; + } + return d; +} + +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0; + int i; + sexp_luint_t n = 0; + for (i=len-1; i>=offset; i--) { + n = (n << sizeof(sexp_uint_t)*8) + data[i]; + q = n / b; + r = n - (sexp_luint_t)q * b; + data[i] = q; + n = r; + } + return r; +} + +sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, + char sign, sexp_uint_t base) { + int c, digit; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE); + sexp_bignum_sign(res) = sign; + sexp_bignum_data(res)[0] = init; + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + res = sexp_bignum_fxmul(ctx, res, res, base, 0); + res = sexp_bignum_fxadd(ctx, res, digit); + } + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); + } else if ((c!=EOF) && ! is_separator(c)) { + res = sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + } + sexp_push_char(ctx, c, in); + sexp_gc_release1(ctx); + return sexp_bignum_normalize(res); +} + +static int log2i(int v) { + int i; + for (i = 0; i < sizeof(v)*8; i++) + if ((1<<(i+1)) > v) + break; + return i; +} + +sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { + int i, str_len, lg_base = log2i(base); + char *data; + sexp_gc_var2(b, str); + sexp_gc_preserve2(ctx, b, str); + b = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(b) = 1; + i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) + / lg_base + 1; + str = sexp_make_string(ctx, sexp_make_fixnum(str_len), + sexp_make_character(' ')); + data = sexp_string_data(str); + while (! sexp_bignum_zerop(b)) + data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0)); + if (i == str_len) + data[--i] = '0'; + else if (sexp_bignum_sign(a) == -1) + data[--i] = '-'; + sexp_write_string(ctx, data + i, out); + sexp_gc_release2(ctx); + return SEXP_VOID; +} + +/****************** bignum arithmetic *************************/ + +sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(c); + sexp_gc_preserve1(ctx, c); + c = sexp_copy_bignum(ctx, NULL, a, 0); + if (sexp_bignum_sign(c) == sexp_fx_sign(b)) + c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + else + c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + sexp_gc_release1(ctx); + return c; +} + +sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), + borrow=0, i, *adata, *bdata, *cdata; + sexp_gc_var1(c); + if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) + return sexp_bignum_sub_digits(ctx, dst, b, a); + sexp_gc_preserve1(ctx, c); + c = ((dst && sexp_bignum_hi(dst) >= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0); + } + for ( ; carry && (i= 0 ? a : b); + } + return res; +} + +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { + sexp res; + if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { + res = sexp_bignum_sub_digits(ctx, dst, a, b); + sexp_bignum_sign(res) + = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a) + : -sexp_bignum_sign(a)); + } else { + res = sexp_bignum_add_digits(ctx, dst, a, b); + sexp_bignum_sign(res) = sexp_bignum_sign(a); + } + return res; +} + +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, + *bdata=sexp_bignum_data(b); + sexp_gc_var2(c, d); + if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); + sexp_gc_preserve2(ctx, c, d); + c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); + d = sexp_make_bignum(ctx, alen+blen+1); + for (i=0; i 0) { + *rem = a; + return sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0)); + } + sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); + k2 = sexp_bignum_double(ctx, k); + i2 = sexp_bignum_double(ctx, i); + x = quot_step(ctx, rem, a, b, k2, i2); + prod = sexp_bignum_mul(ctx, NULL, x, b); + diff = sexp_bignum_sub_digits(ctx, NULL, a, prod); + if (sexp_bignum_compare(diff, k) >= 0) { + *rem = sexp_bignum_sub_digits(ctx, NULL, diff, k); + res = sexp_bignum_add_digits(ctx, NULL, x, i); + } else { + *rem = diff; + res = x; + } + sexp_gc_release5(ctx); + return res; +} + +sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { + sexp res; + sexp_gc_var4(k, i, a1, b1); + sexp_gc_preserve4(ctx, k, i, a1, b1); + a1 = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(a1) = 1; + b1 = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_bignum_sign(b1) = 1; + k = sexp_copy_bignum(ctx, NULL, b1, 0); + i = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + res = quot_step(ctx, rem, a1, b1, k, i); + sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); + if (sexp_bignum_sign(a) < 0) { + sexp_negate(*rem); + } + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { + sexp res; + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + res = sexp_bignum_quot_rem(ctx, &rem, a, b); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { + sexp rem; + sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */ + return rem; +} + +sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { + sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b)); + sexp_gc_var2(res, acc); + sexp_gc_preserve2(ctx, res, acc); + res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + acc = sexp_copy_bignum(ctx, NULL, a, 0); + for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) + if (e & 1) + res = sexp_bignum_mul(ctx, NULL, res, acc); + sexp_gc_release2(ctx); + return res; +} + +/****************** generic arithmetic ************************/ + +enum sexp_number_types { + SEXP_NUM_NOT = 0, + SEXP_NUM_FIX, + SEXP_NUM_FLO, + SEXP_NUM_BIG +}; + +enum sexp_number_combs { + SEXP_NUM_NOT_NOT = 0, + SEXP_NUM_NOT_FIX, + SEXP_NUM_NOT_FLO, + SEXP_NUM_NOT_BIG, + SEXP_NUM_FIX_NOT, + SEXP_NUM_FIX_FIX, + SEXP_NUM_FIX_FLO, + SEXP_NUM_FIX_BIG, + SEXP_NUM_FLO_NOT, + SEXP_NUM_FLO_FIX, + SEXP_NUM_FLO_FLO, + SEXP_NUM_FLO_BIG, + SEXP_NUM_BIG_NOT, + SEXP_NUM_BIG_FIX, + SEXP_NUM_BIG_FLO, + SEXP_NUM_BIG_BIG +}; + +static int sexp_number_types[] = + {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, 0}; + +static int sexp_number_type (sexp a) { + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] +#if SEXP_USE_IMMEDIATE_FLONUMS + : sexp_flonump(a) ? 2 +#endif + : sexp_fixnump(a); +} + +sexp sexp_add (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "+: not a number", a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_add(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_add(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_add(ctx, NULL, b, a)); + break; + } + return r; +} + +sexp sexp_sub (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "-: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "-: not a number", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_sub(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a)); + sexp_negate(r); + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)+sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_sub(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, sexp_fixnum_to_bignum(ctx, b))); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_flonum_value(b) - sexp_bignum_to_double(a)); + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); + break; + } + return r; +} + +sexp sexp_mul (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "*: not a number", a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_mul(a, b); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0); + sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_mul(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_mul(ctx, NULL, a, b); + break; + } + return r; +} + +sexp sexp_div (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + double f; + sexp r=SEXP_VOID, rem; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "/: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "/: not a number", b); + break; + case SEXP_NUM_FIX_FIX: + f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b); + r = ((f == trunc(f)) ? sexp_make_fixnum((sexp_sint_t)f) + : sexp_make_flonum(ctx, f)); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)/sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_div(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_quot_rem(ctx, &rem, a, b); + if (sexp_bignum_normalize(rem) != sexp_make_fixnum(0)) + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) + / sexp_fixnum_to_double(b)); + else + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b)); + break; + } + return r; +} + +sexp sexp_quotient (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "quotient: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "quotient: not a number", b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_div(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(0); + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b)); + break; + } + return r; +} + +sexp sexp_remainder (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "remainder: not a number", a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, "remainder: not a number", b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_rem(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = a; + break; + case SEXP_NUM_BIG_FIX: + b = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b)); + break; + } + return r; +} + +sexp sexp_compare (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + double f; + if (at > bt) { + r = sexp_compare(ctx, b, a); + sexp_negate(r); + } else { + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, "compare: not a number", a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); + break; + case SEXP_NUM_FIX_FLO: + f = sexp_fixnum_to_double(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(-1); + break; + case SEXP_NUM_FLO_FLO: + f = sexp_flonum_value(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FLO_BIG: + f = sexp_flonum_value(a) - sexp_bignum_to_double(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_make_fixnum(sexp_bignum_compare(a, b)); + break; + } + } + return r; +} + diff --git a/opt/plan9-opcodes.c b/opt/plan9-opcodes.c new file mode 100644 index 00000000..9f7cac33 --- /dev/null +++ b/opt/plan9-opcodes.c @@ -0,0 +1,19 @@ +_FN0("random-integer", 0, sexp_rand), +_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), +_FN0("current-directory", 0, sexp_getwd), +_FN0("current-user", 0, sexp_getuser), +_FN0("system-name", 0, sexp_sysname), +_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), +_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), +_FN0("fork", 0, sexp_fork), +_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), +_FN1(SEXP_STRING, "exits", 0, sexp_exits), +_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), +_FN0("pipe", 0, sexp_pipe), +_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), +_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), +_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), +_FN0("wait", 0, sexp_wait), +_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), +_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), +_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), diff --git a/opt/plan9.c b/opt/plan9.c new file mode 100644 index 00000000..b103912a --- /dev/null +++ b/opt/plan9.c @@ -0,0 +1,351 @@ +/* plan9.c -- extended Plan 9 system utils */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +sexp sexp_rand (sexp ctx) { + return sexp_make_fixnum(rand()); +} + +sexp sexp_srand (sexp ctx, sexp seed) { + srand(sexp_unbox_fixnum(seed)); + return SEXP_VOID; +} + +sexp sexp_file_exists_p (sexp ctx, sexp path) { + int res; + uchar statbuf[STATMAX]; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "file-exists?: not a string", path); + res = stat(sexp_string_data(path), statbuf, sizeof(statbuf)); + return (res < 0) ? SEXP_FALSE : SEXP_TRUE; +} + +sexp sexp_fdopen (sexp ctx, sexp fd, sexp mode) { + FILE *f; + if (! sexp_integerp(fd)) + return sexp_type_exception(ctx, "fdopen: not an integer", fd); + if (! sexp_stringp(mode)) + return sexp_type_exception(ctx, "fdopen: not a mode string", mode); + f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode)); + if (! f) + return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd); + /* maybe use fd2path to get the name of the fd */ + if (sexp_string_data(mode)[0] == 'w') + return sexp_make_output_port(ctx, f, SEXP_FALSE); + else + return sexp_make_input_port(ctx, f, SEXP_FALSE); +} + +sexp sexp_fileno (sexp ctx, sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "fileno: not a port", port); + return sexp_make_fixnum(fileno(sexp_port_stream(port))); +} + +sexp sexp_fork (sexp ctx) { + return sexp_make_fixnum(fork()); +} + +sexp sexp_exec (sexp ctx, sexp name, sexp args) { + int i, len = sexp_unbox_fixnum(sexp_length(ctx, args)); + char **argv = malloc((len+1)*sizeof(char*)); + for (i=0; imsg, -1); + res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg); + sexp_gc_release(ctx, msg, s_msg); + return res; +} + +sexp sexp_postnote (sexp ctx, sexp pid, sexp note) { + if (! sexp_integerp(pid)) + return sexp_type_exception(ctx, "postnote: not an integer", pid); + if (! sexp_stringp(note)) + return sexp_type_exception(ctx, "postnote: not a string", note); + postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note)); + return SEXP_VOID; +} + +/**********************************************************************/ +/* 9p interface */ + +typedef struct sexp_plan9_srv { + sexp context, auth, attach, walk, walk1, clone, open, create, remove, + read, write, stat, wstat, flush, destroyfid, destroyreq, end; +} *sexp_plan9_srv; + +void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) { + s->context = ctx; + s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open + = s->create = s->remove = s->read = s->write = s->stat = s->wstat + = s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE; + for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) { + if (sexp_car(ls) == sexp_intern(ctx, "auth:")) { + s->auth = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "attach:")) { + s->attach = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk:")) { + s->walk = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:")) { + s->walk1 = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "clone:")) { + s->clone = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "open:")) { + s->open = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "create:")) { + s->create = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "remove:")) { + s->remove = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "read:")) { + s->read = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "write:")) { + s->write = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "stat:")) { + s->stat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:")) { + s->wstat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "flush:")) { + s->flush = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:")) { + s->destroyfid = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:")) { + s->destroyreq = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "end:")) { + s->end = sexp_cadr(ls); + } + } +} + +void sexp_run_9p_handler (Req *r, sexp handler) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, handler, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +#define sexp_def_9p_handler(name, field) \ + void name (Req *r) { \ + sexp_run_9p_handler(r, ((sexp_plan9_srv)r->srv->aux)->field); \ + } + +sexp_def_9p_handler(sexp_9p_auth, auth) +sexp_def_9p_handler(sexp_9p_attach, attach) +sexp_def_9p_handler(sexp_9p_walk, walk) +sexp_def_9p_handler(sexp_9p_open, open) +sexp_def_9p_handler(sexp_9p_create, create) +sexp_def_9p_handler(sexp_9p_remove, remove) +sexp_def_9p_handler(sexp_9p_read, read) +sexp_def_9p_handler(sexp_9p_write, write) +sexp_def_9p_handler(sexp_9p_stat, stat) +sexp_def_9p_handler(sexp_9p_wstat, wstat) +sexp_def_9p_handler(sexp_9p_flush, flush) + +char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_c_string(ctx, name, -1); + args = sexp_cons(ctx, ptr, args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->walk1, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +char* sexp_9p_clone (Fid *oldfid, Fid *newfid) { + sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->clone, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +void sexp_9p_destroyfid (Fid *fid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyfid, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_destroyreq (Req *r) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyreq, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_end (Srv *srv) { + sexp_plan9_srv s = (sexp_plan9_srv)srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->end, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +sexp sexp_postmountsrv (sexp ctx, sexp ls, sexp name, sexp mtpt, sexp flags) { + Srv s; + struct sexp_plan9_srv p9s; + if (! sexp_listp(ctx, ls)) + return sexp_type_exception(ctx, "postmountsrv: not a list", ls); + if (! sexp_stringp(name)) + return sexp_type_exception(ctx, "postmountsrv: not a string", name); + if (! sexp_stringp(mtpt)) + return sexp_type_exception(ctx, "postmountsrv: not a string", mtpt); + if (! sexp_integerp(flags)) + return sexp_type_exception(ctx, "postmountsrv: not an integer", flags); + sexp_build_srv(ctx, &p9s, ls); + s.aux = &p9s; + s.auth = &sexp_9p_auth; + s.attach = &sexp_9p_attach; + s.walk = &sexp_9p_walk; + s.walk1 = &sexp_9p_walk1; + s.clone = &sexp_9p_clone; + s.open = &sexp_9p_open; + s.create = &sexp_9p_create; + s.remove = &sexp_9p_remove; + s.read = &sexp_9p_read; + s.write = &sexp_9p_write; + s.stat = &sexp_9p_stat; + s.wstat = &sexp_9p_wstat; + s.flush = &sexp_9p_flush; + s.destroyfid = &sexp_9p_destroyfid; + s.destroyreq = &sexp_9p_destroyreq; + s.end = &sexp_9p_end; + postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt), + sexp_unbox_fixnum(flags)); + return SEXP_UNDEF; +} + +sexp sexp_9p_req_offset (sexp ctx, sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset); +} + +sexp sexp_9p_req_count (sexp ctx, sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count); +} + +#if 0 +sexp sexp_9p_req_path (sexp ctx, sexp req) { + return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1); +} +#endif + +sexp sexp_9p_req_fid (sexp ctx, sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0); +} + +sexp sexp_9p_req_newfid (sexp ctx, sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0); +} + +sexp sexp_9p_respond (sexp ctx, sexp req, sexp err) { + char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil; + respond(sexp_cpointer_value(req), cerr); + return SEXP_VOID; +} + +sexp sexp_9p_responderror (sexp ctx, sexp req) { + responderror(sexp_cpointer_value(req)); + return SEXP_VOID; +} + 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/opt/simplify.c b/opt/simplify.c new file mode 100644 index 00000000..d4ac576d --- /dev/null +++ b/opt/simplify.c @@ -0,0 +1,135 @@ +/* simplify.c -- basic simplification pass */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda)) + +static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { + int check; + sexp ls1, ls2, p1, p2, sv, ctx2; + sexp_gc_var4(res, substs, tmp, app); + sexp_gc_preserve4(ctx, res, substs, tmp, app); + res = ast; /* return the ast as-is by default */ + substs = init_substs; + + loop: + switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) { + + case SEXP_PAIR: + /* don't simplify the operator if it's a lambda because we + simplify that as a special case below, with the appropriate + substs list */ + app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res) + : (tmp=simplify(ctx, sexp_car(res), substs, lambda))); + for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); + app = sexp_nreverse(ctx, app); + if (sexp_opcodep(sexp_car(app))) { + if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) { + for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { + if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { + check = 0; + break; + } + } + if (check) { + ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0); + generate(ctx2, app); + app = finalize_bytecode(ctx2); + if (! sexp_exceptionp(app)) { + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + app = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, app, tmp); + if (! sexp_exceptionp(app)) + app = sexp_apply(ctx2, app, SEXP_NULL); + } + } + } + } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */ + p1 = NULL; + p2 = sexp_lambda_params(sexp_car(app)); + ls1 = app; + ls2 = sexp_cdr(app); + sv = sexp_lambda_sv(sexp_car(app)); + for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) { + if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv)) + && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2)) + || (sexp_refp(sexp_car(ls2)) + && sexp_lambdap(sexp_ref_loc(sexp_car(ls2)))))) { + tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2)); + tmp = sexp_cons(ctx, sexp_car(p2), tmp); + sexp_push(ctx, substs, tmp); + sexp_cdr(ls1) = sexp_cdr(ls2); + if (p1) + sexp_cdr(p1) = sexp_cdr(p2); + else + sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2); + } else { + p1 = p2; + ls1 = ls2; + } + } + sexp_lambda_body(sexp_car(app)) + = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app)); + if (sexp_nullp(sexp_cdr(app)) + && sexp_nullp(sexp_lambda_params(sexp_car(app))) + && sexp_nullp(sexp_lambda_defs(sexp_car(app)))) + app = sexp_lambda_body(sexp_car(app)); + } + res = app; + break; + + case SEXP_LAMBDA: + sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res); + break; + + case SEXP_CND: + tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda); + if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) { + res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp)) + ? sexp_cnd_fail(res) : sexp_cnd_pass(res); + goto loop; + } else { + sexp_cnd_test(res) = tmp; + simplify_it(sexp_cnd_pass(res)); + simplify_it(sexp_cnd_fail(res)); + } + break; + + case SEXP_REF: + tmp = sexp_ref_name(res); + for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) { + res = sexp_cddar(ls1); + break; + } + break; + + case SEXP_SET: + simplify_it(sexp_set_value(res)); + break; + + case SEXP_SEQ: + app = SEXP_NULL; + for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { + tmp = simplify(ctx, sexp_car(ls2), substs, lambda); + if (! (sexp_pairp(sexp_cdr(ls2)) + && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) + || sexp_lambdap(tmp)))) + sexp_push(ctx, app, tmp); + } + if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app))) + res = sexp_car(app); + else + sexp_seq_ls(res) = sexp_nreverse(ctx, app); + break; + + } + + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_simplify (sexp ctx, sexp ast) { + return simplify(ctx, ast, SEXP_NULL, NULL); +} + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..2a3ff0f6 --- /dev/null +++ b/sexp.c @@ -0,0 +1,1685 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* optional huffman-compressed immediate symbols */ +struct sexp_huff_entry { + unsigned char len; + unsigned short bits; +}; + +#if SEXP_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; + +sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp); + +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 (int c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int hex_digit (int n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + +static int is_separator(int c) { + return 0= SEXP_MAXIMUM_TYPES) { + res = sexp_user_exception(ctx, SEXP_FALSE, "register-type: exceeded maximum type limit", name); + } else if (! sexp_stringp(name)) { + res = sexp_type_exception(ctx, "register-type: not a string", name); + } else { + if (num_types >= type_array_size) { + len = type_array_size*2; + if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES; +#if SEXP_USE_GLOBAL_TYPES + new = malloc(len * sizeof(_sexp_type_specs[0])); + for (i=0; i num_types) free(tmp); + sexp_type_array_size = len; +#else + res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID); + v1 = sexp_vector_data(res); + v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)); + for (i=0; i= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(sexp_exception_message(exn))) + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); + else + sexp_write(ctx, 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_var4(sym, name, str, irr); + sexp_gc_preserve4(ctx, sym, name, str, irr); + name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); + name = sexp_cons(ctx, name, sexp_make_fixnum(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, sym = sexp_intern(ctx, "read"), + str, irr, SEXP_FALSE, name); + sexp_gc_release4(ctx); + return res; +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons (sexp ctx, sexp head, sexp tail) { + sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); + if (sexp_exceptionp(pair)) return 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_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release1(ctx); + 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_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(ctx, sexp_car(ls), res); + sexp_gc_release1(ctx); + 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_type_exception(ctx, "not a list", ls); + } 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_var2(a1, b1); + sexp_gc_preserve2(ctx, a1, 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_release2(ctx); + 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_fixnum(res); +} + +sexp sexp_equalp (sexp ctx, sexp a, sexp b) { + sexp_uint_t size; + sexp_sint_t i, len; + sexp t, *p, *q; + char *p0, *q0; + + loop: + if (a == b) + return SEXP_TRUE; + else if ((! sexp_pointerp(a)) || (! sexp_pointerp(b)) + || (sexp_pointer_tag(a) != sexp_pointer_tag(b))) + return SEXP_FALSE; + + /* a and b are both pointers of the same type */ +#if SEXP_USE_BIGNUMS + if (sexp_pointer_tag(a) == SEXP_BIGNUM) + return sexp_make_boolean(!sexp_bignum_compare(a, b)); +#endif +#if SEXP_USE_FLONUMS && ! SEXP_USE_IMMEDIATE_FLONUMS + if (sexp_pointer_tag(a) == SEXP_FLONUM) + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); +#endif + t = sexp_object_type(ctx, a); + p0 = ((char*)a) + offsetof(struct sexp_struct, value); + p = (sexp*) (((char*)a) + sexp_type_field_base(t)); + q0 = ((char*)b) + offsetof(struct sexp_struct, value); + q = (sexp*) (((char*)b) + sexp_type_field_base(t)); + if ((sexp)p == a) {p=(sexp*)p0; q=(sexp*)q0;} + /* check preliminary non-object data */ + if ((p0 < (char*)p) && memcmp(p0, q0, ((char*)p - p0))) + return SEXP_FALSE; + /* check trailing non-object data */ + size = sexp_type_size_of_object(t, a) - offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,a)*sizeof(sexp)); + if (((char*)a + size) > p0) { + q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp)); + if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value)) + return SEXP_FALSE; + if (memcmp(p0, q0, size)) + return SEXP_FALSE; + } + /* check eq-object slots */ + len = sexp_type_num_eq_slots_of_object(t, a); + if (len > 0) { + for (i=0; i> 32; + return r.flonum; +} +sexp sexp_make_flonum (sexp ctx, float f) { + union sexp_flonum_conv x; + x.flonum = f; + return (sexp)(((sexp_uint_t)(x.bits) << 32) + SEXP_IFLONUM_TAG); +} +#endif +#endif + +sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { + sexp_sint_t clen = sexp_unbox_fixnum(len); + sexp s; + if (! sexp_fixnump(len)) return sexp_type_exception(ctx, "bad length", len); + if (clen < 0) return sexp_type_exception(ctx, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); + if (sexp_exceptionp(s)) return s; + 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_fixnum(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_fixnump(start)) + return sexp_type_exception(ctx, "not a number", start); + if (sexp_not(end)) + end = sexp_make_fixnum(sexp_string_length(str)); + if (! sexp_fixnump(end)) + return sexp_type_exception(ctx, "not a number", end); + if ((sexp_unbox_fixnum(start) < 0) + || (sexp_unbox_fixnum(start) > sexp_string_length(str)) + || (sexp_unbox_fixnum(end) < 0) + || (sexp_unbox_fixnum(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_fixnum(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 sep) { + sexp res, ls; + sexp_uint_t len=0, i=0, sep_len=0; + char *p, *csep; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + 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)); + if (sexp_stringp(sep) && ((sep_len=sexp_string_length(sep)) > 0)) { + csep = sexp_string_data(sep); + len += sep_len*(i-1); + } + res = sexp_make_string(ctx, sexp_make_fixnum(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; + if (sep_len && sexp_pairp(sexp_cdr(ls))) { + memcpy(p, csep, sep_len); + p += sep_len; + } + } + *p = '\0'; + return res; +} + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#if SEXP_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) { +#if SEXP_USE_HUFF_SYMS + struct sexp_huff_entry he; + sexp_uint_t space=3, newbits; + char c; +#endif + sexp_uint_t len, res=FNV_OFFSET_BASIS, bucket; + char *p=str; + sexp ls; + sexp_gc_var1(sym); + +#if SEXP_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); + + normal_intern: +#endif +#if SEXP_USE_HASH_SYMS + bucket = (sexp_string_hash(p, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + len = strlen(str) + 1; /* include the trailing NULL in the comparison */ + for (ls=sexp_context_symbols(ctx)[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_preserve1(ctx, sym); + sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); + if (sexp_exceptionp(sym)) return sym; + sexp_symbol_string(sym) = sexp_c_string(ctx, str, len-1); + sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); + sexp_gc_release1(ctx); + return sym; +} + +sexp sexp_string_to_symbol (sexp ctx, sexp str) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string->symbol: not a string", str); + return sexp_intern(ctx, sexp_string_data(str)); +} + +sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { + sexp vec, *x; + int i, clen = sexp_unbox_fixnum(len); + if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR); + vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); + if (sexp_exceptionp(vec)) return vec; + x = sexp_vector_data(vec); + 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_fixnum(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_fixnum(sexp_stream_size(vec)); + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_stream_ctx(vec), + sexp_make_fixnum(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_fixnum(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_fixnum(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_fixnum(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_fixnum(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_fixnum(pos); + return pos; +} + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + FILE *in; + sexp res; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = str; + sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str)); + sexp_stream_pos(cookie) = SEXP_ZERO; + 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_release1(ctx); + return res; +} + +sexp sexp_make_output_string_port (sexp ctx) { + FILE *out; + sexp res, size; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + size = sexp_make_fixnum(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(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_ZERO; + 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_release1(ctx); + 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_ZERO, + sexp_stream_pos(cookie)); +} + +#else + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + FILE *in; + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "open-input-string: not a string", str); + in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + 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_var1(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_preserve1(ctx, tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_gc_release1(ctx); + } + sexp_port_offset(p) = 0; + return SEXP_VOID; + } +} + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "open-input-string: not a string", str); + res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + 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); + if (sexp_exceptionp(res)) return res; + 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_var2(ls, tmp); + sexp_gc_preserve2(ctx, ls, 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_FALSE); + sexp_gc_release2(ctx); + return res; +} + +#endif + +sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { + sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); + if (sexp_exceptionp(p)) return p; + 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); + if (sexp_exceptionp(p)) return p; + sexp_pointer_tag(p) = SEXP_OPORT; + return p; +} + +sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { +#if SEXP_USE_HUFF_SYMS + unsigned long res, c; +#endif + unsigned long len; + 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_one(ctx, sexp_car(obj), out); + for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { + sexp_write_char(ctx, ' ', out); + sexp_write_one(ctx, sexp_car(x), out); + } + if (! sexp_nullp(x)) { + sexp_write_string(ctx, " . ", out); + sexp_write_one(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_one(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; +#if SEXP_USE_BIGNUMS + case SEXP_BIGNUM: + sexp_write_bignum(ctx, obj, out, 10); + break; +#endif + default: + i = sexp_pointer_tag(obj); + sexp_write_string(ctx, "#<", out); + sexp_write_string(ctx, + (i < sexp_context_num_types(ctx)) + ? sexp_type_name_by_index(ctx, i) : "invalid", + out); + sexp_write_char(ctx, '>', out); + break; + } + } else if (sexp_fixnump(obj)) { + sprintf(numbuf, "%ld", sexp_unbox_fixnum(obj)); + sexp_write_string(ctx, numbuf, out); +#if SEXP_USE_IMMEDIATE_FLONUMS + } else if (sexp_flonump(obj)) { + f = sexp_flonum_value(obj); +#if SEXP_USE_INFINITIES + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else +#endif + { + i = sprintf(numbuf, "%.8g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + 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 SEXP_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); + } + } + return SEXP_VOID; +} + +sexp sexp_write (sexp ctx, sexp obj, sexp out) { + if (! sexp_oportp(out)) + return sexp_type_exception(ctx, "write: not an output-port", out); + else + return sexp_write_one(ctx, obj, out); +} + +sexp sexp_display (sexp ctx, sexp obj, sexp out) { + sexp res=SEXP_VOID; + if (! sexp_oportp(out)) + res = sexp_type_exception(ctx, "display: not an output-port", out); + else if (sexp_stringp(obj)) + sexp_write_string(ctx, sexp_string_data(obj), out); + else if (sexp_charp(obj)) + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else + res = sexp_write_one(ctx, obj, out); + return res; +} + +sexp sexp_flush_output (sexp ctx, sexp out) { + sexp_flush(ctx, out); + return SEXP_VOID; +} + +#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 'r': c = '\r'; 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_uint_t whole, int negp) { + sexp exponent=SEXP_VOID; + 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; + if (c=='e' || c=='E') { + exponent = sexp_read_number(ctx, in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(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); + } else { + sexp_push_char(ctx, c, in); + } + res = ((double)whole + res) * pow(10, e); + if (negp) res *= -1; + if ((scale == 0.1) && (exponent != SEXP_VOID) && (res == round(res))) + return sexp_make_fixnum(res); + else + return sexp_make_flonum(ctx, res); +} + +sexp sexp_read_number(sexp ctx, sexp in, int base) { + sexp den; + sexp_uint_t res = 0, tmp; + int c, digit, negativep = 0; + + c = sexp_read_char(ctx, in); + if (c == '-') + negativep = 1; + else if (isdigit(c)) + res = digit_value(c); + + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + tmp = res * base + digit; +#if SEXP_USE_BIGNUMS + if ((tmp < res) || (tmp > SEXP_MAX_FIXNUM)) { + sexp_push_char(ctx, c, in); + return sexp_read_bignum(ctx, in, res, (negativep ? -1 : 1), base); + } +#endif + res = tmp; + } + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + return sexp_read_float_tail(ctx, in, res, negativep); + } else if (c=='/') { + den = sexp_read_number(ctx, in, base); + if (! sexp_fixnump(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_fixnum(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_fixnum(negativep ? -res : res); +} + +sexp sexp_read_raw (sexp ctx, sexp in) { + char *str; + int c1, c2, line; + sexp tmp2; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, 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); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res); + break; + case '`': + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res); + break; + case ',': + if ((c1 = sexp_read_char(ctx, in)) == '@') { + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_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)) { + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } + res = sexp_cons(ctx, tmp, res); + tmp = sexp_read_raw(ctx, in); + } + 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_fixnum(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_fixnum((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(ctx, in); + if (sexp_fixnump(res)) + res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res)); + break; + case 'f': case 'F': + case 't': case 'T': + c2 = sexp_read_char(ctx, in); + if (c2 == EOF || is_separator(c2)) { + res = (tolower(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; + break; + case '!': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + sexp_port_line(in)++; + 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, 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 SEXP_USE_FLONUMS + if (sexp_flonump(res)) +#if SEXP_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 +#if SEXP_USE_BIGNUMS + if (sexp_bignump(res)) + sexp_bignum_sign(res) = -sexp_bignum_sign(res); + else +#endif + res = sexp_fx_mul(res, SEXP_NEG_ONE); + } + } else { + sexp_push_char(ctx, c2, in); + res = sexp_read_symbol(ctx, in, c1, 1); +#if SEXP_USE_INFINITIES + if (res == sexp_intern(ctx, "+inf.0")) + res = sexp_make_flonum(ctx, 1.0/0.0); + else if (res == sexp_intern(ctx, "-inf.0")) + res = sexp_make_flonum(ctx, -1.0/0.0); + else if (res == sexp_intern(ctx, "+nan.0")) + res = sexp_make_flonum(ctx, 0.0/0.0); +#endif + } + 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_release2(ctx); + return res; +} + +sexp sexp_read (sexp ctx, sexp in) { + sexp res; + if (sexp_iportp(in)) + res = sexp_read_raw(ctx, in); + else + res = sexp_type_exception(ctx, "read: not an input-port", in); + if (res == SEXP_CLOSE) + res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); + if (res == SEXP_RAWDOT) + res = sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); + return res; +} + +sexp sexp_read_from_string(sexp ctx, char *str) { + sexp res; + sexp_gc_var2(s, in); + sexp_gc_preserve2(ctx, s, in); + s = sexp_c_string(ctx, str, -1); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_write_to_string(sexp ctx, sexp obj) { + sexp str; + sexp_gc_var1(out); + sexp_gc_preserve1(ctx, out); + out = sexp_make_output_string_port(ctx); + str = sexp_write(ctx, obj, out); + if (! sexp_exceptionp(str)) + str = sexp_get_output_string(ctx, out); + sexp_gc_release1(ctx); + return str; +} + +void sexp_init(void) { +#if SEXP_USE_GLOBAL_SYMBOLS + int i; +#endif + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if SEXP_USE_BOEHM + GC_init(); +#if SEXP_USE_GLOBAL_SYMBOLS + GC_add_roots((char*)&sexp_symbol_table, + ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); +#endif +#elif ! SEXP_USE_MALLOC + sexp_gc_init(); +#endif +#if SEXP_USE_GLOBAL_SYMBOLS + 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..820020c1 --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,48 @@ + +(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)))) 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/build/build-opts.txt b/tests/build/build-opts.txt new file mode 100644 index 00000000..e6bcd056 --- /dev/null +++ b/tests/build/build-opts.txt @@ -0,0 +1,21 @@ +CPPFLAGS=-DSEXP_USE_MODULES=0 +CPPFLAGS=-DSEXP_USE_DL=0 +CPPFLAGS=-DSEXP_USE_SIMPLIFY=0 +CPPFLAGS=-DSEXP_USE_TYPE_DEFS=0 +SEXP_USE_BOEHM=1 +CPPFLAGS=-DSEXP_USE_DEBUG_GC=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_HEAP=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_TYPES=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_SYMBOLS=1 +CPPFLAGS=-DSEXP_USE_FLONUMS=0 +CPPFLAGS=-DSEXP_USE_IMMEDIATE_FLONUMS=1 +CPPFLAGS=-DSEXP_USE_BIGNUMS=0 +CPPFLAGS=-DSEXP_USE_MATH=0 +CPPFLAGS=-DSEXP_WARN_UNDEFS=0 +CPPFLAGS=-DSEXP_USE_HUFF_SYMS=0 +CPPFLAGS=-DSEXP_USE_HASH_SYMS=0 +CPPFLAGS=-DSEXP_USE_STRING_STREAMS=0 +CPPFLAGS=-DSEXP_USE_AUTOCLOSE_PORTS=0 +CPPFLAGS=-DSEXP_USE_2010_EPOCH=0 +CPPFLAGS=-DSEXP_USE_CHECK_STACK=0 +CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 diff --git a/tests/build/build-tests.sh b/tests/build/build-tests.sh new file mode 100755 index 00000000..1d239629 --- /dev/null +++ b/tests/build/build-tests.sh @@ -0,0 +1,37 @@ +#! /bin/bash + +# test basic build options + +# for bootstrapping reasons this is a shell script, instead of a +# scheme script using (chibi process) + +# we just check each build against r5rs-tests.scm - +# some of the libraries will fail to build (notably +# if modules or user-defined types are disabled). + +BUILDDIR=tests/build +FAILURES=0 +i=0 + +for opts in `cat ${BUILDDIR}/build-opts.txt`; do + make cleaner 2>&1 >/dev/null + if make $opts chibi-scheme 2>&1 >${BUILDDIR}/build${i}-make.out; then + if make test 2>&1 | tee ${BUILDDIR}/build${i}-test.out | grep -q -E 'FAIL|ERROR'; then + echo "[FAIL] ${i}: tests failed with $opts" + FAILURES=$((FAILURES + 1)) + else + echo "[PASS] ${i}: tests passed with $opts" + fi + else + echo "[FAIL] ${i}: couldn't build with $opts" + FAILURES=$((FAILURES + 1)) + fi + i=$((i+1)) +done + +if (( FAILURES == 0 )); then + echo "build-tests: all tests passed" +else + echo "build-tests: ${FAILURES} tests failed" +fi + diff --git a/tests/install/install-tests.pl b/tests/install/install-tests.pl new file mode 100755 index 00000000..63681324 --- /dev/null +++ b/tests/install/install-tests.pl @@ -0,0 +1,57 @@ +#! /usr/bin/env perl + +use strict; +use warnings; + +my $ROOT="tests/install/root"; +my $USER=$ENV{USER}; + +my $ignore = qr!/lib\d*/modules|/X11|alsa-lib|aspell|dosemu|emacs|erlang|/perl|python|ruby|lisp|sbcl|/ghc-|ocaml|evolution|office|gimp|gtk|mysql|postgres|wordnet|xulrunner!; + +sub linkdir ($$$) { + my ($FROM, $TO, $DEPTH) = @_; + mkdir $TO; + for my $f (`ls $FROM`) { + chomp $f; + if (-d "$FROM/$f") { + if (($DEPTH > 0) && ($FROM !~ $ignore)) { + linkdir("$FROM/$f", "$TO/$f", $DEPTH-1); + } + } else { + link "$FROM/$f", "$TO/$f"; + } + } +} + +mkdir "$ROOT"; +mkdir "$ROOT/bin"; +mkdir "$ROOT/sbin"; +mkdir "$ROOT/dev"; +mkdir "$ROOT/etc"; +mkdir "$ROOT/etc/alternatives"; +mkdir "$ROOT/lib"; +mkdir "$ROOT/lib64"; +mkdir "$ROOT/usr"; +mkdir "$ROOT/usr/bin"; +mkdir "$ROOT/usr/include"; +mkdir "$ROOT/usr/lib"; +mkdir "$ROOT/usr/lib/gcc"; + +linkdir "/bin", "$ROOT/bin", 1; +linkdir "/sbin", "$ROOT/sbin", 1; +link "/etc/passwd", "$ROOT/etc/passwd"; +linkdir "/etc/alternatives", "$ROOT/etc/alternatives", 1; +linkdir "/lib", "$ROOT/lib", 3; +linkdir "/lib64", "$ROOT/lib64", 3; +linkdir "/usr/bin", "$ROOT/usr/bin", 3; +linkdir "/usr/include", "$ROOT/usr/include", 2; +linkdir "/usr/lib", "$ROOT/usr/lib", 3; +linkdir "/usr/lib/gcc", "$ROOT/usr/lib/gcc", 3; + +`make dist`; +my $VERSION=`cat VERSION`; +chomp $VERSION; +`cp chibi-scheme-$VERSION.tgz $ROOT/`; +`sed -e 's/\@VERSION\@/$VERSION/g' $ROOT/bin/run-install-test.sh`; +`chmod 755 $ROOT/bin/run-install-test.sh`; +exec "sudo chroot $ROOT run-install-test.sh"; diff --git a/tests/install/run-install-test.sh b/tests/install/run-install-test.sh new file mode 100755 index 00000000..c558e7cd --- /dev/null +++ b/tests/install/run-install-test.sh @@ -0,0 +1,12 @@ +#! /bin/bash + +export PATH=/usr/local/bin:$PATH +export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH + +tar xzvf chibi-scheme-@VERSION@.tgz +cd chibi-scheme-@VERSION@ +make +make install +cp tests/r5rs-tests.scm .. +cd .. +chibi-scheme r5rs-tests.scm | tee r5rs-tests.out diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm new file mode 100644 index 00000000..1c49d48f --- /dev/null +++ b/tests/loop-tests.scm @@ -0,0 +1,202 @@ + +(import (chibi loop)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test + "stepping" + '(0 1 2) + (loop lp ((with i 0 (+ i 1)) + (with res '() (cons i res))) + (if (= i 3) + (reverse res) + (lp)))) + +(test + "basic in-list" + '(c b a) + (let ((res '())) + (loop ((for x (in-list '(a b c)))) + (set! res (cons x res))) + res)) + +(test + "in-list with result" + '(c b a) + (loop ((for x (in-list '(a b c))) + (with res '() (cons x res))) + => res)) + +(test + "in-list with listing" + '(a b c) + (loop ((for x (in-list '(a b c))) (for res (listing x))) => res)) + +(test + "in-list with listing-reverse" + '(c b a) + (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res)) + +(test + "uneven length in-list's" + '((a . 1) (b . 2) (c . 3)) + (loop ((for x (in-list '(a b c))) + (for y (in-list '(1 2 3 4))) + (for res (listing (cons x y)))) + => res)) + +(test + "in-lists" + '((a 1) (b 2) (c 3)) + (loop ((for ls (in-lists '((a b c) (1 2 3)))) + (for res (listing ls))) + => res)) + +(define (flatten ls) + (reverse + (loop lp ((for x ls (in-list ls)) (with res '())) + => res + (if (pair? x) + (lp (=> res (lp (=> ls x)))) + (lp (=> res (cons x res))))))) + +(test + "flatten (recursion test)" + '(1 2 3 4 5 6 7) + (flatten '(1 (2) (3 (4 (5)) 6) 7))) + +(test + "in-string" + '(#\h #\e #\l #\l #\o) + (loop ((for c (in-string "hello")) (for res (listing c))) => res)) + +(test + "in-string with start" + '(#\l #\o) + (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res)) + +(test + "in-string with start and end" + '(#\h #\e #\l #\l) + (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res)) + +(test + "in-string with start, end and step" + '(#\e #\l) + (loop ((for c (in-string "hello" 1 4 2)) (for res (listing c))) => res)) + +(test + "in-string-reverse" + '(#\o #\l #\l #\e #\h) + (loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res)) + +(test + "in-vector" + '(1 2 3) + (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res)) + +(test "up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 8))) + (for res (listing i))) + => res)) + +(test "up-from by" '(5 10 15) + (loop ((for i (up-from 5 (to 20) (by 5))) + (for res (listing i))) + => res)) + +(test "up-from listing if" '(10 12 14 16 18) + (loop ((for i (up-from 10 (to 20))) + (for res (listing i (if (even? i))))) + => res)) + +(test "down-from" '(7 6 5) + (loop ((for i (down-from 8 (to 5))) + (for res (listing i))) + => res)) + +(test "down-from by" '(15 10 5) + (loop ((for i (down-from 20 (to 5) (by 5))) + (for res (listing i))) + => res)) + +(test "down-from listing if" '(18 16 14 12 10) + (loop ((for i (down-from 20 (to 10))) + (for res (listing i (if (even? i))))) + => res)) + +(test "appending" '(1 2 3 4 5 6 7 8 9) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending ls))) + => res)) + +(test "appending-reverse" '(9 8 7 6 5 4 3 2 1) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending-reverse ls))) + => res)) + +(test "while + up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 10))) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "up-from by, open-ended" '(5 7 9) + (loop ((for i (up-from 5 (by 2))) + (while (< i 10)) + (for res (listing i))) + => res)) + +(test "up-from open-ended" '(5 6 7) + (loop ((for i (up-from 5)) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "down-from by, open-ended" '(5 3 1) + (loop ((for i (down-from 7 (by 2))) + (until (< i 1)) + (for res (listing i))) + => res)) + +(test "down-from open-ended" '(4 3 2) + (loop ((for i (down-from 5)) + (until (< i 2)) + (for res (listing i))) + => res)) + +(test-report) + diff --git a/tests/match-tests.scm b/tests/match-tests.scm new file mode 100644 index 00000000..a223e729 --- /dev/null +++ b/tests/match-tests.scm @@ -0,0 +1,196 @@ + +(import (chibi match)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test "any" (match 'any (_ 'ok)) 'ok) +(test "symbol" (match 'ok (x x)) 'ok) +(test "number" (match 28 (28 'ok)) 'ok) +(test "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok) +(test "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok) +(test "null" (match '() (() 'ok)) 'ok) +(test "pair" (match '(ok) ((x) x)) 'ok) +(test "vector" (match '#(ok) (#(x) x)) 'ok) +(test "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok) +(test "and empty" (match '(o k) ((and) 'ok)) 'ok) +(test "and single" (match 'ok ((and x) x)) 'ok) +(test "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok) +(test "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok) +(test "or single" (match 'ok ((or x) 'ok)) 'ok) +(test "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok) +(test "not" (match 28 ((not (a . b)) 'ok)) 'ok) +(test "pred" (match 28 ((? number?) 'ok)) 'ok) +(test "named pred" (match 28 ((? number? x) (+ x 1))) 29) + +(test "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok) +(test "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok) +(test "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok) + +(test "ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ___) (list x y))) + '((a b c) (1 2 3))) + +(test "real ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ...) (list x y))) + '((a b c) (1 2 3))) + +(test "vector ellipses" + (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) + (#(a b c (hd . tl) ...) (list a b c hd tl))) + '(1 2 3 (a b c) (1 2 3))) + +(test "pred ellipses" + (match '(1 2 3) + (((? odd? n) ___) n) + (((? number? n) ___) n)) + '(1 2 3)) + +(test "failure continuation" + (match '(1 2) + ((a . b) (=> next) (if (even? a) 'fail (next))) + ((a . b) 'ok)) + 'ok) + +(test "let" + (match-let ((x 'ok) (y '(o k))) + y) + '(o k)) + +(test "let*" + (match-let* ((x 'f) (y 'o) ((z w) (list y x))) + (list x y z w)) + '(f o o f)) + +(test "getter car" + (match '(1 . 2) (((get! a) . b) (list (a) b))) + '(1 2)) + +(test "getter cdr" + (match '(1 . 2) ((a . (get! b)) (list a (b)))) + '(1 2)) + +(test "getter vector" + (match '#(1 2 3) (#((get! a) b c) (list (a) b c))) + '(1 2 3)) + +(test "setter car" + (let ((x (cons 1 2))) + (match x (((set! a) . b) (a 3))) + x) + '(3 . 2)) + +(test "setter cdr" + (let ((x (cons 1 2))) + (match x ((a . (set! b)) (b 3))) + x) + '(1 . 3)) + +(test "setter vector" + (let ((x (vector 1 2 3))) + (match x (#(a (set! b) c) (b 0))) + x) + '#(1 0 3)) + +(test "single tail" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) (c . 3))) + +(test "single tail 2" + (match '((a . 1) (b . 2) 3) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) 3)) + +(test "multiple tail" + (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) + (((x . y) ... u v w) (list x y u v w))) + '((a b) (1 2) (c . 3) (d . 4) (e . 5))) + +(test "Riastradh quasiquote" + (match '(1 2 3) (`(1 ,b ,c) (list b c))) + '(2 3)) + +(test "trivial tree search" + (match '(1 2 3) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "simple tree search" + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "deep tree search" + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "non-tail tree search" + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "restricted tree search" + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "fail restricted tree search" + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f)) + #f) + +(test "sxml tree search" + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f)) + '(((href . "http://synthcode.com/")) ("synthcode"))) + +(test "failed sxml tree search" + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f)) + #f) + +(test "collect tree search" + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f)) + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))) + +(test-report) + diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm new file mode 100644 index 00000000..76a783f0 --- /dev/null +++ b/tests/numeric-tests.scm @@ -0,0 +1,150 @@ + +;; these tests are only valid if chibi-scheme is compiled with full +;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-neighborhoods x) + (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) + +(test '(536870912 536870913 536870911 -536870912 -536870911 -536870913) + (integer-neighborhoods (expt 2 29))) + +(test '(1073741824 1073741825 1073741823 -1073741824 -1073741823 -1073741825) + (integer-neighborhoods (expt 2 30))) + +(test '(2147483648 2147483649 2147483647 -2147483648 -2147483647 -2147483649) + (integer-neighborhoods (expt 2 31))) + +(test '(4294967296 4294967297 4294967295 -4294967296 -4294967295 -4294967297) + (integer-neighborhoods (expt 2 32))) + +(test '(4611686018427387904 4611686018427387905 4611686018427387903 + -4611686018427387904 -4611686018427387903 -4611686018427387905) + (integer-neighborhoods (expt 2 62))) + +(test '(9223372036854775808 9223372036854775809 9223372036854775807 + -9223372036854775808 -9223372036854775807 -9223372036854775809) + (integer-neighborhoods (expt 2 63))) + +(test '(18446744073709551616 18446744073709551617 18446744073709551615 + -18446744073709551616 -18446744073709551615 -18446744073709551617) + (integer-neighborhoods (expt 2 64))) + +(test '(85070591730234615865843651857942052864 + 85070591730234615865843651857942052865 + 85070591730234615865843651857942052863 + -85070591730234615865843651857942052864 + -85070591730234615865843651857942052863 + -85070591730234615865843651857942052865) + (integer-neighborhoods (expt 2 126))) + +(test '(170141183460469231731687303715884105728 + 170141183460469231731687303715884105729 + 170141183460469231731687303715884105727 + -170141183460469231731687303715884105728 + -170141183460469231731687303715884105727 + -170141183460469231731687303715884105729) + (integer-neighborhoods (expt 2 127))) + +(test '(340282366920938463463374607431768211456 + 340282366920938463463374607431768211457 + 340282366920938463463374607431768211455 + -340282366920938463463374607431768211456 + -340282366920938463463374607431768211455 + -340282366920938463463374607431768211457) + (integer-neighborhoods (expt 2 128))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-arithmetic-combinations a b) + (list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b))) + +(define (sign-combinations a b) + (list (integer-arithmetic-combinations a b) + (integer-arithmetic-combinations (- a) b) + (integer-arithmetic-combinations a (- b)) + (integer-arithmetic-combinations (- a) (- b)))) + +;; fix x fix +(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0)) + (sign-combinations 0 1)) +(test '((2 0 1 1 0) (0 -2 -1 -1 0) (0 2 -1 -1 0) (-2 0 1 1 0)) + (sign-combinations 1 1)) +(test '((59 25 714 2 8) (-25 -59 -714 -2 -8) + (25 59 -714 -2 8) (-59 -25 714 2 -8)) + (sign-combinations 42 17)) + +;; fix x big +(test '((4294967338 -4294967254 180388626432 0 42) + (4294967254 -4294967338 -180388626432 0 -42) + (-4294967254 4294967338 -180388626432 0 42) + (-4294967338 4294967254 180388626432 0 -42)) + (sign-combinations 42 (expt 2 32))) + +;; big x fix +(test '((4294967338 4294967254 180388626432 102261126 4) + (-4294967254 -4294967338 -180388626432 -102261126 -4) + (4294967254 4294967338 -180388626432 -102261126 4) + (-4294967338 -4294967254 180388626432 102261126 -4)) + (sign-combinations (expt 2 32) 42)) + +;; big x bigger +(test '((12884901889 -4294967297 36893488151714070528 0 4294967296) + (4294967297 -12884901889 -36893488151714070528 0 -4294967296) + (-4294967297 12884901889 -36893488151714070528 0 4294967296) + (-12884901889 4294967297 36893488151714070528 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) + +(test '((18446744078004518913 -18446744069414584321 79228162514264337597838917632 0 4294967296) + (18446744069414584321 -18446744078004518913 -79228162514264337597838917632 0 -4294967296) + (-18446744069414584321 18446744078004518913 -79228162514264337597838917632 0 4294967296) + (-18446744078004518913 18446744069414584321 79228162514264337597838917632 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 64)))) + +;; bigger x big +(test '((12884901889 4294967297 36893488151714070528 2 1) + (-4294967297 -12884901889 -36893488151714070528 -2 -1) + (4294967297 12884901889 -36893488151714070528 -2 1) + (-12884901889 -4294967297 36893488151714070528 2 -1)) + (sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) + +(test '((18446744078004518913 18446744069414584321 79228162514264337597838917632 4294967296 1) + (-18446744069414584321 -18446744078004518913 -79228162514264337597838917632 -4294967296 -1) + (18446744069414584321 18446744078004518913 -79228162514264337597838917632 -4294967296 1) + (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1)) + (sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) + +(test-report) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..1b22acd2 --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,483 @@ + +(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) + (write *tests-run*) + (display ". ") + (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 -2 (let () + (define x 2) + (define f (lambda () (- x))) + (f))) + +(define let*-def 1) +(let* () (define let*-def 2) #f) +(test 1 let*-def) + +(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 4 16 9 8) + `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 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 #f (eqv? 2 2.0)) + +;;(test #f (equal? 2.0 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)) + +;;;; these will fail when compiled either without flonums or trig funcs + +;; (test #t (= -5 (floor -4.3))) + +;; (test #t (= -4 (ceiling -4.3))) + +;; (test #t (= -4 (truncate -4.3))) + +;; (test #t (= -4 (round -4.3))) + +;; (test #t (= 3 (floor 3.5))) + +;; (test #t (= 4 (ceiling 3.5))) + +;; (test #t (= 3 (truncate 3.5))) + +;; (test #t (= 4 (round 3.5))) + +(test 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 127 (string->number "177" 8)) + +(test 5 (string->number "101" 2)) + +(test 100 (string->number "1e2")) + +(test "100" (number->string 100)) + +(test "100" (number->string 256 16)) + +(test "FF" (number->string 255 16)) + +(test "177" (number->string 127 8)) + +(test "101" (number->string 5 2)) + +(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 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + +(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 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad)))) + +(test 'ok (let ((=> 1)) (cond (#t => 'ok)))) + +(test '(,foo) (let ((unquote 1)) `(,foo))) + +(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) + +(test 'ok + (let ((... 2)) + (let-syntax ((s (syntax-rules () + ((_ x ...) 'bad) + ((_ . r) 'ok)))) + (s a b c)))) + +(test 'ok (let () + (let-syntax () + (define internal-def 'ok)) + internal-def)) + +(test 'ok (let () + (letrec-syntax () + (define internal-def 'ok)) + internal-def)) + +(test '(2 1) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y)))))) + +(test '(2 2) + ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y)))))) + +(test '(1 2) + ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y)))))) + +(test '(2 3) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) + +(test '(a b c) + (let* ((path '()) + (add (lambda (s) (set! path (cons s path))))) + (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) + (reverse path))) + +(test '(connect talk1 disconnect connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + +(test 2 (let-syntax + ((foo (syntax-rules ::: () + ((foo ... args :::) + (args ::: ...))))) + (foo 3 - 5))) + +(test '(5 4 1 2 3) + (let-syntax + ((foo (syntax-rules () + ((foo args ... penultimate ultimate) + (list ultimate penultimate args ...))))) + (foo 1 2 3 4 5))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) diff --git a/tools/genstubs.scm b/tools/genstubs.scm new file mode 100755 index 00000000..81b07acc --- /dev/null +++ b/tools/genstubs.scm @@ -0,0 +1,1194 @@ +#! /usr/bin/env chibi-scheme + +;; Note: this evolved as a throw-away script to provide certain core +;; modules, and so is a mess. Tread carefully. + +;; Simple C FFI. "genstubs.scm file.stub" will read in the C function +;; FFI definitions from file.stub and output the appropriate C +;; wrappers into file.c. You can then compile that file with: +;; +;; cc -fPIC -shared file.c -lchibi-scheme +;; +;; (or using whatever flags are appropriate to generate shared libs on +;; your platform) and then the generated .so file can be loaded +;; directly with load, or portably using (include-shared "file") in a +;; module definition (note that include-shared uses no suffix). + +;; The goal of this interface is to make access to C types and +;; functions easy, without requiring the user to write any C code. +;; That means the stubber needs to be intelligent about various C +;; calling conventions and idioms, such as return values passed in +;; actual parameters. Writing C by hand is still possible, and +;; several of the core modules provide C interfaces directly without +;; using the stubber. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Struct Interface +;; +;; (define-c-struct struct-name +;; [predicate: predicate-name] +;; [constructor: constructor-name] +;; [finalizer: c_finalizer_name] +;; (type c_field_name getter-name setter-name) ...) +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Function Interface +;; +;; (define-c return-type name-spec (arg-type ...)) +;; +;; where name-space is either a symbol name, or a list of +;; (scheme-name c_name). If just a symbol, the C name is taken +;; to be the same with -'s replaced by _'s. +;; +;; arg-type is a type suitable for input validation and conversion. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Types +;; +;; Types +;; +;; Basic Types +;; void +;; boolean +;; char +;; sexp (no conversions) +;; +;; Integer Types: +;; signed-char short int long +;; unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t +;; time_t (in seconds, but using the chibi epoch of 2010/01/01) +;; errno (as a return type returns #f on error) +;; +;; Float Types: +;; float double long-double +;; +;; String Types: +;; string - a null-terminated char* +;; env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme +;; in addition you can use (array char) as a string +;; +;; Port Types: +;; input-port output-port +;; +;; Struct Types: +;; +;; Struct types are by default just referred to by the bare +;; struct-name from define-c-struct, and it is assumed you want a +;; pointer to that type. To refer to the full struct, use the struct +;; modifier, as in (struct struct-name). + +;; Type modifiers +;; +;; Any type may also be written as a list of modifiers followed by the +;; type itself. The supported modifiers are: +;; +;; const: prepends the "const" C type modifier +;; * as a return or result parameter, makes non-immediates immutable +;; +;; free: it's Scheme's responsibility to "free" this resource +;; * as a return or result parameter, registers the freep flag +;; this causes the type finalizer to be run when GCed +;; +;; maybe-null: this pointer type may be NULL +;; * as a result parameter, NULL is translated to #f +;; normally this would just return a wrapped NULL pointer +;; * as an input parameter, #f is translated to NULL +;; normally this would be a type error +;; +;; pointer: create a pointer to this type +;; * as a return parameter, wraps the result in a vanilla cpointer +;; * as a result parameter, boxes then unboxes the value +;; +;; struct: treat this struct type as a struct, not a pointer +;; * as an input parameter, dereferences the pointer +;; * as a type field, indicates a nested struct +;; +;; link: add a gc link +;; * as a field getter, link to the parent object, so the +;; parent won't be GCed so long as we have a reference +;; to the child. this behavior is automatic for nested +;; structs. +;; +;; result: return a result in this parameter +;; * if there are multiple results (including the return type), +;; they are all returned in a list +;; * if there are any result parameters, a return type +;; of errno returns #f on failure, and as eliminated +;; from the list of results otherwise +;; +;; (value ): specify a fixed value +;; * as an input parameter, this parameter is not provided +;; in the Scheme API but always passed as +;; +;; (default ): specify a default value +;; * as the final input parameter, makes the Scheme parameter +;; optional, defaulting to +;; +;; (array []) an array type +;; * length must be specified for return and result parameters +;; * if specified, length can be any of +;; ** an integer, for a fixed size +;; ** the symbol null, indicating a NULL-terminated array + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; globals + +(define *types* '()) +(define *funcs* '()) +(define *consts* '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type objects + +(define (parse-type type . o) + (cond + ((vector? type) + type) + (else + (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) + (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f) + (value #f) (default? #f)) + (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) + (case (and (pair? type) (car type)) + ((free) + (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) + ((const) + (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) + ((maybe-null) + (lp (next) free? const? #t ptr? struct? link? result? array value default?)) + ((pointer) + (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) + ((struct) + (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) + ((link) + (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) + ((result) + (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) + ((array) + (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) + ((value) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) + ((default) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) + (else + (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) + +(define (type-base type) (vector-ref type 0)) +(define (type-free? type) (vector-ref type 1)) +(define (type-const? type) (vector-ref type 2)) +(define (type-null? type) (vector-ref type 3)) +(define (type-pointer? type) (vector-ref type 4)) +(define (type-struct? type) (vector-ref type 5)) +(define (type-link? type) (vector-ref type 6)) +(define (type-result? type) (vector-ref type 7)) +(define (type-array type) (vector-ref type 8)) +(define (type-value type) (vector-ref type 9)) +(define (type-default? type) (vector-ref type 10)) +(define (type-index type) (vector-ref type 11)) + +(define (type-auto-expand? type) + (and (pair? (type-array type)) + (memq 'auto-expand (type-array type)))) + +(define (type-index-string type) + (if (integer? (type-index type)) + (number->string (type-index type)) + "")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type predicates + +(define (signed-int-type? type) + (memq type '(signed-char short int long boolean))) + +(define (unsigned-int-type? type) + (memq type '(unsigned-char unsigned-short unsigned-int unsigned-long + size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t + uid_t gid_t pid_t blksize_t blkcnt_t sigval_t))) + +(define (int-type? type) + (or (signed-int-type? type) (unsigned-int-type? type))) + +(define (float-type? type) + (memq type '(float double long-double long-long-double))) + +(define (string-type? type) + (or (memq type '(char* string env-string non-null-string)) + (and (vector? type) + (type-array type) + (not (type-pointer? type)) + (eq? 'char (type-base type))))) + +(define (port-type? type) + (memq type '(port input-port output-port))) + +(define (error-type? type) + (memq type '(errno non-null-string non-null-pointer))) + +(define (array-type? type) + (and (type-array type) (not (eq? 'char (type-base type))))) + +(define (basic-type? type) + (let ((type (parse-type type))) + (and (not (type-array type)) + (not (assq (type-base type) *types*))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; function objects + +(define (parse-func func) + (if (not (and (= 3 (length func)) + (or (identifier? (cadr func)) (list (cadr func))) + (list (caddr func)))) + (error "bad function definition" func)) + (let* ((ret-type (parse-type (car func))) + (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) + (c-name (if (pair? (cadr func)) + (cadadr func) + (mangle scheme-name))) + (stub-name (if (and (pair? (cadr func)) (pair? (cddadr func))) + (car (cddadr func)) + (generate-stub-name scheme-name)))) + (let lp ((ls (caddr func)) + (i 0) + (results '()) + (c-args '()) + (s-args '())) + (cond + ((null? ls) + (if (>= i 6) + (error "FFI currently only supports up to 6 scheme args" func)) + (vector scheme-name c-name stub-name ret-type + (reverse results) (reverse c-args) (reverse s-args))) + (else + (let ((type (parse-type (car ls) i))) + (cond + ((type-result? type) + (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) + ((and (type-value type) (not (type-default? type))) + (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) + (else + (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) + ))))))) + +(define (func-scheme-name func) (vector-ref func 0)) +(define (func-c-name func) (vector-ref func 1)) +(define (func-stub-name func) (vector-ref func 2)) +(define (func-ret-type func) (vector-ref func 3)) +(define (func-results func) (vector-ref func 4)) +(define (func-c-args func) (vector-ref func 5)) +(define (func-scheme-args func) (vector-ref func 6)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (cat . args) + (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (filter pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (cons (car ls) (filter pred (cdr ls)))) + (else (filter pred (cdr ls))))) + +(define (remove pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (filter pred (cdr ls))) + (else (cons (car ls) (filter pred (cdr ls)))))) + +(define (strip-extension path) + (let lp ((i (- (string-length path) 1))) + (cond ((<= i 0) path) + ((eq? #\. (string-ref path i)) (substring path 0 i)) + (else (lp (- i 1)))))) + +(define (string-concatenate-reverse ls) + (cond ((null? ls) "") + ((null? (cdr ls)) (car ls)) + (else (string-concatenate (reverse ls))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase str) + (list->string (map char-downcase (string->list str)))) + +(define (with-output-to-string thunk) + (call-with-output-string + (lambda (out) + (let ((old-out (current-output-port))) + (current-output-port out) + (thunk) + (current-output-port old-out))))) + +(define (definite-article x) + (define (vowel? c) + (memv c '(#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U))) + (define (vowel-exception? str) + (member (string-downcase str) + '("european" "ewe" "unicorn" "unicycle" "university" "user"))) + (define (consonant-exception? str) + ;; not "historic" according to elements of style + (member (string-downcase str) + '("heir" "herb" "herbal" "herbivore" "honest" "honor" "hour"))) + (let* ((full-str (with-output-to-string (lambda () (cat x)))) + (i (string-scan #\space full-str)) + (str (if i (substring full-str 0 i) full-str))) + (string-append + (cond + ((equal? str "") "a ") + ((vowel? (string-ref str 0)) (if (vowel-exception? str) "a " "an ")) + (else (if (consonant-exception? str) "an " "a "))) + full-str))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; naming + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +(define (generate-stub-name sym) + (string-append "sexp_" (mangle sym) "_stub")) + +(define (type-id-name sym) + (string-append "sexp_" (mangle sym) "_type_id")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; .stub file interface + +(define (c-declare . args) + (apply cat args) + (newline)) + +(define (c-include header) + (cat "\n#include \"" header "\"\n")) + +(define (c-system-include header) + (cat "\n#include <" header ">\n")) + +(define (parse-struct-like ls) + (map (lambda (x) (if (pair? x) (cons (parse-type (car x)) (cdr x)) x)) ls)) + +(define-syntax define-struct-like + (er-macro-transformer + (lambda (expr rename compare) + (set! *types* + `((,(cadr expr) + ,@(parse-struct-like (cddr expr))) + ,@*types*)) + `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) + +(define-syntax define-c-struct + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr))))) + +(define-syntax define-c-class + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) + +(define-syntax define-c-type + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) ,@(cddr expr))))) + +(define-syntax define-c + (er-macro-transformer + (lambda (expr rename compare) + (set! *funcs* (cons (parse-func (cdr expr)) *funcs*)) + #f))) + +(define-syntax define-c-const + (er-macro-transformer + (lambda (expr rename compare) + (set! *consts* + (cons (cons (parse-type (cadr expr)) (cddr expr)) *consts*))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; C code generation + +(define (c->scheme-converter type val . o) + (let ((base (type-base type))) + (cond + ((eq? base 'void) + (cat "((" val "), SEXP_VOID)")) + ((or (eq? base 'sexp) (error-type? base)) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_make_boolean(" val ")")) + ((eq? base 'time_t) + (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) + ((unsigned-int-type? base) + (cat "sexp_make_unsigned_integer(ctx, " val ")")) + ((signed-int-type? base) + (cat "sexp_make_integer(ctx, " val ")")) + ((eq? base 'char) + (if (type-array type) + (cat "sexp_c_string(ctx, " val ", -1)") + (cat "sexp_make_character(ctx, " val ")"))) + ((eq? 'env-string base) + (cat "(p=strchr(" val ", '=') ? " + "sexp_cons(ctx, str=sexp_c_string(ctx, " val ", p - " val "), str=sexp_c_string(ctx, p, -1))" + " : sexp_cons(ctx, str=" val ", SEXP_FALSE)")) + ((string-type? base) + (cat "sexp_c_string(ctx, " val ", -1)")) + ((eq? 'input-port base) + (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)")) + ((eq? 'output-port base) + (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) + (else + (let ((ctype (assq base *types*))) + (cond + (ctype + (cat "sexp_make_cpointer(ctx, " (type-id-name base) ", " + val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " + (if (or (type-free? type) + (and (type-result? type) (not (basic-type? type)))) + 1 + 0) + ")")) + (else + (error "unknown type" base)))))))) + +(define (scheme->c-converter type val) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'sexp) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_truep(" val ")")) + ((eq? base 'time_t) + (cat "sexp_unshift_epoch(sexp_uint_value(" val "))")) + ((signed-int-type? base) + (cat "sexp_sint_value(" val ")")) + ((unsigned-int-type? base) + (cat "sexp_uint_value(" val ")")) + ((eq? base 'char) + (cat "sexp_unbox_character(" val ")")) + ((eq? base 'env-string) + (cat "sexp_concat_env_string(" val ")")) + ((string-type? base) + (cat "sexp_string_data(" val ")")) + ((memq base '(port input-port output-port)) + (cat "sexp_port_stream(" val ")")) + (else + (let ((ctype (assq base *types*))) + (cond + (ctype + (cat "(" (type-c-name type) ")" + (if (type-null? type) + "sexp_cpointer_maybe_null_value" + "sexp_cpointer_value") + "(" val ")")) + (else + (error "unknown type" base)))))))) + +(define (type-predicate type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "sexp_exact_integerp") + ((float-type? base) "sexp_flonump") + ((string-type? base) "sexp_stringp") + ((eq? base 'char) "sexp_charp") + ((eq? base 'boolean) "sexp_booleanp") + ((eq? base 'port) "sexp_portp") + ((eq? base 'input-port) "sexp_iportp") + ((eq? base 'output-port) "sexp_oportp") + (else #f)))) + +(define (type-name type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "integer") + ((float-type? base) "flonum") + ((eq? 'boolean base) "int") + (else base)))) + +(define (base-type-c-name base) + (case base + ((string env-string non-null-string) "char*") + (else (symbol->string base)))) + +(define (type-struct-type type) + (let ((type-spec (assq (if (vector? type) (type-base type) type) *types*))) + (cond ((and type-spec (memq 'type: type-spec)) => cadr) + (else #f)))) + +(define (type-c-name type) + (let* ((type (parse-type type)) + (base (type-base type)) + (type-spec (assq base *types*)) + (struct-type (type-struct-type type))) + (string-append + (if (type-const? type) "const " "") + (if struct-type (string-append (symbol->string struct-type) " ") "") + (string-replace (base-type-c-name base) #\- " ") + (if type-spec "*" "") + (if (type-pointer? type) "*" "")))) + +(define (check-type arg type) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'env-string) + (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg + ")) && sexp_stringp(sexp_cdr(" arg ")))")) + ((or (int-type? base) (float-type? base) + (string-type? base) (port-type? base)) + (cat (type-predicate type) "(" arg ")")) + (else + (cond + ((assq base *types*) + (cat + (if (type-null? type) "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " (type-id-name base) "))" + (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) + (else + (display "WARNING: don't know how to check: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (cat "1"))))))) + +(define (write-validator arg type) + (let* ((type (parse-type type)) + (array (type-array type)) + (base-type (type-base type))) + (cond + ((and array (not (string-type? type))) + (cond + ((number? array) + (cat " if (!sexp_listp(ctx, " arg ")" + " || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n" + " return sexp_type_exception(ctx, \"not a list\", " arg ");\n"))) + (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" + " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" + " return sexp_type_exception(ctx, \"not a list of " + (type-name type) "s\", " arg ");\n") + (if (not (number? array)) + (cat " if (! sexp_nullp(res))\n" + " return sexp_type_exception(ctx, \"not a list of " + (type-name type) "s\", " arg ");\n"))) + ((or (int-type? base-type) + (float-type? base-type) + (string-type? base-type) + (port-type? base-type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, \"not " + (definite-article (type-name type)) "\", " + arg ");\n")) + (else + (cond + ((assq base-type *types*) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, \"not " + (definite-article (type-name type)) "\", " arg ");\n")) + ((eq? 'sexp base-type)) + ((string-type? type) + (write-validator arg 'string)) + (else + (display "WARNING: don't know how to validate: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (write type))))))) + +(define (write-parameters args) + (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) + +(define (get-array-length func x) + (let ((len (if (pair? (type-array x)) + (car (reverse (type-array x))) + (type-array x)))) + (if (number? len) + len + (and (symbol? len) + (let* ((str (symbol->string len)) + (len2 (string-length str))) + (and (> len2 3) + (string=? "arg" (substring str 0 3)) + (let ((i (string->number (substring str 3 len2)))) + (if i + (let ((y (list-ref (func-c-args func) i))) + (or (type-value y) len)))))))))) + +(define (write-locals func) + (define (arg-res x) + (string-append "res" (type-index-string x))) + (let* ((ret-type (func-ret-type func)) + (results (func-results func)) + (scheme-args (func-scheme-args func)) + (return-res? (not (error-type? (type-base ret-type)))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons ret-type results))) + (gc-vars (map arg-res results)) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (sexps (if preserve-res? '() '("res"))) + (num-gc-vars (length gc-vars)) + (ints (if (or return-res? + (memq (type-base ret-type) + '(non-null-string non-null-pointer))) + '() + '("err"))) + (ints (if (or (array-type? ret-type) + (any array-type? results) + (any array-type? scheme-args)) + (cons "i" ints) + ints))) + (case (type-base ret-type) + ((non-null-string) (cat " char *err;\n")) + ((non-null-pointer) (cat " void *err;\n"))) + (cond + ((pair? ints) + (cat " int " (car ints)) + (for-each (lambda (x) (display ", ") (display x)) (cdr ints)) + (cat ";\n"))) + (if (any (lambda (a) (eq? 'env-string (type-base a))) + (cons ret-type results)) + (cat " char *p;\n")) + (for-each + (lambda (x) + (let ((len (get-array-length func x))) + (cat " " (type-c-name (type-base x)) " ") + (if (and (type-array x) (not (number? len))) + (cat "*")) + (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) + (if (number? len) + (cat "[" len "]")) + (cat ";\n") + (if (or (vector? len) (type-auto-expand? x)) + (cat " int len" (type-index x) ";\n")) + (if (type-auto-expand? x) + (cat " " (type-c-name (type-base x)) + " *tmp" (type-index-string x) ";\n")))) + (append (if (type-array ret-type) (list ret-type) '()) + results + (remove type-result? (filter type-array scheme-args)))) + (for-each + (lambda (arg) + (cond + ((and (type-pointer? arg) (basic-type? arg)) + (cat " " (type-c-name (type-base arg)) + " tmp" (type-index arg) ";\n")))) + scheme-args) + (cond + ((pair? sexps) + (cat " sexp " (car sexps)) + (for-each (lambda (x) (display ", ") (display x)) (cdr sexps)) + (cat ";\n"))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_var" num-gc-vars "(") + (display (car gc-vars)) + (for-each (lambda (x) (display ", ") (display x)) (cdr gc-vars)) + (cat ");\n") + (cat " sexp_gc_preserve" num-gc-vars "(ctx") + (for-each (lambda (x) (display ", ") (display x)) gc-vars) + (cat ");\n"))))) + +(define (write-validators args) + (for-each + (lambda (a) + (write-validator (string-append "arg" (type-index-string a)) a)) + args)) + +(define (write-temporaries func) + (for-each + (lambda (a) + (let ((len (and (type-array a) (get-array-length func a)))) + (cond + ((and (type-array a) (or (vector? len) (type-auto-expand? a))) + (cat " len" (type-index a) " = " + (lambda () + (if (number? len) (cat len) (scheme->c-converter 'int len))) + ";\n" + " tmp" (type-index a) " = buf" (type-index a) ";\n"))) + (cond + ((and (not (type-result? a)) (type-array a) (not (string-type? a))) + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) + " = (" (type-c-name (type-base a)) "*) malloc(" + "(sexp_unbox_fixnum(sexp_length(ctx, arg" (type-index a) + "))+1) * sizeof(tmp" (type-index a) "[0]));\n")) + (cat " for (i=0, res=arg" (type-index a) + "; sexp_pairp(res); res=sexp_cdr(res), i++) {\n" + " tmp" (type-index a) "[i] = " + (lambda () (scheme->c-converter (type-base a) "sexp_car(res)")) + ";\n" + " }\n") + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) "[i] = NULL;\n"))) + ((and (type-result? a) (not (basic-type? a)) + (not (type-free? a)) (not (type-pointer? a)) + (not (type-auto-expand? a)) + (or (not (type-array a)) + (not (integer? len)))) + (cat " tmp" (type-index a) " = malloc(" + (if (and (symbol? len) (not (eq? len 'null))) + (lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len)) + "*sizeof(tmp" (type-index a) "[0])")) + (lambda () (cat "sizeof(tmp" (type-index a) "[0])"))) + ");\n")) + ((and (type-pointer? a) (basic-type? a)) + (cat " tmp" (type-index a) " = " + (lambda () + (scheme->c-converter + a + (string-append "arg" (type-index-string a)))) + ";\n"))))) + (func-c-args func))) + +(define (write-actual-parameter func arg) + (cond + ((and (not (type-default? arg)) (type-value arg)) + => (lambda (x) + (cond + ((any (lambda (y) + (and (type-array y) + (type-auto-expand? y) + (eq? x (get-array-length func y)))) + (func-c-args func)) + => (lambda (y) (cat "len" (type-index y)))) + (else (write x))))) + ((or (type-result? arg) (type-array arg)) + (cat (if (or (type-pointer? arg) (type-free? arg) (basic-type? arg)) + "&" + "") + "tmp" (type-index arg))) + ((and (type-pointer? arg) (basic-type? arg)) + (cat "&tmp" (type-index arg))) + (else + (scheme->c-converter + arg + (string-append "arg" (type-index-string arg)))))) + +(define (write-call func) + (let ((ret-type (func-ret-type func)) + (c-name (func-c-name func)) + (c-args (func-c-args func))) + (if (any type-auto-expand? (func-c-args func)) + (cat " loop:\n")) + (cat (cond ((error-type? (type-base ret-type)) " err = ") + ((type-array ret-type) " tmp = ") + (else " res = "))) + ((if (type-array ret-type) + (lambda (t f x) (f)) + c->scheme-converter) + ret-type + (lambda () + (cat c-name "(") + (for-each + (lambda (arg) + (if (> (type-index arg) 0) (cat ", ")) + (write-actual-parameter func arg)) + c-args) + (cat ")")) + (cond + ((any type-link? (func-c-args func)) + => (lambda (a) (string-append "arg" (type-index-string a)))) + (else #f))) + (cat ";\n") + (if (type-array ret-type) + (write-result ret-type)))) + +(define (write-result result) + (let ((res (string-append "res" (type-index-string result))) + (tmp (string-append "tmp" (type-index-string result)))) + (cond + ((and (type-array result) (eq? 'char (type-base result))) + (cat " " res " = " (lambda () (c->scheme-converter result tmp)) ";\n")) + ((type-array result) + (cat " " res " = SEXP_NULL;\n") + (let ((auto-expand? + (and (pair? (type-array result)) + (memq 'auto-expand (type-array result)))) + (len (if (pair? (type-array result)) + (car (reverse (type-array result))) + (type-array result)))) + (cond + ((eq? 'null len) + (cat " for (i=0; " tmp "[i]; i++) {\n" + " sexp_push(ctx, " res ", " + (if (eq? 'string (type-base result)) + "str=" + (lambda () (cat "SEXP_VOID);\n sexp_car(" res ") = "))) + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ");\n" + " }\n" + " " res " = sexp_nreverse(ctx, " res ");\n")) + (else + (cat " for (i=" len "-1; i>=0; i--) {\n" + " sexp_push(ctx, " res ", SEXP_VOID);\n" + " sexp_car(" res ") = " + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ";\n" + " }\n"))))) + (else + (cat " " res " = ") + (c->scheme-converter + result + (string-append "tmp" (type-index-string result))) + (cat ";\n"))))) + +(define (write-results func) + (let ((error-res? (error-type? (type-base (func-ret-type func)))) + (results (func-results func))) + (if error-res? + (cat " if (" + (if (memq (type-base (func-ret-type func)) + '(non-null-string non-null-pointer)) + "!" + "") + "err) {\n" + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (lambda () + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")) + (cat " len" i " *= 2;\n" + " tmp" i + " = malloc(len" i "*sizeof(tmp" i "[0]));\n" + " goto loop;\n"))))) + (else + " res = SEXP_FALSE;\n")) + " } else {\n")) + (if (null? results) + (if error-res? + (cat " res = SEXP_TRUE;\n")) + (for-each write-result results)) + (cond + ((> (length results) (if error-res? 1 0)) + (if error-res? + (cat " res = SEXP_NULL;\n") + (cat " res = sexp_cons(ctx, res, SEXP_NULL);\n")) + (for-each + (lambda (x) + (if error-res? + (cat " sexp_push(ctx, res, res" (type-index x) ");\n") + (cat " sexp_push(ctx, res, sexp_car(res));\n" + " sexp_cadr(res) = res" (type-index x) ";\n"))) + (reverse results))) + ((pair? results) + (cat " res = res" (type-index (car results)) ";\n"))) + (if error-res? + (cat " }\n")))) + +(define (write-free type) + (if (type-array type) + (cat " free(tmp" (type-index-string type) ");\n"))) + +(define (write-cleanup func) + (for-each write-free (func-scheme-args func)) + (for-each + (lambda (a) + (cond + ((type-auto-expand? a) + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")))) + ((and (type-result? a) (not (basic-type? a)) + (not (type-free? a)) (not (type-pointer? a)) + (or (not (type-array a)) + (not (integer? (get-array-length func a))))) + (cat " free(tmp" (type-index a) ");\n")))) + (func-c-args func)) + (let* ((results (func-results func)) + (return-res? (not (error-type? (type-base (func-ret-type func))))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons (func-ret-type func) + (func-results func)))) + (gc-vars results) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (num-gc-vars (length gc-vars))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_release" num-gc-vars "(ctx);\n"))))) + +(define (write-func func) + (cat "static sexp " (func-stub-name func) + " (sexp ctx" (write-parameters (func-scheme-args func)) ") {\n") + (write-locals func) + (write-validators (func-scheme-args func)) + (write-temporaries func) + (write-call func) + (write-results func) + (write-cleanup func) + (cat " return res;\n" + "}\n\n")) + +(define (parameter-default? x) + (and (pair? x) + (member x '((current-input-port) + (current-output-port) + (current-error-port))))) + +(define (write-default x) ;; this is a hack but very convenient + (lambda () + (let ((value (type-value x))) + (cond + ((equal? value '(current-input-port)) + (cat "\"*current-input-port*\"")) + ((equal? value '(current-output-port)) + (cat "\"*current-output-port*\"")) + ((equal? value '(current-error-port)) + (cat "\"*current-error-port*\"")) + (else + (c->scheme-converter x value)))))) + +(define (write-func-binding func) + (let ((default (and (pair? (func-scheme-args func)) + (type-default? (car (reverse (func-scheme-args func)))) + (car (reverse (func-scheme-args func)))))) + (cat (if default + (if (parameter-default? (type-value default)) + " sexp_define_foreign_param(ctx, env, " + " sexp_define_foreign_opt(ctx, env, ") + " sexp_define_foreign(ctx, env, ") + (lambda () (write (symbol->string (func-scheme-name func)))) + ", " (length (func-scheme-args func)) ", " + (if default "(sexp_proc1)" "") + (func-stub-name func) + (if default ", " "") + (if default (write-default default) "") + ");\n"))) + +(define (write-type type) + (let ((name (car type)) + (type (cdr type))) + (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" + " " (type-id-name name) + " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, " + (cond ((memq 'finalizer: type) + => (lambda (x) (generate-stub-name (cadr x)))) + (else "sexp_finalize_c_type")) + "));\n") + (cond + ((memq 'predicate: type) + => (lambda (x) + (let ((pred (cadr x))) + (cat " tmp = sexp_make_type_predicate(ctx, name, " + "sexp_make_fixnum(" (type-id-name name) "));\n" + " name = sexp_intern(ctx, \"" pred "\");\n" + " sexp_env_define(ctx, env, name, tmp);\n"))))))) + +(define (type-getter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_get_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-getter type name field) + (cat "static sexp " (type-getter-name type name field) + " (sexp ctx, sexp x) {\n" + (lambda () (write-validator "x" name)) + " return " + (lambda () + (c->scheme-converter + (car field) + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (x->string (cadr field))) + (and (or (type-struct? (car field)) (type-link? (car field))) "x"))) + ";\n" + "}\n\n")) + +(define (type-setter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_set_" (x->string (type-base (parse-type (car field)))))) + +(define (write-type-setter type name field) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx, sexp x, sexp v) {\n" + (lambda () (write-validator "x" name)) + (lambda () (write-validator "v" (car field))) + " " + (lambda () (c->scheme-converter + (car field) + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (x->string (cadr field))))) + " = v;\n" + " return SEXP_VOID;" + "}\n\n")) + +(define (write-type-funcs type) + (let ((name (car type)) + (type (cdr type))) + ;; maybe write finalizer + (cond + ((memq 'finalizer: type) + => (lambda (x) + (cat "static sexp " (generate-stub-name (cadr x)) + " (sexp ctx, sexp x) {\n" + " if (sexp_cpointer_freep(x))\n" + " " (cadr x) "(sexp_cpointer_value(x));\n" + " return SEXP_VOID;\n" + "}\n\n")))) + ;; maybe write constructor + (cond + ((memq 'constructor: type) + => (lambda (x) + (let ((make (caadr x)) + (args (cdadr x))) + (cat "static sexp " (generate-stub-name make) + " (sexp ctx" + (lambda () (for-each (lambda (x) (cat ", sexp " x)) args)) + ") {\n" + " struct " (type-name name) " *r;\n" + " sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + (type-id-name name) + ");\n" + " sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " r = sexp_cpointer_value(res);\n" + " return res;\n" + "}\n\n") + (set! *funcs* + (cons (parse-func `(void ,make ,args)) *funcs*)))))) + ;; write field accessors + (for-each + (lambda (field) + (cond + ((and (pair? field) (pair? (cdr field))) + (cond + ((and (pair? (cddr field)) (caddr field)) + (write-type-getter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(caddr field) + #f + ,(type-getter-name type name field)) + (,name))) + *funcs*)))) + (cond + ((and (pair? (cddr field)) + (pair? (cdddr field)) + (car (cdddr field))) + (write-type-setter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(car (cdddr field)) + #f + ,(type-setter-name type name field)) + (,name ,(car field)))) + *funcs*))))))) + type))) + +(define (write-const const) + (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) + (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) + (cat " name = sexp_intern(ctx, \"" scheme-name "\");\n" + " sexp_env_define(ctx, env, name, tmp=" + (lambda () (c->scheme-converter (car const) c-name)) ");\n"))) + +(define (write-utilities) + (define (input-env-string? x) + (and (eq? 'env-string (type-base x)) (not (type-result? x)))) + (cond + ((any (lambda (f) + (or (any input-env-string? (func-results f)) + (any input-env-string? (func-scheme-args f)))) + *funcs*) + (cat "static char* sexp_concat_env_string (sexp x) {\n" + " int klen=sexp_string_length(sexp_car(x)), vlen=sexp_string_length(sexp_cdr(x));\n" + " char *res = (char*) malloc(klen+vlen+2);\n" + " strncpy(res, sexp_string_data(sexp_car(x)), klen);\n" + " res[sexp_string_length(sexp_car(x))] = '=';\n" + " strncpy(res+sexp_string_length(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n" + " res[len-1] = '\\0';\n" + " return res;\n" + "}\n\n")))) + +(define (write-init) + (newline) + (write-utilities) + (for-each write-func *funcs*) + (for-each write-type-funcs *types*) + (cat "sexp sexp_init_library (sexp ctx, sexp env) {\n" + " sexp_gc_var2(name, tmp);\n" + " sexp_gc_preserve2(ctx, name, tmp);\n") + (for-each write-const *consts*) + (for-each write-type *types*) + (for-each write-func-binding *funcs*) + (cat " sexp_gc_release2(ctx);\n" + " return SEXP_VOID;\n" + "}\n\n")) + +(define (generate file) + (display "/* automatically generated by chibi genstubs */\n") + (c-system-include "chibi/eval.h") + (load file) + (write-init)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main + +(define (main args) + (case (length args) + ((1) + (with-output-to-file (string-append (strip-extension (car args)) ".c") + (lambda () (generate (car args))))) + ((2) + (if (equal? "-" (cadr args)) + (generate (car args)) + (with-output-to-file (cadr args) (lambda () (generate (car args)))))) + (else + (error "usage: genstubs []")))) From cb44b8f4fe3a4ceb341e3edb470856d1785d1938 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 31 Dec 2009 01:20:09 +0900 Subject: [PATCH 326/535] adding port folding utils --- lib/chibi/io.module | 4 +++- lib/chibi/io/io.scm | 49 ++++++++++++++++++++++++++++++++++++++++++++ lib/chibi/io/io.stub | 6 +++--- 3 files changed, 55 insertions(+), 4 deletions(-) diff --git a/lib/chibi/io.module b/lib/chibi/io.module index f20b5b31..f9d531f3 100644 --- a/lib/chibi/io.module +++ b/lib/chibi/io.module @@ -1,6 +1,8 @@ (define-module (chibi io) - (export read-string read-string! write-string read-line write-line) + (export read-string read-string! write-string read-line write-line + port-fold port-fold-right port-map + port->list port->string-list port->sexp-list port->string) (import-immutable (scheme)) (include-shared "io/io") (include "io/io.scm")) diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm index 3ffa8a98..a6e0f8d2 100644 --- a/lib/chibi/io/io.scm +++ b/lib/chibi/io/io.scm @@ -1,6 +1,55 @@ +(define eof + (call-with-input-string " " + (lambda (in) (read-char in) (read-char in)))) + (define (write-line str . o) (let ((out (if (pair? o) (car o) (current-output-port)))) (display str out) (newline out))) +(define (read-line . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192))) + (let ((res (%read-line n in))) + (if (not res) eof res)))) + +(define (read-string n . o) + (let ((in (if (pair? o) (car o) (current-input-port)))) + (let ((res (%read-string n in))) + (if (if (pair? res) (= 0 (car res)) #t) + eof + (cadr res))))) + +(define (port-fold kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp ((acc knil)) + (let ((x (read in))) + (if (eof-object? x) acc (lp (kons x acc))))))) + +(define (port-fold-right kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp () + (let ((x (read in))) + (if (eof-object? x) knil (kons x (lp))))))) + +(define (port-map fn . o) + (reverse (apply port-fold (lambda (x ls) (cons (fn x) ls)) '() o))) + +(define (port->list read in) + (port-map (lambda (x) x) read in)) + +(define (port->sexp-list in) + (port->list read in)) + +(define (port->string-list in) + (port->list read-line in)) + +(define (port->string in) + (string-concatenate (port->list (lambda (in) (read-string 1024 in)) in))) diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub index 665d1bb5..685e1832 100644 --- a/lib/chibi/io/io.stub +++ b/lib/chibi/io/io.stub @@ -1,9 +1,9 @@ -(define-c non-null-string (read-line "fgets") +(define-c non-null-string (%read-line "fgets") ((result (array char arg1)) int (default (current-input-port) input-port))) -(define-c size_t (read-string "fread") - ((result (array char arg1)) size_t (value 1 size_t) (default (current-input-port) input-port))) +(define-c size_t (%read-string "fread") + ((result (array char arg2)) (value 1 size_t) size_t (default (current-input-port) input-port))) (define-c size_t (read-string! "fread") (string size_t (value 1 size_t) (default (current-input-port) input-port))) From 5469e699b6cddc981841d7313b3aa1eb49a3ccfa Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 31 Dec 2009 13:10:35 +0900 Subject: [PATCH 327/535] fixing bug introduced when the space after the -l option was made optional --- main.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main.c b/main.c index 6edd9185..4944520b 100644 --- a/main.c +++ b/main.c @@ -107,7 +107,7 @@ void run_main (int argc, char **argv) { case 'l': load_init(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); - check_exception(ctx, sexp_load_module_file(ctx, argv[++i], env)); + check_exception(ctx, sexp_load_module_file(ctx, arg, env)); break; case 'm': load_init(); From 36732f9134e539867b5d84f0010b2de922830b19 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 31 Dec 2009 13:40:23 +0900 Subject: [PATCH 328/535] is-a-tty? --- lib/chibi/filesystem.module | 2 +- lib/chibi/filesystem.stub | 3 +++ tools/genstubs.scm | 8 +++++++- 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module index 38a8fab1..f7fa4e99 100644 --- a/lib/chibi/filesystem.module +++ b/lib/chibi/filesystem.module @@ -20,7 +20,7 @@ open/read open/write open/read-write open/create open/exclusive open/truncate open/append open/non-block - ) + is-a-tty?) (import-immutable (scheme)) (include-shared "filesystem") (include "filesystem.scm")) diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub index 8c42466f..5656fcdc 100644 --- a/lib/chibi/filesystem.stub +++ b/lib/chibi/filesystem.stub @@ -113,3 +113,6 @@ (define-c-const int (open/truncate "O_TRUNC")) (define-c-const int (open/append "O_APPEND")) (define-c-const int (open/non-block "O_NONBLOCK")) + +(define-c boolean (is-a-tty? "isatty") (port-or-fd)) + diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 81b07acc..fc2c18e0 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -507,7 +507,10 @@ (cat "sexp_concat_env_string(" val ")")) ((string-type? base) (cat "sexp_string_data(" val ")")) - ((memq base '(port input-port output-port)) + ((eq? base 'port-or-fd) + (cat "(sexp_portp(" val ") ? fileno(sexp_port_stream(" val "))" + " : sexp_unbox_fixnum(" val "))")) + ((port-type? base) (cat "sexp_port_stream(" val ")")) (else (let ((ctype (assq base *types*))) @@ -607,6 +610,9 @@ (cat " if (! sexp_nullp(res))\n" " return sexp_type_exception(ctx, \"not a list of " (type-name type) "s\", " arg ");\n"))) + ((eq? base-type 'port-or-fd) + (cat "if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" + " return sexp_type_exception(ctx, \"not a port of file descriptor\"," arg ");\n")) ((or (int-type? base-type) (float-type? base-type) (string-type? base-type) From 718fc2a4b14c53fc73543e1795e952a3d90bf17d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 31 Dec 2009 13:49:47 +0900 Subject: [PATCH 329/535] ignoring generated files --- .hgignore | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/.hgignore b/.hgignore index babe41d2..386b5fc8 100644 --- a/.hgignore +++ b/.hgignore @@ -19,3 +19,9 @@ gc6.8 chibi-scheme chibi-scheme-static include/chibi/install.h +lib/chibi/filesystem.c +lib/chibi/io/io.c +lib/chibi/net.c +lib/chibi/process.c +lib/chibi/system.c +lib/chibi/time.c From 87fa6e3b7e01bab1cb608857980ff2fb53991a4f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 31 Dec 2009 22:51:31 +0900 Subject: [PATCH 330/535] adding libchibi-sexp.so for people who just want the read/write functionality without any evaluator --- Makefile | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Makefile b/Makefile index ddfc56e3..8b58ef90 100644 --- a/Makefile +++ b/Makefile @@ -108,6 +108,9 @@ eval.o: eval.c opcodes.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefil main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< +libchibi-sexp$(SO): sexp.o + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) + libchibi-scheme$(SO): eval.o sexp.o $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) From 4a5cae51aee22976112093d9d9ece8631b7dc5bc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 1 Jan 2010 16:16:40 +0900 Subject: [PATCH 331/535] forgot to preserve a var on remainder --- opt/bignum.c | 12 +++++++----- sexp.c | 2 +- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/opt/bignum.c b/opt/bignum.c index fb211725..d80fb6cb 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -434,8 +434,10 @@ sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { } sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { - sexp rem; + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */ + sexp_gc_release1(ctx); return rem; } @@ -605,9 +607,9 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) { sexp sexp_div (sexp ctx, sexp a, sexp b) { int at=sexp_number_type(a), bt=sexp_number_type(b); double f; - sexp r=SEXP_VOID, rem; - sexp_gc_var1(tmp); - sexp_gc_preserve1(ctx, tmp); + sexp r=SEXP_VOID; + sexp_gc_var2(tmp, rem); + sexp_gc_preserve2(ctx, tmp, rem); switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: @@ -651,7 +653,7 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) { r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b)); break; } - sexp_gc_release1(ctx); + sexp_gc_release2(ctx); return r; } diff --git a/sexp.c b/sexp.c index 2a3ff0f6..b6eab627 100644 --- a/sexp.c +++ b/sexp.c @@ -79,7 +79,7 @@ static struct sexp_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string", NULL), _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector", NULL), _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum", NULL), - _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum", NULL), + _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), "bignum", NULL), _DEF_TYPE(SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL), _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", SEXP_FINALIZE_PORT), _DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port", SEXP_FINALIZE_PORT), From 85298f69e12fc8cb003cebf921e5ae9940cfe087 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 1 Jan 2010 16:32:17 +0900 Subject: [PATCH 332/535] adding release-name and features to -V option --- doc/chibi-scheme.1 | 2 +- main.c | 10 +++++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1 index f20c50e5..b84620d5 100644 --- a/doc/chibi-scheme.1 +++ b/doc/chibi-scheme.1 @@ -13,7 +13,7 @@ chibi-scheme \- a tiny Scheme interpreter [-A .I path ] -[-u +[-m .I module ] [-l diff --git a/main.c b/main.c index 4944520b..3fc018bf 100644 --- a/main.c +++ b/main.c @@ -10,6 +10,8 @@ #define sexp_import_prefix "(import (" #define sexp_import_suffix "))" +#define sexp_version_string "chibi-scheme "sexp_version" \""sexp_release_name"\" " + #ifdef PLAN9 #define exit_failure() exits("ERROR") #else @@ -152,7 +154,13 @@ void run_main (int argc, char **argv) { } break; case 'V': - printf("chibi-scheme 0.3\n"); + load_init(); + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", env); + sexp_write_string(ctx, sexp_version_string, out); + tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*"), SEXP_NULL); + sexp_write(ctx, tmp, out); + sexp_newline(ctx, out); return; default: fprintf(stderr, "unknown option: %s\n", argv[i]); From 3132cb8c42c48c2e82e94ee215c2a7be87a3a8b8 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 1 Jan 2010 23:33:38 +0900 Subject: [PATCH 333/535] don't free result pointers --- tools/genstubs.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index fc2c18e0..786a0717 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -943,9 +943,11 @@ (cat " if (len" i " != " len ")\n" " free(tmp" i ");\n")))) ((and (type-result? a) (not (basic-type? a)) + (not (assq (type-base a) *types*)) (not (type-free? a)) (not (type-pointer? a)) (or (not (type-array a)) (not (integer? (get-array-length func a))))) + ;; the above is hairy - basically this frees temporary strings (cat " free(tmp" (type-index a) ");\n")))) (func-c-args func)) (let* ((results (func-results func)) From ad4f044963634ef6b6bbff4091b16d9386bd2fad Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 1 Jan 2010 23:36:17 +0900 Subject: [PATCH 334/535] adding predicates --- lib/chibi/time.module | 3 ++- lib/chibi/time.stub | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/chibi/time.module b/lib/chibi/time.module index 84f2b800..8d591100 100644 --- a/lib/chibi/time.module +++ b/lib/chibi/time.module @@ -5,7 +5,8 @@ timeval-seconds timeval-microseconds timezone-offset timezone-dst-time time-second time-minute time-hour time-day time-month time-year - time-day-of-week time-day-of-year time-dst?) + time-day-of-week time-day-of-year time-dst? + tm? timeval? timezone?) (import-immutable (scheme)) (include-shared "time")) diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub index bb5cd644..adde486e 100644 --- a/lib/chibi/time.stub +++ b/lib/chibi/time.stub @@ -3,6 +3,7 @@ (c-system-include "sys/time.h") (define-c-struct tm + predicate: tm? (int tm_sec time-second) (int tm_min time-minute) (int tm_hour time-hour) From 22968ec7b3c0dc8c40f7c3d0d4a30405f054ff73 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 2 Jan 2010 01:15:26 +0900 Subject: [PATCH 335/535] sexp_bignum_to_double was backwards --- opt/bignum.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/opt/bignum.c b/opt/bignum.c index d80fb6cb..b1b82780 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -139,8 +139,9 @@ sexp sexp_bignum_normalize (sexp a) { double sexp_bignum_to_double (sexp a) { double res = 0; - sexp_uint_t i, *data=sexp_bignum_data(a); - for (i=0; i=0; i--) res = res * ((double)SEXP_UINT_T_MAX+1) + data[i]; return res; } From 227a094399e8e8bab2ce52be94c38aab4a8c2e7d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 2 Jan 2010 12:02:20 +0900 Subject: [PATCH 336/535] offby1 error in bignum_to_double also fixing exact? definition to include bignums --- lib/init.scm | 2 +- opt/bignum.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/init.scm b/lib/init.scm index e1b7b256..853e2f99 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -425,7 +425,7 @@ (define complex? number?) (define rational? number?) (define real? number?) -(define exact? fixnum?) +(define (exact? x) (if (fixnum? x) #t (bignum? x))) (define inexact? flonum?) (define (integer? x) (if (fixnum? x) #t (if (bignum? x) #t (and (flonum? x) (= x (truncate x)))))) diff --git a/opt/bignum.c b/opt/bignum.c index b1b82780..8cbd012a 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -141,7 +141,7 @@ double sexp_bignum_to_double (sexp a) { double res = 0; sexp_sint_t i; sexp_uint_t *data=sexp_bignum_data(a); - for (i=sexp_bignum_hi(a); i>=0; i--) + for (i=sexp_bignum_hi(a)-1; i>=0; i--) res = res * ((double)SEXP_UINT_T_MAX+1) + data[i]; return res; } From 7c08c67815cf4563e3e6fb2e31cc275a2319690a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 2 Jan 2010 12:19:00 +0900 Subject: [PATCH 337/535] also forgot to propagate the sign in bignum_to_double --- opt/bignum.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/opt/bignum.c b/opt/bignum.c index 8cbd012a..9af36997 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -143,7 +143,7 @@ double sexp_bignum_to_double (sexp a) { sexp_uint_t *data=sexp_bignum_data(a); for (i=sexp_bignum_hi(a)-1; i>=0; i--) res = res * ((double)SEXP_UINT_T_MAX+1) + data[i]; - return res; + return res * sexp_bignum_sign(a); } sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) { From 562ec60926a9fa87f30ed38606cceb391072c8e5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 2 Jan 2010 20:14:32 +0900 Subject: [PATCH 338/535] adding extended io utils, including custom ports, with high-level custom port constructors such as concatenated and filtered ports. --- TODO | 6 ++- include/chibi/sexp.h | 4 ++ lib/chibi/io.module | 7 ++- lib/chibi/io/io.scm | 108 +++++++++++++++++++++++++++++++++++++++++++ lib/chibi/io/io.stub | 18 +++++++- sexp.c | 2 + 6 files changed, 140 insertions(+), 5 deletions(-) diff --git a/TODO b/TODO index 93f7c837..3e01c1f5 100644 --- a/TODO +++ b/TODO @@ -60,7 +60,8 @@ - State "DONE" [2009-07-07 Tue 14:42] ** TODO unicode ** TODO threads -** TODO virtual ports +** DONE virtual ports + - State "DONE" [2010-01-02 Sat 20:12] ** DONE dynamic-wind - State "DONE" [2009-12-26 Sat 01:51] Adapted a version from Scheme48. @@ -114,7 +115,8 @@ - State "DONE" [2009-12-26 Sat 01:50] *** DONE time interface - State "DONE" [2009-12-26 Sat 01:50] -*** TODO host system interface +*** DONE host system interface + - State "DONE" [2010-01-02 Sat 20:12] ** DONE pathname library - State "DONE" [2009-12-16 Wed 18:58] ** DONE uri library diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 369e3b65..491e70a9 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -460,6 +460,10 @@ sexp sexp_make_flonum(sexp ctx, double f); #define SEXP_THREE sexp_make_fixnum(3) #define SEXP_FOUR sexp_make_fixnum(4) #define SEXP_FIVE sexp_make_fixnum(5) +#define SEXP_SIX sexp_make_fixnum(6) +#define SEXP_SEVEN sexp_make_fixnum(7) +#define SEXP_EIGHT sexp_make_fixnum(8) +#define SEXP_NINE sexp_make_fixnum(9) #define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) diff --git a/lib/chibi/io.module b/lib/chibi/io.module index f9d531f3..ec765c04 100644 --- a/lib/chibi/io.module +++ b/lib/chibi/io.module @@ -2,7 +2,12 @@ (define-module (chibi io) (export read-string read-string! write-string read-line write-line port-fold port-fold-right port-map - port->list port->string-list port->sexp-list port->string) + port->list port->string-list port->sexp-list port->string + file-position set-file-position! seek/set seek/cur seek/end + make-custom-input-port make-custom-output-port + make-null-output-port make-broadcast-port make-concatenated-port + make-generated-input-port make-filtered-output-port + make-filtered-input-port) (import-immutable (scheme)) (include-shared "io/io") (include "io/io.scm")) diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm index a6e0f8d2..97de1cc6 100644 --- a/lib/chibi/io/io.scm +++ b/lib/chibi/io/io.scm @@ -1,8 +1,22 @@ +;; io.scm -- various input/output utilities +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities (define eof (call-with-input-string " " (lambda (in) (read-char in) (read-char in)))) +(define (string-copy! dst start src from to) + (do ((i from (+ i 1)) (j start (+ j 1))) + ((>= i to)) + (string-set! dst j (string-ref src i)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; reading and writing + (define (write-line str . o) (let ((out (if (pair? o) (car o) (current-output-port)))) (display str out) @@ -21,6 +35,9 @@ eof (cadr res))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; higher order port operations + (define (port-fold kons knil . o) (let ((read (if (pair? o) (car o) read)) (in (if (and (pair? o) (pair? (cdr o))) @@ -53,3 +70,94 @@ (define (port->string in) (string-concatenate (port->list (lambda (in) (read-string 1024 in)) in))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; custom port utilities + +(define (make-custom-input-port read . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-input-port read seek close))) + +(define (make-custom-output-port write . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-output-port write seek close))) + +(define (make-null-output-port) + (make-custom-output-port (lambda (str n) 0))) + +(define (make-broadcast-port . ports) + (make-custom-output-port + (lambda (str n) + (for-each (lambda (p) (write-string str n p)) ports) + n))) + +(define (make-filtered-output-port filter out) + (make-custom-output-port + (lambda (str n) + (let* ((len (string-length str)) + (s1 (if (= n len) str (substring str 0 n))) + (s2 (filter s1))) + (if (string? s2) + (write-string s2 (string-length s2) out)))))) + +(define (make-concatenated-port . ports) + (make-custom-input-port + (lambda (str n) + (if (null? ports) + 0 + (let lp ((i (read-string! str n (car ports)))) + (cond + ((>= i n) + i) + (else + (set! ports (cdr ports)) + (cond + ((null? ports) + i) + (else + (let* ((s (read-string (- n i) (car ports))) + (len (if (string? s) (string-length s) 0))) + (if (and (string? str) (> len 0)) + (string-copy! str i s 0 len)) + (lp (+ i len)))))))))))) + +(define (make-generated-input-port generator) + (let ((buf "") + (len 0) + (offset 0)) + (make-custom-input-port + (lambda (str n) + (cond + ((>= (- len offset) n) + (string-copy! str 0 buf offset (+ offset n)) + (set! offset (+ offset n)) + n) + (else + (string-copy! str 0 buf offset len) + (let lp ((i (- len offset))) + (set! buf (generator)) + (cond + ((not (string? buf)) + (set! buf "") + (set! len 0) + (set! offset 0) + (- n i)) + (else + (set! len (string-length buf)) + (set! offset 0) + (cond + ((>= (- len offset) (- n i)) + (string-copy! str i buf offset (+ offset (- n i))) + (set! offset (+ offset (- n i))) + n) + (else + (string-copy! str i buf offset len) + (lp (+ i (- len offset)))))))))))))) + +(define (make-filtered-input-port filter in) + (make-generated-input-port + (lambda () + (let ((res (read-string 1024 in))) + (if (string? res) (filter res) res))))) diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub index 685e1832..208d0a18 100644 --- a/lib/chibi/io/io.stub +++ b/lib/chibi/io/io.stub @@ -6,8 +6,22 @@ ((result (array char arg2)) (value 1 size_t) size_t (default (current-input-port) input-port))) (define-c size_t (read-string! "fread") - (string size_t (value 1 size_t) (default (current-input-port) input-port))) + (string (value 1 size_t) size_t (default (current-input-port) input-port))) (define-c size_t (write-string "fwrite") - (string size_t (value 1 size_t) (default (current-output-port) output-port))) + (string (value 1 size_t) size_t (default (current-output-port) output-port))) +(define-c-const int (seek/set "SEEK_SET")) +(define-c-const int (seek/cur "SEEK_CUR")) +(define-c-const int (seek/end "SEEK_END")) + +(define-c long (file-position "ftell") (port)) +(define-c long (set-file-position! "fseek") (port long int)) + +(c-include "port.c") + +(define-c sexp (%make-custom-input-port "sexp_make_custom_input_port") + ((value ctx sexp) sexp sexp sexp)) + +(define-c sexp (%make-custom-output-port "sexp_make_custom_output_port") + ((value ctx sexp) sexp sexp sexp)) diff --git a/sexp.c b/sexp.c index b6eab627..5e313b12 100644 --- a/sexp.c +++ b/sexp.c @@ -291,7 +291,9 @@ sexp sexp_make_context (sexp ctx, sexp_uint_t size) { #if ! SEXP_USE_GLOBAL_HEAP void sexp_destroy_context (sexp ctx) { sexp_heap heap; + size_t sum_freed; if (sexp_context_heap(ctx)) { + sexp_sweep(ctx, &sum_freed); /* sweep w/o mark to run finalizers */ heap = sexp_context_heap(ctx); sexp_context_heap(ctx) = NULL; free(heap); From 1a5a551263df74f956fcb32a183bbcc567105fa4 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 2 Jan 2010 20:16:01 +0900 Subject: [PATCH 339/535] forgot to add port.c --- lib/chibi/io/port.c | 180 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 180 insertions(+) create mode 100644 lib/chibi/io/port.c diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c new file mode 100644 index 00000000..77e9aeab --- /dev/null +++ b/lib/chibi/io/port.c @@ -0,0 +1,180 @@ + +#include +#include + +#define SEXP_PORT_BUFFER_SIZE 1024 +#define SEXP_LAST_CONTEXT_CHECK_LIMIT 256 + +#define sexp_cookie_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO) +#define sexp_cookie_buffer(vec) sexp_vector_ref((sexp)vec, SEXP_ONE) +#define sexp_cookie_read(vec) sexp_vector_ref((sexp)vec, SEXP_TWO) +#define sexp_cookie_write(vec) sexp_vector_ref((sexp)vec, SEXP_THREE) +#define sexp_cookie_seek(vec) sexp_vector_ref((sexp)vec, SEXP_FOUR) +#define sexp_cookie_close(vec) sexp_vector_ref((sexp)vec, SEXP_FIVE) + +#if ! SEXP_USE_BOEHM +static int sexp_in_heap_p (sexp_heap h, sexp p) { + for ( ; h; h = h->next) + if (((sexp)h < p) && (p < (sexp)((char*)h + h->size))) + return 1; + return 0; +} +#endif + +static sexp sexp_last_context (sexp ctx, sexp *cstack) { + sexp res=SEXP_FALSE, p; +#if ! SEXP_USE_BOEHM + sexp_sint_t i; + sexp_heap h = sexp_context_heap(ctx); + for (i=0; i sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_read(vec), args); + sexp_gc_release2(ctx); + if (sexp_fixnump(res)) { + memcpy(buffer, sexp_string_data(sexp_cookie_buffer(vec)), sexp_unbox_fixnum(res)); + return sexp_unbox_fixnum(res); + } else { + return -1; + } +} + +static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_write(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + if (size > sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_write(vec), args); + sexp_gc_release2(ctx); + return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1); +} + +static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + args = sexp_make_integer(ctx, *position); + args = sexp_list2(ctx, args, sexp_make_fixnum(whence)); + res = sexp_apply(ctx, sexp_cookie_seek(vec), args); + if (sexp_fixnump(res)) + *position = sexp_unbox_fixnum(res); + sexp_gc_release2(ctx); + return sexp_fixnump(res); +} + +static int sexp_cookie_cleaner (void *cookie) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_close(vec))) return 0; + ctx = sexp_cookie_ctx(vec); + res = sexp_apply(ctx, sexp_cookie_close(vec), SEXP_NULL); + return (sexp_exceptionp(res) ? -1 : sexp_truep(res)); +} + +#if ! SEXP_BSD + +static cookie_io_functions_t sexp_cookie = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = (cookie_seek_function_t*)sexp_cookie_seeker, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +static cookie_io_functions_t sexp_cookie_no_seek = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = NULL, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +#endif + +#if SEXP_USE_STRING_STREAMS + +static sexp sexp_make_custom_port (sexp ctx, char *mode, sexp read, sexp write, + sexp seek, sexp close) { + FILE *in; + sexp res; + sexp_gc_var1(vec); + if (sexp_truep(read) && ! sexp_procedurep(read)) + return sexp_type_exception(ctx, "make-custom-port: read not a procedure", read); + if (sexp_truep(write) && ! sexp_procedurep(write)) + return sexp_type_exception(ctx, "make-custom-port: write not a procedure", write); + if (sexp_truep(seek) && ! sexp_procedurep(seek)) + return sexp_type_exception(ctx, "make-custom-port: seek not a procedure", seek); + if (sexp_truep(close) && ! sexp_procedurep(close)) + return sexp_type_exception(ctx, "make-custom-port: close not a procedure", close); + sexp_gc_preserve1(ctx, vec); + vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID); + sexp_cookie_ctx(vec) = ctx; + sexp_cookie_buffer(vec) + = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID); + sexp_cookie_read(vec) = read; + sexp_cookie_write(vec) = write; + sexp_cookie_seek(vec) = seek; + sexp_cookie_close(vec) = close; +#if SEXP_BSD + in = funopen(vec, + (sexp_procedurep(read) ? sexp_cookie_reader : NULL), + (sexp_procedurep(write) ? sexp_cookie_writer : NULL), + NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */ + (sexp_procedurep(close) ? sexp_cookie_cleaner : NULL)); +#else + in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek)); +#endif + if (! in) { + res = sexp_user_exception(ctx, read, "couldn't make custom port", read); + } else { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = vec; /* for gc preserving */ + } + sexp_gc_release1(ctx); + return res; +} + +#else + +static sexp sexp_make_custom_port (sexp ctx, char *mode, sexp read, sexp write, + sexp seek, sexp close) { + return sexp_user_exception(ctx, SEXP_FALSE, "custom ports not supported in this configuration", SEXP_NULL); +} + +#endif + +static sexp sexp_make_custom_input_port (sexp ctx, sexp read, sexp seek, sexp close) { + return sexp_make_custom_port(ctx, "r", read, SEXP_FALSE, seek, close); +} + +static sexp sexp_make_custom_output_port (sexp ctx, sexp write, sexp seek, sexp close) { + sexp res = sexp_make_custom_port(ctx, "w", SEXP_FALSE, write, seek, close); + sexp_pointer_tag(res) = SEXP_OPORT; + return res; +} From e5232a08afc4410e05ccbc65033aaa8558a89560 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 2 Jan 2010 20:27:05 +0900 Subject: [PATCH 340/535] quick fix for custom ports on BSD systems using funopen - seeking not yet supported --- lib/chibi/io/port.c | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c index 77e9aeab..770c94dd 100644 --- a/lib/chibi/io/port.c +++ b/lib/chibi/io/port.c @@ -39,7 +39,12 @@ static sexp sexp_last_context (sexp ctx, sexp *cstack) { return res; } -static ssize_t sexp_cookie_reader (void *cookie, char *buffer, size_t size) { +#if SEXP_BSD +static int sexp_cookie_reader (void *cookie, char *buffer, int size) +#else +static ssize_t sexp_cookie_reader (void *cookie, char *buffer, size_t size) +#endif +{ sexp vec = (sexp)cookie, ctx, res; if (! sexp_procedurep(sexp_cookie_read(vec))) return -1; sexp_gc_var2(ctx2, args); @@ -59,7 +64,12 @@ static ssize_t sexp_cookie_reader (void *cookie, char *buffer, size_t size) { } } -static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size) { +#if SEXP_BSD +static int sexp_cookie_writer (void *cookie, const char *buffer, int size) +#else +static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size) +#endif +{ sexp vec = (sexp)cookie, ctx, res; if (! sexp_procedurep(sexp_cookie_write(vec))) return -1; sexp_gc_var2(ctx2, args); @@ -75,6 +85,7 @@ static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1); } +#if ! SEXP_BSD static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) { sexp vec = (sexp)cookie, ctx, res; if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1; @@ -90,6 +101,7 @@ static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) { sexp_gc_release2(ctx); return sexp_fixnump(res); } +#endif static int sexp_cookie_cleaner (void *cookie) { sexp vec = (sexp)cookie, ctx, res; From 33da981dba89452ff959a795baa0bda2375032e8 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 2 Jan 2010 21:04:40 +0900 Subject: [PATCH 341/535] read-line shouldn't include the trailing newline --- lib/chibi/io/io.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm index 97de1cc6..2d4da555 100644 --- a/lib/chibi/io/io.scm +++ b/lib/chibi/io/io.scm @@ -26,7 +26,14 @@ (let ((in (if (pair? o) (car o) (current-input-port))) (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192))) (let ((res (%read-line n in))) - (if (not res) eof res)))) + (if (not res) + eof + (let ((len (string-length res))) + (if (and (> len 0) (eqv? #\newline (string-ref res (- len 1)))) + (if (and (> len 1) (eqv? #\return (string-ref res (- len 2)))) + (substring res 0 (- len 2)) + (substring res 0 (- len 1))) + res)))))) (define (read-string n . o) (let ((in (if (pair? o) (car o) (current-input-port)))) From fdec55997acc9d4a60fe9cee06a41da2e4cd3ba1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 2 Jan 2010 21:51:07 +0900 Subject: [PATCH 342/535] adding http client library. using mime/base64/quoted-printable modules from hato. --- lib/chibi/base64.module | 7 + lib/chibi/base64.scm | 351 +++++++++++++++++++++++++ lib/chibi/mime.module | 7 + lib/chibi/mime.scm | 410 ++++++++++++++++++++++++++++++ lib/chibi/net.module | 3 +- lib/chibi/net.scm | 25 +- lib/chibi/net/http.module | 7 + lib/chibi/net/http.scm | 180 +++++++++++++ lib/chibi/quoted-printable.module | 7 + lib/chibi/quoted-printable.scm | 157 ++++++++++++ lib/chibi/uri.module | 4 +- lib/srfi/33/bitwise.scm | 2 +- 12 files changed, 1148 insertions(+), 12 deletions(-) create mode 100644 lib/chibi/base64.module create mode 100644 lib/chibi/base64.scm create mode 100644 lib/chibi/mime.module create mode 100644 lib/chibi/mime.scm create mode 100644 lib/chibi/net/http.module create mode 100644 lib/chibi/net/http.scm create mode 100644 lib/chibi/quoted-printable.module create mode 100644 lib/chibi/quoted-printable.scm diff --git a/lib/chibi/base64.module b/lib/chibi/base64.module new file mode 100644 index 00000000..12324e1d --- /dev/null +++ b/lib/chibi/base64.module @@ -0,0 +1,7 @@ + +(define-module (chibi base64) + (export base64-encode base64-encode-string + base64-decode base64-decode-string + base64-encode-header) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "base64.scm")) diff --git a/lib/chibi/base64.scm b/lib/chibi/base64.scm new file mode 100644 index 00000000..3d95ad71 --- /dev/null +++ b/lib/chibi/base64.scm @@ -0,0 +1,351 @@ +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: base64-encode-string str +;; Return a base64 encoded representation of string according to the +;; official base64 standard as described in RFC3548. + +;; Procedure: base64-decode-string str +;; Return a base64 decoded representation of string, also interpreting +;; the alternate 62 & 63 valued characters as described in RFC3548. +;; Other out-of-band characters are silently stripped, and = signals +;; the end of the encoded string. No errors will be raised. + +;; Procedure: base64-encode [port] +;; Procedure: base64-decode [port] +;; Variations of the above which read and write to ports. + +;; Procedure: base64-encode-header enc str [start-col max-col nl] +;; Return a base64 encoded representation of string as above, +;; wrapped in =?ENC?B?...?= as per RFC1522, split across multiple +;; MIME-header lines as needed to keep each lines length less than +;; MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring +;; STR is already encoded according to ENC. The optional argument +;; NL is the newline separator, defaulting to CRLF. + +;; This API is compatible with the Gauche library rfc.base64. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-chop str n) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (+ i n))) + (if (>= j len) + (reverse (cons (substring str i len) res)) + (lp j (cons (substring str i j) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; constants and tables + +(define *default-max-col* 76) + +(define *outside-char* 99) ; luft-balloons +(define *pad-char* 101) ; dalmations + +(define *base64-decode-table* + (let ((res (make-vector #x100 *outside-char*))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res (+ i 65) i) + (vector-set! res (+ i 97) (+ i 26)) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 48) (+ i 52)) + (lp (+ i 1))))) + ;; extras (be liberal for different common base64 formats) + (vector-set! res (char->integer #\+) 62) + (vector-set! res (char->integer #\-) 62) + (vector-set! res (char->integer #\/) 63) + (vector-set! res (char->integer #\_) 63) + (vector-set! res (char->integer #\~) 63) + (vector-set! res (char->integer #\=) *pad-char*) + res)) + +(define (base64-decode-char c) + (vector-ref *base64-decode-table* (char->integer c))) + +(define *base64-encode-table* + (let ((res (make-vector 64))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res i (integer->char (+ i 65))) + (vector-set! res (+ i 26) (integer->char (+ i 97))) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 52) (integer->char (+ i 48))) + (lp (+ i 1))))) + (vector-set! res 62 #\+) + (vector-set! res 63 #\/) + res)) + +(define (enc i) + (vector-ref *base64-encode-table* i)) + +;; try to match common boundaries +(define decode-src-length + (lcm 76 78)) + +(define decode-dst-length + (* 3 (arithmetic-shift (+ 3 decode-src-length) -2))) + +(define encode-src-length + (* 3 1024)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; decoding + +;; Create a result buffer with the maximum possible length for the +;; input, and pass it to the internal base64-decode-string! utility. +;; If the resulting length used is exact, we can return that buffer, +;; otherwise we return the appropriate substring. +(define (base64-decode-string src) + (let* ((len (string-length src)) + (dst-len (* 3 (arithmetic-shift (+ 3 len) -2))) + (dst (make-string dst-len))) + (base64-decode-string! + src 0 len dst + (lambda (src-offset res-len b1 b2 b3) + (let ((res-len (base64-decode-finish dst res-len b1 b2 b3))) + (if (= res-len dst-len) + dst + (substring dst 0 res-len))))))) + +;; This is a little funky. +;; +;; We want to skip over "outside" characters (e.g. newlines inside +;; base64-encoded data, as would be passed in mail clients and most +;; large base64 data). This would normally mean two nested loops - +;; one for overall processing the input, and one for looping until +;; we get to a valid character. However, many Scheme compilers are +;; really bad about optimizing nested loops of primitives, so we +;; flatten this into a single loop, using conditionals to determine +;; which character is currently being read. +(define (base64-decode-string! src start end dst kont) + (let lp ((i start) + (j 0) + (b1 *outside-char*) + (b2 *outside-char*) + (b3 *outside-char*)) + (if (>= i end) + (kont i j b1 b2 b3) + (let ((c (base64-decode-char (string-ref src i)))) + (cond + ((eqv? c *pad-char*) + (kont i j b1 b2 b3)) + ((eqv? c *outside-char*) + (lp (+ i 1) j b1 b2 b3)) + ((eqv? b1 *outside-char*) + (lp (+ i 1) j c b2 b3)) + ((eqv? b2 *outside-char*) + (lp (+ i 1) j b1 c b3)) + ((eqv? b3 *outside-char*) + (lp (+ i 1) j b1 b2 c)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (string-set! dst + (+ j 2) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 2 0 b3) 6) + c))) + (lp (+ i 1) (+ j 3) + *outside-char* *outside-char* *outside-char*))))))) + +;; If requested, account for any "partial" results (i.e. trailing 2 or +;; 3 chars) by writing them into the destination (additional 1 or 2 +;; bytes) and returning the adjusted offset for how much data we've +;; written. +(define (base64-decode-finish dst j b1 b2 b3) + (cond + ((eqv? b1 *outside-char*) + j) + ((eqv? b2 *outside-char*) + (string-set! dst j (integer->char (arithmetic-shift b1 2))) + (+ j 1)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (cond + ((eqv? b3 *outside-char*) + (+ j 1)) + (else + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (+ j 2)))))) + +;; General port decoder: work in single blocks at a time to avoid +;; allocating memory (crucial for Scheme implementations that don't +;; allow large strings). +(define (base64-decode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string decode-src-length)) + (dst (make-string decode-dst-length))) + (let lp ((offset 0)) + (let ((src-len (+ offset + (read-string! decode-src-length src in offset)))) + (cond + ((= src-len decode-src-length) + ;; read a full chunk: decode, write and loop + (base64-decode-string! + src 0 decode-src-length dst + (lambda (src-offset dst-len b1 b2 b3) + (cond + ((and (< src-offset src-len) + (eqv? #\= (string-ref src src-offset))) + ;; done + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))) + ((eqv? b1 *outside-char*) + (write-string dst dst-len out) + (lp 0)) + (else + (write-string dst dst-len out) + ;; one to three chars left in buffer + (string-set! src 0 (enc b1)) + (cond + ((eqv? b2 *outside-char*) + (lp 1)) + (else + (string-set! src 1 (enc b2)) + (cond + ((eqv? b3 *outside-char*) + (lp 2)) + (else + (string-set! src 2 (enc b3)) + (lp 3)))))))))) + (else + ;; end of source - just decode and write once + (base64-decode-string! + src 0 src-len dst + (lambda (src-offset dst-len b1 b2 b3) + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; encoding + +(define (base64-encode-string str) + (let* ((len (string-length str)) + (quot (quotient len 3)) + (rem (- len (* quot 3))) + (res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2)) + (res (make-string res-len))) + (base64-encode-string! str 0 len res) + res)) + +(define (base64-encode-string! str start end res) + (let* ((res-len (string-length res)) + (limit (- end 2))) + (let lp ((i start) (j 0)) + (if (>= i limit) + (case (- end i) + ((1) + (let ((b1 (char->integer (string-ref str i)))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (arithmetic-shift (bitwise-and #b11 b1) 4))) + (string-set! res (+ j 2) #\=) + (string-set! res (+ j 3) #\=))) + ((2) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (arithmetic-shift (extract-bit-field 4 0 b2) + 2))) + (string-set! res (+ j 3) #\=)))) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1)))) + (b3 (char->integer (string-ref str (+ i 2))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 2) + (extract-bit-field 2 6 b3)))) + (string-set! res (+ j 3) (enc (bitwise-and #b111111 b3))) + (lp (+ i 3) (+ j 4))))))) + +(define (base64-encode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string encode-src-length)) + (dst (make-string + (arithmetic-shift (quotient encode-src-length 3) 2)))) + (let lp () + (let ((n (read-string! 2048 src in))) + (base64-encode-string! src 0 n dst) + (write-string dst (* 3 (quotient (+ n 3) 4)) out) + (if (= n 2048) + (lp))))))) + +(define (base64-encode-header encoding str . o) + (define (round4 i) (arithmetic-shift (arithmetic-shift i -2) 2)) + (let ((start-col (if (pair? o) (car o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?B?")) + (prefix-length (+ 2 (string-length prefix))) + (effective-max-col (round4 (- max-col prefix-length))) + (first-max-col (round4 (- effective-max-col start-col))) + (str (base64-encode-string str)) + (len (string-length str))) + (if (<= len first-max-col) + (string-append prefix str "?=") + (string-append + (if (positive? first-max-col) + (string-append + prefix (substring str 0 first-max-col) "?=" nl "\t" prefix) + "") + (string-concatenate (string-chop (substring str first-max-col len) + effective-max-col) + (string-append "?=" nl "\t" prefix)) + "?="))))) + diff --git a/lib/chibi/mime.module b/lib/chibi/mime.module new file mode 100644 index 00000000..2c10dbd1 --- /dev/null +++ b/lib/chibi/mime.module @@ -0,0 +1,7 @@ + +(define-module (chibi mime) + (export mime-ref assoc-ref mime-header-fold mime-headers->list + mime-parse-content-type mime-decode-header + mime-message-fold mime-message->sxml) + (import-immutable (scheme) (chibi base64) (chibi quoted-printable) (chibi io)) + (include "mime.scm")) diff --git a/lib/chibi/mime.scm b/lib/chibi/mime.scm new file mode 100644 index 00000000..e712d7fa --- /dev/null +++ b/lib/chibi/mime.scm @@ -0,0 +1,410 @@ +;; mime.scm -- RFC2045 MIME library +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2822 headers + +;; Procedure: mime-header-fold kons knil [source [limit [kons-from]]] +;; +;; Performs a fold operation on the MIME headers of source which can be +;; either a string or port, and defaults to current-input-port. kons +;; is called on the three values: +;; kons header value accumulator +;; where accumulator begins with knil. Neither the header nor the +;; value are modified, except wrapped lines are handled for the value. +;; +;; The optional procedure KONS-FROM is a procedure to be called when +;; the first line of the headers is an "From
" line, to +;; enable this procedure to be used as-is on mbox files and the like. +;; It defaults to KONS, and if such a line is found the fold will begin +;; with (KONS-FROM "%from"
(KONS-FROM "%date" KNIL)). +;; +;; The optional LIMIT gives a limit on the number of headers to read. + +;; Procedure: mime-headers->list [source] +;; Return an alist of the MIME headers from source with headers all +;; downcased. + +;; Procedure: mime-parse-content-type str +;; Parses STR as a Content-Type style-value returning the list +;; (type (attr . val) ...) +;; For example: +;; (mime-parse-content-type +;; "text/html; CHARSET=US-ASCII; filename=index.html") +;; => ("text/html" ("charset" . "US-ASCII") ("filename" . "index.html")) + +;; Procedure: mime-decode-header str +;; Replace all occurrences of RFC1522 =?ENC?...?= escapes in STR with +;; the appropriate decoded and charset converted value. + +;; Procedure: mime-ref headers str [default] +;; A case-insensitive assoc-ref. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2045 MIME encoding + +;; Procedure: mime-message-fold src headers kons knil +;; Performs a fold operation on the given string or port SRC as a MIME +;; body corresponding to the headers give in HEADERS. KONS is called +;; on the successive values: +;; +;; KONS part-headers part-body accumulator +;; +;; where part-headers are the headers for the given MIME part (the +;; original headers for single-part MIME), part-body is the +;; appropriately decoded and charset-converted body of the message, +;; and the accumulator begins with KNIL. +;; +;; TODO: Extend mime-message-fold to (optionally?) pass KONS an +;; input-port instead of string for the body to handle very large bodies +;; (this is not much of an issue for SMTP since the messages are in +;; practice limited, but it could be problematic for large HTTP bodies). +;; +;; This does a depth-first search, folding in sequence. It should +;; probably be doing a tree-fold as in html-parser. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define mime-line-length-limit 4096) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; association lists + +(define (assoc* key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (cond + ((null? ls) #f) + ((eq key (caar ls)) (car ls)) + (else (lp (cdr ls))))))) + +(define (assoc-ref ls key . o) + (let ((default (and (pair? o) (car o))) + (eq (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) equal?))) + (cond ((assoc* key ls eq) => cdr) + (else default)))) + +(define (mime-ref ls key . o) + (assoc-ref ls key (and (pair? o) (car o)) string-ci=?)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; simple matching instead of regexps + +(define (match-mbox-from-line line) + (let ((len (string-length line))) + (and (> len 5) + (string=? (substring line 0 5) "From ") + (let lp ((i 6)) + (cond + ((= i len) (list (substring line 5 len) "")) + ((memq (string-ref line i) '(#\space #\tab)) + (list (substring line 5 i) (substring line (+ i 1) len))) + (else (lp (+ i 1)))))))) + +(define (string-scan-colon-or-maybe-equal str) + (let ((len (string-length str))) + (let lp ((i 0) (best #f)) + (if (= i len) + best + (let ((c (string-ref str i))) + (cond ((or (char-alphabetic? c) + (char-numeric? c) + (memv c '(#\- #\_))) + (lp (+ i 1) best)) + ((eq? c #\:) + (if (= i 0) #f i)) + ((eqv? c #\=) + (lp (+ i 1) (or best i))) + (else + best))))))) + +(define (string-skip-white-space str i) + (let ((lim (string-length str))) + (let lp ((i i)) + (cond ((>= i lim) lim) + ((char-whitespace? (string-ref str i)) (lp (+ i 1))) + (else i))))) + +(define (match-mime-header-line line) + (let ((i (string-scan-colon-or-maybe-equal line))) + (and i + (let ((j (string-skip-white-space line (+ i 1)))) + (list (substring line 0 i) + (substring line j (string-length line))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dummy encoder + +(define (ces-convert str . x) + str) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; some srfi-13 & string utils + +(define (string-copy! to tstart from . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length from)))) + (let lp ((i start) (j tstart)) + (cond + ((< i end) + (string-set! to j (string-ref from i)) + (lp (+ i 1) (+ j 1))))))) + +(define (string-concatenate-reverse ls) + (let lp ((ls ls) (rev '()) (len 0)) + (if (null? ls) + (let ((res (make-string len))) + (let lp ((ls rev) (i 0)) + (cond + ((null? ls) + res) + (else + (string-copy! res i (car ls)) + (lp (cdr ls) (+ i (string-length (car ls)))))))) + (lp (cdr ls) (cons (car ls) rev) (+ len (string-length (car ls))))))) + +(define (string-downcase s . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length s)))) + (let* ((len (- end start)) (s2 (make-string len))) + (let lp ((i start) (j 0)) + (cond + ((>= i end) + s2) + (else + (string-set! s2 j (char-downcase (string-ref s i))) + (lp (+ i 1) (+ j 1)))))))) + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-trim-white-space s) + (let ((len (string-length s))) + (let lp ((i 0)) + (cond ((= i len) "") + ((char-whitespace? (string-ref s i)) (lp (+ i 1))) + (else + (let lp ((j (- len 1))) + (cond ((<= j i) "") + ((char-whitespace? (string-ref s j)) (lp (- j 1))) + (else (substring s i (+ j 1)))))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; header parsing + +(define (mime-header-fold kons knil . o) + (let ((src (and (pair? o) (car o))) + (limit (and (pair? o) (pair? (cdr o)) (car (cdr o)))) + (kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (caddr o) kons))) + ((if (string? src) mime-header-fold-string mime-header-fold-port) + kons knil (or src (current-input-port)) limit kons-from))) + +(define (mime-header-fold-string kons knil str limit kons-from) + (call-with-input-string str + (lambda (in) (mime-header-fold-port kons knil in limit kons-from)))) + +(define (mime-header-fold-port kons knil port limit kons-from) + (define (out line acc count) + (cond + ((or (and limit (> count limit)) (eof-object? line) (string=? line "")) + acc) + ((match-mime-header-line line) + => (lambda (m) (in (car m) (list (cadr m)) acc (+ count 1)))) + (else + ;;(warn "invalid header line: ~S\n" line) + (out (read-line port mime-line-length-limit) acc (+ count 1))))) + (define (in header value acc count) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((and limit (> count limit)) + acc) + ((or (eof-object? line) (string=? line "")) + (kons header (string-concatenate-reverse value) acc)) + ((char-whitespace? (string-ref line 0)) + (in header (cons line value) acc (+ count 1))) + (else + (out line + (kons header (string-concatenate-reverse value) acc) + (+ count 1)))))) + (let ((first-line (read-line port mime-line-length-limit))) + (cond + ((eof-object? first-line) + knil) + ((and kons-from (match-mbox-from-line first-line)) + => (lambda (m) ; special case check on first line for mbox files + (out (read-line port mime-line-length-limit) + (kons-from "%from" (car m) + (kons-from "%date" (cadr m) knil)) + 0))) + (else + (out first-line knil 0))))) + +(define (mime-headers->list . o) + (reverse + (apply + mime-header-fold + (lambda (h v acc) (cons (cons (string-downcase h) v) acc)) + '() + o))) + +(define (mime-split-name+value s) + (let ((i (string-char-index s #\=))) + (if i + (cons (string-downcase (string-trim-white-space (substring s 0 i))) + (if (= i (string-length s)) + "" + (if (eqv? #\" (string-ref s (+ i 1))) + (substring s (+ i 2) (- (string-length s) 1)) + (substring s (+ i 1) (string-length s))))) + (cons (string-downcase (string-trim-white-space s)) "")))) + +(define (mime-parse-content-type str) + (map mime-split-name+value (string-split str #\;))) + +(define (mime-decode-header str) + (let* ((len (string-length str)) + (limit (- len 8))) ; need at least 8 chars: "=?Q?X??=" + (let lp ((i 0) (from 0) (res '())) + (if (>= i limit) + (string-concatenate (reverse (cons (substring str from len) res))) + (if (and (eqv? #\= (string-ref str i)) + (eqv? #\? (string-ref str (+ i 1)))) + (let* ((j (string-char-index str #\? (+ i 3))) + (k (string-char-index str #\? (+ j 3)))) + (if (and j k (< (+ k 1) len) + (eqv? #\? (string-ref str (+ j 2))) + (memq (string-ref str (+ j 1)) '(#\Q #\B #\q #\b)) + (eqv? #\= (string-ref str (+ k 1)))) + (let ((decode (if (memq (string-ref str (+ j 1)) '(#\Q #\q)) + quoted-printable-decode-string + base64-decode-string)) + (cset (substring str (+ i 2) j)) + (content (substring str (+ j 3) k)) + (k2 (+ k 2))) + (lp k2 k2 (cons (ces-convert (decode content) cset) + (cons (substring str from i) res)))) + (lp (+ i 2) from res))) + (lp (+ i 1) from res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; message parsing + +(define (mime-read-to-boundary port boundary next final) + (let ((final-boundary (and boundary (string-append boundary "--")))) + (let lp ((res '())) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((or (eof-object? line) (equal? line final-boundary)) + (final (string-concatenate (reverse res) + (call-with-output-string newline)))) + ((equal? line boundary) + (next (string-concatenate (reverse res) + (call-with-output-string newline)))) + (else + (lp (cons line res)))))))) + +(define (mime-convert-part str cte enc) + (let ((str (cond + ((and (string? cte) (string-ci=? cte "quoted-printable")) + (quoted-printable-decode-string str)) + ((and (string? cte) (string-ci=? cte "base64")) + (base64-decode-string str)) + (else + str)))) + (if (string? enc) (ces-convert str enc) str))) + +(define (mime-read-part port cte enc boundary next final) + (mime-read-to-boundary + port boundary + (lambda (x) (next (mime-convert-part x cte enc))) + (lambda (x) (final (mime-convert-part x cte enc))))) + +;; (kons parent-headers part-headers part-body seed) +;; (start headers seed) +;; (end headers parent-seed seed) +(define (mime-message-fold src kons init-seed . o) + (let ((port (if (string? src) (open-input-string src) src))) + (let ((kons-start + (if (pair? o) (car o) (lambda (headers seed) '()))) + (kons-end + (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)))) + (headers + (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + (mime-headers->list port)))) + (let tfold ((parent-headers '()) + (headers headers) + (seed init-seed) + (boundary #f) + (next (lambda (x) x)) + (final (lambda (x) x))) + (let* ((ctype (mime-parse-content-type + (mime-ref headers "Content-Type" "text/plain"))) + (type (string-trim-white-space (caar ctype))) + (enc (string-trim-white-space + (or (mime-ref ctype "charset") + (mime-ref headers "charset" "ASCII")))) + (cte (string-trim-white-space + (or (mime-ref headers "Content-Transfer-Encoding") + (mime-ref headers "Encoding" "7-bit"))))) + (cond + ((and (string-ci=? type "multipart/") + (mime-ref ctype "boundary")) + => (lambda (boundary2) + (let ((boundary2 (string-append "--" boundary2))) + ;; skip preamble + (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x)) + (let lp ((part-seed (kons-start headers seed))) + (let ((part-headers (mime-headers->list port))) + (tfold parent-headers part-headers + part-seed boundary2 + lp + (lambda (x) + ;; skip epilogue + (if boundary + (mime-read-to-boundary port boundary + (lambda (x) x) (lambda (x) x))) + (next (kons-end headers seed x))) + )))))) + (else + (mime-read-part + port cte enc boundary + (lambda (x) (next (kons parent-headers headers x seed))) + (lambda (x) (final (kons parent-headers headers x seed))))))))))) + +;; (mime (^ (header . value) ...) parts ...) +(define (mime-message->sxml . o) + (car + (apply + mime-message-fold + (if (pair? o) (car o) (current-input-port)) + (lambda (parent-headers headers body seed) + `((mime (^ ,@headers) ,body) ,@seed)) + '() + (lambda (headers seed) '()) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)) + (if (pair? o) (cdr o) '())))) + diff --git a/lib/chibi/net.module b/lib/chibi/net.module index 41cdafe4..845a7aa8 100644 --- a/lib/chibi/net.module +++ b/lib/chibi/net.module @@ -1,6 +1,7 @@ (define-module (chibi net) - (export sockaddr? address-info? get-address-info socket connect with-net-io + (export sockaddr? address-info? get-address-info socket connect + with-net-io open-net-io address-info-family address-info-socket-type address-info-protocol address-info-address address-info-address-length address-info-next) (import-immutable (scheme)) diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm index 85ed756a..5f912cb5 100644 --- a/lib/chibi/net.scm +++ b/lib/chibi/net.scm @@ -1,9 +1,13 @@ ;; net.scm -- the high-level network interface -;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; Copyright (c) 2010 Alex Shinn. All rights reserved. ;; BSD-style license: http://synthcode.com/license.txt -(define (with-net-io host service proc) - (let lp ((addr (get-address-info host service #f))) +(define (open-net-io host service) + (let lp ((addr (get-address-info host + (if (integer? service) + (number->string service) + service) + #f))) (if (not addr) (error "couldn't find address" host service) (let ((sock (socket (address-info-family addr) @@ -16,8 +20,13 @@ (address-info-address addr) (address-info-address-length addr))) (lp (address-info-next addr)) - (let ((in (open-input-file-descriptor sock)) - (out (open-output-file-descriptor sock))) - (let ((res (proc in out))) - (close-input-port in) - res)))))))) + (list (open-input-file-descriptor sock) + (open-output-file-descriptor sock)))))))) + +(define (with-net-io host service proc) + (let ((io (open-net-io host service))) + (if (not (pair? io)) + (error "couldn't find address" host service) + (let ((res (proc (car io) (car (cdr io))))) + (close-input-port (car io)) + res)))) diff --git a/lib/chibi/net/http.module b/lib/chibi/net/http.module new file mode 100644 index 00000000..352bf7b4 --- /dev/null +++ b/lib/chibi/net/http.module @@ -0,0 +1,7 @@ + +(define-module (chibi net http) + (export http-get call-with-input-url with-input-from-url + http-parse-request http-parse-form) + (import-immutable (scheme) (srfi 39) (chibi net) (chibi io) + (chibi uri) (chibi mime)) + (include "http.scm")) diff --git a/lib/chibi/net/http.scm b/lib/chibi/net/http.scm new file mode 100644 index 00000000..37cac5e6 --- /dev/null +++ b/lib/chibi/net/http.scm @@ -0,0 +1,180 @@ +;; http.scm -- http client +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; client utils + +(define http-user-agent "chibi") + +(define http-redirect-limit 10) +(define http-chunked-buffer-size 4096) +(define http-chunked-size-limit 409600) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (http-parse-response line) + (let* ((len (string-length line)) + (i (or (string-scan line #\space 0 len) len)) + (j (or (string-scan line #\space (+ i 1) len) len)) + (n (and (< i j) (string->number (substring line (+ i 1) j))))) + (if (not (integer? n)) + (error "bad response" line i j) + (list (substring line 0 i) + n + (if (>= j len) "" (substring line (+ j 1) len)))))) + +(define (http-wrap-chunked-input-port in) + (define (read-chunk in) + (let* ((line (read-line in)) + (n (and (string? line) (string->number line 16)))) + (display "read-chunk ") (write line) (newline) + (cond + ((not (and (integer? n) (<= 0 n http-chunked-size-limit))) + (error "invalid chunked size line" line)) + ((zero? n) "") + (else (read-string n in))))) + (make-generated-input-port + (lambda () (read-chunk in)))) + +(define (http-get/raw url in-headers limit) + (if (<= limit 0) + (error "http-get: redirect limit reached" url) + (let* ((uri (if (uri? url) url (string->uri url))) + (host (and uri (uri-host uri)))) + (if (not host) + (error "invalid url" url) + (let* ((io (open-net-io + host + (or (uri-port uri) + (if (eq? 'https (uri-scheme uri)) 443 80)))) + (in (car io)) + (out (car (cdr io)))) + (display "GET " out) + (display (or (uri-path uri) "/") out) + (display " HTTP/1.0\r\n" out) + (display "Host: " out) (display host out) (display "\r\n" out) + (cond + ((not (mime-ref in-headers "user-agent")) + (display "User-Agent: " out) + (display http-user-agent out) + (display "\r\n" out))) + (for-each + (lambda (x) + (display (car x) out) (display ": " out) + (display (cdr x) out) (display "\r\n" out)) + in-headers) + (display "Connection: close\r\n\r\n" out) + (flush-output out) + (let* ((resp (http-parse-response (read-line in))) + (headers (mime-headers->list in)) + (status (quotient (cadr resp) 100))) + (case status + ((2) + (let ((enc (mime-ref headers "transfer-encoding"))) + (cond + ((equal? enc "chunked") + (http-wrap-chunked-input-port in)) + (else + in)))) + ((3) + (close-input-port in) + (close-output-port out) + (let ((url2 (mime-ref headers "location"))) + (if url2 + (http-get/raw url2 in-headers (- limit 1)) + (error "redirect with no location header")))) + (else + (close-input-port in) + (close-output-port out) + (error "couldn't retrieve url" url resp))))))))) + +(define (http-get url . headers) + (http-get/raw url + (if (pair? headers) (car headers) '()) + http-redirect-limit)) + +(define (call-with-input-url url proc) + (let* ((p (http-get url)) + (res (proc p))) + (close-input-port p) + res)) + +(define (with-input-from-url url thunk) + (let ((p (http-get url))) + (let ((res (parameterize ((current-input-port p)) (thunk)))) + (close-input-port p) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; server utils + +;; read and parse a request line +(define (http-parse-request . o) + (let ((line (string-split + (read-line (if (pair? o) (car o) (current-input-port)) 4096)))) + (cons (string->symbol (car line)) (cdr line)))) + +;; Parse a form body with a given URI and MIME headers (as parsed with +;; mime-headers->list). Returns an alist of (name . value) for every +;; query or form parameter. +(define (http-parse-form uri headers . o) + (let* ((in (if (pair? o) (car o) (current-input-port))) + (type (mime-ref headers + "content-type" + "application/x-www-form-urlencoded")) + (query0 (or (uri-query (if (string? uri) (string->uri uri) uri)) '())) + (query (if (string? query0) (uri-query->alist query0) query0))) + (cond + ((string-ci=? "multipart/" type) + (let ((mime (mime-message->sxml in headers))) + (append + (let lp ((ls (cddr mime)) + (res '())) + (cond + ((null? ls) + res) + ((and (pair? (car ls)) + (eq? 'mime (caar ls)) + (pair? (cdar ls)) + (pair? (cadar ls)) + (memq (caadar ls) '(^ @))) + (let* ((disp0 (mime-ref (cdadar ls) "content-disposition" "")) + (disp (mime-parse-content-type disp0)) + (name (mime-ref disp "name"))) + (if name + (lp (cdr ls) (cons (cons name (caddar ls)) res)) + (lp (cdr ls) res)))) + (else + (lp (cdr ls) res)))) + query))) + (else + query)))) + diff --git a/lib/chibi/quoted-printable.module b/lib/chibi/quoted-printable.module new file mode 100644 index 00000000..9cbec430 --- /dev/null +++ b/lib/chibi/quoted-printable.module @@ -0,0 +1,7 @@ + +(define-module (chibi quoted-printable) + (export quoted-printable-encode quoted-printable-encode-string + quoted-printable-encode-header + quoted-printable-decode quoted-printable-decode-string) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "quoted-printable.scm")) diff --git a/lib/chibi/quoted-printable.scm b/lib/chibi/quoted-printable.scm new file mode 100644 index 00000000..80709026 --- /dev/null +++ b/lib/chibi/quoted-printable.scm @@ -0,0 +1,157 @@ +;; quoted-printable.scm -- RFC2045 implementation +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: quoted-printable-encode-string str [start-col max-col] +;; Return a quoted-printable encoded representation of string +;; according to the official standard as described in RFC2045. +;; +;; ? and _ are always encoded for compatibility with RFC1522 encoding, +;; and soft newlines are inserted as necessary to keep each lines +;; length less than MAX-COL (default 76). The starting column may be +;; overridden with START-COL (default 0). + +;; Procedure: quoted-printable-decode-string str [mime?] +;; Return a quoted-printable decoded representation of string. If +;; MIME? is specified and true, _ will be decoded as as space in +;; accordance with RFC1522. No errors will be raised on invalid +;; input. + +;; Procedure: quoted-printable-encode [port start-col max-col] +;; Procedure: quoted-printable-decode [port start-col max-col] +;; Variations of the above which read and write to ports. + +;; Procedure: quoted-printable-encode-header enc str [start-col max-col] +;; Return a quoted-printable encoded representation of string as +;; above, wrapped in =?ENC?Q?...?= as per RFC1522, split across +;; multiple MIME-header lines as needed to keep each lines length less +;; than MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring STR +;; is already encoded according to ENC. + +;; Example: + +;; (define (mime-encode-header header value charset) +;; (let ((prefix (string-append header ": ")) +;; (str (ces-convert value "UTF8" charset))) +;; (string-append +;; prefix +;; (quoted-printable-encode-header charset str (string-length prefix))))) + +;; This API is backwards compatible with the Gauche library +;; rfc.quoted-printable. + +(define *default-max-col* 76) + +;; Allow for RFC1522 quoting for headers by always escaping ? and _ +(define (qp-encode str start-col max-col separator) + (define (hex i) (integer->char (+ i (if (<= i 9) 48 55)))) + (let ((end (string-length str)) + (buf (make-string max-col))) + (let lp ((i 0) (col start-col) (res '())) + (cond + ((= i end) + (if (pair? res) + (string-concatenate (reverse (cons (substring buf 0 col) res)) + separator) + (substring buf start-col col))) + ((>= col (- max-col 3)) + (lp i 0 (cons (substring buf (if (pair? res) 0 start-col) col) res))) + (else + (let ((c (char->integer (string-ref str i)))) + (cond + ((and (<= 33 c 126) (not (memq c '(61 63 95)))) + (string-set! buf col (integer->char c)) + (lp (+ i 1) (+ col 1) res)) + (else + (string-set! buf col #\=) + (string-set! buf (+ col 1) (hex (arithmetic-shift c -4))) + (string-set! buf (+ col 2) (hex (bitwise-and c #b1111))) + (lp (+ i 1) (+ col 3) res))))))))) + +(define (quoted-printable-encode-string . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*))) + (qp-encode (if (string? src) src (read-string #f src)) + start-col max-col "=\r\n"))) + +(define (quoted-printable-encode . o) + (display (apply (quoted-printable-encode-string o)))) + +(define (quoted-printable-encode-header encoding . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdddr o))) + (cadddr o) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?Q?")) + (prefix-length (+ 2 (string-length prefix))) + (separator (string-append "?=" nl "\t" prefix)) + (effective-max-col (- max-col prefix-length))) + (string-append prefix + (qp-encode (if (string? src) src (read-string #f src)) + start-col effective-max-col separator) + "?=")))) + +(define (quoted-printable-decode-string . o) + (define (hex? c) (or (char-numeric? c) (<= 65 (char->integer c) 70))) + (define (unhex1 c) + (let ((i (char->integer c))) (if (>= i 65) (- i 55) (- i 48)))) + (define (unhex c1 c2) + (integer->char (+ (arithmetic-shift (unhex1 c1) 4) (unhex1 c2)))) + (let ((src (if (pair? o) (car o) (current-input-port))) + (mime-header? (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (let* ((str (if (string? src) src (read-string #f src))) + (end (string-length str))) + (call-with-output-string + (lambda (out) + (let lp ((i 0)) + (cond + ((< i end) + (let ((c (string-ref str i))) + (case c + ((#\=) ; = escapes + (cond + ((< (+ i 2) end) + (let ((c2 (string-ref str (+ i 1)))) + (cond + ((eq? c2 #\newline) (lp (+ i 2))) + ((eq? c2 #\return) + (lp (if (eq? (string-ref str (+ i 2)) #\newline) + (+ i 3) + (+ i 2)))) + ((hex? c2) + (let ((c3 (string-ref str (+ i 2)))) + (if (hex? c3) (write-char (unhex c2 c3) out)) + (lp (+ i 3)))) + (else (lp (+ i 3)))))))) + ((#\_) ; maybe translate _ to space + (write-char (if mime-header? #\space c) out) + (lp (+ i 1))) + ((#\space #\tab) ; strip trailing whitespace + (let lp2 ((j (+ i 1))) + (cond + ((not (= j end)) + (case (string-ref str j) + ((#\space #\tab) (lp2 (+ j 1))) + ((#\newline) + (lp (+ j 1))) + ((#\return) + (let ((k (+ j 1))) + (lp (if (and (< k end) + (eqv? #\newline (string-ref str k))) + (+ k 1) k)))) + (else (display (substring str i j) out) (lp j))))))) + (else ; a literal char + (write-char c out) + (lp (+ i 1))))))))))))) + +(define (quoted-printable-decode . o) + (display (apply quoted-printable-decode-string o))) + diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module index 2456dd9f..46f9e6a6 100644 --- a/lib/chibi/uri.module +++ b/lib/chibi/uri.module @@ -1,7 +1,7 @@ (define-module (chibi uri) - (export uri->string make-uri string->uri - uri-scheme uri-user uri-host uri-path uri-query uri-fragment + (export uri? uri->string make-uri string->uri + uri-scheme uri-user uri-host uri-port uri-path uri-query uri-fragment uri-with-scheme uri-with-user uri-with-host uri-with-path uri-with-query uri-with-fragment uri-encode uri-decode uri-query->alist uri-alist->query) diff --git a/lib/srfi/33/bitwise.scm b/lib/srfi/33/bitwise.scm index d0ac59f1..4ae8840f 100644 --- a/lib/srfi/33/bitwise.scm +++ b/lib/srfi/33/bitwise.scm @@ -38,7 +38,7 @@ -1 (integer-length (- i (bit-and i (- i 1)))))) -(define (mask len) (bitwise-not (arithmetic-shift -1 len))) +(define (mask len) (- (arithmetic-shift 1 len) 1)) (define (bitwise-merge mask n m) (bit-ior (bit-and mask n) (bit-and (bitwise-not mask) m))) From ce5946578a9162e98ee0212c241fd795ac38469e Mon Sep 17 00:00:00 2001 From: foof Date: Tue, 12 Jan 2010 12:54:24 -0500 Subject: [PATCH 343/535] fixing field setters and type constructors (issue #24) --- tools/genstubs.scm | 52 +++++++++++++++++++++++++++++++++++----------- 1 file changed, 40 insertions(+), 12 deletions(-) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 786a0717..06bd9c3c 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -403,7 +403,16 @@ (cat "\n#include <" header ">\n")) (define (parse-struct-like ls) - (map (lambda (x) (if (pair? x) (cons (parse-type (car x)) (cdr x)) x)) ls)) + (let lp ((ls ls) (res '())) + (cond + ((null? ls) + (reverse res)) + ((symbol? (car ls)) + (lp (cddr ls) (cons (cadr ls) (cons (car ls) res)))) + ((pair? (car ls)) + (lp (cdr ls) (cons (cons (parse-type (caar ls)) (cdar ls)) res))) + (else + (lp (cdr ls) (cons (car ls) res)))))) (define-syntax define-struct-like (er-macro-transformer @@ -1057,7 +1066,7 @@ (define (type-setter-name type name field) (string-append "sexp_" (x->string (type-name (parse-type name))) - "_set_" (x->string (type-base (parse-type (car field)))))) + "_set_" (x->string (type-base (parse-type (cadr field)))))) (define (write-type-setter type name field) (cat "static sexp " (type-setter-name type name field) @@ -1065,15 +1074,13 @@ (lambda () (write-validator "x" name)) (lambda () (write-validator "v" (car field))) " " - (lambda () (c->scheme-converter - (car field) - (string-append "((" (x->string (or (type-struct-type name) "")) - " " (mangle name) "*)" - "sexp_cpointer_value(x))" - (if (type-struct? (car field)) "." "->") - (x->string (cadr field))))) - " = v;\n" - " return SEXP_VOID;" + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (x->string (cadr field))) + " = " (lambda () (scheme->c-converter (car field) "v")) ";\n" + " return SEXP_VOID;\n" "}\n\n")) (define (write-type-funcs type) @@ -1097,7 +1104,11 @@ (args (cdadr x))) (cat "static sexp " (generate-stub-name make) " (sexp ctx" - (lambda () (for-each (lambda (x) (cat ", sexp " x)) args)) + (lambda () + (let lp ((ls args) (i 0)) + (cond ((pair? ls) + (cat ", sexp arg" i) + (lp (cdr ls) (+ i 1)))))) ") {\n" " struct " (type-name name) " *r;\n" " sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " @@ -1105,6 +1116,23 @@ ");\n" " sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" " r = sexp_cpointer_value(res);\n" + (lambda () + (let lp ((ls args) (i 0)) + (cond + ((pair? ls) + (let* ((a (car ls)) + (field + (any (lambda (f) (and (pair? f) (eq? a (cadr f)))) + (cddr x)))) + (if field + (cat " r." (cadr field) " = " + (lambda () + (scheme->c-converter + (car field) + (string-append "arg" + (number->string i)))) + ";\n")) + (lp (cdr ls) (+ i 1))))))) " return res;\n" "}\n\n") (set! *funcs* From 925401c114a50e07149b82d90a0868495a2ab688 Mon Sep 17 00:00:00 2001 From: foof Date: Tue, 12 Jan 2010 13:00:37 -0500 Subject: [PATCH 344/535] fixing division of flonum by fixnum (issue #25) --- opt/bignum.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/opt/bignum.c b/opt/bignum.c index 9af36997..2cd42bb0 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -631,7 +631,7 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) { r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); break; case SEXP_NUM_FLO_FIX: - r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)/sexp_flonum_value(a)); + r = sexp_make_flonum(ctx, sexp_flonum_value(a)/sexp_fixnum_to_double(b)); break; case SEXP_NUM_FLO_FLO: r = sexp_fp_div(ctx, a, b); From ad1be9cbcd3693b9c19d437c737cc048c4fd0276 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 20 Jan 2010 20:45:06 +0900 Subject: [PATCH 345/535] fixing FFI # args check (> 6), not (>= 6) --- tools/genstubs.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 06bd9c3c..5d4a89f1 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -260,7 +260,7 @@ (s-args '())) (cond ((null? ls) - (if (>= i 6) + (if (> i 6) (error "FFI currently only supports up to 6 scheme args" func)) (vector scheme-name c-name stub-name ret-type (reverse results) (reverse c-args) (reverse s-args))) From add39db40b5b617a2444e65aab56c78252507d23 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 20 Jan 2010 21:00:37 +0900 Subject: [PATCH 346/535] fixing error checks on first digit for numbers with #r prefix (issue #27) --- sexp.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/sexp.c b/sexp.c index 5e313b12..e0285afc 100644 --- a/sexp.c +++ b/sexp.c @@ -1328,12 +1328,12 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { int c, digit, negativep = 0; c = sexp_read_char(ctx, in); - if (c == '-') + if (c == '-') { negativep = 1; - else if (isdigit(c)) - res = digit_value(c); + c = sexp_read_char(ctx, in); + } - for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + for ( ; isxdigit(c); c=sexp_read_char(ctx, in)) { digit = digit_value(c); if ((digit < 0) || (digit >= base)) break; From 6fb2d4cf213e4b7fbec9b7ce4b77595ba66698e2 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 22 Jan 2010 00:24:28 +0900 Subject: [PATCH 347/535] adding mechanism to statically include modules which use C code --- Makefile | 16 +++-- README | 16 +++++ eval.c | 7 ++ include/chibi/features.h | 14 ++++ lib/chibi/ast.module | 1 + lib/chibi/filesystem.module | 2 +- lib/chibi/heap-stats.module | 1 + lib/config.scm | 20 +++--- tools/genstatic.scm | 135 ++++++++++++++++++++++++++++++++++++ 9 files changed, 198 insertions(+), 14 deletions(-) create mode 100755 tools/genstatic.scm diff --git a/Makefile b/Makefile index 8b58ef90..941e3e9c 100644 --- a/Makefile +++ b/Makefile @@ -17,7 +17,8 @@ MANDIR ?= $(PREFIX)/share/man/man1 DESTDIR ?= -GENSTUBS ?= ./tools/genstubs.scm +GENSTUBS ?= ./tools/genstubs.scm +GENSTATIC ?= ./tools/genstatic.scm ######################################################################## # system configuration - if not using GNU make, set PLATFORM and the @@ -50,6 +51,7 @@ CC = gcc CLIBFLAGS = -shared CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL -DSEXP_USE_DEBUG=0 LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +STATICFLAGS = -DSEXP_USE_DL=0 else SO = .so EXE = @@ -118,10 +120,16 @@ 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) + $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm + +clibs.c: $(GENSTATIC) lib lib/chibi lib/srfi + make chibi-scheme$(EXE) + make libs + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) PATH=.:$(PATH) $(GENSTATIC) $< > $@ %.c: %.stub $(GENSTUBS) - LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) PATH=.:$(PATH) $(GENSTUBS) $< + make chibi-scheme$(EXE) + -LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) PATH=.:$(PATH) $(GENSTUBS) $< lib/%$(SO): lib/%.c $(INCLUDES) -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme @@ -178,7 +186,7 @@ install: chibi-scheme$(EXE) -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ mkdir -p $(DESTDIR)$(MANDIR) cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/ - if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + -if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi uninstall: rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) diff --git a/README b/README index 172c476d..69965ea7 100644 --- a/README +++ b/README @@ -41,6 +41,22 @@ directly from make with: make SEXP_USE_BOEHM=1 +To compile a static executable, use + + make chibi-scheme-static SEXP_USE_DL=0 + +To compile a static executable with all C libraries statically +included, first you need to create a clibs.c file, which can be done +with: + + make clibs.c + +or edited manually. Be sure to run this with a non-static +chibi-scheme. Then you can make the static executable with: + + make cleaner + make chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS + ------------------------------------------------------------------------ CHIBI-SCHEME LANGUAGE diff --git a/eval.c b/eval.c index d74812a6..7f48dd6e 100644 --- a/eval.c +++ b/eval.c @@ -2414,6 +2414,10 @@ sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index) { #endif +#if SEXP_USE_STATIC_LIBS +#include "clibs.c" +#endif + /*********************** standard environment *************************/ static struct sexp_struct core_forms[] = { @@ -2606,6 +2610,9 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { } sexp_env_define(ctx, e, sym, tmp); } +#endif +#if SEXP_USE_STATIC_LIBS + sexp_init_all_libraries(ctx, e); #endif sexp_gc_release3(ctx); return sexp_exceptionp(tmp) ? tmp : e; diff --git a/include/chibi/features.h b/include/chibi/features.h index 9143a071..1a6caed2 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -17,6 +17,16 @@ /* sexp_init_library(ctx, env) function provided. */ /* #define SEXP_USE_DL 0 */ +/* uncomment this to statically compile all C libs */ +/* If set, this will statically include the clibs.c file */ +/* into the standard environment, so that you can have */ +/* access to a predefined set of C libraries without */ +/* needing dynamic loading. The clibs.c file is generated */ +/* automatically by searching the lib directory for */ +/* modules with include-shared, but can be hand-tailored */ +/* to your needs. */ +/* #define SEXP_USE_STATIC_LIBS 1 */ + /* uncomment this to disable a simplifying optimization pass */ /* This performs some simple optimizations such as dead-code */ /* elimination, constant-folding, and directly propagating */ @@ -179,6 +189,10 @@ #endif #endif +#ifndef SEXP_USE_STATIC_LIBS +#define SEXP_USE_STATIC_LIBS 0 +#endif + #ifndef SEXP_USE_SIMPLIFY #define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES #endif diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index 57068ece..497fc5ed 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -10,5 +10,6 @@ set-var set-value set-var-set! set-value-set! ref-name ref-cell ref-name-set! ref-cell-set! seq-ls seq-ls-set! lit-value lit-value-set!) + (import-immutable (scheme)) (include-shared "ast")) diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module index f7fa4e99..ecd4af32 100644 --- a/lib/chibi/filesystem.module +++ b/lib/chibi/filesystem.module @@ -4,7 +4,7 @@ duplicate-file-descriptor duplicate-file-descriptor-to close-file-descriptor renumber-file-descriptor delete-file link-file symbolic-link-file rename-file - directory-files create-directory delete-directory + directory-files directory-fold create-directory delete-directory file-status file-device file-inode file-mode file-num-links diff --git a/lib/chibi/heap-stats.module b/lib/chibi/heap-stats.module index af84ca44..c1599c35 100644 --- a/lib/chibi/heap-stats.module +++ b/lib/chibi/heap-stats.module @@ -1,5 +1,6 @@ (define-module (chibi heap-stats) (export heap-stats heap-dump) + (import-immutable (scheme)) (include-shared "heap-stats")) diff --git a/lib/config.scm b/lib/config.scm index 1254360d..dbdf28b2 100644 --- a/lib/config.scm +++ b/lib/config.scm @@ -111,15 +111,17 @@ (eq? (car x) 'import-immutable)))) (cdr x))) ((include include-shared) - (for-each - (lambda (f) - (let ((f (string-append - dir f - (if (eq? (car x) 'include) "" *shared-object-extension*)))) - (cond - ((find-module-file f) => (lambda (x) (load x env))) - (else (error "couldn't find include" f))))) - (cdr x))) + (if (cond-expand (dynamic-loading #t) + (else (not (eq? 'include-shared (car x))))) + (for-each + (lambda (f) + (let ((f (string-append + dir f + (if (eq? (car x) 'include) "" *shared-object-extension*)))) + (cond + ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + (cdr x)))) ((body) (for-each (lambda (expr) (eval expr env)) (cdr x))))) (module-meta-data mod)) diff --git a/tools/genstatic.scm b/tools/genstatic.scm new file mode 100755 index 00000000..3382698e --- /dev/null +++ b/tools/genstatic.scm @@ -0,0 +1,135 @@ +#! /usr/bin/env chibi-scheme + +(import (chibi filesystem) + (chibi pathname)) + +(define c-libs '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (path-relative path dir) + (let ((p-len (string-length path)) + (d-len (string-length dir))) + (and (> p-len d-len) + (string=? dir (substring path 0 d-len)) + (cond + ((eqv? #\/ (string-ref path d-len)) + (substring path (+ d-len 1) p-len)) + ((eqv? #\/ (string-ref path (- d-len 1))) + (substring path d-len p-len)) + (else #f))))) + +(define (path-split file) + (let ((len (string-length file))) + (let lp ((i 0) (res '())) + (let ((j (string-scan #\/ file i))) + (cond + (j (lp (+ j 1) (cons (substring file i j) res))) + (else (reverse (if (= i len) + res + (cons (substring file i len) res))))))))) + +(define (init-name mod) + (string-append "sexp_init_lib_" + (string-concatenate (map mangle mod) "_"))) + +(define (find-c-libs basedir) + (define (process-dir dir) + (directory-fold + dir + (lambda (f x) + (if (and (not (equal? "" f)) (not (eqv? #\. (string-ref f 0)))) + (process (string-append dir "/" f)))) + #f)) + (define (process file) + (cond + ((file-directory? file) + (process-dir file)) + ((equal? "module" (path-extension file)) + (let* ((mod-path (path-strip-extension (path-relative file basedir))) + (mod-name (map (lambda (x) (or (string->number x) (string->symbol x))) + (path-split mod-path)))) + (cond + ((eval `(find-module ',mod-name) *config-env*) + => (lambda (mod) + (cond + ((assq 'include-shared (vector-ref mod 2)) + => (lambda (x) + (set! c-libs + (cons (cons (string-append + (path-directory file) + "/" + (cadr x) + ".c") + (init-name mod-name)) + c-libs)))))))))))) + (process-dir basedir)) + +(define (include-c-lib lib) + (display "#define sexp_init_library ") + (display (cdr lib)) + (newline) + (display "#include \"") + (display (car lib)) + (display "\"") + (newline) + (display "#undef sexp_init_library") + (newline) + (newline)) + +(define (init-c-lib lib) + (display " ") + (display (cdr lib)) + (display "(ctx, env);\n")) + +(define (main args) + (find-c-libs (if (pair? (cdr args)) (cadr args) "lib")) + (newline) + (for-each include-c-lib c-libs) + (newline) + (display "static sexp sexp_init_all_libraries (sexp ctx, sexp env) {\n") + (for-each init-c-lib c-libs) + (display " return SEXP_VOID;\n") + (display "}\n\n")) + From 372aabb63645bafd9bd73adf0823f932844bc01d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 22 Jan 2010 10:50:28 +0900 Subject: [PATCH 348/535] fixing bug in iota when start/step given --- lib/srfi/1/constructors.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm index e205cee0..3bd3b6a6 100644 --- a/lib/srfi/1/constructors.scm +++ b/lib/srfi/1/constructors.scm @@ -29,7 +29,7 @@ (define (iota count . o) (let ((start (if (pair? o) (car o) count)) (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) - (let lp ((i count) (n (- start step)) (res '())) + (let lp ((i count) (n (+ start (* (- count 1) step))) (res '())) (if (<= i 0) res (lp (- i 1) (- n step) (cons n res)))))) From bd1e861afa8b476f64d8a809e24f43114eec7844 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 22 Jan 2010 11:57:07 +0900 Subject: [PATCH 349/535] fixing the default start in iota --- lib/srfi/1/constructors.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm index 3bd3b6a6..1f8a8d5e 100644 --- a/lib/srfi/1/constructors.scm +++ b/lib/srfi/1/constructors.scm @@ -27,7 +27,7 @@ res)) (define (iota count . o) - (let ((start (if (pair? o) (car o) count)) + (let ((start (if (pair? o) (car o) 0)) (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) (let lp ((i count) (n (+ start (* (- count 1) step))) (res '())) (if (<= i 0) From dd8846de76854de72dea3ebe43353359edb622f1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 24 Jan 2010 01:46:25 +0900 Subject: [PATCH 350/535] GC preserving result in C struct constructors. --- tools/genstubs.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 5d4a89f1..d3c1892c 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -1111,7 +1111,9 @@ (lp (cdr ls) (+ i 1)))))) ") {\n" " struct " (type-name name) " *r;\n" - " sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + " sexp_gc_var1(res);\n" + " sexp_gc_preserve1(ctx, res);\n" + " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " (type-id-name name) ");\n" " sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" @@ -1133,6 +1135,7 @@ (number->string i)))) ";\n")) (lp (cdr ls) (+ i 1))))))) + " sexp_gc_release1(ctx);\n" " return res;\n" "}\n\n") (set! *funcs* From 49174f31ba6d8175f298c6e3f2be05aa7818d153 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 24 Jan 2010 02:09:23 +0900 Subject: [PATCH 351/535] using separately malloced struct for C struct constructors --- tools/genstubs.scm | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index d3c1892c..581ea2c1 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -1113,11 +1113,16 @@ " struct " (type-name name) " *r;\n" " sexp_gc_var1(res);\n" " sexp_gc_preserve1(ctx, res);\n" - " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + ;; (type-id-name name) + ;; ");\n" + ;; " r = sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), " (type-id-name name) ");\n" - " sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" - " r = sexp_cpointer_value(res);\n" + " r = sexp_cpointer_value(res) = malloc(sizeof(struct " + (type-name name) "));\n" + " sexp_freep(res) = 1;\n" (lambda () (let lp ((ls args) (i 0)) (cond @@ -1127,7 +1132,7 @@ (any (lambda (f) (and (pair? f) (eq? a (cadr f)))) (cddr x)))) (if field - (cat " r." (cadr field) " = " + (cat " r->" (cadr field) " = " (lambda () (scheme->c-converter (car field) From 8946aaca2592de3fd76878a1a4a4a97c3526da92 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 24 Jan 2010 21:43:58 +0900 Subject: [PATCH 352/535] makefile tweaks from Lorenzo Campedelli (issue 28) --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 941e3e9c..be8ff9bd 100644 --- a/Makefile +++ b/Makefile @@ -92,7 +92,7 @@ COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ libs: $(COMPILED_LIBS) -INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h +INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h include/chibi/install.h: Makefile echo '#define sexp_so_extension "'$(SO)'"' > $@ @@ -174,8 +174,8 @@ test: chibi-scheme$(EXE) install: chibi-scheme$(EXE) mkdir -p $(DESTDIR)$(BINDIR) cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ + cp tools/genstubs.scm $(DESTDIR)$(BINDIR)/ mkdir -p $(DESTDIR)$(MODDIR) - cp lib/init.scm lib/config.scm $(DESTDIR)$(MODDIR)/ cp -r lib/ $(DESTDIR)$(MODDIR)/ mkdir -p $(DESTDIR)$(INCDIR) cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ From 8046a3c1390f21ef56b8571c2cecc285f92f646c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 24 Jan 2010 21:52:46 +0900 Subject: [PATCH 353/535] workaround for bug in fmemopen - open /dev/null instead of empty strings --- sexp.c | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/sexp.c b/sexp.c index e0285afc..3549f5b7 100644 --- a/sexp.c +++ b/sexp.c @@ -889,9 +889,18 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) { sexp res; if (! sexp_stringp(str)) return sexp_type_exception(ctx, "open-input-string: not a string", str); - in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); - res = sexp_make_input_port(ctx, in, SEXP_FALSE); - sexp_port_cookie(res) = str; /* for gc preservation */ + if (sexp_string_length(str) == 0) + in = fopen("/dev/null", "r"); + else + in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + if (in) { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + if (sexp_string_length(str) == 0) + sexp_port_name(res) = sexp_c_string(ctx, "/dev/null", -1); + sexp_port_cookie(res) = str; /* for gc preservation */ + } else { + res = sexp_user_exception(ctx, SEXP_FALSE, "couldn't open string", str); + } return res; } From b8e816c4603d4692b6fa31e94e856aa5d55725e7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 24 Jan 2010 22:03:36 +0900 Subject: [PATCH 354/535] number->string and string->number edge cases (issue 29) --- lib/init.scm | 32 ++++++++++++++++++++------------ 1 file changed, 20 insertions(+), 12 deletions(-) diff --git a/lib/init.scm b/lib/init.scm index 853e2f99..b0bea0a7 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -488,24 +488,32 @@ (and (<= 65 (char->integer (char-upcase ch)) 70) (- (char->integer (char-upcase ch)) 55)))) -(define (number->string n . o) +(define (number->string num . 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 '())) + (call-with-output-string (lambda (out) (write num out))) + (let lp ((n (abs num)) (d (car o)) (res '())) (if (> n 0) (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) - (if (null? res) "0" (list->string res)))))) + (if (null? res) + "0" + (list->string (if (negative? num) (cons #\- res) 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)))))))))) + (cond + ((= 0 (string-length str)) + #f) + ((if (null? o) + #t + (if (eq? 10 (car o)) #t (eq? #\# (string-ref str 0)))) + (call-with-input-string str (lambda (in) (read in)))) + (else + (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 From 59e88c7ded898c0aac6b17901e3b3a4dd1382604 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 27 Jan 2010 22:35:59 +0900 Subject: [PATCH 355/535] fixing simplify bug, neither var can be mutated for a let id substitution (issue 30) --- opt/simplify.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/opt/simplify.c b/opt/simplify.c index d4ac576d..fb99f12f 100644 --- a/opt/simplify.c +++ b/opt/simplify.c @@ -54,7 +54,9 @@ static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv)) && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2)) || (sexp_refp(sexp_car(ls2)) - && sexp_lambdap(sexp_ref_loc(sexp_car(ls2)))))) { + && sexp_lambdap(sexp_ref_loc(sexp_car(ls2))) + && sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)), + sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) { tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2)); tmp = sexp_cons(ctx, sexp_car(p2), tmp); sexp_push(ctx, substs, tmp); From d4eaecd65837c6bf55b453c959cf87b725d783e3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 28 Jan 2010 01:02:33 +0900 Subject: [PATCH 356/535] (/ big big) and (- big flo) patches from lorenzo campedelli (issue 31) --- opt/bignum.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/opt/bignum.c b/opt/bignum.c index 2cd42bb0..7e48466c 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -565,6 +565,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { break; case SEXP_NUM_BIG_FLO: r = sexp_make_flonum(ctx, sexp_flonum_value(b) - sexp_bignum_to_double(a)); + break; case SEXP_NUM_BIG_BIG: r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); break; @@ -646,7 +647,7 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) { r = sexp_bignum_quot_rem(ctx, &rem, a, b); if (sexp_bignum_normalize(rem) != SEXP_ZERO) r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) - / sexp_fixnum_to_double(b)); + / sexp_bignum_to_double(b)); else r = sexp_bignum_normalize(r); break; From 7d4a34a17525a7b1b35a9a7582ca0e0ef88a09ab Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 5 Feb 2010 10:31:22 +0900 Subject: [PATCH 357/535] fixing installed lib files (thanks sladegen) --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index be8ff9bd..cb7633f2 100644 --- a/Makefile +++ b/Makefile @@ -176,7 +176,7 @@ install: chibi-scheme$(EXE) cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ cp tools/genstubs.scm $(DESTDIR)$(BINDIR)/ mkdir -p $(DESTDIR)$(MODDIR) - cp -r lib/ $(DESTDIR)$(MODDIR)/ + cp -r lib/* $(DESTDIR)$(MODDIR)/ mkdir -p $(DESTDIR)$(INCDIR) cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ mkdir -p $(DESTDIR)$(LIBDIR) From 2d8c3829785c952f0c3b9321755380b20dce43ac Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 5 Feb 2010 13:17:43 +0900 Subject: [PATCH 358/535] fixing sign of (- bignum flonum) (issue 31) --- opt/bignum.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/opt/bignum.c b/opt/bignum.c index 7e48466c..835b354f 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -564,7 +564,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, tmp)); break; case SEXP_NUM_BIG_FLO: - r = sexp_make_flonum(ctx, sexp_flonum_value(b) - sexp_bignum_to_double(a)); + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) - sexp_flonum_value(b)); break; case SEXP_NUM_BIG_BIG: r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); From e8030d7eb780952d6f407abf7c3f85f16b161320 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 5 Feb 2010 13:27:04 +0900 Subject: [PATCH 359/535] fixing bug when reading invalid "." in non-decimal bignums (issue 32) --- opt/bignum.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/opt/bignum.c b/opt/bignum.c index 835b354f..61bde456 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -225,8 +225,10 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, if (c=='.' || c=='e' || c=='E') { if (base != 10) res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); - if (c!='.') sexp_push_char(ctx, c, in); - res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); + else { + if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */ + res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); + } } else if ((c!=EOF) && ! is_separator(c)) { res = sexp_read_error(ctx, "invalid numeric syntax", sexp_make_character(c), in); From 4020a1c1f6a025e086aaf8a0f73918176372c724 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 5 Feb 2010 13:30:00 +0900 Subject: [PATCH 360/535] widening whole # input to a double on read_float_tail (issue 33) --- sexp.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/sexp.c b/sexp.c index 3549f5b7..58dc734b 100644 --- a/sexp.c +++ b/sexp.c @@ -19,7 +19,7 @@ static struct sexp_huff_entry huff_table[] = { static int sexp_initialized_p = 0; -sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp); +sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp); static char sexp_separators[] = { /* 1 2 3 4 5 6 7 8 9 a b c d e f */ @@ -1304,7 +1304,7 @@ sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) { return res; } -sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp) { +sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp) { sexp exponent=SEXP_VOID; double res=0.0, scale=0.1, e=0.0; int c; @@ -1323,7 +1323,7 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp) { } else { sexp_push_char(ctx, c, in); } - res = ((double)whole + res) * pow(10, e); + res = (whole + res) * pow(10, e); if (negp) res *= -1; if ((scale == 0.1) && (exponent != SEXP_VOID) && (res == round(res))) return sexp_make_fixnum(res); From 4dcfb8aa6b05bf18964690eaed983c49b2ac0cbd Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 5 Feb 2010 13:42:30 +0900 Subject: [PATCH 361/535] exponents in numbers always indicate inexactness per R5RS (indirectly fixes issue 34) --- sexp.c | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/sexp.c b/sexp.c index 58dc734b..d0c41eaf 100644 --- a/sexp.c +++ b/sexp.c @@ -1325,10 +1325,7 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp) { } res = (whole + res) * pow(10, e); if (negp) res *= -1; - if ((scale == 0.1) && (exponent != SEXP_VOID) && (res == round(res))) - return sexp_make_fixnum(res); - else - return sexp_make_flonum(ctx, res); + return sexp_make_flonum(ctx, res); } sexp sexp_read_number(sexp ctx, sexp in, int base) { From efb6f24a610639f91b2d8e81a12be204d4655b44 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 6 Feb 2010 21:33:45 +0900 Subject: [PATCH 362/535] don't push back final char when reading a bignum-sized float (issue 32, part 2) --- opt/bignum.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/opt/bignum.c b/opt/bignum.c index 61bde456..37c94c72 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -223,17 +223,18 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, res = sexp_bignum_fxadd(ctx, res, digit); } if (c=='.' || c=='e' || c=='E') { - if (base != 10) + if (base != 10) { res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); - else { + } else { if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */ res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); } } else if ((c!=EOF) && ! is_separator(c)) { res = sexp_read_error(ctx, "invalid numeric syntax", sexp_make_character(c), in); + } else { + sexp_push_char(ctx, c, in); } - sexp_push_char(ctx, c, in); sexp_gc_release1(ctx); return sexp_bignum_normalize(res); } From b71195955ea2c6b17e1d6df8434967e82c87e6b7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 11 Feb 2010 19:00:53 +0900 Subject: [PATCH 363/535] fixing sort when less predicate is given without a key --- lib/srfi/95/qsort.c | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c index 6b304e54..f9f1bd9e 100644 --- a/lib/srfi/95/qsort.c +++ b/lib/srfi/95/qsort.c @@ -99,11 +99,19 @@ static sexp sexp_qsort_less (sexp ctx, sexp *vec, } else { mid = lo + (hi-lo)/2; swap(tmp, vec[mid], vec[hi]); - sexp_car(args1) = tmp; - b = sexp_apply(ctx, key, args1); + if (sexp_truep(key)) { + sexp_car(args1) = tmp; + b = sexp_apply(ctx, key, args1); + } else { + b = tmp; + } for (i=j=lo; i < hi; i++) { - sexp_car(args1) = vec[i]; - a = sexp_apply(ctx, key, args1); + if (sexp_truep(key)) { + sexp_car(args1) = vec[i]; + a = sexp_apply(ctx, key, args1); + } else { + a = vec[i]; + } sexp_car(args2) = a; sexp_car(args1) = b; res = sexp_apply(ctx, less, args2); From 819fbd2c9945c1e351bd8101fa991f6e8ae55ef9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 25 Feb 2010 23:54:47 +0900 Subject: [PATCH 364/535] fixing bug in sorted? --- lib/srfi/95/sort.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm index 38273199..14e24517 100644 --- a/lib/srfi/95/sort.scm +++ b/lib/srfi/95/sort.scm @@ -27,7 +27,7 @@ ((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f) (else (lp (+ i 1))))))) ((null? seq) - #f) + #t) (else (let lp ((ls1 seq) (ls2 (cdr seq))) (cond ((null? ls2) #t) From 445f5f5f311c0a5145a644f906098c80435edf9d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 25 Feb 2010 23:55:38 +0900 Subject: [PATCH 365/535] stripping syntactic-closures from record descriptive names --- lib/srfi/9.module | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/lib/srfi/9.module b/lib/srfi/9.module index 0516b201..1c9aad91 100644 --- a/lib/srfi/9.module +++ b/lib/srfi/9.module @@ -7,12 +7,13 @@ (er-macro-transformer (lambda (expr rename compare) (let* ((name (cadr expr)) + (name-str (symbol->string (identifier->symbol name))) (make (caaddr expr)) (make-fields (cdaddr expr)) (pred (cadddr expr)) (fields (cddddr expr)) (num-fields (length fields)) - (index (register-simple-type (symbol->string name) num-fields)) + (index (register-simple-type name-str num-fields)) (_define (rename 'define)) (_lambda (rename 'lambda)) (_let (rename 'let))) @@ -21,7 +22,7 @@ (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) `(,(rename 'begin) (,_define ,pred (,(rename 'make-type-predicate) - ,(symbol->string pred) + ,(symbol->string (identifier->symbol pred)) ,index)) ,@(let lp ((ls fields) (i 0) (res '())) (if (null? ls) @@ -29,7 +30,8 @@ (let ((res (cons `(,_define ,(cadar ls) (,(rename 'make-getter) - ,(symbol->string (cadar ls)) + ,(symbol->string + (identifier->symbol (cadar ls))) ,index ,i)) res))) @@ -39,7 +41,8 @@ (cons `(,_define ,(caddar ls) (,(rename 'make-setter) - ,(symbol->string (caddar ls)) + ,(symbol->string + (identifier->symbol (caddar ls))) ,index ,i)) res) @@ -49,7 +52,7 @@ (cond ((null? ls) `(,_let ((%make (,(rename 'make-constructor) - ,(symbol->string make) + ,(symbol->string (identifier->symbol make)) ,index)) ,@set-defs) (,_lambda ,make-fields @@ -67,7 +70,7 @@ set-defs)) (else (let* ((setter-name - (string-append "%" (symbol->string name) "-" + (string-append "%" name-str "-" (symbol->string (car ls)) "-set!")) (setter (rename (string->symbol setter-name))) (i (index-of (car ls) fields))) From 5ee65cd71b44b44f9eb9d49146aeeb4ce3e617f0 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 25 Feb 2010 23:56:28 +0900 Subject: [PATCH 366/535] fixing bug in multiple -p/-e options to main --- main.c | 1 - 1 file changed, 1 deletion(-) diff --git a/main.c b/main.c index 3fc018bf..df1d9017 100644 --- a/main.c +++ b/main.c @@ -104,7 +104,6 @@ void run_main (int argc, char **argv) { sexp_write_char(ctx, '\n', out); } quit = 1; - i++; break; case 'l': load_init(); From 670a4ae67b83af151c373e9dba7febc660ccf48e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 25 Feb 2010 23:58:57 +0900 Subject: [PATCH 367/535] adding option to mmap heaps instead of mallocing them --- gc.c | 14 ++++++++++++-- include/chibi/features.h | 7 +++++++ sexp.c | 16 ++++++++++++---- 3 files changed, 31 insertions(+), 6 deletions(-) diff --git a/gc.c b/gc.c index 5e2a4d23..455b1a85 100644 --- a/gc.c +++ b/gc.c @@ -4,6 +4,10 @@ #include "chibi/sexp.h" +#if SEXP_USE_MMAP_GC +#include +#endif + /* These settings are configurable but only recommended for */ /* experienced users, so they're not in config.h. */ @@ -171,8 +175,14 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) { sexp_heap sexp_make_heap (size_t size) { sexp_free_list free, next; - sexp_heap h - = (sexp_heap) malloc(sizeof(struct sexp_heap) + size + sexp_heap_align(1)); + sexp_heap h; +#if SEXP_USE_MMAP_GC + h = mmap(NULL, sizeof(struct sexp_heap) + size + sexp_heap_align(1), + PROT_READ|PROT_WRITE|PROT_EXEC, + MAP_ANON|MAP_PRIVATE, 0, 0); +#else + h = malloc(sizeof(struct sexp_heap) + size + sexp_heap_align(1)); +#endif if (! h) return NULL; h->size = size; h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); diff --git a/include/chibi/features.h b/include/chibi/features.h index 1a6caed2..d93f5b5c 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -57,6 +57,9 @@ /* explicitly free sexps, though. */ /* #define SEXP_USE_MALLOC 1 */ +/* uncomment this to allocate heaps with mmap instead of malloc */ +/* #define SEXP_USE_MMAP_GC 1 */ + /* uncomment this to add conservative checks to the native GC */ /* Please mail the author if enabling this makes a bug */ /* go away and you're not working on your own C extension. */ @@ -205,6 +208,10 @@ #define SEXP_USE_MALLOC 0 #endif +#ifndef SEXP_USE_MMAP_GC +#define SEXP_USE_MMAP_GC 0 +#endif + #ifndef SEXP_USE_DEBUG_GC #define SEXP_USE_DEBUG_GC 0 #endif diff --git a/sexp.c b/sexp.c index d0c41eaf..dd32415d 100644 --- a/sexp.c +++ b/sexp.c @@ -290,13 +290,20 @@ sexp sexp_make_context (sexp ctx, sexp_uint_t size) { #if ! SEXP_USE_GLOBAL_HEAP void sexp_destroy_context (sexp ctx) { - sexp_heap heap; + sexp_heap heap, tmp; size_t sum_freed; if (sexp_context_heap(ctx)) { sexp_sweep(ctx, &sum_freed); /* sweep w/o mark to run finalizers */ heap = sexp_context_heap(ctx); sexp_context_heap(ctx) = NULL; - free(heap); + for ( ; heap; heap=tmp) { + tmp = heap->next; +#if SEXP_USE_MMAP_GC + munmap(heap, heap->size); +#else + free(heap); +#endif + } } } #endif @@ -702,11 +709,12 @@ sexp sexp_intern(sexp ctx, char *str) { #if SEXP_USE_HUFF_SYMS res = 0; for ( ; (c=*p); p++) { + if ((c < 0) || (c > 127)) + goto normal_intern; he = huff_table[(unsigned char)c]; newbits = he.len; - if ((space+newbits) > (sizeof(sexp)*8)) { + if ((space+newbits) > (sizeof(sexp)*8)) goto normal_intern; - } res |= (((sexp_uint_t) he.bits) << space); space += newbits; } From c14e32a0ebdd20dc3fbb252593175285c7d7c901 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 25 Feb 2010 23:59:40 +0900 Subject: [PATCH 368/535] exposing sexp_free_vars --- eval.c | 26 +++++++++++++------------- include/chibi/eval.h | 3 +++ 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/eval.c b/eval.c index 7f48dd6e..9aed9e18 100644 --- a/eval.c +++ b/eval.c @@ -28,7 +28,7 @@ static sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env); static sexp sexp_find_module_file_op (sexp ctx, sexp file); #endif -static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) { +sexp sexp_compile_error (sexp ctx, char *message, sexp obj) { sexp exn; sexp_gc_var3(sym, irritants, msg); sexp_gc_preserve3(ctx, sym, irritants, msg); @@ -1149,12 +1149,12 @@ static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { return res; } -static sexp free_vars (sexp ctx, sexp x, sexp fv) { +sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) { sexp_gc_var2(fv1, fv2); sexp_gc_preserve2(ctx, fv1, fv2); fv1 = fv; if (sexp_lambdap(x)) { - fv1 = free_vars(ctx, sexp_lambda_body(x), SEXP_NULL); + fv1 = sexp_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); @@ -1162,21 +1162,21 @@ static sexp free_vars (sexp ctx, sexp x, sexp fv) { 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); + fv1 = sexp_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); + fv1 = sexp_free_vars(ctx, sexp_cnd_test(x), fv); + fv1 = sexp_free_vars(ctx, sexp_cnd_pass(x), fv1); + fv1 = sexp_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); + fv1 = sexp_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); + fv1 = sexp_free_vars(ctx, sexp_set_value(x), fv); + fv1 = sexp_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); + fv1 = sexp_free_vars(ctx, sexp_synclo_expr(x), fv); } sexp_gc_release2(ctx); return fv1; @@ -2261,7 +2261,7 @@ static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { /************************** optimizations *****************************/ -static sexp sexp_apply_optimization (sexp ctx, sexp proc, sexp ast) { +sexp sexp_apply_optimization (sexp ctx, sexp proc, sexp ast) { sexp res; sexp_gc_var1(args); if (sexp_opcodep(proc)) { @@ -2701,7 +2701,7 @@ sexp sexp_compile (sexp ctx, sexp x) { res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); for ( ; sexp_pairp(res); res=sexp_cdr(res)) ast = sexp_apply_optimization(ctx, sexp_cdar(res), ast); - free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + sexp_free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ generate(ctx, ast); res = finalize_bytecode(ctx); vec = sexp_make_vector(ctx, 0, SEXP_VOID); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 7ce70433..7fa0b1ae 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -124,8 +124,11 @@ enum sexp_opcode_names { SEXP_API void sexp_scheme_init (void); SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size); SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); +SEXP_API sexp sexp_compile_error (sexp ctx, char *message, sexp obj); SEXP_API sexp sexp_analyze (sexp context, sexp x); SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); +SEXP_API sexp sexp_apply_optimization (sexp context, sexp proc, sexp ast); +SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); From 20da1b89098a28d72bd9b8c9d82841db64273429 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 26 Feb 2010 00:04:46 +0900 Subject: [PATCH 369/535] fixing string-ref for 8-bit values (need to separate strings from byte-vectors) --- include/chibi/sexp.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 491e70a9..a47ae337 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -523,7 +523,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #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_fixnum(i)])) +#define sexp_string_ref(x, i) (sexp_make_character((unsigned char)sexp_string_data(x)[sexp_unbox_fixnum(i)])) #define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_character(v)) #define sexp_symbol_string(x) ((x)->value.symbol.string) From a7ad2d547c2a1c26b0246b81d67f1acf0e23f72c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 26 Feb 2010 00:11:12 +0900 Subject: [PATCH 370/535] removing warning about no shared object extension when compiling statically. patch from andreas rottman (issue 36). --- lib/config.scm | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/lib/config.scm b/lib/config.scm index dbdf28b2..be6fb36a 100644 --- a/lib/config.scm +++ b/lib/config.scm @@ -99,6 +99,13 @@ (define (eval-module name mod) (let ((env (make-environment)) (dir (module-name-prefix name))) + (define (load-modules files extension) + (for-each + (lambda (f) + (let ((f (string-append dir f extension))) + (cond ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + files)) (for-each (lambda (x) (case (and (pair? x) (car x)) @@ -110,18 +117,12 @@ (%env-copy! env (module-env mod2) (cdr mod2-name+imports) (eq? (car x) 'import-immutable)))) (cdr x))) - ((include include-shared) - (if (cond-expand (dynamic-loading #t) - (else (not (eq? 'include-shared (car x))))) - (for-each - (lambda (f) - (let ((f (string-append - dir f - (if (eq? (car x) 'include) "" *shared-object-extension*)))) - (cond - ((find-module-file f) => (lambda (x) (load x env))) - (else (error "couldn't find include" f))))) - (cdr x)))) + ((include) + (load-modules (cdr x) "")) + ((include-shared) + (cond-expand + (dynamic-loading (load-modules (cdr x) *shared-object-extension*)) + (else #f))) ((body) (for-each (lambda (expr) (eval expr env)) (cdr x))))) (module-meta-data mod)) From fea1b696a4158e86cf0aafc3cb7cfc1bb820d634 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 27 Feb 2010 23:57:54 +0900 Subject: [PATCH 371/535] adding patches for C++ --- eval.c | 2 +- gc.c | 4 ++-- include/chibi/eval.h | 9 +++++++++ include/chibi/sexp.h | 20 ++++++++++++++------ sexp.c | 8 ++++---- 5 files changed, 30 insertions(+), 13 deletions(-) diff --git a/eval.c b/eval.c index 9aed9e18..66ab8649 100644 --- a/eval.c +++ b/eval.c @@ -148,7 +148,7 @@ 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) { +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++) diff --git a/gc.c b/gc.c index 455b1a85..b7f275f2 100644 --- a/gc.c +++ b/gc.c @@ -177,11 +177,11 @@ sexp_heap sexp_make_heap (size_t size) { sexp_free_list free, next; sexp_heap h; #if SEXP_USE_MMAP_GC - h = mmap(NULL, sizeof(struct sexp_heap) + size + sexp_heap_align(1), + h = mmap(NULL, sizeof(struct sexp_heap_t) + size + sexp_heap_align(1), PROT_READ|PROT_WRITE|PROT_EXEC, MAP_ANON|MAP_PRIVATE, 0, 0); #else - h = malloc(sizeof(struct sexp_heap) + size + sexp_heap_align(1)); + h = malloc(sizeof(struct sexp_heap_t) + size + sexp_heap_align(1)); #endif if (! h) return NULL; h->size = size; diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 7fa0b1ae..22b82f7f 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -5,6 +5,10 @@ #ifndef SEXP_EVAL_H #define SEXP_EVAL_H +#ifdef __cplusplus +extern "C" { +#endif + #include "chibi/sexp.h" /************************* additional types ***************************/ @@ -129,6 +133,7 @@ SEXP_API sexp sexp_analyze (sexp context, sexp x); SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); SEXP_API sexp sexp_apply_optimization (sexp context, sexp proc, sexp ast); SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); +SEXP_API int sexp_param_index (sexp lambda, sexp name); SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); @@ -164,5 +169,9 @@ SEXP_API sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index); SEXP_API sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index); #endif +#ifdef __cplusplus +} /* extern "C" */ +#endif + #endif /* ! SEXP_EVAL_H */ diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index a47ae337..054be66c 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -5,6 +5,10 @@ #ifndef SEXP_H #define SEXP_H +#ifdef __cplusplus +extern "C" { +#endif + #define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" #include "chibi/features.h" @@ -129,14 +133,14 @@ 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 sexp_free_list *sexp_free_list; -struct sexp_free_list { +typedef struct sexp_free_list_t *sexp_free_list; +struct sexp_free_list_t { sexp_uint_t size; sexp_free_list next; }; -typedef struct sexp_heap *sexp_heap; -struct sexp_heap { +typedef struct sexp_heap_t *sexp_heap; +struct sexp_heap_t { sexp_uint_t size; sexp_free_list free_list; sexp_heap next; @@ -811,7 +815,7 @@ 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_c_string(sexp ctx, const 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_string_concatenate (sexp ctx, sexp str_ls, sexp sep); @@ -819,7 +823,7 @@ 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_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, sexp parent, int freep); +SEXP_API sexp sexp_make_cpointer(sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out); SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out); SEXP_API sexp sexp_flush_output(sexp ctx, sexp out); @@ -862,5 +866,9 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp obj); #define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) #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))) +#ifdef __cplusplus +} /* extern "C" */ +#endif + #endif /* ! SEXP_H */ diff --git a/sexp.c b/sexp.c index dd32415d..b6304431 100644 --- a/sexp.c +++ b/sexp.c @@ -623,7 +623,7 @@ sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { return s; } -sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen) { +sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen) { sexp_sint_t len = ((slen >= 0) ? slen : strlen(str)); sexp s = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID); memcpy(sexp_string_data(s), str, len); @@ -709,7 +709,7 @@ sexp sexp_intern(sexp ctx, char *str) { #if SEXP_USE_HUFF_SYMS res = 0; for ( ; (c=*p); p++) { - if ((c < 0) || (c > 127)) + if ((unsigned char)c > 127) goto normal_intern; he = huff_table[(unsigned char)c]; newbits = he.len; @@ -773,10 +773,10 @@ sexp sexp_list_to_vector(sexp ctx, sexp ls) { return vec; } -sexp sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, sexp parent, int freep) { +sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void *value, sexp parent, int freep) { sexp ptr; if (! value) return SEXP_FALSE; - ptr = sexp_alloc_type(ctx, cpointer, typeid); + ptr = sexp_alloc_type(ctx, cpointer, type_id); if (sexp_exceptionp(ptr)) return ptr; sexp_freep(ptr) = freep; sexp_cpointer_value(ptr) = value; From 8dd1d572f00111994442e67d1d66679e762c609a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 1 Mar 2010 01:49:26 +0900 Subject: [PATCH 372/535] fixing test for 1e2 - should be inexact --- tests/r5rs-tests.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 1b22acd2..80db4e00 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -242,7 +242,7 @@ (test 5 (string->number "101" 2)) -(test 100 (string->number "1e2")) +(test 100.0 (string->number "1e2")) (test "100" (number->string 100)) From e999b1a77aac947304b243d42886a37a9a6c0304 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 1 Mar 2010 12:55:24 +0900 Subject: [PATCH 373/535] Need to wrap constant-folded results in a literal. --- opt/simplify.c | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/opt/simplify.c b/opt/simplify.c index fb99f12f..eb4c97f3 100644 --- a/opt/simplify.c +++ b/opt/simplify.c @@ -1,5 +1,5 @@ /* simplify.c -- basic simplification pass */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ #define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda)) @@ -24,7 +24,10 @@ static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); app = sexp_nreverse(ctx, app); + /* app now holds a copy of the list, and is the default result + (res = app below) if we don't replace it with a simplification */ if (sexp_opcodep(sexp_car(app))) { + /* opcode app - right now we just constant fold arithmetic */ if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) { for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { @@ -35,12 +38,15 @@ static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { if (check) { ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0); generate(ctx2, app); - app = finalize_bytecode(ctx2); - if (! sexp_exceptionp(app)) { + res = finalize_bytecode(ctx2); + if (! sexp_exceptionp(res)) { tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); - app = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, app, tmp); - if (! sexp_exceptionp(app)) - app = sexp_apply(ctx2, app, SEXP_NULL); + tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp); + if (! sexp_exceptionp(tmp)) { + tmp = sexp_apply(ctx2, tmp, SEXP_NULL); + if (! sexp_exceptionp(tmp)) + app = sexp_make_lit(ctx2, tmp); + } } } } From 325007d2b92f391c2fa0f31de6cebcadd7ea9bd2 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 1 Mar 2010 13:15:06 +0900 Subject: [PATCH 374/535] Removing SEXP_OP_NEGATIVE and SEXP_OP_INVERSE - these are compiled directly by generate_opcode_app now. Zero arity cases now supported: (-) => 0, (/) => 1, equivalent to the zero arity + and * cases. --- eval.c | 66 +++++++++++++++----------------------------- include/chibi/eval.h | 3 -- opcodes.c | 8 +++--- 3 files changed, 26 insertions(+), 51 deletions(-) diff --git a/eval.c b/eval.c index 66ab8649..d2360568 100644 --- a/eval.c +++ b/eval.c @@ -11,7 +11,7 @@ static int scheme_initialized_p = 0; #if SEXP_USE_DEBUG_VM static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { int i; - if (! sexp_oport(out)) out = sexp_current_error_port(ctx); + if (! sexp_oportp(out)) out = sexp_current_error_port(ctx); for (i=0; i 1) + /* fold variadic arithmetic operators */ + for (i=num_args-1; i>0; i--) emit(ctx, sexp_opcode_code(op)); break; - case SEXP_OPC_ARITHMETIC_INV: - emit(ctx, (num_args==1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); - break; case SEXP_OPC_ARITHMETIC_CMP: if (num_args > 2) { emit(ctx, SEXP_OP_STACK_REF); @@ -993,13 +1002,6 @@ static void generate_opcode_app (sexp ctx, sexp app) { emit(ctx, sexp_opcode_code(op)); } - /* emit optional folding of operator */ - if ((num_args > 2) - && (sexp_opcode_class(op) == SEXP_OPC_ARITHMETIC - || sexp_opcode_class(op) == SEXP_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_release1(ctx); } @@ -1815,30 +1817,6 @@ sexp sexp_vm (sexp ctx, sexp proc) { else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); #endif break; - case SEXP_OP_NEGATIVE: - if (sexp_fixnump(_ARG1)) - _ARG1 = sexp_make_fixnum(-sexp_unbox_fixnum(_ARG1)); -#if SEXP_USE_BIGNUMS - else if (sexp_bignump(_ARG1)) { - _ARG1 = sexp_copy_bignum(ctx, NULL, _ARG1, 0); - sexp_bignum_sign(_ARG1) = -sexp_bignum_sign(_ARG1); - } -#endif -#if SEXP_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 SEXP_OP_INVERSE: - if (sexp_fixnump(_ARG1)) - _ARG1 = sexp_make_flonum(ctx, 1/(double)sexp_unbox_fixnum(_ARG1)); -#if SEXP_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 SEXP_OP_LT: if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; @@ -2686,7 +2664,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { stack[top++] = SEXP_ZERO; sexp_context_top(ctx) = top; res = sexp_vm(ctx, proc); - if (! res) res = SEXP_VOID; + if (! res) res = SEXP_VOID; /* shouldn't happen */ } return res; } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 22b82f7f..2337feb4 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -37,7 +37,6 @@ enum sexp_opcode_classes { SEXP_OPC_TYPE_PREDICATE, SEXP_OPC_PREDICATE, SEXP_OPC_ARITHMETIC, - SEXP_OPC_ARITHMETIC_INV, SEXP_OPC_ARITHMETIC_CMP, SEXP_OPC_IO, SEXP_OPC_CONSTRUCTOR, @@ -102,8 +101,6 @@ enum sexp_opcode_names { SEXP_OP_DIV, SEXP_OP_QUOTIENT, SEXP_OP_REMAINDER, - SEXP_OP_NEGATIVE, - SEXP_OP_INVERSE, SEXP_OP_LT, SEXP_OP_LE, SEXP_OP_EQN, diff --git a/opcodes.c b/opcodes.c index 85a35afc..e3837e42 100644 --- a/opcodes.c +++ b/opcodes.c @@ -33,10 +33,10 @@ _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", _OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_fixnum(0), NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_fixnum(1), NULL), -_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_SUB, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_NEGATIVE, "-", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_DIV, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_INVERSE, "/", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 0, 1, SEXP_FIXNUM, 0, 1, "-", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 0, 1, SEXP_FIXNUM, 0, 1, "/", SEXP_ONE, NULL), _OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), _OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), _OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), From 5002f796d8c078e10a5fbbd5fdf75fd0bbff7a3a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 1 Mar 2010 13:54:57 +0900 Subject: [PATCH 375/535] backing out the zero-arity option to - and / --- opcodes.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/opcodes.c b/opcodes.c index e3837e42..8267f396 100644 --- a/opcodes.c +++ b/opcodes.c @@ -35,8 +35,8 @@ _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), _OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", SEXP_ZERO, NULL), _OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", SEXP_ONE, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 0, 1, SEXP_FIXNUM, 0, 1, "-", SEXP_ZERO, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 0, 1, SEXP_FIXNUM, 0, 1, "/", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, SEXP_FIXNUM, 0, 1, "-", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 1, 1, SEXP_FIXNUM, 0, 1, "/", SEXP_ONE, NULL), _OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), _OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), _OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), From 32de527a7726cbec768e6cc8e17a85053bebdd82 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 1 Mar 2010 15:53:55 +0900 Subject: [PATCH 376/535] adding tests --- Makefile | 3 ++ tests/hash-tests.scm | 74 ++++++++++++++++++++++++++++++++++++++++++++ tests/sort-tests.scm | 51 ++++++++++++++++++++++++++++++ 3 files changed, 128 insertions(+) create mode 100644 tests/hash-tests.scm create mode 100644 tests/sort-tests.scm diff --git a/Makefile b/Makefile index cb7633f2..fcc10ae6 100644 --- a/Makefile +++ b/Makefile @@ -168,6 +168,9 @@ test-match: chibi-scheme$(EXE) test-loop: chibi-scheme$(EXE) LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/loop-tests.scm +test-sort: chibi-scheme$(EXE) + LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/sort-tests.scm + test: chibi-scheme$(EXE) LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/r5rs-tests.scm diff --git a/tests/hash-tests.scm b/tests/hash-tests.scm new file mode 100644 index 00000000..6dec5734 --- /dev/null +++ b/tests/hash-tests.scm @@ -0,0 +1,74 @@ + +(import (srfi 69)) + +(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) + (write *tests-run*) + (display ". ") + (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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test + 'white + (let ((ht (make-hash-table eq?))) + (hash-table-set! ht 'cat 'black) + (hash-table-set! ht 'dog 'white) + (hash-table-set! ht 'elephant 'pink) + (hash-table-ref/default ht 'dog #f))) + +(test + 'white + (let ((ht (make-hash-table equal?))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "dog" #f))) + +(test + 'white + (let ((ht (make-hash-table string-ci=? string-ci-hash))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "DOG" #f))) + +(test 625 + (let ((ht (make-hash-table))) + (do ((i 0 (+ i 1))) ((= i 1000)) + (hash-table-set! ht i (* i i))) + (hash-table-ref/default ht 25 #f))) + +(test-report) + diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm new file mode 100644 index 00000000..a0cc92f4 --- /dev/null +++ b/tests/sort-tests.scm @@ -0,0 +1,51 @@ + +(import (srfi 95)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test "sort null" (sort '()) '()) +(test "sort null <" (sort '() <) '()) +(test "sort null < car" (sort '() < car) '()) +(test "sort list" (sort '(7 5 2 8 1 6 4 9 3)) '(1 2 3 4 5 6 7 8 9)) +(test "sort list <" (sort '(7 5 2 8 1 6 4 9 3) <) '(1 2 3 4 5 6 7 8 9)) +(test "sort list < car" (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car) + '((1) (2) (3) (4) (5) (6) (7) (8) (9))) +(test "sort list (lambda (a b) (< (car a) (car b)))" + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) + (lambda (a b) (< (car a) (car b)))) + '((1) (2) (3) (4) (5) (6) (7) (8) (9))) + +(test-report) From e569fd18478407a7f6eb9f888354ac5af422e605 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 1 Mar 2010 15:55:41 +0900 Subject: [PATCH 377/535] ignoring generated clibs.c --- .hgignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.hgignore b/.hgignore index 386b5fc8..d1af4846 100644 --- a/.hgignore +++ b/.hgignore @@ -16,6 +16,7 @@ junk* *.out gc gc6.8 +clibs.c chibi-scheme chibi-scheme-static include/chibi/install.h From 3123d48da7d6127637311ea991c72b8271fed387 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 1 Mar 2010 15:57:02 +0900 Subject: [PATCH 378/535] removing negative and inverse opcodes from disasm --- lib/chibi/disasm.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index 89fde159..96bcfb47 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -17,7 +17,7 @@ static const char* reverse_opcode_names[] = "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", - "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE", + "MUL", "DIV", "QUOTIENT", "REMAINDER", "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", From a630d84413ce7997eca1caa637a220932b67d545 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 4 Mar 2010 12:35:18 +0900 Subject: [PATCH 379/535] adding dll fixes for mingw --- Makefile | 6 +++++- eval.c | 18 +++++++++++++++++- include/chibi/sexp.h | 2 ++ 3 files changed, 24 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index fcc10ae6..37aa5ca1 100644 --- a/Makefile +++ b/Makefile @@ -24,6 +24,9 @@ GENSTATIC ?= ./tools/genstatic.scm # system configuration - if not using GNU make, set PLATFORM and the # following flags as necessary. +# +LIBDL = -ldl + ifndef PLATFORM ifeq ($(shell uname),Darwin) PLATFORM=macosx @@ -52,6 +55,7 @@ CLIBFLAGS = -shared CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL -DSEXP_USE_DEBUG=0 LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a STATICFLAGS = -DSEXP_USE_DL=0 +LIBDL = else SO = .so EXE = @@ -76,7 +80,7 @@ ifeq ($(SEXP_USE_DL),0) XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm XCFLAGS := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS) else -XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -ldl -lm +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm XCFLAGS := -Wall -g3 $(CFLAGS) endif diff --git a/eval.c b/eval.c index d2360568..8e18b8f7 100644 --- a/eval.c +++ b/eval.c @@ -2039,7 +2039,22 @@ void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) { } #if SEXP_USE_DL -sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { +#ifdef __MINGW32__ +#include +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + HINSTANCE handle = LoadLibraryA(sexp_string_data(file)); + if(!handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = (sexp_proc2) GetProcAddress(handle, "sexp_init_library"); + if(!init) { + FreeLibrary(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx, env); +} +#else +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { sexp_proc2 init; void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); if (! handle) @@ -2052,6 +2067,7 @@ sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { return init(ctx, env); } #endif +#endif sexp sexp_load (sexp ctx, sexp source, sexp env) { #if SEXP_USE_DL diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 054be66c..35dc565a 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -18,8 +18,10 @@ extern "C" { #include #if SEXP_USE_DL +#ifndef __MINGW32__ #include #endif +#endif #ifdef PLAN9 #include From 95e0b0bb31fb5043e1d322ecf3ce3b1d8e5ea75d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 9 Mar 2010 19:08:58 +0900 Subject: [PATCH 380/535] adding type-checking on the remaining I/O opcodes --- eval.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/eval.c b/eval.c index 8e18b8f7..369cb55f 100644 --- a/eval.c +++ b/eval.c @@ -1942,19 +1942,27 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_WRITE_CHAR: if (! sexp_charp(_ARG1)) sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); + if (! sexp_oportp(_ARG2)) + sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2)); sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); _ARG2 = SEXP_VOID; top--; break; case SEXP_OP_NEWLINE: + if (! sexp_oportp(_ARG1)) + sexp_raise("newline: not an output-port", sexp_list1(ctx, _ARG1)); sexp_newline(ctx, _ARG1); _ARG1 = SEXP_VOID; break; case SEXP_OP_READ_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("read-char: not an intput-port", sexp_list1(ctx, _ARG1)); i = sexp_read_char(ctx, _ARG1); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case SEXP_OP_PEEK_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("peek-char: not an intput-port", sexp_list1(ctx, _ARG1)); i = sexp_read_char(ctx, _ARG1); sexp_push_char(ctx, i, _ARG1); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); From 171966956f4da3fc8d45e047cabef1ea1aa8f521 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 9 Mar 2010 20:23:29 +0900 Subject: [PATCH 381/535] fixing bug in sexp_destroy_context We need to grab a reference to the context heap before sweeping, in case sweeping overwrites the heap reference. --- sexp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sexp.c b/sexp.c index b6304431..4d2baed7 100644 --- a/sexp.c +++ b/sexp.c @@ -293,8 +293,8 @@ void sexp_destroy_context (sexp ctx) { sexp_heap heap, tmp; size_t sum_freed; if (sexp_context_heap(ctx)) { - sexp_sweep(ctx, &sum_freed); /* sweep w/o mark to run finalizers */ heap = sexp_context_heap(ctx); + sexp_sweep(ctx, &sum_freed); /* sweep w/o mark to run finalizers */ sexp_context_heap(ctx) = NULL; for ( ; heap; heap=tmp) { tmp = heap->next; From f866875e688788a305492e809a84a882abb89554 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 9 Mar 2010 20:28:32 +0900 Subject: [PATCH 382/535] adding alignment bytcode patch for ARM --- eval.c | 34 +++++++++++++++++++++++++++++++++- include/chibi/features.h | 12 ++++++++++++ include/chibi/sexp.h | 12 ++++++++++++ 3 files changed, 57 insertions(+), 1 deletion(-) diff --git a/eval.c b/eval.c index 369cb55f..eb5be667 100644 --- a/eval.c +++ b/eval.c @@ -206,6 +206,7 @@ static void emit_word (sexp ctx, sexp_uint_t val) { unsigned char *data; expand_bcode(ctx, sizeof(sexp)); data = sexp_bytecode_data(sexp_context_bc(ctx)); + sexp_context_align_pos(ctx); *((sexp_uint_t*)(&(data[sexp_context_pos(ctx)]))) = val; sexp_context_pos(ctx) += sizeof(sexp); } @@ -799,7 +800,9 @@ static sexp analyze (sexp ctx, sexp object) { sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} static sexp_sint_t sexp_context_make_label (sexp ctx) { - sexp_sint_t label = sexp_context_pos(ctx); + sexp_sint_t label; + sexp_context_align_pos(ctx); + label = sexp_context_pos(ctx); sexp_context_pos(ctx) += sizeof(sexp_uint_t); return label; } @@ -1253,6 +1256,13 @@ static sexp_uint_t sexp_restore_stack (sexp saved, sexp *current) { #define _ARG5 stack[top-5] #define _ARG6 stack[top-6] #define _PUSH(x) (stack[top++]=(x)) + +#if SEXP_USE_ALIGNED_BYTECODE +#define _ALIGN_IP() ip = (unsigned char *)sexp_word_align((unsigned long)ip) +#else +#define _ALIGN_IP() +#endif + #define _WORD0 ((sexp*)ip)[0] #define _UWORD0 ((sexp_uint_t*)ip)[0] #define _SWORD0 ((sexp_sint_t*)ip)[0] @@ -1352,6 +1362,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { ip -= sizeof(sexp); goto make_call; case SEXP_OP_TAIL_CALL: + _ALIGN_IP(); i = sexp_unbox_fixnum(_WORD0); /* number of params */ tmp1 = _ARG1; /* procedure to call */ /* save frame info */ @@ -1375,6 +1386,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { goto end_loop; } #endif + _ALIGN_IP(); i = sexp_unbox_fixnum(_WORD0); tmp1 = _ARG1; make_call: @@ -1426,18 +1438,21 @@ sexp sexp_vm (sexp ctx, sexp proc) { fp = top-4; break; case SEXP_OP_FCALL0: + _ALIGN_IP(); sexp_context_top(ctx) = top; _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx)); ip += sizeof(sexp); sexp_check_exception(); break; case SEXP_OP_FCALL1: + _ALIGN_IP(); sexp_context_top(ctx) = top; _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx, _ARG1); ip += sizeof(sexp); sexp_check_exception(); break; case SEXP_OP_FCALL2: + _ALIGN_IP(); sexp_context_top(ctx) = top; _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2); top--; @@ -1445,6 +1460,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_check_exception(); break; case SEXP_OP_FCALL3: + _ALIGN_IP(); sexp_context_top(ctx) = top; _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3); top -= 2; @@ -1452,6 +1468,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_check_exception(); break; case SEXP_OP_FCALL4: + _ALIGN_IP(); sexp_context_top(ctx) = top; _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4); top -= 3; @@ -1459,6 +1476,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_check_exception(); break; case SEXP_OP_FCALL5: + _ALIGN_IP(); sexp_context_top(ctx) = top; _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); top -= 4; @@ -1466,6 +1484,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_check_exception(); break; case SEXP_OP_FCALL6: + _ALIGN_IP(); sexp_context_top(ctx) = top; _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); top -= 5; @@ -1473,15 +1492,18 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_check_exception(); break; case SEXP_OP_JUMP_UNLESS: + _ALIGN_IP(); if (stack[--top] == SEXP_FALSE) ip += _SWORD0; else ip += sizeof(sexp_sint_t); break; case SEXP_OP_JUMP: + _ALIGN_IP(); ip += _SWORD0; break; case SEXP_OP_PUSH: + _ALIGN_IP(); _PUSH(_WORD0); ip += sizeof(sexp); break; @@ -1489,29 +1511,35 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case SEXP_OP_GLOBAL_REF: + _ALIGN_IP(); if (sexp_cdr(_WORD0) == SEXP_UNDEF) sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); /* ... FALLTHROUGH ... */ case SEXP_OP_GLOBAL_KNOWN_REF: + _ALIGN_IP(); _PUSH(sexp_cdr(_WORD0)); ip += sizeof(sexp); break; case SEXP_OP_STACK_REF: /* `pick' in forth */ + _ALIGN_IP(); stack[top] = stack[top - _SWORD0]; ip += sizeof(sexp); top++; break; case SEXP_OP_LOCAL_REF: + _ALIGN_IP(); stack[top] = stack[fp - 1 - _SWORD0]; ip += sizeof(sexp); top++; break; case SEXP_OP_LOCAL_SET: + _ALIGN_IP(); stack[fp - 1 - _SWORD0] = _ARG1; _ARG1 = SEXP_VOID; ip += sizeof(sexp); break; case SEXP_OP_CLOSURE_REF: + _ALIGN_IP(); _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); ip += sizeof(sexp); break; @@ -1608,20 +1636,24 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_CHARP: _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; case SEXP_OP_TYPEP: + _ALIGN_IP(); _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); ip += sizeof(sexp); break; case SEXP_OP_MAKE: + _ALIGN_IP(); _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); ip += sizeof(sexp)*2; break; case SEXP_OP_SLOT_REF: + _ALIGN_IP(); if (! sexp_check_tag(_ARG1, _UWORD0)) sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); ip += sizeof(sexp)*2; break; case SEXP_OP_SLOT_SET: + _ALIGN_IP(); if (! sexp_check_tag(_ARG1, _UWORD0)) sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); else if (sexp_immutablep(_ARG1)) diff --git a/include/chibi/features.h b/include/chibi/features.h index d93f5b5c..afa04c43 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -149,6 +149,10 @@ /* Experts only. */ /* For *very* verbose output on every VM operation. */ +/* uncomment this to make the VM adhere to alignment rules */ +/* This is required on some platforms, e.g. ARM */ +/* #define SEXP_USE_ALIGNED_BYTECODE */ + /************************************************************************/ /* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ /************************************************************************/ @@ -300,6 +304,14 @@ #define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES #endif +#ifndef SEXP_USE_ALIGNED_BYTECODE +#if defined(__arm__) +#define SEXP_USE_ALIGNED_BYTECODE 1 +#else +#define SEXP_USE_ALIGNED_BYTECODE 0 +#endif +#endif + #ifdef PLAN9 #define strcasecmp cistrcmp #define strncasecmp cistrncmp diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 35dc565a..fa668c2f 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -356,6 +356,12 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1))) +#if SEXP_64_BIT +#define sexp_word_align(n) sexp_align((n), 3) +#else +#define sexp_word_align(n) sexp_align((n), 2) +#endif + #define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ + sizeof(((sexp)0)->value.x)) @@ -637,6 +643,12 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_context_tracep(x) ((x)->value.context.tailp) #define sexp_context_globals(x) ((x)->value.context.globals) +#if SEXP_USE_ALIGNED_BYTECODE +#define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx)) +#else +#define sexp_context_align_pos(ctx) +#endif + #define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) #if SEXP_USE_GLOBAL_HEAP From d6c3b04e06e09ece32b36630ee04b1c6fd135d50 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 9 Mar 2010 20:47:10 +0900 Subject: [PATCH 383/535] Adding AUTHORS file. --- AUTHORS | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 AUTHORS diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 00000000..8996ef81 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,23 @@ +Alex Shinn wrote the initial version of chibi-scheme and all +distributed modules. + +The `dynamic-wind' implementation is adapted from the implementation +in the appendix to the Scheme48 reference manual, reportedly first +written by Chris Hanson and John Lamping. + +Thanks to the following people for patches: + + * Andreas Rottman + * Derrick Eddington + * Felix Winkelmann + * Gregor Klinke + * John Cowan + * John Samsa + * Lars J Aas + * Lorenzo Campedelli + * sladegen + +If you would prefer not to be listed, or are one of the users listed +without a full name, please contact me. If you've made a contribution +and are not listed, please accept my apologies and contact me +immediately! From e15c49389c95e263dfedf1ddfa03aed47f77a005 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 10 Mar 2010 21:39:20 +0900 Subject: [PATCH 384/535] auto-closing gc'ed string ports to prevent memory leaks (issue #41). also using a separate port field no_closep to indicate ports whose underlying streams shouldn't be closed (stdin/stdout/stderr). --- eval.c | 24 ++++++++++-------------- include/chibi/sexp.h | 4 +++- sexp.c | 18 +++++++++++++----- 3 files changed, 26 insertions(+), 20 deletions(-) diff --git a/eval.c b/eval.c index eb5be667..a3b2a0d7 100644 --- a/eval.c +++ b/eval.c @@ -2058,14 +2058,7 @@ static sexp sexp_close_port (sexp ctx, sexp 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_stream(port)) - fclose(sexp_port_stream(port)); -#if ! SEXP_USE_STRING_STREAMS - if (sexp_port_buf(port) && sexp_oportp(port)) - free(sexp_port_buf(port)); -#endif - sexp_port_openp(port) = 0; - return SEXP_VOID; + return sexp_finalize_port(ctx, port); } void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) { @@ -2588,12 +2581,15 @@ sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp) { sexp sexp_load_standard_parameters (sexp ctx, sexp e) { /* add io port and interaction env parameters */ - sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), - sexp_make_input_port(ctx, stdin, SEXP_FALSE)); - sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), - sexp_make_output_port(ctx, stdout, SEXP_FALSE)); - sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), - sexp_make_output_port(ctx, stderr, SEXP_FALSE)); + sexp p = sexp_make_input_port(ctx, stdin, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p); + p = sexp_make_output_port(ctx, stdout, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p); + p = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p); sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); return SEXP_VOID; } diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index fa668c2f..56315ef3 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -190,7 +190,7 @@ struct sexp_struct { struct { FILE *stream; char *buf; - char openp, sourcep; + char openp, no_closep, sourcep; sexp_uint_t offset, line; size_t size; sexp name; @@ -544,6 +544,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #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_no_closep(p) ((p)->value.port.no_closep) #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) @@ -848,6 +849,7 @@ 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_write_to_string(sexp ctx, sexp obj); +SEXP_API sexp sexp_finalize_port (sexp ctx, sexp port); 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); diff --git a/sexp.c b/sexp.c index 4d2baed7..517a0d70 100644 --- a/sexp.c +++ b/sexp.c @@ -53,13 +53,20 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { return res; } -#if SEXP_USE_AUTOCLOSE_PORTS -static sexp sexp_finalize_port (sexp ctx, sexp port) { - if (sexp_port_openp(port) && sexp_port_stream(port) - && sexp_stringp(sexp_port_name(port))) - fclose(sexp_port_stream(port)); +sexp sexp_finalize_port (sexp ctx, sexp port) { + if (sexp_port_openp(port)) { + sexp_port_openp(port) = 0; + if (sexp_port_stream(port) && ! sexp_port_no_closep(port)) + fclose(sexp_port_stream(port)); +#if ! SEXP_USE_STRING_STREAMS + if (sexp_port_buf(port) && sexp_oportp(port)) + free(sexp_port_buf(port)); +#endif + } return SEXP_VOID; } + +#if SEXP_USE_AUTOCLOSE_PORTS #define SEXP_FINALIZE_PORT sexp_finalize_port #else #define SEXP_FINALIZE_PORT NULL @@ -1032,6 +1039,7 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { sexp_port_line(p) = 1; sexp_port_buf(p) = NULL; sexp_port_openp(p) = 1; + sexp_port_no_closep(p) = 0; sexp_port_sourcep(p) = 1; sexp_port_cookie(p) = SEXP_VOID; return p; From 4b2ed4cf48222dacc7692e68af076d36562cbbe0 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 12 Mar 2010 14:26:03 +0900 Subject: [PATCH 385/535] verifying command-line option arguments are given when needed (issue #43) --- main.c | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/main.c b/main.c index df1d9017..5d3c713c 100644 --- a/main.c +++ b/main.c @@ -56,6 +56,13 @@ static void repl (sexp ctx) { sexp_gc_release4(ctx); } +static void check_nonull_arg (int c, char *arg) { + if (! arg) { + fprintf(stderr, "chibi-scheme: option '%c' requires an argument\n", c); + exit_failure(); + } +} + static sexp check_exception (sexp ctx, sexp res) { sexp err; if (res && sexp_exceptionp(res)) { @@ -95,6 +102,7 @@ void run_main (int argc, char **argv) { load_init(); print = (argv[i][1] == 'p'); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('e', arg); res = check_exception(ctx, sexp_read_from_string(ctx, arg)); res = check_exception(ctx, sexp_eval(ctx, res, env)); if (print) { @@ -108,11 +116,13 @@ void run_main (int argc, char **argv) { case 'l': load_init(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('l', arg); check_exception(ctx, sexp_load_module_file(ctx, arg, env)); break; case 'm': load_init(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('m', arg); len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); impmod = (char*) malloc(len+1); strcpy(impmod, sexp_import_prefix); @@ -131,11 +141,13 @@ void run_main (int argc, char **argv) { case 'A': init_context(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('A', arg); sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); break; case 'I': init_context(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('I', arg); sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); break; case '-': @@ -143,6 +155,7 @@ void run_main (int argc, char **argv) { goto done_options; case 'h': arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('h', arg); heap_size = atol(arg); len = strlen(arg); if (heap_size && isalpha(arg[len-1])) { From 2e9a09fc1ea8934874c36f524f8bccd864356eb2 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 13 Mar 2010 18:31:30 +0900 Subject: [PATCH 386/535] type checking env arg to eval (issue #44) --- eval.c | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/eval.c b/eval.c index a3b2a0d7..5d42e74d 100644 --- a/eval.c +++ b/eval.c @@ -2745,14 +2745,15 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) { sexp_sint_t top; sexp ctx2; sexp_gc_var2(res, err_handler); + if (! env) + env = sexp_context_env(ctx); + else if (! sexp_envp(env)) + return sexp_type_exception(ctx, "eval: not an env", env); sexp_gc_preserve2(ctx, res, err_handler); top = sexp_context_top(ctx); err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = SEXP_FALSE; - ctx2 = sexp_make_eval_context(ctx, - sexp_context_stack(ctx), - (env ? env : sexp_context_env(ctx)), - 0); + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0); res = sexp_compile(ctx2, obj); if (! sexp_exceptionp(res)) res = sexp_apply(ctx2, res, SEXP_NULL); From 725316ad3cd033a78f661ac3ad986e7bdcbcd2f2 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 13 Mar 2010 23:19:52 +0900 Subject: [PATCH 387/535] initial sexp_copy_context - need utils to dump/load initial image --- gc.c | 121 +++++++++++++++++++++++++++++---------- include/chibi/features.h | 26 ++++++++- include/chibi/sexp.h | 4 ++ 3 files changed, 119 insertions(+), 32 deletions(-) diff --git a/gc.c b/gc.c index b7f275f2..60653eae 100644 --- a/gc.c +++ b/gc.c @@ -8,28 +8,6 @@ #include #endif -/* These settings are configurable but only recommended for */ -/* experienced users, so they're not in config.h. */ - -/* the initial heap size in bytes */ -#ifndef SEXP_INITIAL_HEAP_SIZE -#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) -#endif - -/* the maximum heap size in bytes - if 0 there is no limit */ -#ifndef SEXP_MAXIMUM_HEAP_SIZE -#define SEXP_MAXIMUM_HEAP_SIZE 0 -#endif -#ifndef SEXP_MINIMUM_HEAP_SIZE -#define SEXP_MINIMUM_HEAP_SIZE 512*1024 -#endif - -/* if after GC more than this percentage of memory is still in use, */ -/* and we've not exceeded the maximum size, grow the heap */ -#ifndef SEXP_GROW_HEAP_RATIO -#define SEXP_GROW_HEAP_RATIO 0.75 -#endif - #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair)) #if SEXP_64_BIT @@ -38,6 +16,8 @@ #define sexp_heap_align(n) sexp_align(n, 4) #endif +#define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1)) + #if SEXP_USE_GLOBAL_HEAP sexp_heap sexp_global_heap; #endif @@ -98,20 +78,19 @@ 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 = sexp_context_heap(ctx); - sexp p; + sexp p, end; sexp_free_list q, r, s; - char *end; sexp_proc2 finalizer; /* scan over the whole heap */ for ( ; h; h=h->next) { p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); q = h->free_list; - end = (char*)h->data + h->size; - while (((char*)p) < end) { + end = (sexp) ((char*)h->data + h->size); + while (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) { + if ((char*)r == (char*)p) { /* this is a free block, skip it */ p = (sexp) (((char*)p) + r->size); continue; } @@ -157,7 +136,7 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { } } } - sum_freed_ptr[0] = sum_freed; + if (sum_freed_ptr) *sum_freed_ptr = sum_freed; return sexp_make_fixnum(max_freed); } @@ -177,11 +156,10 @@ sexp_heap sexp_make_heap (size_t size) { sexp_free_list free, next; sexp_heap h; #if SEXP_USE_MMAP_GC - h = mmap(NULL, sizeof(struct sexp_heap_t) + size + sexp_heap_align(1), - PROT_READ|PROT_WRITE|PROT_EXEC, + h = mmap(NULL, sexp_heap_pad_size(size), PROT_READ|PROT_WRITE|PROT_EXEC, MAP_ANON|MAP_PRIVATE, 0, 0); #else - h = malloc(sizeof(struct sexp_heap_t) + size + sexp_heap_align(1)); + h = malloc(sexp_heap_pad_size(size)); #endif if (! h) return NULL; h->size = size; @@ -245,6 +223,87 @@ void* sexp_alloc (sexp ctx, size_t size) { return res; } +#if ! SEXP_USE_GLOBAL_HEAP + +sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { + sexp_sint_t i, off, len, freep; + sexp_heap to, from = sexp_context_heap(ctx); + sexp_free_list q; + sexp p, p2, t, end, *v; + freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP); + + /* validate input, creating a new heap if needed */ + if (from->next) { + return sexp_type_exception(ctx, "can't copy a non-contiguous heap", ctx); + } else if (! dst || sexp_not(dst)) { + to = sexp_make_heap(from->size); + dst = (sexp) ((char*)ctx + ((char*)to - (char*)from)); + } else if (! sexp_contextp(dst)) { + return sexp_type_exception(ctx, "destination not a context", dst); + } else if (sexp_context_heap(dst)->size < from->size) { + return sexp_type_exception(ctx, "destination context too small", dst); + } else { + to = sexp_context_heap(dst); + } + + /* copy the raw data */ + off = (char*)to - (char*)from; + memcpy(to, from, sexp_heap_pad_size(from->size)); + to->free_list = (sexp_free_list) ((char*)to->free_list + off); + to->data += off; + end = (sexp) (from->data + from->size); + + /* adjust the free list */ + for (q=to->free_list; q->next; q=q->next) + q->next = (sexp_free_list) ((char*)q->next + off); + + /* adjust if the destination is larger */ + if (from->size < to->size) { + if (((char*)q + q->size - off) >= (char*)end) { + q->size += (to->size - from->size); + } else { + q->next = (sexp_free_list) ((char*)end + off); + q->next->next = NULL; + q->next->size = (to->size - from->size); + } + } + + /* adjust data by traversing over the _original_ heap */ + p = (sexp) (from->data + sexp_heap_align(sexp_sizeof(pair))); + q = from->free_list; + while (p < end) { + /* find the next free list pointer */ + for ( ; q && ((char*)q < (char*)p); q=q->next) + ; + if ((char*)q == (char*)p) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + q->size); + } else { + t = sexp_object_type(ctx, p); + len = sexp_type_num_slots_of_object(t, p); + p2 = (sexp)((char*)p + off); + v = (sexp*) ((char*)p2 + sexp_type_field_base(t)); + /* offset any pointers in the _destination_ heap */ + for (i=0; i Date: Sun, 14 Mar 2010 21:11:28 +0900 Subject: [PATCH 388/535] repl creates a new env so new definitions don't show in the standard env --- main.c | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/main.c b/main.c index 5d3c713c..aa0a44a7 100644 --- a/main.c +++ b/main.c @@ -1,6 +1,6 @@ -/* main.c -- chibi-scheme command-line app */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include "chibi/eval.h" @@ -22,7 +22,10 @@ static void repl (sexp ctx) { sexp in, out, err; sexp_gc_var4(obj, tmp, res, env); sexp_gc_preserve4(ctx, obj, tmp, res, env); - env = sexp_context_env(ctx); + env = sexp_make_env(ctx); + sexp_env_parent(env) = sexp_context_env(ctx); + sexp_env_define(ctx, sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); sexp_context_tracep(ctx) = 1; in = sexp_eval_string(ctx, "(current-input-port)", env); out = sexp_eval_string(ctx, "(current-output-port)", env); From ca1f6202aef745c8ec43a39dc8b0597e5669fe33 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 15 Mar 2010 13:29:43 +0900 Subject: [PATCH 389/535] adding (pointer void) support --- tools/genstubs.scm | 68 ++++++++++++++++++++++++---------------------- 1 file changed, 36 insertions(+), 32 deletions(-) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 581ea2c1..06bebb97 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -235,8 +235,13 @@ (define (basic-type? type) (let ((type (parse-type type))) (and (not (type-array type)) + (not (void-pointer-type? type)) (not (assq (type-base type) *types*))))) +(define (void-pointer-type? type) + (or (and (eq? 'void (type-base type)) (type-pointer? type)) + (eq? 'void* (type-base type)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; function objects @@ -456,7 +461,7 @@ (define (c->scheme-converter type val . o) (let ((base (type-base type))) (cond - ((eq? base 'void) + ((and (eq? base 'void) (not (type-pointer? type))) (cat "((" val "), SEXP_VOID)")) ((or (eq? base 'sexp) (error-type? base)) (cat val)) @@ -483,10 +488,12 @@ ((eq? 'output-port base) (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) (else - (let ((ctype (assq base *types*))) + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) (cond - (ctype - (cat "sexp_make_cpointer(ctx, " (type-id-name base) ", " + ((or ctype void*?) + (cat "sexp_make_cpointer(ctx, " + (if void*? "SEXP_CPOINTER" (type-id-name base)) ", " val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " (if (or (type-free? type) (and (type-result? type) (not (basic-type? type)))) @@ -522,9 +529,10 @@ ((port-type? base) (cat "sexp_port_stream(" val ")")) (else - (let ((ctype (assq base *types*))) + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) (cond - (ctype + ((or ctype void*?) (cat "(" (type-c-name type) ")" (if (type-null? type) "sexp_cpointer_maybe_null_value" @@ -586,19 +594,18 @@ ((or (int-type? base) (float-type? base) (string-type? base) (port-type? base)) (cat (type-predicate type) "(" arg ")")) + ((or (assq base *types*) (void-pointer-type? type)) + (cat + (if (type-null? type) "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " + (if (void-pointer-type? type) "SEXP_CPOINTER" (type-id-name base)) "))" + (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) (else - (cond - ((assq base *types*) - (cat - (if (type-null? type) "(" "") - "(sexp_pointerp(" arg ")" - " && (sexp_pointer_tag(" arg ") == " (type-id-name base) "))" - (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) - (else - (display "WARNING: don't know how to check: " (current-error-port)) - (write type (current-error-port)) - (newline (current-error-port)) - (cat "1"))))))) + (display "WARNING: don't know how to check: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (cat "1"))))) (define (write-validator arg type) (let* ((type (parse-type type)) @@ -631,21 +638,18 @@ " return sexp_type_exception(ctx, \"not " (definite-article (type-name type)) "\", " arg ");\n")) + ((or (assq base-type *types*) (void-pointer-type? type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, \"not " + (definite-article (type-name type)) "\", " arg ");\n")) + ((eq? 'sexp base-type)) + ((string-type? type) + (write-validator arg 'string)) (else - (cond - ((assq base-type *types*) - (cat - " if (! " (lambda () (check-type arg type)) ")\n" - " return sexp_type_exception(ctx, \"not " - (definite-article (type-name type)) "\", " arg ");\n")) - ((eq? 'sexp base-type)) - ((string-type? type) - (write-validator arg 'string)) - (else - (display "WARNING: don't know how to validate: " (current-error-port)) - (write type (current-error-port)) - (newline (current-error-port)) - (write type))))))) + (display "WARNING: don't know how to validate: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)))))) (define (write-parameters args) (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) From 9604d914400e2030760dbe26821e5c09a63b65f1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 15 Mar 2010 16:38:17 +0900 Subject: [PATCH 390/535] reordering some immediates --- include/chibi/sexp.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index f6608d93..c2a6e1bf 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -278,9 +278,9 @@ struct sexp_struct { #define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n< Date: Tue, 16 Mar 2010 15:19:46 +0900 Subject: [PATCH 391/535] replacing SEXP_OPC_ACCESSOR with separate getter & setter opcode classes --- eval.c | 29 +++++++++++++++++------------ include/chibi/eval.h | 3 ++- opcodes.c | 20 ++++++++++---------- 3 files changed, 29 insertions(+), 23 deletions(-) diff --git a/eval.c b/eval.c index 5d42e74d..86422e4e 100644 --- a/eval.c +++ b/eval.c @@ -986,7 +986,8 @@ static void generate_opcode_app (sexp ctx, sexp app) { emit_word(ctx, (sexp_uint_t)op); break; case SEXP_OPC_TYPE_PREDICATE: - case SEXP_OPC_ACCESSOR: + case SEXP_OPC_GETTER: + case SEXP_OPC_SETTER: case SEXP_OPC_CONSTRUCTOR: emit(ctx, sexp_opcode_code(op)); if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) @@ -2421,22 +2422,26 @@ sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { sexp_make_fixnum(type_size), NULL); } -sexp sexp_make_accessor (sexp ctx, sexp name, sexp type, sexp index, sexp code) { - if (! sexp_fixnump(type)) - return sexp_type_exception(ctx, "make-accessor: bad type", type); +sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, "make-getter: bad type", type); if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) - return sexp_type_exception(ctx, "make-accessor: bad index", index); + return sexp_type_exception(ctx, "make-getter: bad index", index); return - sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_ACCESSOR), code, - sexp_make_fixnum(sexp_unbox_fixnum(code)==SEXP_OP_SLOT_REF?1:2), - SEXP_ZERO, type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); + sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_GETTER), + sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); } -sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { - return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(SEXP_OP_SLOT_REF)); -} sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index) { - return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(SEXP_OP_SLOT_SET)); + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, "make-setter: bad type", type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, "make-setter: bad index", index); + return + sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_SETTER), + sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); } #endif diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 2337feb4..437aaa37 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -40,7 +40,8 @@ enum sexp_opcode_classes { SEXP_OPC_ARITHMETIC_CMP, SEXP_OPC_IO, SEXP_OPC_CONSTRUCTOR, - SEXP_OPC_ACCESSOR, + SEXP_OPC_GETTER, + SEXP_OPC_SETTER, SEXP_OPC_PARAMETER, SEXP_OPC_FOREIGN, SEXP_OPC_NUM_OP_CLASSES diff --git a/opcodes.c b/opcodes.c index 8267f396..8e1dbeb1 100644 --- a/opcodes.c +++ b/opcodes.c @@ -17,16 +17,16 @@ #define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, 0, 0, n, a, 0) static struct sexp_struct opcodes[] = { -_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), -_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), -_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), -_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), -_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), -_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), -_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), -_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), -_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), -_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), From bb3d44054e6f73f38fbc7a0795b538ccc498a190 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 16 Mar 2010 21:41:32 +0900 Subject: [PATCH 392/535] fixing syntax error with " .)" in source (issue #45) --- sexp.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/sexp.c b/sexp.c index 517a0d70..169420d9 100644 --- a/sexp.c +++ b/sexp.c @@ -1584,13 +1584,12 @@ sexp sexp_read_raw (sexp ctx, sexp in) { break; case '.': c1 = sexp_read_char(ctx, in); + sexp_push_char(ctx, c1, 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, 0); } else { - sexp_push_char(ctx, c1, in); res = sexp_read_symbol(ctx, in, '.', 1); } break; From 0a9085fbbd83f5d75d0ced57ed19f4cee931c158 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 22 Mar 2010 15:14:30 +0900 Subject: [PATCH 393/535] const qualifying char* inputs to various API functions --- eval.c | 20 ++++++++++---------- include/chibi/eval.h | 14 +++++++------- include/chibi/sexp.h | 14 +++++++------- sexp.c | 33 +++++++++++++++++---------------- 4 files changed, 41 insertions(+), 40 deletions(-) diff --git a/eval.c b/eval.c index 86422e4e..41e81d4b 100644 --- a/eval.c +++ b/eval.c @@ -28,7 +28,7 @@ static sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env); static sexp sexp_find_module_file_op (sexp ctx, sexp file); #endif -sexp sexp_compile_error (sexp ctx, char *message, sexp obj) { +sexp sexp_compile_error (sexp ctx, const char *message, sexp obj) { sexp exn; sexp_gc_var3(sym, irritants, msg); sexp_gc_preserve3(ctx, sym, irritants, msg); @@ -307,8 +307,8 @@ static sexp sexp_make_lit (sexp ctx, sexp value) { #define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) -static void sexp_add_path (sexp ctx, char *str) { - char *colon; +static void sexp_add_path (sexp ctx, const char *str) { + const char *colon; if (str && *str) { colon = strchr(str, ':'); if (colon) @@ -2355,7 +2355,7 @@ sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code, return res; } -sexp sexp_make_foreign (sexp ctx, char *name, int num_args, +sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data) { sexp res; if (num_args > 6) { @@ -2375,7 +2375,7 @@ sexp sexp_make_foreign (sexp ctx, char *name, int num_args, return res; } -sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, +sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data) { sexp_gc_var1(op); sexp_gc_preserve1(ctx, op); @@ -2389,8 +2389,8 @@ sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, return res; } -sexp sexp_define_foreign_param (sexp ctx, sexp env, char *name, int num_args, - sexp_proc1 f, char *param) { +sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, + sexp_proc1 f, const char *param) { sexp res; sexp_gc_var1(tmp); sexp_gc_preserve1(ctx, tmp); @@ -2499,7 +2499,7 @@ sexp sexp_make_primitive_env (sexp ctx, sexp version) { return e; } -sexp sexp_find_module_file (sexp ctx, char *file) { +sexp sexp_find_module_file (sexp ctx, const char *file) { sexp res=SEXP_FALSE, ls; char *dir, *path; sexp_uint_t slash, dirlen, filelen, len; @@ -2535,7 +2535,7 @@ sexp sexp_find_module_file (sexp ctx, char *file) { #define sexp_file_not_found "couldn't find file in module path" -sexp sexp_load_module_file (sexp ctx, char *file, sexp env) { +sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { sexp res; sexp_gc_var1(path); sexp_gc_preserve1(ctx, path); @@ -2768,7 +2768,7 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) { return res; } -sexp sexp_eval_string (sexp ctx, char *str, sexp env) { +sexp sexp_eval_string (sexp ctx, const char *str, sexp env) { sexp res; sexp_gc_var1(obj); sexp_gc_preserve1(ctx, obj); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 437aaa37..7cd1d8d9 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -126,14 +126,14 @@ enum sexp_opcode_names { SEXP_API void sexp_scheme_init (void); SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size); SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); -SEXP_API sexp sexp_compile_error (sexp ctx, char *message, sexp obj); +SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj); SEXP_API sexp sexp_analyze (sexp context, sexp x); SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); SEXP_API sexp sexp_apply_optimization (sexp context, sexp proc, sexp ast); SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); SEXP_API int sexp_param_index (sexp lambda, sexp name); SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); -SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); +SEXP_API sexp sexp_eval_string (sexp context, const char *str, sexp env); SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); SEXP_API sexp sexp_make_env (sexp context); SEXP_API sexp sexp_make_null_env (sexp context, sexp version); @@ -141,8 +141,8 @@ SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version); SEXP_API sexp sexp_make_standard_env (sexp context, sexp version); SEXP_API sexp sexp_load_standard_parameters (sexp context, sexp env); SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version); -SEXP_API sexp sexp_find_module_file (sexp ctx, char *file); -SEXP_API sexp sexp_load_module_file (sexp ctx, char *file, sexp env); +SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file); +SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env); SEXP_API sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp); SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls, sexp immutp); @@ -152,13 +152,13 @@ SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); -SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data); -SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, int flags, sexp_proc1 f, sexp data); +SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); +SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); #define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL) #define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d) -SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, char *name, int num_args, sexp_proc1 f, char *param); +SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, sexp_proc1 f, const char *param); #if SEXP_USE_TYPE_DEFS SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index c2a6e1bf..235e48ca 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -234,7 +234,7 @@ struct sexp_struct { struct { unsigned char op_class, code, num_args, flags, arg1_type, arg2_type, inverse; - char *name; + const char *name; sexp data, data2, proc; sexp_proc1 func; } opcode; @@ -810,8 +810,8 @@ enum sexp_context_globals { SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); SEXP_API sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); -SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p); -SEXP_API sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p); +SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, const char *str, sexp_uint_t len, sexp p); +SEXP_API sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p); SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); #endif @@ -834,7 +834,7 @@ SEXP_API sexp sexp_c_string(sexp ctx, const 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_string_concatenate (sexp ctx, sexp str_ls, sexp sep); -SEXP_API sexp sexp_intern(sexp ctx, char *str); +SEXP_API sexp sexp_intern(sexp ctx, const 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); @@ -847,7 +847,7 @@ 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_read_from_string(sexp ctx, const char *str); SEXP_API sexp sexp_write_to_string(sexp ctx, sexp obj); SEXP_API sexp sexp_finalize_port (sexp ctx, sexp port); SEXP_API sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); @@ -856,8 +856,8 @@ 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 source); -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_user_exception(sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_type_exception(sexp ctx, const char *message, sexp x); 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(void); diff --git a/sexp.c b/sexp.c index 169420d9..9132fbe1 100644 --- a/sexp.c +++ b/sexp.c @@ -21,7 +21,7 @@ static int sexp_initialized_p = 0; sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp); -static char sexp_separators[] = { +static const 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_ */ @@ -328,20 +328,20 @@ sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, return exn; } -sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp irritants) { +sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { sexp res; sexp_gc_var3(sym, str, irr); sexp_gc_preserve3(ctx, sym, str, irr); res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user"), - str = sexp_c_string(ctx, message, -1), - ((sexp_pairp(irritants) || sexp_nullp(irritants)) - ? irritants : (irr = sexp_list1(ctx, irritants))), + str = sexp_c_string(ctx, ms, -1), + ((sexp_pairp(ir) || sexp_nullp(ir)) + ? ir : (irr = sexp_list1(ctx, ir))), self, SEXP_FALSE); sexp_gc_release3(ctx); return res; } -sexp sexp_type_exception (sexp ctx, char *message, sexp obj) { +sexp sexp_type_exception (sexp ctx, const char *message, sexp obj) { sexp res; sexp_gc_var3(sym, str, irr); sexp_gc_preserve3(ctx, sym, str, irr); @@ -424,15 +424,14 @@ sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { return SEXP_VOID; } -static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) { +static sexp sexp_read_error (sexp ctx, const char *msg, sexp ir, sexp port) { sexp res; sexp_gc_var4(sym, name, str, irr); sexp_gc_preserve4(ctx, sym, name, str, irr); name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port))); str = sexp_c_string(ctx, msg, -1); - irr = ((sexp_pairp(irritants) || sexp_nullp(irritants)) - ? irritants : sexp_list1(ctx, irritants)); + irr = ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir)); res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read"), str, irr, SEXP_FALSE, name); sexp_gc_release4(ctx); @@ -695,21 +694,21 @@ sexp sexp_string_concatenate (sexp ctx, sexp str_ls, sexp sep) { #if SEXP_USE_HASH_SYMS -static sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) { +static sexp_uint_t sexp_string_hash(const char *str, sexp_uint_t acc) { while (*str) {acc *= FNV_PRIME; acc ^= *str++;} return acc; } #endif -sexp sexp_intern(sexp ctx, char *str) { +sexp sexp_intern(sexp ctx, const char *str) { #if SEXP_USE_HUFF_SYMS struct sexp_huff_entry he; sexp_uint_t space=3, newbits; char c; #endif sexp_uint_t len, res=FNV_OFFSET_BASIS, bucket; - char *p=str; + const char *p=str; sexp ls; sexp_gc_var1(sym); @@ -780,7 +779,8 @@ sexp sexp_list_to_vector(sexp ctx, sexp ls) { return vec; } -sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void *value, sexp parent, int freep) { +sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void *value, + sexp parent, int freep) { sexp ptr; if (! value) return SEXP_FALSE; ptr = sexp_alloc_type(ctx, cpointer, type_id); @@ -958,7 +958,8 @@ sexp sexp_buffered_write_char (sexp ctx, int c, sexp p) { return SEXP_VOID; } -sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p) { +sexp sexp_buffered_write_string_n (sexp ctx, const 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); @@ -966,7 +967,7 @@ sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p) return SEXP_VOID; } -sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p) { +sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p) { return sexp_buffered_write_string_n(ctx, str, strlen(str), p); } @@ -1661,7 +1662,7 @@ sexp sexp_read (sexp ctx, sexp in) { return res; } -sexp sexp_read_from_string(sexp ctx, char *str) { +sexp sexp_read_from_string(sexp ctx, const char *str) { sexp res; sexp_gc_var2(s, in); sexp_gc_preserve2(ctx, s, in); From 87e80f85c0f87f1192914a4968b6c0553319dbc7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 22 Mar 2010 15:19:48 +0900 Subject: [PATCH 394/535] also making core form names const char* --- include/chibi/sexp.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 235e48ca..cc45b3ab 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -240,7 +240,7 @@ struct sexp_struct { } opcode; struct { char code; - char *name; + const char *name; } core; /* ast types */ struct { From 0e6c2ffde9ebca3c8a95ba7d21db565380a512d5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 22 Mar 2010 15:20:21 +0900 Subject: [PATCH 395/535] updating authors --- AUTHORS | 1 + 1 file changed, 1 insertion(+) diff --git a/AUTHORS b/AUTHORS index 8996ef81..df7959c1 100644 --- a/AUTHORS +++ b/AUTHORS @@ -8,6 +8,7 @@ written by Chris Hanson and John Lamping. Thanks to the following people for patches: * Andreas Rottman + * Bruno Deferrari * Derrick Eddington * Felix Winkelmann * Gregor Klinke From cc6f727adde451cd2f83f6ddb1d4868a5cbd97c9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 23 Mar 2010 20:52:47 +0900 Subject: [PATCH 397/535] sexp_intern, sexp_read_from_string and sexp_eval_string now all take length parameters. this is more flexible and will help if strings are changed to be non-null-terminated. --- eval.c | 44 +++++++++++++++--------------- include/chibi/sexp.h | 4 +-- lib/chibi/ast.c | 8 +++--- lib/chibi/heap-stats.c | 2 +- lib/srfi/27/rand.c | 10 +++---- lib/srfi/69/hash.c | 2 +- main.c | 22 +++++++-------- sexp.c | 62 ++++++++++++++++++++++-------------------- tools/genstubs.scm | 6 ++-- 9 files changed, 83 insertions(+), 77 deletions(-) diff --git a/eval.c b/eval.c index 41e81d4b..9e64e1e5 100644 --- a/eval.c +++ b/eval.c @@ -28,15 +28,15 @@ static sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env); static sexp sexp_find_module_file_op (sexp ctx, sexp file); #endif -sexp sexp_compile_error (sexp ctx, const char *message, sexp obj) { +sexp sexp_compile_error (sexp ctx, const char *message, sexp o) { sexp exn; sexp_gc_var3(sym, irritants, msg); sexp_gc_preserve3(ctx, sym, irritants, msg); - irritants = sexp_list1(ctx, obj); + irritants = sexp_list1(ctx, o); msg = sexp_c_string(ctx, message, -1); - exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile"), msg, irritants, - SEXP_FALSE, (sexp_pairp(obj) ? - sexp_pair_source(obj) : SEXP_FALSE)); + exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile", -1), + msg, irritants, SEXP_FALSE, + (sexp_pairp(o)?sexp_pair_source(o):SEXP_FALSE)); sexp_gc_release3(ctx); return exn; } @@ -325,7 +325,7 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_gc_var2(tmp, vec); ctx = sexp_make_child_context(ctx, NULL); sexp_gc_preserve2(ctx, tmp, vec); - tmp = sexp_intern(ctx, "*current-exception-handler*"); + tmp = sexp_intern(ctx, "*current-exception-handler*", -1); sexp_global(ctx, SEXP_G_ERR_HANDLER) = sexp_env_cell_create(ctx, sexp_context_env(ctx), tmp, SEXP_FALSE, NULL); emit(ctx, SEXP_OP_RESUMECC); @@ -337,7 +337,7 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_global(ctx, SEXP_G_FINAL_RESUMER) = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) - = sexp_intern(ctx, "final-resumer"); + = sexp_intern(ctx, "final-resumer", -1); sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL; sexp_add_path(ctx, sexp_default_module_dir); sexp_add_path(ctx, getenv(SEXP_MODULE_PATH_VAR)); @@ -2384,7 +2384,7 @@ sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args if (sexp_exceptionp(op)) res = op; else - sexp_env_define(ctx, env, sexp_intern(ctx, name), op); + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), op); sexp_gc_release1(ctx); return res; } @@ -2394,7 +2394,7 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar sexp res; sexp_gc_var1(tmp); sexp_gc_preserve1(ctx, tmp); - tmp = sexp_intern(ctx, param); + tmp = sexp_intern(ctx, param, -1); tmp = sexp_env_cell(env, tmp); res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); sexp_gc_release1(ctx); @@ -2477,7 +2477,7 @@ sexp sexp_make_null_env (sexp ctx, sexp version) { sexp_uint_t i; sexp e = sexp_make_env(ctx); for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) - sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i])), + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i]), -1), sexp_copy_core(ctx, &core_forms[i])); return e; } @@ -2490,10 +2490,10 @@ sexp sexp_make_primitive_env (sexp ctx, sexp version) { for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { op = sexp_copy_opcode(ctx, &opcodes[i]); if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { - sym = sexp_intern(ctx, (char*)sexp_opcode_data(op)); + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1); sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); } - sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op), -1), op); } sexp_gc_release3(ctx); return e; @@ -2604,21 +2604,21 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { sexp_gc_preserve3(ctx, op, tmp, sym); sexp_load_standard_parameters(ctx, e); #if SEXP_USE_DL - sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*"), + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1), tmp=sexp_c_string(ctx, sexp_so_extension, -1)); #endif - tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform)); + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform, -1)); #if SEXP_USE_DL - sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading")); + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading", -1)); #endif #if SEXP_USE_MODULES - sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules")); + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules", -1)); #endif #if SEXP_USE_BOEHM - sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc")); + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); #endif - sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); - sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp); + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; #if SEXP_USE_SIMPLIFY op = sexp_make_foreign(ctx, "simplify", 1, 0, @@ -2631,7 +2631,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { /* load and bind config env */ #if SEXP_USE_MODULES if (! sexp_exceptionp(tmp)) { - sym = sexp_intern(ctx, "*config-env*"); + sym = sexp_intern(ctx, "*config-env*", -1); if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { tmp = sexp_make_env(ctx); if (! sexp_exceptionp(tmp)) { @@ -2768,11 +2768,11 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) { return res; } -sexp sexp_eval_string (sexp ctx, const char *str, sexp env) { +sexp sexp_eval_string (sexp ctx, const char *str, sexp_sint_t len, sexp env) { sexp res; sexp_gc_var1(obj); sexp_gc_preserve1(ctx, obj); - obj = sexp_read_from_string(ctx, str); + obj = sexp_read_from_string(ctx, str, len); res = sexp_eval(ctx, obj, env); sexp_gc_release1(ctx); return res; diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index cc45b3ab..952bdfbd 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -834,7 +834,7 @@ SEXP_API sexp sexp_c_string(sexp ctx, const 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_string_concatenate (sexp ctx, sexp str_ls, sexp sep); -SEXP_API sexp sexp_intern(sexp ctx, const char *str); +SEXP_API sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len); 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); @@ -847,7 +847,7 @@ 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, const char *str); +SEXP_API sexp sexp_read_from_string(sexp ctx, const char *str, sexp_sint_t len); SEXP_API sexp sexp_write_to_string(sexp ctx, sexp obj); SEXP_API sexp sexp_finalize_port (sexp ctx, sexp port); SEXP_API sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 19721c10..ecb00a86 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -10,7 +10,7 @@ static void sexp_define_type_predicate (sexp ctx, sexp env, sexp_gc_preserve2(ctx, name, op); name = sexp_c_string(ctx, cname, -1); op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); - sexp_env_define(ctx, env, name=sexp_intern(ctx, cname), op); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); sexp_gc_release2(ctx); } @@ -22,9 +22,9 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, type = sexp_make_fixnum(ctype); index = sexp_make_fixnum(cindex); op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); - sexp_env_define(ctx, env, name=sexp_intern(ctx, get), op); + sexp_env_define(ctx, env, name=sexp_intern(ctx, get, -1), op); op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); - sexp_env_define(ctx, env, name=sexp_intern(ctx, set), op); + sexp_env_define(ctx, env, name=sexp_intern(ctx, set, -1), op); sexp_gc_release2(ctx); } @@ -43,7 +43,7 @@ static sexp sexp_get_opcode_name (sexp ctx, sexp op) { else if (! sexp_opcode_name(op)) return SEXP_FALSE; else - return sexp_intern(ctx, sexp_opcode_name(op)); + return sexp_intern(ctx, sexp_opcode_name(op), -1); } sexp sexp_init_library (sexp ctx, sexp env) { diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c index 34e415c1..581acfc2 100644 --- a/lib/chibi/heap-stats.c +++ b/lib/chibi/heap-stats.c @@ -103,7 +103,7 @@ static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { res = SEXP_NULL; for (i=hi_type; i>0; i--) if (stats[i]) { - name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i)); + name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i), -1); tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); res = sexp_cons(ctx, tmp, res); } diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index d5d3d984..e56bdbeb 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -1,6 +1,6 @@ -/* rand.c -- rand_r/random_r interface */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include #include @@ -180,7 +180,7 @@ sexp sexp_init_library (sexp ctx, sexp env) { name = sexp_c_string(ctx, "random-source?", -1); op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(rs_type_id)); - name = sexp_intern(ctx, "random-source?"); + name = sexp_intern(ctx, "random-source?", -1); sexp_env_define(ctx, env, name, op); sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source); @@ -194,7 +194,7 @@ sexp sexp_init_library (sexp ctx, sexp env) { sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 2, sexp_random_source_pseudo_randomize); default_random_source = op = sexp_make_random_source(ctx); - name = sexp_intern(ctx, "default-random-source"); + name = sexp_intern(ctx, "default-random-source", -1); sexp_env_define(ctx, env, name, default_random_source); sexp_random_source_randomize(ctx, default_random_source); diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c index e38c23c0..b6918454 100644 --- a/lib/srfi/69/hash.c +++ b/lib/srfi/69/hash.c @@ -114,7 +114,7 @@ static sexp sexp_get_bucket (sexp ctx, sexp buckets, sexp hash_fn, sexp obj) { args = sexp_list2(ctx, obj, sexp_make_fixnum(len)); res = sexp_apply(ctx, hash_fn, args); if (sexp_exceptionp(res)) { - args = sexp_eval_string(ctx, "(current-error-port)", sexp_context_env(ctx)); + args = sexp_eval_string(ctx, "(current-error-port)", -1, sexp_context_env(ctx)); sexp_print_exception(ctx, res, args); res = sexp_make_fixnum(0); } diff --git a/main.c b/main.c index aa0a44a7..ef97201b 100644 --- a/main.c +++ b/main.c @@ -27,9 +27,9 @@ static void repl (sexp ctx) { sexp_env_define(ctx, sexp_context_env(ctx), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); sexp_context_tracep(ctx) = 1; - in = sexp_eval_string(ctx, "(current-input-port)", env); - out = sexp_eval_string(ctx, "(current-output-port)", env); - err = sexp_eval_string(ctx, "(current-error-port)", env); + in = sexp_eval_string(ctx, "(current-input-port)", -1, env); + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + err = sexp_eval_string(ctx, "(current-error-port)", -1, env); sexp_port_sourcep(in) = 1; while (1) { sexp_write_string(ctx, "> ", out); @@ -106,11 +106,11 @@ void run_main (int argc, char **argv) { print = (argv[i][1] == 'p'); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('e', arg); - res = check_exception(ctx, sexp_read_from_string(ctx, arg)); + res = check_exception(ctx, sexp_read_from_string(ctx, arg, -1)); res = check_exception(ctx, sexp_eval(ctx, res, env)); if (print) { if (! sexp_oportp(out)) - out = sexp_eval_string(ctx, "(current-output-port)", env); + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); sexp_write(ctx, res, out); sexp_write_char(ctx, '\n', out); } @@ -134,7 +134,7 @@ void run_main (int argc, char **argv) { impmod[len] = '\0'; for (p=impmod; *p; p++) if (*p == '.') *p=' '; - check_exception(ctx, sexp_eval_string(ctx, impmod, env)); + check_exception(ctx, sexp_eval_string(ctx, impmod, -1, env)); free(impmod); break; case 'q': @@ -171,9 +171,9 @@ void run_main (int argc, char **argv) { case 'V': load_init(); if (! sexp_oportp(out)) - out = sexp_eval_string(ctx, "(current-output-port)", env); + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); sexp_write_string(ctx, sexp_version_string, out); - tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*"), SEXP_NULL); + tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*", -1), SEXP_NULL); sexp_write(ctx, tmp, out); sexp_newline(ctx, out); return; @@ -191,11 +191,11 @@ void run_main (int argc, char **argv) { args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); else args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); - sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol), args); - sexp_eval_string(ctx, sexp_argv_proc, env); + sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args); + sexp_eval_string(ctx, sexp_argv_proc, -1, env); if (i < argc) { /* script usage */ check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); - tmp = sexp_intern(ctx, "main"); + tmp = sexp_intern(ctx, "main", -1); tmp = sexp_env_ref(env, tmp, SEXP_FALSE); if (sexp_procedurep(tmp)) { args = sexp_list1(ctx, args); diff --git a/sexp.c b/sexp.c index 9132fbe1..1da3114c 100644 --- a/sexp.c +++ b/sexp.c @@ -224,14 +224,14 @@ void sexp_init_context_globals (sexp ctx) { #endif sexp_global(ctx, SEXP_G_OOM_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of memory", SEXP_NULL); sexp_global(ctx, SEXP_G_OOS_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of stack space", SEXP_NULL); - sexp_global(ctx, SEXP_G_QUOTE_SYMBOL) = sexp_intern(ctx, "quote"); - sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote"); - sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote"); - sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL) = sexp_intern(ctx, "unquote-splicing"); - sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL) = sexp_intern(ctx, "*current-input-port*"); - sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL) = sexp_intern(ctx, "*current-output-port*"); - sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL) = sexp_intern(ctx, "*current-error-port*"); - sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL) = sexp_intern(ctx, "*interaction-environment*"); + sexp_global(ctx, SEXP_G_QUOTE_SYMBOL) = sexp_intern(ctx, "quote", -1); + sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote", -1); + sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote", -1); + sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL) = sexp_intern(ctx, "unquote-splicing", -1); + sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL) = sexp_intern(ctx, "*current-input-port*", -1); + sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL) = sexp_intern(ctx, "*current-output-port*", -1); + sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL) = sexp_intern(ctx, "*current-error-port*", -1); + sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL) = sexp_intern(ctx, "*interaction-environment*", -1); sexp_global(ctx, SEXP_G_EMPTY_VECTOR) = sexp_alloc_type(ctx, vector, SEXP_VECTOR); sexp_vector_length(sexp_global(ctx, SEXP_G_EMPTY_VECTOR)) = 0; #if ! SEXP_USE_GLOBAL_TYPES @@ -332,7 +332,7 @@ sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { sexp res; sexp_gc_var3(sym, str, irr); sexp_gc_preserve3(ctx, sym, str, irr); - res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user"), + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user", -1), str = sexp_c_string(ctx, ms, -1), ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : (irr = sexp_list1(ctx, ir))), @@ -345,7 +345,7 @@ sexp sexp_type_exception (sexp ctx, const char *message, sexp obj) { sexp res; sexp_gc_var3(sym, str, irr); sexp_gc_preserve3(ctx, sym, str, irr); - res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type"), + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type", -1), str = sexp_c_string(ctx, message, -1), irr = sexp_list1(ctx, obj), SEXP_FALSE, SEXP_FALSE); @@ -359,7 +359,7 @@ sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { 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, + res = sexp_make_exception(ctx, sexp_intern(ctx, "range", -1), msg, res, SEXP_FALSE, SEXP_FALSE); sexp_gc_release2(ctx); return res; @@ -432,7 +432,7 @@ static sexp sexp_read_error (sexp ctx, const char *msg, sexp ir, sexp port) { name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port))); str = sexp_c_string(ctx, msg, -1); irr = ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir)); - res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read"), + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read", -1), str, irr, SEXP_FALSE, name); sexp_gc_release4(ctx); return res; @@ -694,27 +694,31 @@ sexp sexp_string_concatenate (sexp ctx, sexp str_ls, sexp sep) { #if SEXP_USE_HASH_SYMS -static sexp_uint_t sexp_string_hash(const char *str, sexp_uint_t acc) { - while (*str) {acc *= FNV_PRIME; acc ^= *str++;} +static sexp_uint_t sexp_string_hash(const char *str, sexp_sint_t len, + sexp_uint_t acc) { + for ( ; len; len--) {acc *= FNV_PRIME; acc ^= *str++;} return acc; } #endif -sexp sexp_intern(sexp ctx, const char *str) { +sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { #if SEXP_USE_HUFF_SYMS struct sexp_huff_entry he; sexp_uint_t space=3, newbits; char c; #endif - sexp_uint_t len, res=FNV_OFFSET_BASIS, bucket; + sexp_uint_t res=FNV_OFFSET_BASIS, bucket, i=0; const char *p=str; - sexp ls; + sexp ls, tmp; sexp_gc_var1(sym); + if (len < 0) len = strlen(str); + #if SEXP_USE_HUFF_SYMS res = 0; - for ( ; (c=*p); p++) { + for ( ; i 127) goto normal_intern; he = huff_table[(unsigned char)c]; @@ -729,20 +733,20 @@ sexp sexp_intern(sexp ctx, const char *str) { normal_intern: #endif #if SEXP_USE_HASH_SYMS - bucket = (sexp_string_hash(p, res) % SEXP_SYMBOL_TABLE_SIZE); + bucket = (sexp_string_hash(p, len-i, res) % SEXP_SYMBOL_TABLE_SIZE); #else bucket = 0; #endif - len = strlen(str) + 1; /* include the trailing NULL in the comparison */ for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) - if (! strncmp(str, sexp_string_data(sexp_symbol_string(sexp_car(ls))), len)) + if ((sexp_string_length(tmp=sexp_symbol_string(sexp_car(ls))) == len) + && ! strncmp(str, sexp_string_data(tmp), len)) return sexp_car(ls); /* not found, make a new symbol */ sexp_gc_preserve1(ctx, sym); sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); if (sexp_exceptionp(sym)) return sym; - sexp_symbol_string(sym) = sexp_c_string(ctx, str, len-1); + sexp_symbol_string(sym) = sexp_c_string(ctx, str, len); sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); sexp_gc_release1(ctx); return sym; @@ -751,7 +755,7 @@ sexp sexp_intern(sexp ctx, const char *str) { sexp sexp_string_to_symbol (sexp ctx, sexp str) { if (! sexp_stringp(str)) return sexp_type_exception(ctx, "string->symbol: not a string", str); - return sexp_intern(ctx, sexp_string_data(str)); + return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); } sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { @@ -1316,7 +1320,7 @@ sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) { } buf[i] = '\0'; - res = (internp ? sexp_intern(ctx, buf) : sexp_c_string(ctx, buf, i)); + res = (internp ? sexp_intern(ctx, buf, i) : sexp_c_string(ctx, buf, i)); if (size != INIT_STRING_BUFFER_SIZE) free(buf); return res; } @@ -1624,11 +1628,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) { sexp_push_char(ctx, c2, in); res = sexp_read_symbol(ctx, in, c1, 1); #if SEXP_USE_INFINITIES - if (res == sexp_intern(ctx, "+inf.0")) + if (res == sexp_intern(ctx, "+inf.0", -1)) res = sexp_make_flonum(ctx, 1.0/0.0); - else if (res == sexp_intern(ctx, "-inf.0")) + else if (res == sexp_intern(ctx, "-inf.0", -1)) res = sexp_make_flonum(ctx, -1.0/0.0); - else if (res == sexp_intern(ctx, "+nan.0")) + else if (res == sexp_intern(ctx, "+nan.0", -1)) res = sexp_make_flonum(ctx, 0.0/0.0); #endif } @@ -1662,11 +1666,11 @@ sexp sexp_read (sexp ctx, sexp in) { return res; } -sexp sexp_read_from_string(sexp ctx, const char *str) { +sexp sexp_read_from_string(sexp ctx, const char *str, sexp_sint_t len) { sexp res; sexp_gc_var2(s, in); sexp_gc_preserve2(ctx, s, in); - s = sexp_c_string(ctx, str, -1); + s = sexp_c_string(ctx, str, len); in = sexp_make_input_string_port(ctx, s); res = sexp_read(ctx, in); sexp_gc_release2(ctx); diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 06bebb97..cdd8d235 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -1044,7 +1044,8 @@ (let ((pred (cadr x))) (cat " tmp = sexp_make_type_predicate(ctx, name, " "sexp_make_fixnum(" (type-id-name name) "));\n" - " name = sexp_intern(ctx, \"" pred "\");\n" + " name = sexp_intern(ctx, \"" pred "\", " + (string-length (x->string pred)) ");\n" " sexp_env_define(ctx, env, name, tmp);\n"))))))) (define (type-getter-name type name field) @@ -1183,7 +1184,8 @@ (define (write-const const) (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) - (cat " name = sexp_intern(ctx, \"" scheme-name "\");\n" + (cat " name = sexp_intern(ctx, \"" scheme-name "\", " + (string-length (x->string scheme-name)) ");\n" " sexp_env_define(ctx, env, name, tmp=" (lambda () (c->scheme-converter (car const) c-name)) ");\n"))) From 135d53a8f0d2c7c173938231085c8e54e3f42458 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 23 Mar 2010 20:53:12 +0900 Subject: [PATCH 398/535] forgot to include eval.h --- include/chibi/eval.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 7cd1d8d9..8f1e11a3 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -133,7 +133,7 @@ SEXP_API sexp sexp_apply_optimization (sexp context, sexp proc, sexp ast); SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); SEXP_API int sexp_param_index (sexp lambda, sexp name); SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); -SEXP_API sexp sexp_eval_string (sexp context, const char *str, sexp env); +SEXP_API sexp sexp_eval_string (sexp context, const char *str, sexp_sint_t len, sexp env); SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); SEXP_API sexp sexp_make_env (sexp context); SEXP_API sexp sexp_make_null_env (sexp context, sexp version); From 36043bb8da17765fd01b6d0bf6f32d36b263a860 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 24 Mar 2010 01:27:09 +0900 Subject: [PATCH 399/535] making sexp_make_procedure public --- eval.c | 4 ++-- include/chibi/eval.h | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/eval.c b/eval.c index 9e64e1e5..3b8a0e36 100644 --- a/eval.c +++ b/eval.c @@ -234,8 +234,8 @@ static sexp finalize_bytecode (sexp ctx) { return bc; } -static sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args, - sexp bc, sexp vars) { +sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args, + sexp bc, sexp vars) { 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; diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 8f1e11a3..ba55e691 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -152,6 +152,7 @@ SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); +SEXP_API sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args, sexp bc, sexp vars); SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); From a89956fc1615eed285b58dd5a44ad585fa7d115e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 24 Mar 2010 19:58:50 +0900 Subject: [PATCH 400/535] new primitives API Primitives now have a signature of prim(ctx, self, n, args ...) instead of just prim(ctx, args ...). This allows for variadic primitives, should help clean up exception handling, and will allow primitives generated from Scheme->C or JIT compilation. The primitives sometimes used as utility functions from C such as sexp_memq have been renamed with a "_op" suffix (e.g. sexp_memq_op) and a macro sexp_memq has been provided filling in the self and n args automatically. The self is passed as NULL in these macros, but will be probably replaced with a reference to the opcode later. --- Makefile | 18 ++--- eval.c | 80 ++++++++++----------- gc.c | 8 +-- include/chibi/eval.h | 44 ++++++++---- include/chibi/features.h | 14 +++- include/chibi/sexp.h | 146 +++++++++++++++++++++++++-------------- opcodes.c | 92 ++++++++++++------------ opt/simplify.c | 2 +- sexp.c | 93 +++++++++++++------------ 9 files changed, 283 insertions(+), 214 deletions(-) diff --git a/Makefile b/Makefile index 37aa5ca1..0d6da9fa 100644 --- a/Makefile +++ b/Makefile @@ -129,11 +129,11 @@ chibi-scheme-static$(EXE): main.o eval.o sexp.o clibs.c: $(GENSTATIC) lib lib/chibi lib/srfi make chibi-scheme$(EXE) make libs - LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) PATH=.:$(PATH) $(GENSTATIC) $< > $@ + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTATIC) $< > $@ %.c: %.stub $(GENSTUBS) make chibi-scheme$(EXE) - -LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) PATH=.:$(PATH) $(GENSTUBS) $< + -LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTUBS) $< lib/%$(SO): lib/%.c $(INCLUDES) -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme @@ -149,7 +149,7 @@ cleaner: clean test-basic: chibi-scheme$(EXE) @for f in tests/basic/*.scm; do \ - ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ if diff -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \ echo "[PASS] $${f%.scm}"; \ else \ @@ -161,22 +161,22 @@ test-build: ./tests/build/build-tests.sh test-numbers: chibi-scheme$(EXE) - LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/numeric-tests.scm + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/numeric-tests.scm test-hash: chibi-scheme$(EXE) - LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/hash-tests.scm + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/hash-tests.scm test-match: chibi-scheme$(EXE) - LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/match-tests.scm + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/match-tests.scm test-loop: chibi-scheme$(EXE) - LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/loop-tests.scm + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/loop-tests.scm test-sort: chibi-scheme$(EXE) - LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/sort-tests.scm + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm test: chibi-scheme$(EXE) - LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/r5rs-tests.scm + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/r5rs-tests.scm install: chibi-scheme$(EXE) mkdir -p $(DESTDIR)$(BINDIR) diff --git a/eval.c b/eval.c index 3b8a0e36..693ec8f5 100644 --- a/eval.c +++ b/eval.c @@ -1,6 +1,6 @@ -/* eval.c -- evaluator library implementation */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include "chibi/eval.h" @@ -24,8 +24,8 @@ static sexp analyze (sexp ctx, sexp x); static void generate (sexp ctx, sexp x); #if SEXP_USE_MODULES -static sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env); -static sexp sexp_find_module_file_op (sexp ctx, sexp file); +static sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env); +static sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file); #endif sexp sexp_compile_error (sexp ctx, const char *message, sexp o) { @@ -110,7 +110,7 @@ sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { return res; } -sexp sexp_env_exports (sexp ctx, sexp env) { +sexp sexp_env_exports_op (sexp ctx sexp_api_params(self, n), sexp env) { sexp ls; sexp_gc_var1(res); sexp_gc_preserve1(ctx, res); @@ -251,7 +251,7 @@ static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) { return mac; } -static sexp sexp_make_synclo (sexp ctx, sexp env, sexp fv, sexp expr) { +static sexp sexp_make_synclo_op (sexp ctx sexp_api_params(self, n), sexp env, sexp fv, sexp expr) { sexp res; if (! (sexp_symbolp(expr) || sexp_pairp(expr))) return expr; @@ -382,11 +382,11 @@ sexp sexp_make_child_context (sexp ctx, sexp lambda) { /**************************** identifiers *****************************/ -static sexp sexp_identifierp (sexp ctx, sexp x) { +static sexp sexp_identifierp_op (sexp ctx sexp_api_params(self, n), sexp x) { return sexp_make_boolean(sexp_idp(x)); } -static sexp sexp_syntactic_closure_expr (sexp ctx, sexp x) { +static sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), sexp x) { return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); } @@ -410,7 +410,7 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) { return res; } -static sexp sexp_identifier_eq (sexp ctx, sexp e1, sexp id1, sexp e2, sexp id2) { +static sexp sexp_identifier_eq_op (sexp ctx sexp_api_params(self, n), 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); @@ -1441,21 +1441,21 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_FCALL0: _ALIGN_IP(); sexp_context_top(ctx) = top; - _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx)); + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 0))); ip += sizeof(sexp); sexp_check_exception(); break; case SEXP_OP_FCALL1: _ALIGN_IP(); sexp_context_top(ctx) = top; - _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx, _ARG1); + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 1), _ARG1); ip += sizeof(sexp); sexp_check_exception(); break; case SEXP_OP_FCALL2: _ALIGN_IP(); sexp_context_top(ctx) = top; - _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2); + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 2), _ARG1, _ARG2); top--; ip += sizeof(sexp); sexp_check_exception(); @@ -1463,7 +1463,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_FCALL3: _ALIGN_IP(); sexp_context_top(ctx) = top; - _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3); + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 3), _ARG1, _ARG2, _ARG3); top -= 2; ip += sizeof(sexp); sexp_check_exception(); @@ -1471,7 +1471,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_FCALL4: _ALIGN_IP(); sexp_context_top(ctx) = top; - _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 4), _ARG1, _ARG2, _ARG3, _ARG4); top -= 3; ip += sizeof(sexp); sexp_check_exception(); @@ -1479,7 +1479,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_FCALL5: _ALIGN_IP(); sexp_context_top(ctx) = top; - _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 5), _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); top -= 4; ip += sizeof(sexp); sexp_check_exception(); @@ -1487,7 +1487,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_FCALL6: _ALIGN_IP(); sexp_context_top(ctx) = top; - _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 6), _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); top -= 5; ip += sizeof(sexp); sexp_check_exception(); @@ -2025,14 +2025,14 @@ sexp sexp_vm (sexp ctx, sexp proc) { /************************ library procedures **************************/ -static sexp sexp_exception_type_func (sexp ctx, sexp exn) { +static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), 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) { +static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) { FILE *in; if (! sexp_stringp(path)) return sexp_type_exception(ctx, "not a string", path); @@ -2043,7 +2043,7 @@ static sexp sexp_open_input_file (sexp ctx, sexp path) { return sexp_make_input_port(ctx, in, path); } -static sexp sexp_open_output_file (sexp ctx, sexp path) { +static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) { FILE *out; if (! sexp_stringp(path)) return sexp_type_exception(ctx, "not a string", path); @@ -2054,12 +2054,12 @@ static sexp sexp_open_output_file (sexp ctx, sexp path) { return sexp_make_output_port(ctx, out, path); } -static sexp sexp_close_port (sexp ctx, sexp port) { +static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), 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); - return sexp_finalize_port(ctx, port); + return sexp_finalize_port(ctx sexp_api_pass(self, n), port); } void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) { @@ -2085,7 +2085,7 @@ static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { FreeLibrary(handle); return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); } - return init(ctx, env); + return init(ctx sexp_api_pass(NULL, 1), env); } #else static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { @@ -2098,12 +2098,12 @@ static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { dlclose(handle); return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); } - return init(ctx, env); + return init(ctx sexp_api_pass(NULL, 1), env); } #endif #endif -sexp sexp_load (sexp ctx, sexp source, sexp env) { +sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { #if SEXP_USE_DL char *suffix; #endif @@ -2208,7 +2208,7 @@ static sexp sexp_sqrt (sexp ctx, sexp z) { #endif -static sexp sexp_expt (sexp ctx, sexp x, sexp e) { +static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { long double f, x1, e1; sexp res; #if SEXP_USE_BIGNUMS @@ -2265,7 +2265,7 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { return res; } -static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { +static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), 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); @@ -2293,7 +2293,7 @@ sexp sexp_apply_optimization (sexp ctx, sexp proc, sexp ast) { sexp res; sexp_gc_var1(args); if (sexp_opcodep(proc)) { - res = ((sexp_proc2)sexp_opcode_func(proc))(ctx, ast); + res = ((sexp_proc2)sexp_opcode_func(proc))(ctx sexp_api_pass(proc, 1), ast); } else { sexp_gc_preserve1(ctx, args); res = sexp_apply(ctx, proc, args=sexp_list1(ctx, ast)); @@ -2403,7 +2403,7 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar #if SEXP_USE_TYPE_DEFS -sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { +sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { if (! sexp_fixnump(type)) return sexp_type_exception(ctx, "make-type-predicate: bad type", type); return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), @@ -2411,7 +2411,7 @@ sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); } -sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { +sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { sexp_uint_t type_size; if (! sexp_fixnump(type)) return sexp_type_exception(ctx, "make-constructor: bad type", type); @@ -2422,7 +2422,7 @@ sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { sexp_make_fixnum(type_size), NULL); } -sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { +sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) return sexp_type_exception(ctx, "make-getter: bad type", type); if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) @@ -2433,7 +2433,7 @@ sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); } -sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index) { +sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) return sexp_type_exception(ctx, "make-setter: bad type", type); if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) @@ -2465,7 +2465,7 @@ static struct sexp_struct core_forms[] = { {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}}}, }; -sexp sexp_make_env (sexp ctx) { +sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) { sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); sexp_env_lambda(e) = NULL; sexp_env_parent(e) = NULL; @@ -2473,7 +2473,7 @@ sexp sexp_make_env (sexp ctx) { return e; } -sexp sexp_make_null_env (sexp ctx, sexp version) { +sexp sexp_make_null_env_op (sexp ctx sexp_api_params(self, n), sexp version) { sexp_uint_t i; sexp e = sexp_make_env(ctx); for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) @@ -2551,13 +2551,13 @@ sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { } #if SEXP_USE_MODULES -static sexp sexp_find_module_file_op (sexp ctx, sexp file) { +static sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file) { if (! sexp_stringp(file)) return sexp_type_exception(ctx, "not a string", file); else return sexp_find_module_file(ctx, sexp_string_data(file)); } -sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env) { +sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env) { if (! sexp_stringp(file)) return sexp_type_exception(ctx, "not a string", file); else if (! sexp_envp(env)) @@ -2566,7 +2566,7 @@ sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env) { } #endif -sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp) { +sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp) { sexp ls; if (! sexp_stringp(dir)) return sexp_type_exception(ctx, "not a string", dir); @@ -2653,7 +2653,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { return sexp_exceptionp(tmp) ? tmp : e; } -sexp sexp_make_standard_env (sexp ctx, sexp version) { +sexp sexp_make_standard_env_op (sexp ctx sexp_api_params(self, n), sexp version) { sexp_gc_var1(env); sexp_gc_preserve1(ctx, env); env = sexp_make_primitive_env(ctx, version); @@ -2662,7 +2662,7 @@ sexp sexp_make_standard_env (sexp ctx, sexp version) { return env; } -sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls, sexp immutp) { +sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) { sexp oldname, newname, value, out; if (! sexp_envp(to)) to = sexp_context_env(ctx); if (! sexp_envp(from)) from = sexp_context_env(ctx); @@ -2746,7 +2746,7 @@ sexp sexp_compile (sexp ctx, sexp x) { return res; } -sexp sexp_eval (sexp ctx, sexp obj, sexp env) { +sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { sexp_sint_t top; sexp ctx2; sexp_gc_var2(res, err_handler); diff --git a/gc.c b/gc.c index 60653eae..399dd6b8 100644 --- a/gc.c +++ b/gc.c @@ -1,6 +1,6 @@ -/* gc.c -- simple mark&sweep garbage collector */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* gc.c -- simple mark&sweep garbage collector */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include "chibi/sexp.h" @@ -98,7 +98,7 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { /* free p */ finalizer = sexp_type_finalize(sexp_object_type(ctx, p)); - if (finalizer) finalizer(ctx, p); + if (finalizer) finalizer(ctx sexp_api_pass(NULL, 1), p); sum_freed += size; if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) { /* merge q with p */ diff --git a/include/chibi/eval.h b/include/chibi/eval.h index ba55e691..07dd9ac8 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -1,6 +1,6 @@ -/* eval.h -- headers for eval library */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* eval.h -- headers for eval library */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #ifndef SEXP_EVAL_H #define SEXP_EVAL_H @@ -132,20 +132,20 @@ SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); SEXP_API sexp sexp_apply_optimization (sexp context, sexp proc, sexp ast); SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); SEXP_API int sexp_param_index (sexp lambda, sexp name); -SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); +SEXP_API sexp sexp_eval_op (sexp context sexp_api_params(self, n), sexp obj, sexp env); SEXP_API sexp sexp_eval_string (sexp context, const char *str, sexp_sint_t len, sexp env); -SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); -SEXP_API sexp sexp_make_env (sexp context); -SEXP_API sexp sexp_make_null_env (sexp context, sexp version); +SEXP_API sexp sexp_load_op (sexp context sexp_api_params(self, n), sexp expr, sexp env); +SEXP_API sexp sexp_make_env_op (sexp context sexp_api_params(self, n)); +SEXP_API sexp sexp_make_null_env_op (sexp context sexp_api_params(self, n), sexp version); SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version); -SEXP_API sexp sexp_make_standard_env (sexp context, sexp version); +SEXP_API sexp sexp_make_standard_env_op (sexp context sexp_api_params(self, n), sexp version); SEXP_API sexp sexp_load_standard_parameters (sexp context, sexp env); SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version); SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file); SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env); -SEXP_API sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp); +SEXP_API sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp); SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); -SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls, sexp immutp); +SEXP_API sexp sexp_env_copy_op (sexp context sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp); SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_env_cell (sexp env, sexp sym); SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); @@ -162,12 +162,28 @@ SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, sexp_proc1 f, const char *param); #if SEXP_USE_TYPE_DEFS -SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); -SEXP_API sexp sexp_make_constructor (sexp ctx, sexp name, sexp type); -SEXP_API sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index); -SEXP_API sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index); +SEXP_API sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type); +SEXP_API sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type); +SEXP_API sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index); +SEXP_API sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index); #endif +/* simplify primitive API interface */ +#define sexp_make_synclo(ctx, a, b, c) sexp_make_synclo_op(ctx sexp_api_pass(NULL, 3) a, b, c) +#define sexp_make_env(ctx) sexp_make_env_op(ctx sexp_api_pass(NULL, 0)) +#define sexp_make_null_env(ctx, v) sexp_make_null_env_op(ctx sexp_api_pass(NULL, 0), v) +#define sexp_make_standard_env(ctx) sexp_make_standard_env_op(ctx sexp_api_pass(NULL, 0)) +#define sexp_add_module_directory(ctx, d, a) sexp_add_module_directory_op(ctx sexp_api_pass(NULL, 1), d, a) +#define sexp_eval(ctx, x, e) sexp_eval_op(ctx sexp_api_pass(NULL, 2), x, e) +#define sexp_load(ctx, f, e) sexp_load_op(ctx sexp_api_pass(NULL, 2), f, e) +#define sexp_env_copy(ctx, a, b, c, d) sexp_env_copy_op(ctx sexp_api_pass(NULL, 4), a, b, c, d) +#define sexp_identifierp(ctx, x) sexp_identifier_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_identifier_to_symbol(ctx, x) sexp_syntactic_closure_expr(ctx sexp_api_pass(NULL, 1), x) +#define sexp_identifier_eq(ctx, a, b, c, d) sexp_identifier_eq_op(ctx sexp_api_pass(NULL, 4), a, b, c, d) +#define sexp_open_input_file(ctx, x) sexp_open_input_file_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_open_output_file(ctx, x) sexp_open_output_file_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_close_port(ctx, x) sexp_close_port_op(ctx sexp_api_pass(NULL, 1), x) + #ifdef __cplusplus } /* extern "C" */ #endif diff --git a/include/chibi/features.h b/include/chibi/features.h index b7770647..8c933bcc 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -1,6 +1,6 @@ -/* features.h -- general feature configuration */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* features.h -- general feature configuration */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ /* uncomment this to disable most features */ /* Most features are enabled by default, but setting this */ @@ -104,6 +104,10 @@ /* Automatically disabled if you've disabled flonums. */ /* #define SEXP_USE_MATH 0 */ +/* uncomment this to disable the self and n parameters to primitives */ +/* This is the old style API. */ +/* #define SEXP_USE_SELF_PARAMETER 0 */ + /* uncomment this to disable warning about references to undefined variables */ /* This is something of a hack, but can be quite useful. */ /* It's very fast and doesn't involve any separate analysis */ @@ -288,6 +292,10 @@ #define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES #endif +#ifndef SEXP_USE_SELF_PARAMETER +#define SEXP_USE_SELF_PARAMETER 1 +#endif + #ifndef SEXP_USE_WARN_UNDEFS #define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES #endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 952bdfbd..6737e2a8 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1,6 +1,6 @@ -/* sexp.h -- header for sexp library */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* sexp.h -- header for sexp library */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #ifndef SEXP_H #define SEXP_H @@ -125,15 +125,23 @@ typedef struct sexp_struct *sexp; #define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1) #define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1) +#if SEXP_USE_SELF_PARAMETER +#define sexp_api_params(self, n) , sexp self, long n +#define sexp_api_pass(self, n) , self, n +#else +#define sexp_api_params(self, n) +#define sexp_api_pass(self, n) +#endif + /* procedure types */ typedef sexp (*sexp_proc0) (void); -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 sexp (*sexp_proc1) (sexp sexp_api_params(self, n)); +typedef sexp (*sexp_proc2) (sexp sexp_api_params(self, n), sexp); +typedef sexp (*sexp_proc3) (sexp sexp_api_params(self, n), sexp, sexp); +typedef sexp (*sexp_proc4) (sexp sexp_api_params(self, n), sexp, sexp, sexp); +typedef sexp (*sexp_proc5) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc6) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc7) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp); typedef struct sexp_free_list_t *sexp_free_list; struct sexp_free_list_t { @@ -820,46 +828,46 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); SEXP_API sexp sexp_make_context(sexp ctx, sexp_uint_t size); 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_cons_op(sexp ctx sexp_api_params(self, n), 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_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_listp_op(sexp ctx sexp_api_params(self, n), sexp obj); +SEXP_API sexp sexp_reverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_nreverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_append2_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_memq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_assq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_length_op(sexp ctx sexp_api_params(self, n), sexp ls); SEXP_API sexp sexp_c_string(sexp ctx, const 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_string_concatenate (sexp ctx, sexp str_ls, sexp sep); -SEXP_API sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len); -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_make_cpointer(sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); -SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out); -SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out); -SEXP_API sexp sexp_flush_output(sexp ctx, 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, const char *str, sexp_sint_t len); -SEXP_API sexp sexp_write_to_string(sexp ctx, sexp obj); -SEXP_API sexp sexp_finalize_port (sexp ctx, sexp port); -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 source); -SEXP_API sexp sexp_user_exception(sexp ctx, sexp self, const char *msg, sexp x); -SEXP_API sexp sexp_type_exception(sexp ctx, const char *message, sexp x); -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 sexp sexp_make_string_op(sexp ctx sexp_api_params(self, n), sexp len, sexp ch); +SEXP_API sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end); +SEXP_API sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep); +SEXP_API sexp sexp_intern (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_make_vector (sexp ctx, sexp len, sexp dflt); +SEXP_API sexp sexp_list_to_vector_op (sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); +SEXP_API sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp in); +SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_write_to_string (sexp ctx, sexp obj); +SEXP_API sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port); +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_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)); +SEXP_API sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port); +SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); +SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_type_exception (sexp ctx, const char *message, sexp x); +SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +SEXP_API sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out); SEXP_API void sexp_init(void); #define SEXP_COPY_DEFAULT SEXP_ZERO @@ -868,15 +876,15 @@ SEXP_API void sexp_init(void); #if SEXP_USE_GLOBAL_HEAP #define sexp_destroy_context(ctx) #else -SEXP_API void sexp_destroy_context(sexp ctx); -SEXP_API sexp sexp_copy_context(sexp ctx, sexp dst, sexp flags); +SEXP_API void sexp_destroy_context (sexp ctx); +SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags); #endif #if SEXP_USE_TYPE_DEFS -SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); -SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots); +SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots); SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); -SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp obj); +SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj); #define sexp_register_c_type(ctx, name, finalizer) \ sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ @@ -886,6 +894,38 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp obj); #define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) #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))) +/* simplify primitive API interface */ + +#define sexp_read(ctx, in) sexp_read_op(ctx sexp_api_pass(NULL, 1), in) +#define sexp_write(ctx, obj, out) sexp_write_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_display(ctx, obj, out) sexp_display_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx sexp_api_pass(NULL, 2), e, out) +#define sexp_flush_output(ctx, obj, out) sexp_flush_output_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_listp(ctx, x) sexp_listp_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_length(ctx, x) sexp_length_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_reverse(ctx, x) sexp_reverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_cons(ctx, a, b) sexp_cons_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_append2(ctx, a, b) sexp_append2_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), l, c) +#define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_substring(ctx, a, b, c) sexp_substring_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx sexp_api_pass(NULL, 2), ls, s) +#define sexp_memq(ctx, a, b) sexp_memq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_assq(ctx, a, b) sexp_assq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_output_string_port(ctx) sexp_make_output_string_port_op(ctx sexp_api_pass(NULL, 0)) +#define sexp_make_input_string_port(ctx, s) sexp_make_input_string_port_op(ctx sexp_api_pass(NULL, 1), s) +#define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_expt(ctx, a, b) sexp_expt_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_simple_type(ctx, a, b) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_make_setter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) + #ifdef __cplusplus } /* extern "C" */ #endif diff --git a/opcodes.c b/opcodes.c index 8e1dbeb1..86ab0687 100644 --- a/opcodes.c +++ b/opcodes.c @@ -58,7 +58,7 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_f _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), #if SEXP_USE_IMMEDIATE_FLONUMS -_FN1(0, "flonum?", 0, sexp_flonum_predicate), +_FN1(0, "flonum?", 0, sexp_flonump_op), #else _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), #endif @@ -74,49 +74,49 @@ _OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp _OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), _OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), _OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), -_FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read), -_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write), -_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display), -_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output), -_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), -_FN0("make-environment", 0, sexp_make_env), -_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), -_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), -_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval), -_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load), -_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), -_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), -_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), -_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), -_FN2OPT(SEXP_PAIR, SEXP_STRING, "string-concatenate", SEXP_FALSE, 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), +_FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read_op), +_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write_op), +_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display_op), +_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op), +_FN2(0, 0, "equal?", 0, sexp_equalp_op), +_FN1(0, "list?", 0, sexp_listp_op), +_FN1(0, "identifier?", 0, sexp_identifierp_op), +_FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr_op), +_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq_op), +_FN1(SEXP_PAIR, "length", 0, sexp_length_op), +_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse_op), +_FN1(SEXP_PAIR, "reverse!", 0, sexp_nreverse_op), +_FN2(SEXP_PAIR, SEXP_PAIR, "append2", 0, sexp_append2_op), +_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector_op), +_FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file_op), +_FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file_op), +_FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port_op), +_FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port_op), +_FN0("make-environment", 0, sexp_make_env_op), +_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env_op), +_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env_op), +_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval_op), +_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load_op), +_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy_op), +_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception_op), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_op), +_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string_op), +_FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp_op), +_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring_op), +_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol_op), +_FN2OPT(SEXP_PAIR, SEXP_STRING, "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op), +_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq_op), +_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq_op), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo_op), _FN1(0, "strip-syntactic-closures", 0, sexp_strip_synclos), _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), -_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), +_FN0("open-output-string", 0, sexp_make_output_string_port_op), +_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port_op), +_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string_op), #if SEXP_USE_MATH _FN1(0, "exp", 0, sexp_exp), _FN1(0, "log", 0, sexp_log), @@ -132,22 +132,22 @@ _FN1(0, "truncate", 0, sexp_trunc), _FN1(0, "floor", 0, sexp_floor), _FN1(0, "ceiling", 0, sexp_ceiling), #endif -_FN2(0, 0, "expt", 0, sexp_expt), +_FN2(0, 0, "expt", 0, sexp_expt_op), #if SEXP_USE_TYPE_DEFS -_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type), -_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate), -_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor), -_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter), -_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter), +_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type_op), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate_op), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor_op), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter_op), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter_op), #endif #if PLAN9 #include "opt/plan9-opcodes.c" #endif #if SEXP_USE_MODULES -_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports), +_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports_op), _FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), _FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), -_FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory), +_FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory_op), #endif }; diff --git a/opt/simplify.c b/opt/simplify.c index eb4c97f3..4217a1bb 100644 --- a/opt/simplify.c +++ b/opt/simplify.c @@ -137,7 +137,7 @@ static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { return res; } -sexp sexp_simplify (sexp ctx, sexp ast) { +sexp sexp_simplify (sexp ctx sexp_api_params(self, n), sexp ast) { return simplify(ctx, ast, SEXP_NULL, NULL); } diff --git a/sexp.c b/sexp.c index 1da3114c..f4f3d46c 100644 --- a/sexp.c +++ b/sexp.c @@ -1,6 +1,6 @@ -/* sexp.c -- standalone sexp library implementation */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include "chibi/sexp.h" @@ -53,7 +53,7 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { return res; } -sexp sexp_finalize_port (sexp ctx, sexp port) { +sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port) { if (sexp_port_openp(port)) { sexp_port_openp(port) = 0; if (sexp_port_stream(port) && ! sexp_port_no_closep(port)) @@ -184,7 +184,7 @@ sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp felb, sexp flb, return res; } -sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) { +sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots) { short type_size = sexp_sizeof_header + sizeof(sexp)*sexp_unbox_fixnum(slots); return sexp_register_type(ctx, name, sexp_make_fixnum(sexp_offsetof_slot0), @@ -192,7 +192,7 @@ sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) { sexp_make_fixnum(type_size), SEXP_ZERO, SEXP_ZERO, NULL); } -sexp sexp_finalize_c_type (sexp ctx, sexp obj) { +sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) { if (sexp_cpointer_freep(obj)) free(sexp_cpointer_value(obj)); return SEXP_VOID; @@ -365,7 +365,7 @@ sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { return res; } -sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { +sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out) { sexp ls; if (! sexp_oportp(out)) out = sexp_make_output_port(ctx, stderr, SEXP_FALSE); @@ -440,7 +440,7 @@ static sexp sexp_read_error (sexp ctx, const char *msg, sexp ir, sexp port) { /*************************** list utilities ***************************/ -sexp sexp_cons (sexp ctx, sexp head, sexp tail) { +sexp sexp_cons_op (sexp ctx sexp_api_params(self, n), sexp head, sexp tail) { sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); if (sexp_exceptionp(pair)) return pair; sexp_car(pair) = head; @@ -458,7 +458,7 @@ sexp sexp_list2 (sexp ctx, sexp a, sexp b) { return res; } -sexp sexp_listp (sexp ctx, sexp hare) { +sexp sexp_listp_op (sexp ctx sexp_api_params(self, n), sexp hare) { sexp turtle; if (! sexp_pairp(hare)) return sexp_make_boolean(sexp_nullp(hare)); @@ -472,7 +472,7 @@ sexp sexp_listp (sexp ctx, sexp hare) { return sexp_make_boolean(sexp_nullp(hare)); } -sexp sexp_memq (sexp ctx, sexp x, sexp ls) { +sexp sexp_memq_op (sexp ctx sexp_api_params(self, n), sexp x, sexp ls) { while (sexp_pairp(ls)) if (x == sexp_car(ls)) return ls; @@ -481,7 +481,7 @@ sexp sexp_memq (sexp ctx, sexp x, sexp ls) { return SEXP_FALSE; } -sexp sexp_assq (sexp ctx, sexp x, sexp ls) { +sexp sexp_assq_op (sexp ctx sexp_api_params(self, n), sexp x, sexp ls) { while (sexp_pairp(ls)) if (sexp_pairp(sexp_car(ls)) && (x == sexp_caar(ls))) return sexp_car(ls); @@ -490,7 +490,7 @@ sexp sexp_assq (sexp ctx, sexp x, sexp ls) { return SEXP_FALSE; } -sexp sexp_reverse (sexp ctx, sexp ls) { +sexp sexp_reverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { sexp_gc_var1(res); sexp_gc_preserve1(ctx, res); for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) @@ -499,7 +499,7 @@ sexp sexp_reverse (sexp ctx, sexp ls) { return res; } -sexp sexp_nreverse (sexp ctx, sexp ls) { +sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { sexp a, b, tmp; if (ls == SEXP_NULL) { return ls; @@ -517,7 +517,7 @@ sexp sexp_nreverse (sexp ctx, sexp ls) { } } -sexp sexp_append2 (sexp ctx, sexp a, sexp b) { +sexp sexp_append2_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { sexp_gc_var2(a1, b1); sexp_gc_preserve2(ctx, a1, b1); b1 = b; @@ -527,14 +527,14 @@ sexp sexp_append2 (sexp ctx, sexp a, sexp b) { return b1; } -sexp sexp_length (sexp ctx, sexp ls) { +sexp sexp_length_op (sexp ctx sexp_api_params(self, n), sexp ls) { sexp_uint_t res=0; for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) ; return sexp_make_fixnum(res); } -sexp sexp_equalp (sexp ctx, sexp a, sexp b) { +sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { sexp_uint_t size; sexp_sint_t i, len; sexp t, *p, *q; @@ -597,7 +597,7 @@ sexp sexp_make_flonum (sexp ctx, double f) { return x; } #else -sexp sexp_flonum_predicate (sexp ctx, sexp x) { +sexp sexp_flonump_op (sexp ctx sexp_api_params(self, n), sexp x) { return sexp_make_boolean(sexp_flonump(x)); } #if SEXP_64_BIT @@ -614,7 +614,7 @@ sexp sexp_make_flonum (sexp ctx, float f) { #endif #endif -sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { +sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) { sexp_sint_t clen = sexp_unbox_fixnum(len); sexp s; if (! sexp_fixnump(len)) return sexp_type_exception(ctx, "bad length", len); @@ -629,7 +629,7 @@ sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { return s; } -sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen) { +sexp sexp_c_string (sexp ctx, const char *str, sexp_sint_t slen) { sexp_sint_t len = ((slen >= 0) ? slen : strlen(str)); sexp s = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID); memcpy(sexp_string_data(s), str, len); @@ -637,7 +637,7 @@ sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen) { return s; } -sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { +sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end) { sexp res; if (! sexp_stringp(str)) return sexp_type_exception(ctx, "not a string", str); @@ -661,7 +661,7 @@ sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { return res; } -sexp sexp_string_concatenate (sexp ctx, sexp str_ls, sexp sep) { +sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep) { sexp res, ls; sexp_uint_t len=0, i=0, sep_len=0; char *p, *csep; @@ -752,13 +752,13 @@ sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { return sym; } -sexp sexp_string_to_symbol (sexp ctx, sexp str) { +sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str) { if (! sexp_stringp(str)) return sexp_type_exception(ctx, "string->symbol: not a string", str); return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); } -sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { +sexp sexp_make_vector (sexp ctx, sexp len, sexp dflt) { sexp vec, *x; int i, clen = sexp_unbox_fixnum(len); if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR); @@ -772,7 +772,7 @@ sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { return vec; } -sexp sexp_list_to_vector(sexp ctx, sexp ls) { +sexp sexp_list_to_vector_op (sexp ctx sexp_api_params(self, n), sexp ls) { sexp x, vec = sexp_make_vector(ctx, sexp_length(ctx, ls), SEXP_VOID); sexp *elts; int i; @@ -857,7 +857,7 @@ off_t sstream_seek (void *vec, off_t offset, int whence) { return pos; } -sexp sexp_make_input_string_port (sexp ctx, sexp str) { +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { FILE *in; sexp res; sexp_gc_var1(cookie); @@ -874,7 +874,7 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) { return res; } -sexp sexp_make_output_string_port (sexp ctx) { +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { FILE *out; sexp res, size; sexp_gc_var1(cookie); @@ -892,7 +892,7 @@ sexp sexp_make_output_string_port (sexp ctx) { return res; } -sexp sexp_get_output_string (sexp ctx, sexp port) { +sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) { sexp cookie = sexp_port_cookie(port); fflush(sexp_port_stream(port)); return sexp_substring(ctx, @@ -903,7 +903,7 @@ sexp sexp_get_output_string (sexp ctx, sexp port) { #else -sexp sexp_make_input_string_port (sexp ctx, sexp str) { +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { FILE *in; sexp res; if (! sexp_stringp(str)) @@ -923,14 +923,14 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) { return res; } -sexp sexp_make_output_string_port (sexp ctx) { +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { 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 sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) { fflush(sexp_port_stream(port)); return sexp_c_string(ctx, sexp_port_buf(port), sexp_port_size(port)); } @@ -996,7 +996,7 @@ sexp sexp_buffered_flush (sexp ctx, sexp p) { } } -sexp sexp_make_input_string_port (sexp ctx, sexp str) { +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { sexp res; if (! sexp_stringp(str)) return sexp_type_exception(ctx, "open-input-string: not a string", str); @@ -1009,7 +1009,7 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) { return res; } -sexp sexp_make_output_string_port (sexp ctx) { +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); if (sexp_exceptionp(res)) return res; sexp_port_buf(res) = (char*) malloc(SEXP_PORT_BUFFER_SIZE); @@ -1019,7 +1019,7 @@ sexp sexp_make_output_string_port (sexp ctx) { return res; } -sexp sexp_get_output_string (sexp ctx, sexp out) { +sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp out) { sexp res; sexp_gc_var2(ls, tmp); sexp_gc_preserve2(ctx, ls, tmp); @@ -1152,6 +1152,11 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { sexp_write_bignum(ctx, obj, out, 10); break; #endif + case SEXP_OPCODE: + sexp_write_string(ctx, "#', out); + break; default: i = sexp_pointer_tag(obj); sexp_write_string(ctx, "#<", out); @@ -1232,14 +1237,14 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { return SEXP_VOID; } -sexp sexp_write (sexp ctx, sexp obj, sexp out) { +sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { if (! sexp_oportp(out)) return sexp_type_exception(ctx, "write: not an output-port", out); else return sexp_write_one(ctx, obj, out); } -sexp sexp_display (sexp ctx, sexp obj, sexp out) { +sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { sexp res=SEXP_VOID; if (! sexp_oportp(out)) res = sexp_type_exception(ctx, "display: not an output-port", out); @@ -1252,14 +1257,14 @@ sexp sexp_display (sexp ctx, sexp obj, sexp out) { return res; } -sexp sexp_flush_output (sexp ctx, sexp out) { +sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), sexp out) { sexp_flush(ctx, out); return SEXP_VOID; } #define INIT_STRING_BUFFER_SIZE 128 -sexp sexp_read_string(sexp ctx, sexp in) { +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; @@ -1294,7 +1299,7 @@ sexp sexp_read_string(sexp ctx, sexp in) { return res; } -sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) { +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; @@ -1325,7 +1330,7 @@ sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) { return res; } -sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp) { +sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) { sexp exponent=SEXP_VOID; double res=0.0, scale=0.1, e=0.0; int c; @@ -1349,7 +1354,7 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp) { return sexp_make_flonum(ctx, res); } -sexp sexp_read_number(sexp ctx, sexp in, int base) { +sexp sexp_read_number (sexp ctx, sexp in, int base) { sexp den; sexp_uint_t res = 0, tmp; int c, digit, negativep = 0; @@ -1653,7 +1658,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { return res; } -sexp sexp_read (sexp ctx, sexp in) { +sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in) { sexp res; if (sexp_iportp(in)) res = sexp_read_raw(ctx, in); @@ -1666,7 +1671,7 @@ sexp sexp_read (sexp ctx, sexp in) { return res; } -sexp sexp_read_from_string(sexp ctx, const char *str, sexp_sint_t len) { +sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) { sexp res; sexp_gc_var2(s, in); sexp_gc_preserve2(ctx, s, in); @@ -1677,7 +1682,7 @@ sexp sexp_read_from_string(sexp ctx, const char *str, sexp_sint_t len) { return res; } -sexp sexp_write_to_string(sexp ctx, sexp obj) { +sexp sexp_write_to_string (sexp ctx, sexp obj) { sexp str; sexp_gc_var1(out); sexp_gc_preserve1(ctx, out); @@ -1689,7 +1694,7 @@ sexp sexp_write_to_string(sexp ctx, sexp obj) { return str; } -void sexp_init(void) { +void sexp_init (void) { #if SEXP_USE_GLOBAL_SYMBOLS int i; #endif From ded9bbf0b6daf42fd458af6619caa357682c4b6b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 24 Mar 2010 20:13:05 +0900 Subject: [PATCH 401/535] updating libraries and genstubs to use new primitives API --- lib/chibi/ast.c | 2 +- lib/chibi/disasm.c | 2 +- lib/chibi/heap-stats.c | 2 +- lib/srfi/27/rand.c | 2 +- lib/srfi/33/bit.c | 2 +- lib/srfi/69/hash.c | 2 +- lib/srfi/95/qsort.c | 2 +- lib/srfi/98/env.c | 2 +- tools/genstubs.scm | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index ecb00a86..9171cb02 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -46,7 +46,7 @@ static sexp sexp_get_opcode_name (sexp ctx, sexp op) { return sexp_intern(ctx, sexp_opcode_name(op), -1); } -sexp sexp_init_library (sexp ctx, sexp env) { +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index 96bcfb47..78977222 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -110,7 +110,7 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { return disasm(ctx, bc, out, 0); } -sexp sexp_init_library (sexp ctx, sexp env) { +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "*current-output-port*"); return SEXP_VOID; } diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c index 581acfc2..0e455ba9 100644 --- a/lib/chibi/heap-stats.c +++ b/lib/chibi/heap-stats.c @@ -121,7 +121,7 @@ static sexp sexp_heap_dump (sexp ctx, sexp depth) { return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); } -sexp sexp_init_library (sexp ctx, sexp env) { +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats); sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE); return SEXP_VOID; diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index e56bdbeb..25aff799 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -166,7 +166,7 @@ static sexp sexp_random_source_pseudo_randomize (sexp ctx, sexp rs, sexp seed) { return SEXP_VOID; } -sexp sexp_init_library (sexp ctx, sexp env) { +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_gc_var2(name, op); sexp_gc_preserve2(ctx, name, op); diff --git a/lib/srfi/33/bit.c b/lib/srfi/33/bit.c index 38aa4652..4fa7f234 100644 --- a/lib/srfi/33/bit.c +++ b/lib/srfi/33/bit.c @@ -290,7 +290,7 @@ static sexp sexp_bit_set_p (sexp ctx, sexp i, sexp x) { } } -sexp sexp_init_library (sexp ctx, sexp env) { +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "bit-and", 2, sexp_bit_and); sexp_define_foreign(ctx, env, "bit-ior", 2, sexp_bit_ior); sexp_define_foreign(ctx, env, "bit-xor", 2, sexp_bit_xor); diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c index b6918454..da28f079 100644 --- a/lib/srfi/69/hash.c +++ b/lib/srfi/69/hash.c @@ -228,7 +228,7 @@ static sexp sexp_hash_table_delete (sexp ctx, sexp ht, sexp obj) { return SEXP_VOID; } -sexp sexp_init_library (sexp ctx, sexp env) { +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign_opt(ctx, env, "string-hash", 2, sexp_string_hash, HASH_BOUND); sexp_define_foreign_opt(ctx, env, "string-ci-hash", 2, sexp_string_ci_hash, HASH_BOUND); diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c index f9f1bd9e..1cfdbe24 100644 --- a/lib/srfi/95/qsort.c +++ b/lib/srfi/95/qsort.c @@ -172,7 +172,7 @@ static sexp sexp_sort_x (sexp ctx, sexp seq, sexp less, sexp key) { return res; } -sexp sexp_init_library (sexp ctx, sexp env) { +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE); return SEXP_VOID; } diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c index 38f8b883..990fec8f 100644 --- a/lib/srfi/98/env.c +++ b/lib/srfi/98/env.c @@ -40,7 +40,7 @@ sexp sexp_get_environment_variables (sexp ctx) { return res; } -sexp sexp_init_library (sexp ctx, sexp env) { +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable); sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables); return SEXP_VOID; diff --git a/tools/genstubs.scm b/tools/genstubs.scm index cdd8d235..b38b1704 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -1212,7 +1212,7 @@ (write-utilities) (for-each write-func *funcs*) (for-each write-type-funcs *types*) - (cat "sexp sexp_init_library (sexp ctx, sexp env) {\n" + (cat "sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {\n" " sexp_gc_var2(name, tmp);\n" " sexp_gc_preserve2(ctx, name, tmp);\n") (for-each write-const *consts*) From 9a3c863630fdab1c0f4837ebcc9de28c6a0c5ea3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 24 Mar 2010 20:42:49 +0900 Subject: [PATCH 402/535] updating some individual opcodes to new API --- include/chibi/sexp.h | 2 +- lib/srfi/27/rand.c | 46 ++++++++++++++++++++++---------------------- lib/srfi/33/bit.c | 22 ++++++++++----------- lib/srfi/69/hash.c | 16 +++++++-------- lib/srfi/95/qsort.c | 3 ++- sexp.c | 6 +++--- 6 files changed, 48 insertions(+), 47 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 6737e2a8..fb8e33b1 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -134,7 +134,6 @@ typedef struct sexp_struct *sexp; #endif /* procedure types */ -typedef sexp (*sexp_proc0) (void); typedef sexp (*sexp_proc1) (sexp sexp_api_params(self, n)); typedef sexp (*sexp_proc2) (sexp sexp_api_params(self, n), sexp); typedef sexp (*sexp_proc3) (sexp sexp_api_params(self, n), sexp, sexp); @@ -921,6 +920,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) #define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx sexp_api_pass(NULL, 1), out) #define sexp_expt(ctx, a, b) sexp_expt_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_register_simple_type(ctx, a, b) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j) sexp_register_type_op(ctx sexp_api_pass(NULL, 10), a, b, c, d, e, f, g, h, i, j) #define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index 25aff799..210b9e42 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -37,17 +37,17 @@ typedef struct random_data sexp_random_t; static sexp_uint_t rs_type_id; static sexp default_random_source; -static sexp sexp_rs_random_integer (sexp ctx, sexp rs, sexp bound) { +static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, sexp bound) { sexp res; - int32_t n; + int32_t m; #if SEXP_USE_BIGNUMS int32_t hi, mod, len, i, *data; #endif if (! sexp_random_source_p(rs)) res = sexp_type_exception(ctx, "not a random-source", rs); if (sexp_fixnump(bound)) { - sexp_call_random(rs, n); - res = sexp_make_fixnum(n % sexp_unbox_fixnum(bound)); + sexp_call_random(rs, m); + res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound)); #if SEXP_USE_BIGNUMS } else if (sexp_bignump(bound)) { hi = sexp_bignum_hi(bound); @@ -55,13 +55,13 @@ static sexp sexp_rs_random_integer (sexp ctx, sexp rs, sexp bound) { res = sexp_make_bignum(ctx, hi); data = (int32_t*) sexp_bignum_data(res); for (i=0; i> (sizeof(i) - 1) * CHAR_BIT); } -static sexp sexp_bit_count (sexp ctx, sexp x) { +static sexp sexp_bit_count (sexp ctx sexp_api_params(self, n), sexp x) { sexp res; sexp_sint_t i; #if SEXP_USE_BIGNUMS @@ -250,7 +250,7 @@ static sexp_uint_t integer_log2 (sexp_uint_t x) { return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; } -static sexp sexp_integer_length (sexp ctx, sexp x) { +static sexp sexp_integer_length (sexp ctx sexp_api_params(self, n), sexp x) { sexp_sint_t tmp; #if SEXP_USE_BIGNUMS sexp_sint_t hi; @@ -269,7 +269,7 @@ static sexp sexp_integer_length (sexp ctx, sexp x) { } } -static sexp sexp_bit_set_p (sexp ctx, sexp i, sexp x) { +static sexp sexp_bit_set_p (sexp ctx sexp_api_params(self, n), sexp i, sexp x) { #if SEXP_USE_BIGNUMS sexp_uint_t pos; #endif diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c index da28f079..ec0b1d30 100644 --- a/lib/srfi/69/hash.c +++ b/lib/srfi/69/hash.c @@ -23,7 +23,7 @@ static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { return acc % bound; } -static sexp sexp_string_hash (sexp ctx, sexp str, sexp bound) { +static sexp sexp_string_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { if (! sexp_stringp(str)) return sexp_type_exception(ctx, "string-hash: not a string", str); else if (! sexp_integerp(bound)) @@ -38,7 +38,7 @@ static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { return acc % bound; } -static sexp sexp_string_ci_hash (sexp ctx, sexp str, sexp bound) { +static sexp sexp_string_ci_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { if (! sexp_stringp(str)) return sexp_type_exception(ctx, "string-ci-hash: not a string", str); else if (! sexp_integerp(bound)) @@ -89,13 +89,13 @@ static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t return (bound ? acc % bound : acc); } -static sexp sexp_hash (sexp ctx, sexp obj, sexp bound) { +static sexp sexp_hash (sexp ctx sexp_api_params(self, n), sexp obj, sexp bound) { if (! sexp_exact_integerp(bound)) return sexp_type_exception(ctx, "hash: not an integer", bound); return sexp_make_fixnum(hash_one(ctx, obj, sexp_unbox_fixnum(bound), HASH_DEPTH)); } -static sexp sexp_hash_by_identity (sexp ctx, sexp obj, sexp bound) { +static sexp sexp_hash_by_identity (sexp ctx sexp_api_params(self, n), sexp obj, sexp bound) { if (! sexp_exact_integerp(bound)) return sexp_type_exception(ctx, "hash-by-identity: not an integer", bound); return sexp_make_fixnum((sexp_uint_t)obj % sexp_unbox_fixnum(bound)); @@ -106,9 +106,9 @@ static sexp sexp_get_bucket (sexp ctx, sexp buckets, sexp hash_fn, sexp obj) { sexp res; sexp_uint_t len = sexp_vector_length(buckets); if (hash_fn == sexp_make_fixnum(1)) - res = sexp_hash_by_identity(ctx, obj, sexp_make_fixnum(len)); + res = sexp_hash_by_identity(ctx sexp_api_pass(NULL, 2), obj, sexp_make_fixnum(len)); else if (hash_fn == sexp_make_fixnum(2)) - res = sexp_hash(ctx, obj, sexp_make_fixnum(len)); + res = sexp_hash(ctx sexp_api_pass(NULL, 2), obj, sexp_make_fixnum(len)); else { sexp_gc_preserve1(ctx, args); args = sexp_list2(ctx, obj, sexp_make_fixnum(len)); @@ -180,7 +180,7 @@ static void sexp_regrow_hash_table (sexp ctx, sexp ht, sexp oldbuckets, sexp has sexp_gc_release1(ctx); } -static sexp sexp_hash_table_cell (sexp ctx, sexp ht, sexp obj, sexp createp) { +static sexp sexp_hash_table_cell (sexp ctx sexp_api_params(self, n), sexp ht, sexp obj, sexp createp) { sexp buckets, eq_fn, hash_fn, i; sexp_uint_t size; sexp_gc_var1(res); @@ -209,7 +209,7 @@ static sexp sexp_hash_table_cell (sexp ctx, sexp ht, sexp obj, sexp createp) { return res; } -static sexp sexp_hash_table_delete (sexp ctx, sexp ht, sexp obj) { +static sexp sexp_hash_table_delete (sexp ctx sexp_api_params(self, n), sexp ht, sexp obj) { sexp buckets=sexp_hash_table_buckets(ht), eq_fn=sexp_hash_table_eq_fn(ht), hash_fn=sexp_hash_table_hash_fn(ht), i, p, res; i = sexp_get_bucket(ctx, buckets, hash_fn, obj); diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c index 1cfdbe24..970f36b4 100644 --- a/lib/srfi/95/qsort.c +++ b/lib/srfi/95/qsort.c @@ -134,7 +134,8 @@ static sexp sexp_qsort_less (sexp ctx, sexp *vec, return res; } -static sexp sexp_sort_x (sexp ctx, sexp seq, sexp less, sexp key) { +static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, + sexp less, sexp key) { sexp_sint_t len; sexp res, *data; sexp_gc_var1(vec); diff --git a/sexp.c b/sexp.c index f4f3d46c..1f7c3468 100644 --- a/sexp.c +++ b/sexp.c @@ -122,9 +122,9 @@ static sexp_uint_t sexp_type_array_size = SEXP_NUM_CORE_TYPES; #define SEXP_INIT_NUM_TYPES (SEXP_NUM_CORE_TYPES*2) #endif -sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp felb, sexp flb, - sexp flo, sexp fls, sexp sb, sexp so, sexp sc, - sexp_proc2 f) { +sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, + sexp fb, sexp felb, sexp flb, sexp flo, sexp fls, + sexp sb, sexp so, sexp sc, sexp_proc2 f) { #if SEXP_USE_GLOBAL_TYPES struct sexp_struct *new, *tmp; #else From 061dacbf8e14c38631704ff89f0f6d57bb7dbac4 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 25 Mar 2010 17:34:52 +0900 Subject: [PATCH 403/535] adding sexp_version and sexp_release to plan9 mkfile --- mkfile | 2 ++ 1 file changed, 2 insertions(+) diff --git a/mkfile b/mkfile index fdce3e9f..a193e9b6 100644 --- a/mkfile +++ b/mkfile @@ -15,6 +15,8 @@ HFILES=include/chibi/sexp.h include/chibi/eval.h include/chibi/features.h includ include/chibi/install.h: mkfile echo '#define sexp_default_module_dir "'$MODDIR'"' > include/chibi/install.h echo '#define sexp_platform "plan9"' >> include/chibi/install.h + echo '#define sexp_version "'`{cat VERSION}'"' >> include/chibi/install.h + echo '#define sexp_release_name "'`{cat RELEASE}'"' >> include/chibi/install.h install:V: $BIN/$TARG test -d $MODDIR || mkdir -p $MODDIR From 74f7c5737c0813772f466f60545415b2a45356cc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 25 Mar 2010 17:40:02 +0900 Subject: [PATCH 404/535] updating sexp_intern calls --- opt/plan9.c | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/opt/plan9.c b/opt/plan9.c index b103912a..d51c9f67 100644 --- a/opt/plan9.c +++ b/opt/plan9.c @@ -143,37 +143,37 @@ void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) { = s->create = s->remove = s->read = s->write = s->stat = s->wstat = s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE; for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) { - if (sexp_car(ls) == sexp_intern(ctx, "auth:")) { + if (sexp_car(ls) == sexp_intern(ctx, "auth:", -1)) { s->auth = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "attach:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "attach:", -1)) { s->attach = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "walk:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "walk:", -1)) { s->walk = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:", -1)) { s->walk1 = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "clone:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "clone:", -1)) { s->clone = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "open:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "open:", -1)) { s->open = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "create:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "create:", -1)) { s->create = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "remove:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "remove:", -1)) { s->remove = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "read:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "read:", -1)) { s->read = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "write:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "write:", -1)) { s->write = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "stat:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "stat:", -1)) { s->stat = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:", -1)) { s->wstat = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "flush:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "flush:", -1)) { s->flush = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:", -1)) { s->destroyfid = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:", -1)) { s->destroyreq = sexp_cadr(ls); - } else if (sexp_car(ls) == sexp_intern(ctx, "end:")) { + } else if (sexp_car(ls) == sexp_intern(ctx, "end:", -1)) { s->end = sexp_cadr(ls); } } From a7794e81894adffc03c3365d57f3670f7a106bd2 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 30 Mar 2010 22:03:30 +0900 Subject: [PATCH 405/535] only conditionally defining _GNU_SOURCE to avoid warning (issue 48) --- include/chibi/features.h | 2 ++ 1 file changed, 2 insertions(+) diff --git a/include/chibi/features.h b/include/chibi/features.h index 8c933bcc..fdb6fe98 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -197,8 +197,10 @@ #define SEXP_BSD 1 #else #define SEXP_BSD 0 +#ifndef _GNU_SOURCE #define _GNU_SOURCE #endif +#endif #ifndef SEXP_USE_NO_FEATURES #define SEXP_USE_NO_FEATURES 0 From 71821fc95adae31014341e62742c4638d67e6539 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 30 Mar 2010 22:06:16 +0900 Subject: [PATCH 406/535] convertin plan9 functions to new API --- opt/plan9.c | 58 ++++++++++++++++++++++++++--------------------------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/opt/plan9.c b/opt/plan9.c index d51c9f67..ca25afba 100644 --- a/opt/plan9.c +++ b/opt/plan9.c @@ -1,17 +1,17 @@ -/* plan9.c -- extended Plan 9 system utils */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* plan9.c -- extended Plan 9 system utils */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ -sexp sexp_rand (sexp ctx) { +sexp sexp_rand (sexp ctx sexp_api_params(self, n)) { return sexp_make_fixnum(rand()); } -sexp sexp_srand (sexp ctx, sexp seed) { +sexp sexp_srand (sexp ctx sexp_api_params(self, n), sexp seed) { srand(sexp_unbox_fixnum(seed)); return SEXP_VOID; } -sexp sexp_file_exists_p (sexp ctx, sexp path) { +sexp sexp_file_exists_p (sexp ctx sexp_api_params(self, n), sexp path) { int res; uchar statbuf[STATMAX]; if (! sexp_stringp(path)) @@ -20,7 +20,7 @@ sexp sexp_file_exists_p (sexp ctx, sexp path) { return (res < 0) ? SEXP_FALSE : SEXP_TRUE; } -sexp sexp_fdopen (sexp ctx, sexp fd, sexp mode) { +sexp sexp_fdopen (sexp ctx sexp_api_params(self, n), sexp fd, sexp mode) { FILE *f; if (! sexp_integerp(fd)) return sexp_type_exception(ctx, "fdopen: not an integer", fd); @@ -36,17 +36,17 @@ sexp sexp_fdopen (sexp ctx, sexp fd, sexp mode) { return sexp_make_input_port(ctx, f, SEXP_FALSE); } -sexp sexp_fileno (sexp ctx, sexp port) { +sexp sexp_fileno (sexp ctx sexp_api_params(self, n), sexp port) { if (! sexp_portp(port)) return sexp_type_exception(ctx, "fileno: not a port", port); return sexp_make_fixnum(fileno(sexp_port_stream(port))); } -sexp sexp_fork (sexp ctx) { +sexp sexp_fork (sexp ctx sexp_api_params(self, n)) { return sexp_make_fixnum(fork()); } -sexp sexp_exec (sexp ctx, sexp name, sexp args) { +sexp sexp_exec (sexp ctx sexp_api_params(self, n), sexp name, sexp args) { int i, len = sexp_unbox_fixnum(sexp_length(ctx, args)); char **argv = malloc((len+1)*sizeof(char*)); for (i=0; iifcall.offset); } -sexp sexp_9p_req_count (sexp ctx, sexp req) { +sexp sexp_9p_req_count (sexp ctx sexp_api_params(self, n), sexp req) { return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count); } #if 0 -sexp sexp_9p_req_path (sexp ctx, sexp req) { +sexp sexp_9p_req_path (sexp ctx sexp_api_params(self, n), sexp req) { return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1); } #endif -sexp sexp_9p_req_fid (sexp ctx, sexp req) { +sexp sexp_9p_req_fid (sexp ctx sexp_api_params(self, n), sexp req) { return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0); } -sexp sexp_9p_req_newfid (sexp ctx, sexp req) { +sexp sexp_9p_req_newfid (sexp ctx sexp_api_params(self, n), sexp req) { return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0); } -sexp sexp_9p_respond (sexp ctx, sexp req, sexp err) { +sexp sexp_9p_respond (sexp ctx sexp_api_params(self, n), sexp req, sexp err) { char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil; respond(sexp_cpointer_value(req), cerr); return SEXP_VOID; } -sexp sexp_9p_responderror (sexp ctx, sexp req) { +sexp sexp_9p_responderror (sexp ctx sexp_api_params(self, n), sexp req) { responderror(sexp_cpointer_value(req)); return SEXP_VOID; } From f1040180f43c946200cede9a50847c6e5b0eb251 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 30 Mar 2010 22:07:37 +0900 Subject: [PATCH 407/535] moving ctype.h and stdio.h includes after u.h include for plan9 (issue 47) --- include/chibi/sexp.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index fb8e33b1..53e771e4 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -14,9 +14,6 @@ extern "C" { #include "chibi/features.h" #include "chibi/install.h" -#include -#include - #if SEXP_USE_DL #ifndef __MINGW32__ #include @@ -40,6 +37,9 @@ typedef unsigned long size_t; #include #endif +#include +#include + /* tagging system * bits end in 00: pointer * 01: fixnum From 9f239534b489e41d15e2b6ee80af231cf5eaadac Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 3 Apr 2010 11:31:11 +0900 Subject: [PATCH 408/535] rewriting string->number in C to fix the error catching problem (should return #f) this calls sexp_read_number directly passing the base, so the C implementation is shorter than the Scheme implementation, much faster, and as an opcode generates smaller bytecode per use. --- include/chibi/sexp.h | 7 ++++++- lib/init.scm | 18 ------------------ opcodes.c | 1 + sexp.c | 17 +++++++++++++++++ 4 files changed, 24 insertions(+), 19 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 53e771e4..ace6463e 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -483,6 +483,7 @@ sexp sexp_make_flonum(sexp ctx, double f); #define SEXP_SEVEN sexp_make_fixnum(7) #define SEXP_EIGHT sexp_make_fixnum(8) #define SEXP_NINE sexp_make_fixnum(9) +#define SEXP_TEN sexp_make_fixnum(10) #define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) @@ -510,8 +511,10 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #if SEXP_USE_FLONUMS #define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) +#define sexp_numberp(x) (sexp_exact_integerp(x) || sexp_flonump(x)) #else #define sexp_fixnum_to_flonum(ctx, x) (x) +#define sexp_numberp(x) sexp_exact_integerp(x) #endif #if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS @@ -843,6 +846,7 @@ SEXP_API sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, se SEXP_API sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep); SEXP_API sexp sexp_intern (sexp ctx, const char *str, sexp_sint_t len); SEXP_API sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b); SEXP_API sexp sexp_make_vector (sexp ctx, sexp len, sexp dflt); SEXP_API sexp sexp_list_to_vector_op (sexp ctx sexp_api_params(self, n), sexp ls); SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); @@ -887,7 +891,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) #define sexp_register_c_type(ctx, name, finalizer) \ sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ - SEXP_ZERO, SEXP_ZERO, finalizer) + SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer) #endif #define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) @@ -909,6 +913,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) #define sexp_append2(ctx, a, b) sexp_append2_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_string_to_number(ctx, s, b) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), s, b) #define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), l, c) #define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx sexp_api_pass(NULL, 3), a, b, c) #define sexp_substring(ctx, a, b, c) sexp_substring_op(ctx sexp_api_pass(NULL, 3), a, b, c) diff --git a/lib/init.scm b/lib/init.scm index b0bea0a7..b7f40fe0 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -498,24 +498,6 @@ "0" (list->string (if (negative? num) (cons #\- res) res))))))) -(define (string->number str . o) - (let ((res - (cond - ((= 0 (string-length str)) - #f) - ((if (null? o) - #t - (if (eq? 10 (car o)) #t (eq? #\# (string-ref str 0)))) - (call-with-input-string str (lambda (in) (read in)))) - (else - (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) diff --git a/opcodes.c b/opcodes.c index 86ab0687..4f11e7e0 100644 --- a/opcodes.c +++ b/opcodes.c @@ -101,6 +101,7 @@ _FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy_op), _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception_op), _FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_op), _FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string_op), +_FN2OPT(SEXP_FIXNUM, SEXP_FIXNUM, "string->number", SEXP_TEN, sexp_string_to_number_op), _FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp_op), _FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring_op), _FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol_op), diff --git a/sexp.c b/sexp.c index 1f7c3468..c2981ed4 100644 --- a/sexp.c +++ b/sexp.c @@ -1682,6 +1682,23 @@ sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) { return res; } +sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b) { + int base; + sexp_gc_var1(in); + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "string->number: not a string", str); + else if (! sexp_numberp(b)) + return sexp_type_exception(ctx, "string->number: not a number", b); + if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36)) + return sexp_type_exception(ctx, "string->number: bad base", b); + sexp_gc_preserve1(ctx, in); + in = sexp_make_input_string_port(ctx, str); + in = ((sexp_string_data(str)[0] == '#') ? + sexp_read(ctx, in) : sexp_read_number(ctx, in, base)); + sexp_gc_release1(ctx); + return sexp_numberp(in) ? in : SEXP_FALSE; +} + sexp sexp_write_to_string (sexp ctx, sexp obj) { sexp str; sexp_gc_var1(out); From 8357b3afaa57f4770c555877758535ebebab4d0d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 3 Apr 2010 11:42:33 +0900 Subject: [PATCH 409/535] forgot to add the new self, n parameters in the new stubber --- tools/genstubs.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index b38b1704..daf8a684 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -982,7 +982,8 @@ (define (write-func func) (cat "static sexp " (func-stub-name func) - " (sexp ctx" (write-parameters (func-scheme-args func)) ") {\n") + " (sexp ctx sexp_api_params(self, n)" + (write-parameters (func-scheme-args func)) ") {\n") (write-locals func) (write-validators (func-scheme-args func)) (write-temporaries func) From d5ddfe6a929a793ff8eef0a9477dc94839aff3dc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 4 Apr 2010 10:10:17 +0900 Subject: [PATCH 410/535] changing type_exception to use self and a type_id this simplifies and reduces the number of different static strings. specific error messages are still available with sexp_xtype_exception. --- eval.c | 81 ++++++++++++++++---------------- gc.c | 6 +-- include/chibi/eval.h | 2 +- include/chibi/sexp.h | 6 ++- lib/chibi/ast.c | 15 +++--- lib/chibi/disasm.c | 18 ++++---- lib/chibi/heap-stats.c | 12 ++--- lib/chibi/io/io.stub | 4 +- lib/chibi/io/port.c | 28 ++++++----- lib/chibi/process.stub | 2 +- lib/chibi/signal.c | 8 ++-- lib/srfi/27/rand.c | 24 +++++----- lib/srfi/33/bit.c | 36 +++++++-------- lib/srfi/69/hash.c | 26 +++++------ lib/srfi/95/qsort.c | 12 ++--- lib/srfi/98/env.c | 12 ++--- opt/bignum.c | 46 +++++++++---------- sexp.c | 102 +++++++++++++++++++++++++++-------------- tools/genstubs.scm | 58 ++++++++++------------- 19 files changed, 265 insertions(+), 233 deletions(-) diff --git a/eval.c b/eval.c index 693ec8f5..af6fb097 100644 --- a/eval.c +++ b/eval.c @@ -93,12 +93,12 @@ sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { sexp cell = sexp_assq(ctx, key, sexp_env_bindings(env)), res=SEXP_VOID; sexp_gc_var1(tmp); if (sexp_immutablep(env)) { - res = sexp_type_exception(ctx, "immutable binding", key); + res = sexp_user_exception(ctx, NULL, "immutable binding", key); } else { sexp_gc_preserve1(ctx, tmp); if (sexp_truep(cell)) { if (sexp_immutablep(cell)) - res = sexp_type_exception(ctx, "immutable binding", key); + res = sexp_user_exception(ctx, NULL, "immutable binding", key); else sexp_cdr(cell) = value; } else { @@ -2029,24 +2029,23 @@ static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) if (sexp_exceptionp(exn)) return sexp_exception_kind(exn); else - return sexp_type_exception(ctx, "not an exception", exn); + return sexp_type_exception(ctx, self, SEXP_EXCEPTION, exn); } static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) { FILE *in; if (! sexp_stringp(path)) - return sexp_type_exception(ctx, "not a string", path); + return sexp_type_exception(ctx, self, SEXP_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, self, "couldn't open input file", path); return sexp_make_input_port(ctx, in, path); } static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) { FILE *out; if (! sexp_stringp(path)) - return sexp_type_exception(ctx, "not a string", path); + return sexp_type_exception(ctx, self, SEXP_STRING, path); out = fopen(sexp_string_data(path), "w"); if (! out) return @@ -2056,7 +2055,7 @@ static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp pa static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) { if (! sexp_portp(port)) - return sexp_type_exception(ctx, "not a port", port); + return sexp_type_exception(ctx, self, SEXP_OPORT, port); if (! sexp_port_openp(port)) return sexp_user_exception(ctx, SEXP_FALSE, "port already closed", port); return sexp_finalize_port(ctx sexp_api_pass(self, n), port); @@ -2110,9 +2109,9 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { sexp tmp, out=SEXP_FALSE; sexp_gc_var4(ctx2, x, in, res); if (! sexp_stringp(source)) - return sexp_type_exception(ctx, "not a string", source); + return sexp_type_exception(ctx, self, SEXP_STRING, source); if (! sexp_envp(env)) - return sexp_type_exception(ctx, "not an environment", env); + return sexp_type_exception(ctx, self, SEXP_ENV, env); #if SEXP_USE_DL suffix = sexp_string_data(source) + sexp_string_length(source) - strlen(sexp_so_extension); @@ -2165,7 +2164,7 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { #endif #define define_math_op(name, cname) \ - static sexp name (sexp ctx, sexp z) { \ + static sexp name (sexp ctx sexp_api_params(self, n), sexp z) { \ double d; \ if (sexp_flonump(z)) \ d = sexp_flonum_value(z); \ @@ -2173,7 +2172,7 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { d = (double)sexp_unbox_fixnum(z); \ maybe_convert_bignum(z) \ else \ - return sexp_type_exception(ctx, "not a number", z); \ + return sexp_type_exception(ctx, self, SEXP_FIXNUM, z); \ return sexp_make_flonum(ctx, cname(d)); \ } @@ -2190,7 +2189,7 @@ define_math_op(sexp_trunc, trunc) define_math_op(sexp_floor, floor) define_math_op(sexp_ceiling, ceil) -static sexp sexp_sqrt (sexp ctx, sexp z) { +static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) { double d, r; if (sexp_flonump(z)) d = sexp_flonum_value(z); @@ -2198,7 +2197,7 @@ static sexp sexp_sqrt (sexp ctx, sexp z) { d = (double)sexp_unbox_fixnum(z); maybe_convert_bignum(z) /* XXXX add bignum sqrt */ else - return sexp_type_exception(ctx, "not a number", z); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, z); r = sqrt(d); if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) return sexp_make_fixnum(round(r)); @@ -2232,7 +2231,7 @@ static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { x1 = sexp_flonum_value(x); #endif else - return sexp_type_exception(ctx, "expt: not a number", x); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); if (sexp_fixnump(e)) e1 = sexp_unbox_fixnum(e); #if SEXP_USE_FLONUMS @@ -2240,7 +2239,7 @@ static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { e1 = sexp_flonum_value(e); #endif else - return sexp_type_exception(ctx, "expt: not a number", e); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, e); f = pow(x1, e1); if ((f > SEXP_MAX_FIXNUM) || (f < SEXP_MIN_FIXNUM) #if SEXP_USE_FLONUMS @@ -2268,9 +2267,9 @@ static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), 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); + return sexp_type_exception(ctx, self, SEXP_STRING, str1); if (! sexp_stringp(str2)) - return sexp_type_exception(ctx, "not a string", str2); + return sexp_type_exception(ctx, self, SEXP_STRING, str2); len1 = sexp_string_length(str1); len2 = sexp_string_length(str2); len = ((len1= SEXP_OPC_NUM_OP_CLASSES)) - res = sexp_type_exception(ctx, "make-opcode: bad opcode class", op_class); + res = sexp_user_exception(ctx, self, "make-opcode: bad opcode class", op_class); else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) - res = sexp_type_exception(ctx, "make-opcode: bad opcode", code); + res = sexp_user_exception(ctx, self, "make-opcode: bad opcode", code); else if (! sexp_fixnump(num_args)) - res = sexp_type_exception(ctx, "make-opcode: bad num_args", num_args); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, num_args); else if (! sexp_fixnump(flags)) - res = sexp_type_exception(ctx, "make-opcode: bad flags", flags); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, flags); else { res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); @@ -2359,7 +2358,7 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data) { sexp res; if (num_args > 6) { - res = sexp_type_exception(ctx, "make-foreign: exceeded foreign arg limit", + res = sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", sexp_make_fixnum(num_args)); } else { res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); @@ -2405,8 +2404,8 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { if (! sexp_fixnump(type)) - return sexp_type_exception(ctx, "make-type-predicate: bad type", type); - return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); } @@ -2414,9 +2413,9 @@ sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { sexp_uint_t type_size; if (! sexp_fixnump(type)) - return sexp_type_exception(ctx, "make-constructor: bad type", type); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); - return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, sexp_make_fixnum(type_size), NULL); @@ -2424,22 +2423,22 @@ sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sex sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) - return sexp_type_exception(ctx, "make-getter: bad type", type); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) - return sexp_type_exception(ctx, "make-getter: bad index", index); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); return - sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_GETTER), + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER), sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO, type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); } sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) - return sexp_type_exception(ctx, "make-setter: bad type", type); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) - return sexp_type_exception(ctx, "make-setter: bad index", index); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); return - sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_SETTER), + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER), sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO, type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); } @@ -2553,15 +2552,15 @@ sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { #if SEXP_USE_MODULES static sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file) { if (! sexp_stringp(file)) - return sexp_type_exception(ctx, "not a string", file); + return sexp_type_exception(ctx, self, SEXP_STRING, file); else return sexp_find_module_file(ctx, sexp_string_data(file)); } sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env) { if (! sexp_stringp(file)) - return sexp_type_exception(ctx, "not a string", file); + return sexp_type_exception(ctx, self, SEXP_STRING, file); else if (! sexp_envp(env)) - return sexp_type_exception(ctx, "not an environment", env); + return sexp_type_exception(ctx, self, SEXP_ENV, env); return sexp_load_module_file(ctx, sexp_string_data(file), env); } #endif @@ -2569,7 +2568,7 @@ sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sex sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp) { sexp ls; if (! sexp_stringp(dir)) - return sexp_type_exception(ctx, "not a string", dir); + return sexp_type_exception(ctx, self, SEXP_STRING, dir); if (sexp_truep(appendp)) { if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) @@ -2709,7 +2708,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { proc = make_opcode_procedure(ctx, proc, len); if (! sexp_procedurep(proc)) { res = sexp_exceptionp(proc) ? proc : - sexp_type_exception(ctx, "apply: not a procedure", proc); + sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); } else { offset = top + len; for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) @@ -2753,7 +2752,7 @@ sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { if (! env) env = sexp_context_env(ctx); else if (! sexp_envp(env)) - return sexp_type_exception(ctx, "eval: not an env", env); + return sexp_type_exception(ctx, self, SEXP_ENV, env); sexp_gc_preserve2(ctx, res, err_handler); top = sexp_context_top(ctx); err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); diff --git a/gc.c b/gc.c index 399dd6b8..d0a2dc94 100644 --- a/gc.c +++ b/gc.c @@ -234,14 +234,14 @@ sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { /* validate input, creating a new heap if needed */ if (from->next) { - return sexp_type_exception(ctx, "can't copy a non-contiguous heap", ctx); + return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx); } else if (! dst || sexp_not(dst)) { to = sexp_make_heap(from->size); dst = (sexp) ((char*)ctx + ((char*)to - (char*)from)); } else if (! sexp_contextp(dst)) { - return sexp_type_exception(ctx, "destination not a context", dst); + return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst); } else if (sexp_context_heap(dst)->size < from->size) { - return sexp_type_exception(ctx, "destination context too small", dst); + return sexp_user_exception(ctx, NULL, "destination context too small", dst); } else { to = sexp_context_heap(dst); } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 07dd9ac8..1994bc74 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -151,7 +151,7 @@ SEXP_API sexp sexp_env_cell (sexp env, sexp sym); SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); -SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); +SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); SEXP_API sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args, sexp bc, sexp vars); SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index ace6463e..b110a973 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -74,6 +74,7 @@ enum sexp_types { SEXP_OBJECT, SEXP_TYPE, SEXP_FIXNUM, + SEXP_NUMBER, SEXP_CHAR, SEXP_BOOLEAN, SEXP_PAIR, @@ -868,11 +869,14 @@ SEXP_API sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n) SEXP_API sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port); SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x); -SEXP_API sexp sexp_type_exception (sexp ctx, const char *message, sexp x); +SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x); +SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x); SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); SEXP_API sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out); SEXP_API void sexp_init(void); +#define sexp_assert_type(ctx, pred, type_id, obj) if (! pred(obj)) return sexp_type_exception(ctx, self, type_id, obj) + #define SEXP_COPY_DEFAULT SEXP_ZERO #define SEXP_COPY_FREEP SEXP_ONE diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 9171cb02..2b740f41 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -1,11 +1,10 @@ -/* ast.c -- interface to the Abstract Syntax Tree */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include -static void sexp_define_type_predicate (sexp ctx, sexp env, - char *cname, sexp_uint_t type) { +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { sexp_gc_var2(name, op); sexp_gc_preserve2(ctx, name, op); name = sexp_c_string(ctx, cname, -1); @@ -28,7 +27,7 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, sexp_gc_release2(ctx); } -static sexp sexp_get_env_cell (sexp ctx, sexp env, sexp id) { +static sexp sexp_get_env_cell (sexp ctx sexp_api_params(self, n), sexp env, sexp id) { sexp cell = sexp_env_cell(env, id); while ((! cell) && sexp_synclop(id)) { env = sexp_synclo_env(id); @@ -37,9 +36,9 @@ static sexp sexp_get_env_cell (sexp ctx, sexp env, sexp id) { return cell ? cell : SEXP_FALSE; } -static sexp sexp_get_opcode_name (sexp ctx, sexp op) { +static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { if (! sexp_opcodep(op)) - return sexp_type_exception(ctx, "not an opcode", op); + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); else if (! sexp_opcode_name(op)) return SEXP_FALSE; else diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index 78977222..57dcf94d 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -1,6 +1,6 @@ -/* disasm.c -- optional debugging utilities */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include "chibi/eval.h" @@ -23,7 +23,7 @@ static const char* reverse_opcode_names[] = "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", }; -static sexp disasm (sexp ctx, sexp bc, sexp out, int depth) { +static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { sexp tmp; unsigned char *ip, opcode, i; @@ -33,10 +33,10 @@ static sexp disasm (sexp ctx, sexp bc, sexp out, int depth) { sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); return SEXP_VOID; } else if (! sexp_bytecodep(bc)) { - return sexp_type_exception(ctx, "not a procedure", bc); + return sexp_type_exception(ctx, self, SEXP_BYTECODE, bc); } if (! sexp_oportp(out)) { - return sexp_type_exception(ctx, "not an output-port", out); + return sexp_type_exception(ctx, self, SEXP_OPORT, out); } for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) @@ -100,14 +100,14 @@ static sexp disasm (sexp ctx, sexp bc, sexp out, int depth) { sexp_write_char(ctx, '\n', out); if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) - disasm(ctx, tmp, out, depth+1); + disasm(ctx, self, tmp, out, depth+1); if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) goto loop; return SEXP_VOID; } -static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { - return disasm(ctx, bc, out, 0); +static sexp sexp_disasm (sexp ctx sexp_api_params(self, n), sexp bc, sexp out) { + return disasm(ctx, self, bc, out, 0); } sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c index 0e455ba9..976b5b27 100644 --- a/lib/chibi/heap-stats.c +++ b/lib/chibi/heap-stats.c @@ -1,6 +1,6 @@ -/* heap-stats.c -- count or dump heap objects */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include @@ -111,13 +111,13 @@ static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { return res; } -static sexp sexp_heap_stats (sexp ctx) { +static sexp sexp_heap_stats (sexp ctx sexp_api_params(self, n)) { return sexp_heap_walk(ctx, 0, 0); } -static sexp sexp_heap_dump (sexp ctx, sexp depth) { +static sexp sexp_heap_dump (sexp ctx sexp_api_params(self, n), sexp depth) { if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) - return sexp_type_exception(ctx, "bad heap-dump depth", depth); + return sexp_xtype_exception(ctx, self, "bad heap-dump depth", depth); return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); } diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub index 208d0a18..07450dc0 100644 --- a/lib/chibi/io/io.stub +++ b/lib/chibi/io/io.stub @@ -21,7 +21,7 @@ (c-include "port.c") (define-c sexp (%make-custom-input-port "sexp_make_custom_input_port") - ((value ctx sexp) sexp sexp sexp)) + ((value ctx sexp) (value self sexp) sexp sexp sexp)) (define-c sexp (%make-custom-output-port "sexp_make_custom_output_port") - ((value ctx sexp) sexp sexp sexp)) + ((value ctx sexp) (value self sexp) sexp sexp sexp)) diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c index 770c94dd..947f3400 100644 --- a/lib/chibi/io/port.c +++ b/lib/chibi/io/port.c @@ -131,19 +131,20 @@ static cookie_io_functions_t sexp_cookie_no_seek = { #if SEXP_USE_STRING_STREAMS -static sexp sexp_make_custom_port (sexp ctx, char *mode, sexp read, sexp write, +static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode, + sexp read, sexp write, sexp seek, sexp close) { FILE *in; sexp res; sexp_gc_var1(vec); if (sexp_truep(read) && ! sexp_procedurep(read)) - return sexp_type_exception(ctx, "make-custom-port: read not a procedure", read); + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read); if (sexp_truep(write) && ! sexp_procedurep(write)) - return sexp_type_exception(ctx, "make-custom-port: write not a procedure", write); + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write); if (sexp_truep(seek) && ! sexp_procedurep(seek)) - return sexp_type_exception(ctx, "make-custom-port: seek not a procedure", seek); + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek); if (sexp_truep(close) && ! sexp_procedurep(close)) - return sexp_type_exception(ctx, "make-custom-port: close not a procedure", close); + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close); sexp_gc_preserve1(ctx, vec); vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID); sexp_cookie_ctx(vec) = ctx; @@ -163,7 +164,7 @@ static sexp sexp_make_custom_port (sexp ctx, char *mode, sexp read, sexp write, in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek)); #endif if (! in) { - res = sexp_user_exception(ctx, read, "couldn't make custom port", read); + res = sexp_user_exception(ctx, self, "couldn't make custom port", read); } else { res = sexp_make_input_port(ctx, in, SEXP_FALSE); sexp_port_cookie(res) = vec; /* for gc preserving */ @@ -174,19 +175,22 @@ static sexp sexp_make_custom_port (sexp ctx, char *mode, sexp read, sexp write, #else -static sexp sexp_make_custom_port (sexp ctx, char *mode, sexp read, sexp write, +static sexp sexp_make_custom_port (sexp ctx, sexp self, + char *mode, sexp read, sexp write, sexp seek, sexp close) { - return sexp_user_exception(ctx, SEXP_FALSE, "custom ports not supported in this configuration", SEXP_NULL); + return sexp_user_exception(ctx, self, "custom ports not supported in this configuration", SEXP_NULL); } #endif -static sexp sexp_make_custom_input_port (sexp ctx, sexp read, sexp seek, sexp close) { - return sexp_make_custom_port(ctx, "r", read, SEXP_FALSE, seek, close); +static sexp sexp_make_custom_input_port (sexp ctx, sexp self, + sexp read, sexp seek, sexp close) { + return sexp_make_custom_port(ctx, self, "r", read, SEXP_FALSE, seek, close); } -static sexp sexp_make_custom_output_port (sexp ctx, sexp write, sexp seek, sexp close) { - sexp res = sexp_make_custom_port(ctx, "w", SEXP_FALSE, write, seek, close); +static sexp sexp_make_custom_output_port (sexp ctx, sexp self, + sexp write, sexp seek, sexp close) { + sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close); sexp_pointer_tag(res) = SEXP_OPORT; return res; } diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub index 7dbca7eb..17287d30 100644 --- a/lib/chibi/process.stub +++ b/lib/chibi/process.stub @@ -42,7 +42,7 @@ (c-include "signal.c") (define-c sexp (set-signal-action! "sexp_set_signal_action") - ((value ctx sexp) sexp sexp)) + ((value ctx sexp) (value self sexp) sexp sexp)) (define-c errno (make-signal-set "sigemptyset") ((result sigset_t))) (define-c errno (signal-set-fill! "sigfillset") (sigset_t)) diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c index 463e481d..ea23929f 100644 --- a/lib/chibi/signal.c +++ b/lib/chibi/signal.c @@ -35,15 +35,15 @@ static struct sigaction call_sigaction = { static struct sigaction call_sigdefault = {.sa_handler = SIG_DFL}; static struct sigaction call_sigignore = {.sa_handler = SIG_IGN}; -static sexp sexp_set_signal_action (sexp ctx, sexp signum, sexp newaction) { +static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newaction) { int res; sexp oldaction; if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0 && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) - return sexp_type_exception(ctx, "not a valid signal number", signum); + return sexp_xtype_exception(ctx, self, "not a valid signal number", signum); if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) || sexp_booleanp(newaction))) - return sexp_type_exception(ctx, "not a procedure", newaction); + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, newaction); if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS))) sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS) = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE); @@ -54,7 +54,7 @@ static sexp sexp_set_signal_action (sexp ctx, sexp signum, sexp newaction) { : &call_sigaction), NULL); if (res) - return sexp_user_exception(ctx, SEXP_FALSE, "couldn't set signal", signum); + return sexp_user_exception(ctx, self, "couldn't set signal", signum); sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction); sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx; return oldaction; diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index 210b9e42..d70f8726 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -44,7 +44,7 @@ static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, int32_t hi, mod, len, i, *data; #endif if (! sexp_random_source_p(rs)) - res = sexp_type_exception(ctx, "not a random-source", rs); + res = sexp_type_exception(ctx, self, rs_type_id, rs); if (sexp_fixnump(bound)) { sexp_call_random(rs, m); res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound)); @@ -64,7 +64,7 @@ static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, data[i] = m % mod; #endif } else { - res = sexp_type_exception(ctx, "random-integer: not an integer", bound); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); } return res; } @@ -76,7 +76,7 @@ static sexp sexp_random_integer (sexp ctx sexp_api_params(self, n), sexp bound) static sexp sexp_rs_random_real (sexp ctx sexp_api_params(self, n), sexp rs) { int32_t res; if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); sexp_call_random(rs, res); return sexp_make_flonum(ctx, (double)res / (double)RAND_MAX); } @@ -96,14 +96,14 @@ static sexp sexp_make_random_source (sexp ctx sexp_api_params(self, n)) { static sexp sexp_random_source_state_ref (sexp ctx sexp_api_params(self, n), sexp rs) { if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); else return sexp_make_integer(ctx, *sexp_random_data(rs)); } static sexp sexp_random_source_state_set (sexp ctx sexp_api_params(self, n), sexp rs, sexp state) { if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); else if (sexp_fixnump(state)) *sexp_random_data(rs) = sexp_unbox_fixnum(state); #if SEXP_USE_BIGNUMS @@ -112,7 +112,7 @@ static sexp sexp_random_source_state_set (sexp ctx sexp_api_params(self, n), sex = sexp_bignum_data(state)[0]*sexp_bignum_sign(state); #endif else - return sexp_type_exception(ctx, "not a valid random-state", state); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, state); return SEXP_VOID; } @@ -132,17 +132,17 @@ static sexp sexp_make_random_source (sexp ctx sexp_api_params(self, n)) { static sexp sexp_random_source_state_ref (sexp ctx sexp_api_params(self, n), sexp rs) { if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); else return sexp_substring(ctx, sexp_random_state(rs), ZERO, STATE_SIZE); } static sexp sexp_random_source_state_set (sexp ctx sexp_api_params(self, n), sexp rs, sexp state) { if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); else if (! (sexp_stringp(state) && (sexp_string_length(state) == SEXP_RANDOM_STATE_SIZE))) - return sexp_type_exception(ctx, "not a valid random-state", state); + return sexp_type_exception(ctx, self, SEXP_STRING, state); sexp_random_state(rs) = state; sexp_random_init(rs, 1); return SEXP_VOID; @@ -152,16 +152,16 @@ static sexp sexp_random_source_state_set (sexp ctx sexp_api_params(self, n), sex static sexp sexp_random_source_randomize (sexp ctx sexp_api_params(self, n), sexp rs) { if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); sexp_seed_random(time(NULL), rs); return SEXP_VOID; } static sexp sexp_random_source_pseudo_randomize (sexp ctx sexp_api_params(self, n), sexp rs, sexp seed) { if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, "not a random-source", rs); + return sexp_type_exception(ctx, self, rs_type_id, rs); if (! sexp_fixnump(seed)) - return sexp_type_exception(ctx, "not an integer", seed); + return sexp_type_exception(ctx, self, rs_type_id, seed); sexp_seed_random(sexp_unbox_fixnum(seed), rs); return SEXP_VOID; } diff --git a/lib/srfi/33/bit.c b/lib/srfi/33/bit.c index b2e685a5..c7a8f843 100644 --- a/lib/srfi/33/bit.c +++ b/lib/srfi/33/bit.c @@ -1,6 +1,6 @@ -/* bit.c -- bitwise operators */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* bit.c -- bitwise operators */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include #include @@ -24,7 +24,7 @@ static sexp sexp_bit_and (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { res = sexp_bit_and(ctx sexp_api_pass(self, n), y, x); #endif else - res = sexp_type_exception(ctx, "bitwise-and: not an integer", y); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); #if SEXP_USE_BIGNUMS } else if (sexp_bignump(x)) { if (sexp_fixnump(y)) { @@ -38,11 +38,11 @@ static sexp sexp_bit_and (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { sexp_bignum_data(res)[i] = sexp_bignum_data(x)[i] & sexp_bignum_data(y)[i]; } else { - res = sexp_type_exception(ctx, "bitwise-and: not an integer", y); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); } #endif } else { - res = sexp_type_exception(ctx, "bitwise-and: not an integer", x); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x); } return sexp_bignum_normalize(res); } @@ -60,7 +60,7 @@ static sexp sexp_bit_ior (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { res = sexp_bit_ior(ctx sexp_api_pass(self, n), y, x); #endif else - res = sexp_type_exception(ctx, "bitwise-ior: not an integer", y); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); #if SEXP_USE_BIGNUMS } else if (sexp_bignump(x)) { if (sexp_fixnump(y)) { @@ -78,11 +78,11 @@ static sexp sexp_bit_ior (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { sexp_bignum_data(res)[i] = sexp_bignum_data(x)[i] | sexp_bignum_data(y)[i]; } else { - res = sexp_type_exception(ctx, "bitwise-ior: not an integer", y); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); } #endif } else { - res = sexp_type_exception(ctx, "bitwise-ior: not an integer", x); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x); } return sexp_bignum_normalize(res); } @@ -100,7 +100,7 @@ static sexp sexp_bit_xor (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { res = sexp_bit_xor(ctx sexp_api_pass(self, n), y, x); #endif else - res = sexp_type_exception(ctx, "bitwise-xor: not an integer", y); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); #if SEXP_USE_BIGNUMS } else if (sexp_bignump(x)) { if (sexp_fixnump(y)) { @@ -118,11 +118,11 @@ static sexp sexp_bit_xor (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { sexp_bignum_data(res)[i] = sexp_bignum_data(x)[i] ^ sexp_bignum_data(y)[i]; } else { - res = sexp_type_exception(ctx, "bitwise-xor: not an integer", y); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); } #endif } else { - res = sexp_type_exception(ctx, "bitwise-xor: not an integer", x); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x); } return sexp_bignum_normalize(res); } @@ -139,7 +139,7 @@ static sexp sexp_arithmetic_shift (sexp ctx sexp_api_params(self, n), sexp i, se sexp res; #endif if (! sexp_fixnump(count)) - return sexp_type_exception(ctx, "arithmetic-shift: not an integer", count); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, count); c = sexp_unbox_fixnum(count); if (c == 0) return i; if (sexp_fixnump(i)) { @@ -192,7 +192,7 @@ static sexp sexp_arithmetic_shift (sexp ctx sexp_api_params(self, n), sexp i, se } #endif } else { - res = sexp_type_exception(ctx, "arithmetic-shift: not an integer", i); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i); } return sexp_bignum_normalize(res); } @@ -224,7 +224,7 @@ static sexp sexp_bit_count (sexp ctx sexp_api_params(self, n), sexp x) { res = sexp_make_fixnum(count); #endif } else { - res = sexp_type_exception(ctx, "bit-count: not an integer", x); + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x); } return res; } @@ -265,7 +265,7 @@ static sexp sexp_integer_length (sexp ctx sexp_api_params(self, n), sexp x) { + hi*sizeof(sexp_uint_t)); #endif } else { - return sexp_type_exception(ctx, "integer-length: not an integer", x); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); } } @@ -274,7 +274,7 @@ static sexp sexp_bit_set_p (sexp ctx sexp_api_params(self, n), sexp i, sexp x) { sexp_uint_t pos; #endif if (! sexp_fixnump(i)) - return sexp_type_exception(ctx, "bit-set?: not an integer", i); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, i); if (sexp_fixnump(x)) { return sexp_make_boolean(sexp_unbox_fixnum(x) & (1< @@ -25,9 +25,9 @@ static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { static sexp sexp_string_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { if (! sexp_stringp(str)) - return sexp_type_exception(ctx, "string-hash: not a string", str); - else if (! sexp_integerp(bound)) - return sexp_type_exception(ctx, "string-hash: not an integer", bound); + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); return sexp_make_fixnum(string_hash(sexp_string_data(str), sexp_unbox_fixnum(bound))); } @@ -40,9 +40,9 @@ static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { static sexp sexp_string_ci_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { if (! sexp_stringp(str)) - return sexp_type_exception(ctx, "string-ci-hash: not a string", str); - else if (! sexp_integerp(bound)) - return sexp_type_exception(ctx, "string-ci-hash: not an integer", bound); + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), sexp_unbox_fixnum(bound))); } @@ -91,13 +91,13 @@ static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t static sexp sexp_hash (sexp ctx sexp_api_params(self, n), sexp obj, sexp bound) { if (! sexp_exact_integerp(bound)) - return sexp_type_exception(ctx, "hash: not an integer", bound); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); return sexp_make_fixnum(hash_one(ctx, obj, sexp_unbox_fixnum(bound), HASH_DEPTH)); } static sexp sexp_hash_by_identity (sexp ctx sexp_api_params(self, n), sexp obj, sexp bound) { if (! sexp_exact_integerp(bound)) - return sexp_type_exception(ctx, "hash-by-identity: not an integer", bound); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); return sexp_make_fixnum((sexp_uint_t)obj % sexp_unbox_fixnum(bound)); } @@ -184,8 +184,8 @@ static sexp sexp_hash_table_cell (sexp ctx sexp_api_params(self, n), sexp ht, se sexp buckets, eq_fn, hash_fn, i; sexp_uint_t size; sexp_gc_var1(res); - if (! sexp_pointerp(ht)) - return sexp_type_exception(ctx, "not a hash-table", ht); + if (! sexp_pointerp(ht)) /* XXXX check the real type id */ + return sexp_xtype_exception(ctx, self, "not a hash-table", ht); buckets = sexp_hash_table_buckets(ht); eq_fn = sexp_hash_table_eq_fn(ht); hash_fn = sexp_hash_table_hash_fn(ht); diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c index 970f36b4..438820f9 100644 --- a/lib/srfi/95/qsort.c +++ b/lib/srfi/95/qsort.c @@ -1,6 +1,6 @@ -/* qsort.c -- quicksort implementation */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include "chibi/eval.h" @@ -147,7 +147,7 @@ static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); if (! sexp_vectorp(vec)) { - res = sexp_type_exception(ctx, "sort: not a vector", vec); + res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec); } else { data = sexp_vector_data(vec); len = sexp_vector_length(vec); @@ -156,9 +156,9 @@ static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, if (sexp_opcodep(less) && sexp_opcode_inverse(less)) sexp_vector_nreverse(ctx, vec); } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { - res = sexp_type_exception(ctx, "sort: not a procedure", less); + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less); } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { - res = sexp_type_exception(ctx, "sort: not a procedure", less); + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key); } else { res = sexp_qsort_less(ctx, data, 0, len-1, less, key); } diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c index 990fec8f..f8e519f3 100644 --- a/lib/srfi/98/env.c +++ b/lib/srfi/98/env.c @@ -1,6 +1,6 @@ -/* env.c -- SRFI-98 environment interface */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #ifdef __APPLE__ #include @@ -11,15 +11,15 @@ extern char **environ; #include -sexp sexp_get_environment_variable (sexp ctx, sexp str) { +sexp sexp_get_environment_variable (sexp ctx sexp_api_params(self, n), sexp str) { char *cstr; if (! sexp_stringp(str)) - return sexp_type_exception(ctx, "get-environment-variable: not a string", str); + return sexp_type_exception(ctx, self, SEXP_STRING, str); cstr = getenv(sexp_string_data(str)); return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE; } -sexp sexp_get_environment_variables (sexp ctx) { +sexp sexp_get_environment_variables (sexp ctx sexp_api_params(self, n)) { int i; char **env, *cname, *cval; sexp_gc_var3(res, name, val); diff --git a/opt/bignum.c b/opt/bignum.c index 37c94c72..588dbde5 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -1,6 +1,6 @@ -/* bignum.c -- bignum support */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #define SEXP_INIT_BIGNUM_SIZE 2 @@ -61,8 +61,8 @@ sexp sexp_double_to_bignum (sexp ctx, double f) { int sign; sexp_gc_var3(res, scale, tmp); sexp_gc_preserve3(ctx, res, scale, tmp); - res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0)); - scale = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE); sign = (f < 0 ? -1 : 1); for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); @@ -390,7 +390,7 @@ static sexp quot_step (sexp ctx, sexp *rem, sexp a, sexp b, sexp k, sexp i) { sexp_gc_var5(x, prod, diff, k2, i2); if (sexp_bignum_compare(k, a) > 0) { *rem = a; - return sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0)); + return sexp_fixnum_to_bignum(ctx, SEXP_ZERO); } sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); k2 = sexp_bignum_double(ctx, k); @@ -418,7 +418,7 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { b1 = sexp_copy_bignum(ctx, NULL, b, 0); sexp_bignum_sign(b1) = 1; k = sexp_copy_bignum(ctx, NULL, b1, 0); - i = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + i = sexp_fixnum_to_bignum(ctx, SEXP_ONE); res = quot_step(ctx, rem, a1, b1, k, i); sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); if (sexp_bignum_sign(a) < 0) { @@ -449,7 +449,7 @@ sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b)); sexp_gc_var2(res, acc); sexp_gc_preserve2(ctx, res, acc); - res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1)); + res = sexp_fixnum_to_bignum(ctx, SEXP_ONE); acc = sexp_copy_bignum(ctx, NULL, a, 0); for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) if (e & 1) @@ -504,7 +504,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "+: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); break; case SEXP_NUM_FIX_FIX: r = sexp_fx_add(a, b); /* VM catches this case */ @@ -536,10 +536,10 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "-: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); break; case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: - r = sexp_type_exception(ctx, "-: not a number", b); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); break; case SEXP_NUM_FIX_FIX: r = sexp_fx_sub(a, b); /* VM catches this case */ @@ -584,7 +584,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "*: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); break; case SEXP_NUM_FIX_FIX: r = sexp_fx_mul(a, b); @@ -618,10 +618,10 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "/: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); break; case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: - r = sexp_type_exception(ctx, "/: not a number", b); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); break; case SEXP_NUM_FIX_FIX: f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b); @@ -670,16 +670,16 @@ sexp sexp_quotient (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "quotient: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); break; case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: - r = sexp_type_exception(ctx, "quotient: not a number", b); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); break; case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: - r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", a); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); break; case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: - r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", b); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); break; case SEXP_NUM_FIX_FIX: r = sexp_fx_div(a, b); @@ -706,16 +706,16 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "remainder: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); break; case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: - r = sexp_type_exception(ctx, "remainder: not a number", b); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); break; case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: - r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", a); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); break; case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: - r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", b); + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); break; case SEXP_NUM_FIX_FIX: r = sexp_fx_rem(a, b); @@ -745,7 +745,7 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) { switch ((at << 2) + bt) { case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: - r = sexp_type_exception(ctx, "compare: not a number", a); + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); break; case SEXP_NUM_FIX_FIX: r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); diff --git a/sexp.c b/sexp.c index c2981ed4..52b77cb6 100644 --- a/sexp.c +++ b/sexp.c @@ -78,14 +78,15 @@ sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port) { static struct sexp_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, "object", NULL), _DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type", NULL), - _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, "fixnum", NULL), + _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, "integer", NULL), + _DEF_TYPE(SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, "number", NULL), _DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, "char", NULL), _DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", NULL), _DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, "pair", NULL), _DEF_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol", NULL), _DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string", NULL), _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector", NULL), - _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum", NULL), + _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "real", NULL), _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), "bignum", NULL), _DEF_TYPE(SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL), _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", SEXP_FINALIZE_PORT), @@ -136,7 +137,7 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, if (num_types >= SEXP_MAXIMUM_TYPES) { res = sexp_user_exception(ctx, SEXP_FALSE, "register-type: exceeded maximum type limit", name); } else if (! sexp_stringp(name)) { - res = sexp_type_exception(ctx, "register-type: not a string", name); + res = sexp_type_exception(ctx, self, SEXP_STRING, name); } else { if (num_types >= type_array_size) { len = type_array_size*2; @@ -328,6 +329,17 @@ sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, return exn; } +sexp sexp_string_cat3 (sexp ctx, char *pre, char *mid, char* suf) { + int plen=strlen(pre), mlen=strlen(mid), slen=strlen(suf); + char *s; + sexp str; + str = sexp_make_string(ctx, sexp_make_fixnum(plen+mlen+slen), SEXP_VOID); + memcpy(s=sexp_string_data(str), pre, plen); + memcpy(s+plen, mid, mlen); + memcpy(s+plen+mlen, suf, slen); + return str; +} + sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { sexp res; sexp_gc_var3(sym, str, irr); @@ -341,15 +353,32 @@ sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { return res; } -sexp sexp_type_exception (sexp ctx, const char *message, sexp obj) { - sexp res; - sexp_gc_var3(sym, str, irr); - sexp_gc_preserve3(ctx, sym, str, irr); - res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type", -1), - str = sexp_c_string(ctx, message, -1), - irr = sexp_list1(ctx, obj), - SEXP_FALSE, SEXP_FALSE); - sexp_gc_release3(ctx); +static sexp type_exception (sexp ctx, sexp self, sexp str, sexp obj, sexp src) { + sexp_gc_var2(res, sym); + sexp_gc_preserve2(ctx, res, sym); + sym = sexp_intern(ctx, "type", -1); + res = sexp_make_exception(ctx, sym, str, obj, self, src); + sexp_exception_irritants(res)=sexp_list1(ctx, sexp_exception_irritants(res)); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_c_string(ctx, msg, -1); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_string_cat3(ctx, "invalid type, expected ", + sexp_type_name_by_index(ctx, type_id), ""); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); return res; } @@ -371,12 +400,17 @@ sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out = sexp_make_output_port(ctx, stderr, SEXP_FALSE); sexp_write_string(ctx, "ERROR", out); if (sexp_exceptionp(exn)) { - if (sexp_procedurep(sexp_exception_procedure(exn))) { - ls = sexp_bytecode_name( - sexp_procedure_code(sexp_exception_procedure(exn))); - if (sexp_symbolp(ls)) { + if (sexp_exception_procedure(exn)) { + if (sexp_procedurep(sexp_exception_procedure(exn))) { + ls = sexp_bytecode_name( + sexp_procedure_code(sexp_exception_procedure(exn))); + if (sexp_symbolp(ls)) { + sexp_write_string(ctx, " in ", out); + sexp_write(ctx, ls, out); + } + } else if (sexp_opcodep(sexp_exception_procedure(exn))) { sexp_write_string(ctx, " in ", out); - sexp_write(ctx, ls, out); + sexp_write_string(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out); } } if (sexp_pairp(sexp_exception_source(exn))) { @@ -504,7 +538,7 @@ sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { if (ls == SEXP_NULL) { return ls; } else if (! sexp_pairp(ls)) { - return sexp_type_exception(ctx, "not a list", ls); + return sexp_type_exception(ctx, self, SEXP_PAIR, ls); } else { b = ls; a = sexp_cdr(ls); @@ -617,8 +651,8 @@ sexp sexp_make_flonum (sexp ctx, float f) { sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) { sexp_sint_t clen = sexp_unbox_fixnum(len); sexp s; - if (! sexp_fixnump(len)) return sexp_type_exception(ctx, "bad length", len); - if (clen < 0) return sexp_type_exception(ctx, "negative length", len); + if (! sexp_fixnump(len)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, len); + if (clen < 0) return sexp_user_exception(ctx, self, "negative length", len); s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); if (sexp_exceptionp(s)) return s; sexp_pointer_tag(s) = SEXP_STRING; @@ -640,13 +674,13 @@ sexp sexp_c_string (sexp ctx, const char *str, sexp_sint_t slen) { sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end) { sexp res; if (! sexp_stringp(str)) - return sexp_type_exception(ctx, "not a string", str); + return sexp_type_exception(ctx, self, SEXP_STRING, str); if (! sexp_fixnump(start)) - return sexp_type_exception(ctx, "not a number", start); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, start); if (sexp_not(end)) end = sexp_make_fixnum(sexp_string_length(str)); if (! sexp_fixnump(end)) - return sexp_type_exception(ctx, "not a number", end); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, end); if ((sexp_unbox_fixnum(start) < 0) || (sexp_unbox_fixnum(start) > sexp_string_length(str)) || (sexp_unbox_fixnum(end) < 0) @@ -667,7 +701,7 @@ sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, char *p, *csep; for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls), i++) if (! sexp_stringp(sexp_car(ls))) - return sexp_type_exception(ctx, "not a string", sexp_car(ls)); + return sexp_type_exception(ctx, self, SEXP_STRING, sexp_car(ls)); else len += sexp_string_length(sexp_car(ls)); if (sexp_stringp(sep) && ((sep_len=sexp_string_length(sep)) > 0)) { @@ -754,7 +788,7 @@ sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str) { if (! sexp_stringp(str)) - return sexp_type_exception(ctx, "string->symbol: not a string", str); + return sexp_type_exception(ctx, self, SEXP_STRING, str); return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); } @@ -907,7 +941,7 @@ sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str FILE *in; sexp res; if (! sexp_stringp(str)) - return sexp_type_exception(ctx, "open-input-string: not a string", str); + return sexp_type_exception(ctx, self, SEXP_STRING, str); if (sexp_string_length(str) == 0) in = fopen("/dev/null", "r"); else @@ -978,7 +1012,7 @@ sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p) { sexp sexp_buffered_flush (sexp ctx, sexp p) { sexp_gc_var1(tmp); if (! sexp_oportp(p)) - return sexp_type_exception(ctx, "not an output-port", p); + return sexp_type_exception(ctx, NULL, SEXP_OPORT, p); else if (! sexp_port_openp(p)) return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p); else { @@ -999,7 +1033,7 @@ sexp sexp_buffered_flush (sexp ctx, sexp p) { sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { sexp res; if (! sexp_stringp(str)) - return sexp_type_exception(ctx, "open-input-string: not a string", str); + return sexp_type_exception(ctx, self, SEXP_STRING, str); res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); if (sexp_exceptionp(res)) return res; sexp_port_cookie(res) = str; @@ -1239,7 +1273,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { if (! sexp_oportp(out)) - return sexp_type_exception(ctx, "write: not an output-port", out); + return sexp_type_exception(ctx, self, SEXP_OPORT, out); else return sexp_write_one(ctx, obj, out); } @@ -1247,7 +1281,7 @@ sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { sexp res=SEXP_VOID; if (! sexp_oportp(out)) - res = sexp_type_exception(ctx, "display: not an output-port", out); + res = sexp_type_exception(ctx, self, SEXP_OPORT, out); else if (sexp_stringp(obj)) sexp_write_string(ctx, sexp_string_data(obj), out); else if (sexp_charp(obj)) @@ -1663,7 +1697,7 @@ sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in) { if (sexp_iportp(in)) res = sexp_read_raw(ctx, in); else - res = sexp_type_exception(ctx, "read: not an input-port", in); + res = sexp_type_exception(ctx, self, SEXP_IPORT, in); if (res == SEXP_CLOSE) res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); if (res == SEXP_RAWDOT) @@ -1686,11 +1720,11 @@ sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp int base; sexp_gc_var1(in); if (! sexp_stringp(str)) - return sexp_type_exception(ctx, "string->number: not a string", str); + return sexp_type_exception(ctx, self, SEXP_STRING, str); else if (! sexp_numberp(b)) - return sexp_type_exception(ctx, "string->number: not a number", b); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, b); if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36)) - return sexp_type_exception(ctx, "string->number: bad base", b); + return sexp_user_exception(ctx, self, "invalid numeric base", b); sexp_gc_preserve1(ctx, in); in = sexp_make_input_string_port(ctx, str); in = ((sexp_string_data(str)[0] == '#') ? diff --git a/tools/genstubs.scm b/tools/genstubs.scm index daf8a684..77acbe26 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -348,26 +348,6 @@ (thunk) (current-output-port old-out))))) -(define (definite-article x) - (define (vowel? c) - (memv c '(#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U))) - (define (vowel-exception? str) - (member (string-downcase str) - '("european" "ewe" "unicorn" "unicycle" "university" "user"))) - (define (consonant-exception? str) - ;; not "historic" according to elements of style - (member (string-downcase str) - '("heir" "herb" "herbal" "herbivore" "honest" "honor" "hour"))) - (let* ((full-str (with-output-to-string (lambda () (cat x)))) - (i (string-scan #\space full-str)) - (str (if i (substring full-str 0 i) full-str))) - (string-append - (cond - ((equal? str "") "a ") - ((vowel? (string-ref str 0)) (if (vowel-exception? str) "a " "an ")) - (else (if (consonant-exception? str) "an " "a "))) - full-str))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; naming @@ -607,6 +587,19 @@ (newline (current-error-port)) (cat "1"))))) +(define (type-id-number type) + (let ((base (type-base type))) + (cond + ((int-type? base) "SEXP_FIXNUM") + ((float-type? base) "SEXP_FLONUM") + ((string-type? base) "SEXP_STRING") + ((eq? base 'char) "SEXP_CHAR") + ((eq? base 'boolean) "SEXP_BOOLEAN") + ((eq? base 'port) "SEXP_IPORT") + ((eq? base 'input-port) "SEXP_IPORT") + ((eq? base 'output-port) "SEXP_OPORT") + (else (type-id-name base))))) + (define (write-validator arg type) (let* ((type (parse-type type)) (array (type-array type)) @@ -617,32 +610,31 @@ ((number? array) (cat " if (!sexp_listp(ctx, " arg ")" " || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n" - " return sexp_type_exception(ctx, \"not a list\", " arg ");\n"))) + " return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n"))) (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" - " return sexp_type_exception(ctx, \"not a list of " + " return sexp_xtype_exception(ctx, self, \"not a list of " (type-name type) "s\", " arg ");\n") (if (not (number? array)) (cat " if (! sexp_nullp(res))\n" - " return sexp_type_exception(ctx, \"not a list of " + " return sexp_xtype_exception(ctx, self, \"not a list of " (type-name type) "s\", " arg ");\n"))) ((eq? base-type 'port-or-fd) (cat "if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" - " return sexp_type_exception(ctx, \"not a port of file descriptor\"," arg ");\n")) + " return sexp_xtype_exception(ctx, self, \"not a port of file descriptor\"," arg ");\n")) ((or (int-type? base-type) (float-type? base-type) (string-type? base-type) (port-type? base-type)) (cat " if (! " (lambda () (check-type arg type)) ")\n" - " return sexp_type_exception(ctx, \"not " - (definite-article (type-name type)) "\", " - arg ");\n")) + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) ((or (assq base-type *types*) (void-pointer-type? type)) (cat " if (! " (lambda () (check-type arg type)) ")\n" - " return sexp_type_exception(ctx, \"not " - (definite-article (type-name type)) "\", " arg ");\n")) + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) ((eq? 'sexp base-type)) ((string-type? type) (write-validator arg 'string)) @@ -1055,7 +1047,7 @@ (define (write-type-getter type name field) (cat "static sexp " (type-getter-name type name field) - " (sexp ctx, sexp x) {\n" + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" (lambda () (write-validator "x" name)) " return " (lambda () @@ -1076,7 +1068,7 @@ (define (write-type-setter type name field) (cat "static sexp " (type-setter-name type name field) - " (sexp ctx, sexp x, sexp v) {\n" + " (sexp ctx sexp_api_params(self, n), sexp x, sexp v) {\n" (lambda () (write-validator "x" name)) (lambda () (write-validator "v" (car field))) " " @@ -1097,7 +1089,7 @@ ((memq 'finalizer: type) => (lambda (x) (cat "static sexp " (generate-stub-name (cadr x)) - " (sexp ctx, sexp x) {\n" + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" " if (sexp_cpointer_freep(x))\n" " " (cadr x) "(sexp_cpointer_value(x));\n" " return SEXP_VOID;\n" @@ -1109,7 +1101,7 @@ (let ((make (caadr x)) (args (cdadr x))) (cat "static sexp " (generate-stub-name make) - " (sexp ctx" + " (sexp ctx sexp_api_params(self, n)" (lambda () (let lp ((ls args) (i 0)) (cond ((pair? ls) From 6e554911e6b9f918ab61909961f01a1812bf0c8a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 4 Apr 2010 10:28:09 +0900 Subject: [PATCH 411/535] simplifying with sexp_assert_type macro --- Makefile | 3 +- eval.c | 96 ++++++++++++++++++++++---------------------------------- sexp.c | 74 +++++++++++++++++-------------------------- 3 files changed, 67 insertions(+), 106 deletions(-) diff --git a/Makefile b/Makefile index 0d6da9fa..1debb799 100644 --- a/Makefile +++ b/Makefile @@ -92,7 +92,8 @@ COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \ lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \ lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \ - lib/chibi/io/io$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + lib/chibi/io/io$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \ + lib/chibi/x86$(SO) libs: $(COMPILED_LIBS) diff --git a/eval.c b/eval.c index af6fb097..7754a700 100644 --- a/eval.c +++ b/eval.c @@ -2026,16 +2026,13 @@ sexp sexp_vm (sexp ctx, sexp proc) { /************************ library procedures **************************/ static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) { - if (sexp_exceptionp(exn)) - return sexp_exception_kind(exn); - else - return sexp_type_exception(ctx, self, SEXP_EXCEPTION, exn); + sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn); + return sexp_exception_kind(exn); } static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) { FILE *in; - if (! sexp_stringp(path)) - return sexp_type_exception(ctx, self, SEXP_STRING, path); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); in = fopen(sexp_string_data(path), "r"); if (! in) return sexp_user_exception(ctx, self, "couldn't open input file", path); @@ -2044,20 +2041,17 @@ static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp pat static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) { FILE *out; - if (! sexp_stringp(path)) - return sexp_type_exception(ctx, self, SEXP_STRING, path); + sexp_assert_type(ctx, sexp_stringp, SEXP_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, self, "couldn't open output file", path); return sexp_make_output_port(ctx, out, path); } static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) { - if (! sexp_portp(port)) - return sexp_type_exception(ctx, self, SEXP_OPORT, port); + sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port); if (! sexp_port_openp(port)) - return sexp_user_exception(ctx, SEXP_FALSE, "port already closed", port); + return sexp_user_exception(ctx, self, "port already closed", port); return sexp_finalize_port(ctx sexp_api_pass(self, n), port); } @@ -2108,10 +2102,8 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { #endif sexp tmp, out=SEXP_FALSE; sexp_gc_var4(ctx2, x, in, res); - if (! sexp_stringp(source)) - return sexp_type_exception(ctx, self, SEXP_STRING, source); - if (! sexp_envp(env)) - return sexp_type_exception(ctx, self, SEXP_ENV, env); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); #if SEXP_USE_DL suffix = sexp_string_data(source) + sexp_string_length(source) - strlen(sexp_so_extension); @@ -2163,17 +2155,17 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { #define maybe_convert_bignum(z) #endif -#define define_math_op(name, cname) \ +#define define_math_op(name, cname) \ static sexp name (sexp ctx sexp_api_params(self, n), sexp z) { \ - double d; \ - if (sexp_flonump(z)) \ - d = sexp_flonum_value(z); \ - else if (sexp_fixnump(z)) \ - d = (double)sexp_unbox_fixnum(z); \ - maybe_convert_bignum(z) \ - else \ - return sexp_type_exception(ctx, self, SEXP_FIXNUM, z); \ - return sexp_make_flonum(ctx, cname(d)); \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_fixnump(z)) \ + d = (double)sexp_unbox_fixnum(z); \ + maybe_convert_bignum(z) \ + else \ + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \ + return sexp_make_flonum(ctx, cname(d)); \ } define_math_op(sexp_exp, exp) @@ -2197,7 +2189,7 @@ static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) { d = (double)sexp_unbox_fixnum(z); maybe_convert_bignum(z) /* XXXX add bignum sqrt */ else - return sexp_type_exception(ctx, self, SEXP_FIXNUM, z); + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); r = sqrt(d); if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) return sexp_make_fixnum(round(r)); @@ -2266,10 +2258,8 @@ static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, sexp str2, sexp ci) { sexp_sint_t len1, len2, len, diff; - if (! sexp_stringp(str1)) - return sexp_type_exception(ctx, self, SEXP_STRING, str1); - if (! sexp_stringp(str2)) - return sexp_type_exception(ctx, self, SEXP_STRING, str2); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2); len1 = sexp_string_length(str1); len2 = sexp_string_length(str2); len = ((len1= SEXP_OPC_NUM_OP_CLASSES)) - res = sexp_user_exception(ctx, self, "make-opcode: bad opcode class", op_class); + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode class", op_class); else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) - res = sexp_user_exception(ctx, self, "make-opcode: bad opcode", code); - else if (! sexp_fixnump(num_args)) - res = sexp_type_exception(ctx, self, SEXP_FIXNUM, num_args); - else if (! sexp_fixnump(flags)) - res = sexp_type_exception(ctx, self, SEXP_FIXNUM, flags); + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code); else { res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); @@ -2403,8 +2390,7 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar #if SEXP_USE_TYPE_DEFS sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { - if (! sexp_fixnump(type)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); @@ -2412,8 +2398,7 @@ sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { sexp_uint_t type_size; - if (! sexp_fixnump(type)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, @@ -2551,24 +2536,19 @@ sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { #if SEXP_USE_MODULES static sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file) { - if (! sexp_stringp(file)) - return sexp_type_exception(ctx, self, SEXP_STRING, file); - else - return sexp_find_module_file(ctx, sexp_string_data(file)); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + return sexp_find_module_file(ctx, sexp_string_data(file)); } sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env) { - if (! sexp_stringp(file)) - return sexp_type_exception(ctx, self, SEXP_STRING, file); - else if (! sexp_envp(env)) - return sexp_type_exception(ctx, self, SEXP_ENV, env); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); return sexp_load_module_file(ctx, sexp_string_data(file), env); } #endif sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp) { sexp ls; - if (! sexp_stringp(dir)) - return sexp_type_exception(ctx, self, SEXP_STRING, dir); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dir); if (sexp_truep(appendp)) { if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) @@ -2749,10 +2729,8 @@ sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { sexp_sint_t top; sexp ctx2; sexp_gc_var2(res, err_handler); - if (! env) - env = sexp_context_env(ctx); - else if (! sexp_envp(env)) - return sexp_type_exception(ctx, self, SEXP_ENV, env); + if (! env) env = sexp_context_env(ctx); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); sexp_gc_preserve2(ctx, res, err_handler); top = sexp_context_top(ctx); err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); diff --git a/sexp.c b/sexp.c index 52b77cb6..82dfb36f 100644 --- a/sexp.c +++ b/sexp.c @@ -135,7 +135,7 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp_uint_t i, len, num_types=sexp_context_num_types(ctx), type_array_size=sexp_context_type_array_size(ctx); if (num_types >= SEXP_MAXIMUM_TYPES) { - res = sexp_user_exception(ctx, SEXP_FALSE, "register-type: exceeded maximum type limit", name); + res = sexp_user_exception(ctx, self, "register-type: exceeded maximum type limit", name); } else if (! sexp_stringp(name)) { res = sexp_type_exception(ctx, self, SEXP_STRING, name); } else { @@ -535,20 +535,16 @@ sexp sexp_reverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { sexp a, b, tmp; - if (ls == SEXP_NULL) { - return ls; - } else if (! sexp_pairp(ls)) { - return sexp_type_exception(ctx, self, SEXP_PAIR, ls); - } 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; + if (ls == SEXP_NULL) return ls; + sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, ls); + 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_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { @@ -651,8 +647,8 @@ sexp sexp_make_flonum (sexp ctx, float f) { sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) { sexp_sint_t clen = sexp_unbox_fixnum(len); sexp s; - if (! sexp_fixnump(len)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, len); - if (clen < 0) return sexp_user_exception(ctx, self, "negative length", len); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len); + if (clen < 0) return sexp_xtype_exception(ctx, self, "negative length", len); s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); if (sexp_exceptionp(s)) return s; sexp_pointer_tag(s) = SEXP_STRING; @@ -673,14 +669,11 @@ sexp sexp_c_string (sexp ctx, const char *str, sexp_sint_t slen) { sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end) { sexp res; - if (! sexp_stringp(str)) - return sexp_type_exception(ctx, self, SEXP_STRING, str); - if (! sexp_fixnump(start)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, start); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start); if (sexp_not(end)) end = sexp_make_fixnum(sexp_string_length(str)); - if (! sexp_fixnump(end)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, end); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end); if ((sexp_unbox_fixnum(start) < 0) || (sexp_unbox_fixnum(start) > sexp_string_length(str)) || (sexp_unbox_fixnum(end) < 0) @@ -787,8 +780,7 @@ sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { } sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str) { - if (! sexp_stringp(str)) - return sexp_type_exception(ctx, self, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); } @@ -940,8 +932,7 @@ sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) { sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { FILE *in; sexp res; - if (! sexp_stringp(str)) - return sexp_type_exception(ctx, self, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); if (sexp_string_length(str) == 0) in = fopen("/dev/null", "r"); else @@ -1011,9 +1002,8 @@ sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p) { sexp sexp_buffered_flush (sexp ctx, sexp p) { sexp_gc_var1(tmp); - if (! sexp_oportp(p)) - return sexp_type_exception(ctx, NULL, SEXP_OPORT, p); - else if (! sexp_port_openp(p)) + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, p); + if (! sexp_port_openp(p)) return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p); else { if (sexp_port_stream(p)) { @@ -1032,8 +1022,7 @@ sexp sexp_buffered_flush (sexp ctx, sexp p) { sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { sexp res; - if (! sexp_stringp(str)) - return sexp_type_exception(ctx, self, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); if (sexp_exceptionp(res)) return res; sexp_port_cookie(res) = str; @@ -1272,17 +1261,14 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { } sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { - if (! sexp_oportp(out)) - return sexp_type_exception(ctx, self, SEXP_OPORT, out); - else - return sexp_write_one(ctx, obj, out); + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + return sexp_write_one(ctx, obj, out); } sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { sexp res=SEXP_VOID; - if (! sexp_oportp(out)) - res = sexp_type_exception(ctx, self, SEXP_OPORT, out); - else if (sexp_stringp(obj)) + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + if (sexp_stringp(obj)) sexp_write_string(ctx, sexp_string_data(obj), out); else if (sexp_charp(obj)) sexp_write_char(ctx, sexp_unbox_character(obj), out); @@ -1694,10 +1680,8 @@ sexp sexp_read_raw (sexp ctx, sexp in) { sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in) { sexp res; - if (sexp_iportp(in)) - res = sexp_read_raw(ctx, in); - else - res = sexp_type_exception(ctx, self, SEXP_IPORT, in); + sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in); + res = sexp_read_raw(ctx, in); if (res == SEXP_CLOSE) res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); if (res == SEXP_RAWDOT) @@ -1719,10 +1703,8 @@ sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) { sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b) { int base; sexp_gc_var1(in); - if (! sexp_stringp(str)) - return sexp_type_exception(ctx, self, SEXP_STRING, str); - else if (! sexp_numberp(b)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, b); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b); if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36)) return sexp_user_exception(ctx, self, "invalid numeric base", b); sexp_gc_preserve1(ctx, in); From 53e538d5a33f989d611f834a85555cc6e0b0f7a1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 4 Apr 2010 10:31:42 +0900 Subject: [PATCH 412/535] initial refactoring of VM code to vm.c --- eval.c | 793 +------------------------------------------------------- vm.c | 797 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 798 insertions(+), 792 deletions(-) create mode 100644 vm.c diff --git a/eval.c b/eval.c index 7754a700..d5babf23 100644 --- a/eval.c +++ b/eval.c @@ -1230,798 +1230,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { 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_fixnum(to), SEXP_VOID); - data = sexp_vector_data(res); - for (i=0; i= SEXP_INIT_STACK_SIZE) { - _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); - goto end_loop; - } -#endif - _ALIGN_IP(); - i = sexp_unbox_fixnum(_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_fixnum(sexp_procedure_num_args(tmp1)); - if (j < 0) - sexp_raise("not enough args", - sexp_list2(ctx, tmp1, sexp_make_fixnum(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_fixnum(i); - stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc)); - stack[top+1] = self; - stack[top+2] = sexp_make_fixnum(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 SEXP_OP_FCALL0: - _ALIGN_IP(); - sexp_context_top(ctx) = top; - _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 0))); - ip += sizeof(sexp); - sexp_check_exception(); - break; - case SEXP_OP_FCALL1: - _ALIGN_IP(); - sexp_context_top(ctx) = top; - _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 1), _ARG1); - ip += sizeof(sexp); - sexp_check_exception(); - break; - case SEXP_OP_FCALL2: - _ALIGN_IP(); - sexp_context_top(ctx) = top; - _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 2), _ARG1, _ARG2); - top--; - ip += sizeof(sexp); - sexp_check_exception(); - break; - case SEXP_OP_FCALL3: - _ALIGN_IP(); - sexp_context_top(ctx) = top; - _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 3), _ARG1, _ARG2, _ARG3); - top -= 2; - ip += sizeof(sexp); - sexp_check_exception(); - break; - case SEXP_OP_FCALL4: - _ALIGN_IP(); - sexp_context_top(ctx) = top; - _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 4), _ARG1, _ARG2, _ARG3, _ARG4); - top -= 3; - ip += sizeof(sexp); - sexp_check_exception(); - break; - case SEXP_OP_FCALL5: - _ALIGN_IP(); - sexp_context_top(ctx) = top; - _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 5), _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); - top -= 4; - ip += sizeof(sexp); - sexp_check_exception(); - break; - case SEXP_OP_FCALL6: - _ALIGN_IP(); - sexp_context_top(ctx) = top; - _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 6), _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); - top -= 5; - ip += sizeof(sexp); - sexp_check_exception(); - break; - case SEXP_OP_JUMP_UNLESS: - _ALIGN_IP(); - if (stack[--top] == SEXP_FALSE) - ip += _SWORD0; - else - ip += sizeof(sexp_sint_t); - break; - case SEXP_OP_JUMP: - _ALIGN_IP(); - ip += _SWORD0; - break; - case SEXP_OP_PUSH: - _ALIGN_IP(); - _PUSH(_WORD0); - ip += sizeof(sexp); - break; - case SEXP_OP_DROP: - top--; - break; - case SEXP_OP_GLOBAL_REF: - _ALIGN_IP(); - if (sexp_cdr(_WORD0) == SEXP_UNDEF) - sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); - /* ... FALLTHROUGH ... */ - case SEXP_OP_GLOBAL_KNOWN_REF: - _ALIGN_IP(); - _PUSH(sexp_cdr(_WORD0)); - ip += sizeof(sexp); - break; - case SEXP_OP_STACK_REF: /* `pick' in forth */ - _ALIGN_IP(); - stack[top] = stack[top - _SWORD0]; - ip += sizeof(sexp); - top++; - break; - case SEXP_OP_LOCAL_REF: - _ALIGN_IP(); - stack[top] = stack[fp - 1 - _SWORD0]; - ip += sizeof(sexp); - top++; - break; - case SEXP_OP_LOCAL_SET: - _ALIGN_IP(); - stack[fp - 1 - _SWORD0] = _ARG1; - _ARG1 = SEXP_VOID; - ip += sizeof(sexp); - break; - case SEXP_OP_CLOSURE_REF: - _ALIGN_IP(); - _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); - ip += sizeof(sexp); - break; - case SEXP_OP_VECTOR_REF: - if (! sexp_vectorp(_ARG1)) - sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); - else if (! sexp_fixnump(_ARG2)) - sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); - i = sexp_unbox_fixnum(_ARG2); - if ((i < 0) || (i >= sexp_vector_length(_ARG1))) - sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); - _ARG2 = sexp_vector_ref(_ARG1, _ARG2); - top--; - break; - case SEXP_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)); - else if (! sexp_fixnump(_ARG2)) - sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); - i = sexp_unbox_fixnum(_ARG2); - if ((i < 0) || (i >= sexp_vector_length(_ARG1))) - sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); - sexp_vector_set(_ARG1, _ARG2, _ARG3); - _ARG3 = SEXP_VOID; - top-=2; - break; - case SEXP_OP_VECTOR_LENGTH: - if (! sexp_vectorp(_ARG1)) - sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); - _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); - break; - case SEXP_OP_STRING_REF: - if (! sexp_stringp(_ARG1)) - sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); - else if (! sexp_fixnump(_ARG2)) - sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); - i = sexp_unbox_fixnum(_ARG2); - if ((i < 0) || (i >= sexp_string_length(_ARG1))) - sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); - _ARG2 = sexp_string_ref(_ARG1, _ARG2); - top--; - break; - case SEXP_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)); - else if (! sexp_fixnump(_ARG2)) - sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2)); - else if (! sexp_charp(_ARG3)) - sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); - i = sexp_unbox_fixnum(_ARG2); - if ((i < 0) || (i >= sexp_string_length(_ARG1))) - sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); - sexp_string_set(_ARG1, _ARG2, _ARG3); - _ARG3 = SEXP_VOID; - top-=2; - break; - case SEXP_OP_STRING_LENGTH: - if (! sexp_stringp(_ARG1)) - sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); - _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); - break; - case SEXP_OP_MAKE_PROCEDURE: - sexp_context_top(ctx) = top; - _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); - top-=3; - break; - case SEXP_OP_MAKE_VECTOR: - sexp_context_top(ctx) = top; - if (! sexp_fixnump(_ARG1)) - sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); - _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); - top--; - break; - case SEXP_OP_MAKE_EXCEPTION: - _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); - top -= 4; - break; - case SEXP_OP_AND: - _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); - top--; - break; - case SEXP_OP_EOFP: - _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; - case SEXP_OP_NULLP: - _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; - case SEXP_OP_FIXNUMP: - _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; - case SEXP_OP_SYMBOLP: - _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; - case SEXP_OP_CHARP: - _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; - case SEXP_OP_TYPEP: - _ALIGN_IP(); - _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); - ip += sizeof(sexp); - break; - case SEXP_OP_MAKE: - _ALIGN_IP(); - _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); - ip += sizeof(sexp)*2; - break; - case SEXP_OP_SLOT_REF: - _ALIGN_IP(); - if (! sexp_check_tag(_ARG1, _UWORD0)) - sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); - _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); - ip += sizeof(sexp)*2; - break; - case SEXP_OP_SLOT_SET: - _ALIGN_IP(); - if (! sexp_check_tag(_ARG1, _UWORD0)) - sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); - else if (sexp_immutablep(_ARG1)) - sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); - sexp_slot_set(_ARG1, _UWORD1, _ARG2); - _ARG2 = SEXP_VOID; - ip += sizeof(sexp)*2; - top--; - break; - case SEXP_OP_CAR: - if (! sexp_pairp(_ARG1)) - sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); - _ARG1 = sexp_car(_ARG1); break; - case SEXP_OP_CDR: - if (! sexp_pairp(_ARG1)) - sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); - _ARG1 = sexp_cdr(_ARG1); break; - case SEXP_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 SEXP_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 SEXP_OP_CONS: - sexp_context_top(ctx) = top; - _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); - top--; - break; - case SEXP_OP_ADD: -#if SEXP_USE_BIGNUMS - tmp1 = _ARG1, tmp2 = _ARG2; - sexp_context_top(ctx) = top; - if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { - j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); - if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) - _ARG2 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); - else - _ARG2 = sexp_make_fixnum(j); - } - else - _ARG2 = sexp_add(ctx, tmp1, tmp2); -#else - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_fx_add(_ARG1, _ARG2); -#if SEXP_USE_FLONUMS - else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2); - else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_fixnum(_ARG2)); - else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) + sexp_flonum_value(_ARG2)); -#endif - else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2)); -#endif - top--; - break; - case SEXP_OP_SUB: -#if SEXP_USE_BIGNUMS - tmp1 = _ARG1, tmp2 = _ARG2; - sexp_context_top(ctx) = top; - if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { - j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); - if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) - _ARG2 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); - else - _ARG2 = sexp_make_fixnum(j); - } - else - _ARG2 = sexp_sub(ctx, tmp1, tmp2); -#else - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_fx_sub(_ARG1, _ARG2); -#if SEXP_USE_FLONUMS - else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2); - else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_fixnum(_ARG2)); - else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) - sexp_flonum_value(_ARG2)); -#endif - else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2)); -#endif - top--; - break; - case SEXP_OP_MUL: -#if SEXP_USE_BIGNUMS - tmp1 = _ARG1, tmp2 = _ARG2; - sexp_context_top(ctx) = top; - if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { - prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); - if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) - _ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); - else - _ARG2 = sexp_make_fixnum(prod); - } - else - _ARG2 = sexp_mul(ctx, tmp1, tmp2); -#else - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_fx_mul(_ARG1, _ARG2); -#if SEXP_USE_FLONUMS - else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2); - else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_fixnum(_ARG2)); - else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) * sexp_flonum_value(_ARG2)); -#endif - else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2)); -#endif - top--; - break; - case SEXP_OP_DIV: - sexp_context_top(ctx) = top; - if (_ARG2 == SEXP_ZERO) { -#if SEXP_USE_FLONUMS - if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) - _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); - else -#endif - sexp_raise("divide by zero", SEXP_NULL); - } else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { -#if SEXP_USE_FLONUMS - _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); - _ARG2 = sexp_fixnum_to_flonum(ctx, _ARG2); - _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); - if (sexp_flonum_value(_ARG2) == trunc(sexp_flonum_value(_ARG2))) - _ARG2 = sexp_make_fixnum(sexp_flonum_value(_ARG2)); -#else - _ARG2 = sexp_fx_div(_ARG1, _ARG2); -#endif - } -#if SEXP_USE_BIGNUMS - else - _ARG2 = sexp_div(ctx, _ARG1, _ARG2); -#else -#if SEXP_USE_FLONUMS - else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); - else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_fixnum(_ARG2)); - else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) / sexp_flonum_value(_ARG2)); -#endif - else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2)); -#endif - top--; - break; - case SEXP_OP_QUOTIENT: - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - if (_ARG2 == SEXP_ZERO) - sexp_raise("divide by zero", SEXP_NULL); - _ARG2 = sexp_fx_div(_ARG1, _ARG2); - top--; - } -#if SEXP_USE_BIGNUMS - else { - sexp_context_top(ctx) = top; - _ARG2 = sexp_quotient(ctx, _ARG1, _ARG2); - top--; - } -#else - else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); -#endif - break; - case SEXP_OP_REMAINDER: - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - if (_ARG2 == SEXP_ZERO) - sexp_raise("divide by zero", SEXP_NULL); - tmp1 = sexp_fx_rem(_ARG1, _ARG2); - top--; - _ARG1 = tmp1; - } -#if SEXP_USE_BIGNUMS - else { - sexp_context_top(ctx) = top; - _ARG2 = sexp_remainder(ctx, _ARG1, _ARG2); - top--; - } -#else - else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); -#endif - break; - case SEXP_OP_LT: - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; -#if SEXP_USE_BIGNUMS - _ARG2 = sexp_make_boolean(i); - } else { - tmp1 = sexp_compare(ctx, _ARG1, _ARG2); - _ARG2 = sexp_fixnump(tmp1) - ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) < 0) : tmp1; - } -#else -#if SEXP_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_fixnump(_ARG2)) { - i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_fixnum(_ARG2); - } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { - i = (double)sexp_unbox_fixnum(_ARG1) < sexp_flonum_value(_ARG2); -#endif - } else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); - _ARG2 = sexp_make_boolean(i); -#endif - top--; - break; - case SEXP_OP_LE: - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; -#if SEXP_USE_BIGNUMS - _ARG2 = sexp_make_boolean(i); - } else { - tmp1 = sexp_compare(ctx, _ARG1, _ARG2); - _ARG2 = sexp_fixnump(tmp1) - ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) <= 0) : tmp1; - } -#else -#if SEXP_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_fixnump(_ARG2)) { - i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_fixnum(_ARG2); - } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { - i = (double)sexp_unbox_fixnum(_ARG1) <= sexp_flonum_value(_ARG2); -#endif - } else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); - _ARG2 = sexp_make_boolean(i); -#endif - top--; - break; - case SEXP_OP_EQN: - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - i = _ARG1 == _ARG2; -#if SEXP_USE_BIGNUMS - _ARG2 = sexp_make_boolean(i); - } else { - tmp1 = sexp_compare(ctx, _ARG1, _ARG2); - _ARG2 = sexp_fixnump(tmp1) - ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) == 0) : tmp1; - } -#else -#if SEXP_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_fixnump(_ARG2)) { - i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_fixnum(_ARG2); - } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { - i = (double)sexp_unbox_fixnum(_ARG1) == sexp_flonum_value(_ARG2); -#endif - } else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); - _ARG2 = sexp_make_boolean(i); -#endif - top--; - break; - case SEXP_OP_EQ: - _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); - top--; - break; - case SEXP_OP_FIX2FLO: - if (sexp_fixnump(_ARG1)) - _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); -#if SEXP_USE_BIGNUMS - else if (sexp_bignump(_ARG1)) - _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); -#endif - else if (! sexp_flonump(_ARG1)) - sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); - break; - case SEXP_OP_FLO2FIX: - if (sexp_flonump(_ARG1)) { - if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { - sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); -#if SEXP_USE_BIGNUMS - } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) - || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { - _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); -#endif - } else { - _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); - } - } else if (! sexp_fixnump(_ARG1) && ! sexp_bignump(_ARG1)) { - sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); - } - break; - case SEXP_OP_CHAR2INT: - if (! sexp_charp(_ARG1)) - sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); - _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); - break; - case SEXP_OP_INT2CHAR: - if (! sexp_fixnump(_ARG1)) - sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); - _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); - break; - case SEXP_OP_CHAR_UPCASE: - if (! sexp_charp(_ARG1)) - sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); - _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); - break; - case SEXP_OP_CHAR_DOWNCASE: - if (! sexp_charp(_ARG1)) - sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); - _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); - break; - case SEXP_OP_WRITE_CHAR: - if (! sexp_charp(_ARG1)) - sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); - if (! sexp_oportp(_ARG2)) - sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2)); - sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); - _ARG2 = SEXP_VOID; - top--; - break; - case SEXP_OP_NEWLINE: - if (! sexp_oportp(_ARG1)) - sexp_raise("newline: not an output-port", sexp_list1(ctx, _ARG1)); - sexp_newline(ctx, _ARG1); - _ARG1 = SEXP_VOID; - break; - case SEXP_OP_READ_CHAR: - if (! sexp_iportp(_ARG1)) - sexp_raise("read-char: not an intput-port", sexp_list1(ctx, _ARG1)); - i = sexp_read_char(ctx, _ARG1); - _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); - break; - case SEXP_OP_PEEK_CHAR: - if (! sexp_iportp(_ARG1)) - sexp_raise("peek-char: not an intput-port", sexp_list1(ctx, _ARG1)); - i = sexp_read_char(ctx, _ARG1); - sexp_push_char(ctx, i, _ARG1); - _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); - break; - case SEXP_OP_RET: - i = sexp_unbox_fixnum(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_fixnum(stack[fp+1]); - cp = sexp_procedure_vars(self); - fp = sexp_unbox_fixnum(stack[fp+3]); - break; - case SEXP_OP_DONE: - goto end_loop; - default: - sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); - } - goto loop; - - end_loop: - sexp_gc_release3(ctx); - sexp_context_top(ctx) = top; - return _ARG1; -} +#include "vm.c" /************************ library procedures **************************/ diff --git a/vm.c b/vm.c new file mode 100644 index 00000000..e0edd053 --- /dev/null +++ b/vm.c @@ -0,0 +1,797 @@ +/* vm.c -- stack-based virtual machine backend */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +/*********************** 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_fixnum(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= SEXP_INIT_STACK_SIZE) { + _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); + goto end_loop; + } +#endif + _ALIGN_IP(); + i = sexp_unbox_fixnum(_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_fixnum(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_fixnum(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_fixnum(i); + stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + stack[top+1] = self; + stack[top+2] = sexp_make_fixnum(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 SEXP_OP_FCALL0: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 0))); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL1: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 1), _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL2: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 2), _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL3: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 3), _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL4: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 4), _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL5: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 5), _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL6: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 6), _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_JUMP_UNLESS: + _ALIGN_IP(); + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case SEXP_OP_JUMP: + _ALIGN_IP(); + ip += _SWORD0; + break; + case SEXP_OP_PUSH: + _ALIGN_IP(); + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case SEXP_OP_DROP: + top--; + break; + case SEXP_OP_GLOBAL_REF: + _ALIGN_IP(); + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case SEXP_OP_GLOBAL_KNOWN_REF: + _ALIGN_IP(); + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_STACK_REF: /* `pick' in forth */ + _ALIGN_IP(); + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_REF: + _ALIGN_IP(); + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_SET: + _ALIGN_IP(); + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case SEXP_OP_CLOSURE_REF: + _ALIGN_IP(); + _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); + ip += sizeof(sexp); + break; + case SEXP_OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_VECTOR_LENGTH: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); + break; + case SEXP_OP_STRING_REF: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_string_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2)); + else if (! sexp_charp(_ARG3)) + sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_string_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_STRING_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); + break; + case SEXP_OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; + _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case SEXP_OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; + if (! sexp_fixnump(_ARG1)) + sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); + _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_MAKE_EXCEPTION: + _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + break; + case SEXP_OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case SEXP_OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case SEXP_OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case SEXP_OP_FIXNUMP: + _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; + case SEXP_OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case SEXP_OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case SEXP_OP_TYPEP: + _ALIGN_IP(); + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_MAKE: + _ALIGN_IP(); + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_REF: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_SET: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); + sexp_slot_set(_ARG1, _UWORD1, _ARG2); + _ARG2 = SEXP_VOID; + ip += sizeof(sexp)*2; + top--; + break; + case SEXP_OP_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case SEXP_OP_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case SEXP_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 SEXP_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 SEXP_OP_CONS: + sexp_context_top(ctx) = top; + _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_ADD: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(j); + } + else + _ARG2 = sexp_add(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_add(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) + sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_SUB: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(j); + } + else + _ARG2 = sexp_sub(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_sub(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) - sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_MUL: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); + if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(prod); + } + else + _ARG2 = sexp_mul(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_mul(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) * sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_DIV: + sexp_context_top(ctx) = top; + if (_ARG2 == SEXP_ZERO) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) + _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { +#if SEXP_USE_FLONUMS + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); + _ARG2 = sexp_fixnum_to_flonum(ctx, _ARG2); + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + if (sexp_flonum_value(_ARG2) == trunc(sexp_flonum_value(_ARG2))) + _ARG2 = sexp_make_fixnum(sexp_flonum_value(_ARG2)); +#else + _ARG2 = sexp_fx_div(_ARG1, _ARG2); +#endif + } +#if SEXP_USE_BIGNUMS + else + _ARG2 = sexp_div(ctx, _ARG1, _ARG2); +#else +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) / sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_QUOTIENT: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG2 = sexp_fx_div(_ARG1, _ARG2); + top--; + } +#if SEXP_USE_BIGNUMS + else { + sexp_context_top(ctx) = top; + _ARG2 = sexp_quotient(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case SEXP_OP_REMAINDER: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + tmp1 = sexp_fx_rem(_ARG1, _ARG2); + top--; + _ARG1 = tmp1; + } +#if SEXP_USE_BIGNUMS + else { + sexp_context_top(ctx) = top; + _ARG2 = sexp_remainder(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case SEXP_OP_LT: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) < 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) < sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_LE: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) <= 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) <= sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_EQN: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = _ARG1 == _ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) == 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) == sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case SEXP_OP_FIX2FLO: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); +#endif + else if (! sexp_flonump(_ARG1)) + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case SEXP_OP_FLO2FIX: + if (sexp_flonump(_ARG1)) { + if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { + sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_BIGNUMS + } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { + _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); +#endif + } else { + _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); + } + } else if (! sexp_fixnump(_ARG1) && ! sexp_bignump(_ARG1)) { + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + } + break; + case SEXP_OP_CHAR2INT: + if (! sexp_charp(_ARG1)) + sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); + break; + case SEXP_OP_INT2CHAR: + if (! sexp_fixnump(_ARG1)) + sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); + break; + case SEXP_OP_CHAR_UPCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_CHAR_DOWNCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_WRITE_CHAR: + if (! sexp_charp(_ARG1)) + sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); + if (! sexp_oportp(_ARG2)) + sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2)); + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_NEWLINE: + if (! sexp_oportp(_ARG1)) + sexp_raise("newline: not an output-port", sexp_list1(ctx, _ARG1)); + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case SEXP_OP_READ_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("read-char: not an intput-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_PEEK_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("peek-char: not an intput-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); + sexp_push_char(ctx, i, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_RET: + i = sexp_unbox_fixnum(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_fixnum(stack[fp+1]); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_fixnum(stack[fp+3]); + break; + case SEXP_OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); + } + goto loop; + + end_loop: + sexp_gc_release3(ctx); + sexp_context_top(ctx) = top; + return _ARG1; +} + From 0299d428070d76e9636b24968a9760f727001b95 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 15 Apr 2010 22:25:35 +0900 Subject: [PATCH 413/535] fixing bug reading SEXP_MIN_FIXNUM --- include/chibi/sexp.h | 3 ++- opt/bignum.c | 6 +++--- sexp.c | 12 ++++++++---- 3 files changed, 13 insertions(+), 8 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index b110a973..05cdb7b5 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -848,7 +848,7 @@ SEXP_API sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sex SEXP_API sexp sexp_intern (sexp ctx, const char *str, sexp_sint_t len); SEXP_API sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str); SEXP_API sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b); -SEXP_API sexp sexp_make_vector (sexp ctx, sexp len, sexp dflt); +SEXP_API sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt); SEXP_API sexp sexp_list_to_vector_op (sexp ctx sexp_api_params(self, n), sexp ls); SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); SEXP_API sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); @@ -915,6 +915,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) #define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_cons(ctx, a, b) sexp_cons_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_append2(ctx, a, b) sexp_append2_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx sexp_api_pass(NULL, 2), a, b); #define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_string_to_number(ctx, s, b) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), s, b) diff --git a/opt/bignum.c b/opt/bignum.c index 588dbde5..5ad40e70 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -27,7 +27,7 @@ sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { sexp res; - if ((SEXP_MIN_FIXNUM < x) && (x < SEXP_MAX_FIXNUM)) { + if ((SEXP_MIN_FIXNUM <= x) && (x <= SEXP_MAX_FIXNUM)) { res = sexp_make_fixnum(x); } else { res = sexp_make_bignum(ctx, 1); @@ -44,7 +44,7 @@ sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { sexp res; - if (x < SEXP_MAX_FIXNUM) { + if (x <= SEXP_MAX_FIXNUM) { res = sexp_make_fixnum(x); } else { res = sexp_make_bignum(ctx, 1); @@ -487,7 +487,7 @@ enum sexp_number_combs { }; static int sexp_number_types[] = - {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, 0}; + {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0}; static int sexp_number_type (sexp a) { return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] diff --git a/sexp.c b/sexp.c index 82dfb36f..f92d13c5 100644 --- a/sexp.c +++ b/sexp.c @@ -784,7 +784,7 @@ sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str) { return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); } -sexp sexp_make_vector (sexp ctx, sexp len, sexp dflt) { +sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt) { sexp vec, *x; int i, clen = sexp_unbox_fixnum(len); if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR); @@ -1643,9 +1643,13 @@ sexp sexp_read_raw (sexp ctx, sexp in) { else #endif #if SEXP_USE_BIGNUMS - if (sexp_bignump(res)) - sexp_bignum_sign(res) = -sexp_bignum_sign(res); - else + if (sexp_bignump(res)) { + if ((sexp_bignum_hi(res) == 1) + && sexp_bignum_data(res)[0] == SEXP_MAX_FIXNUM) + res = sexp_make_fixnum(-sexp_bignum_data(res)[0]); + else + sexp_bignum_sign(res) = -sexp_bignum_sign(res); + } else #endif res = sexp_fx_mul(res, SEXP_NEG_ONE); } From 340ab8404c624d982f025f6f1bc223cbafd4d866 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 15 Apr 2010 22:34:43 +0900 Subject: [PATCH 414/535] off by one error on last patch --- sexp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sexp.c b/sexp.c index f92d13c5..295492f0 100644 --- a/sexp.c +++ b/sexp.c @@ -1645,7 +1645,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { #if SEXP_USE_BIGNUMS if (sexp_bignump(res)) { if ((sexp_bignum_hi(res) == 1) - && sexp_bignum_data(res)[0] == SEXP_MAX_FIXNUM) + && (sexp_bignum_data(res)[0] == (SEXP_MAX_FIXNUM+1))) res = sexp_make_fixnum(-sexp_bignum_data(res)[0]); else sexp_bignum_sign(res) = -sexp_bignum_sign(res); From 5c91226157b0f23ebf28bf10e194d5b5c158c940 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 19 Apr 2010 07:44:09 +0900 Subject: [PATCH 415/535] removing experimental x86.so from targets --- Makefile | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index 1debb799..d22b2dfa 100644 --- a/Makefile +++ b/Makefile @@ -92,8 +92,7 @@ COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \ lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \ lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \ - lib/chibi/io/io$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \ - lib/chibi/x86$(SO) + lib/chibi/io/io$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) libs: $(COMPILED_LIBS) @@ -109,7 +108,7 @@ include/chibi/install.h: Makefile sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< -eval.o: eval.c opcodes.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile +eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile From 4d6456873651548bbd6f3e13d3e49b8193714555 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 20 Apr 2010 21:12:24 +0900 Subject: [PATCH 416/535] fixing bug in lset-union (thanks to alexander shendi) --- lib/srfi/1/lset.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm index f2ffc4ae..8565fac3 100644 --- a/lib/srfi/1/lset.scm +++ b/lib/srfi/1/lset.scm @@ -23,7 +23,7 @@ (define (lset-union2 eq a b) (if (null? b) a - (lset-union2 (cdr b) (if (member (car b) a eq) a (cons (car b) a))))) + (lset-union2 eq (if (member (car b) a eq) a (cons (car b) a)) (cdr b)))) (define (lset-union eq . sets) (reduce (lambda (a b) (lset-union2 eq a b)) '() sets)) From 758e423c1b444f28346c00e6cfd7d56c43ec0a3e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 20 Apr 2010 22:30:38 +0900 Subject: [PATCH 417/535] fixing signedness bug in heap growing heuristics --- gc.c | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/gc.c b/gc.c index d0a2dc94..bb5e7b87 100644 --- a/gc.c +++ b/gc.c @@ -205,16 +205,19 @@ void* sexp_try_alloc (sexp ctx, size_t size) { void* sexp_alloc (sexp ctx, size_t size) { void *res; - size_t max_freed, sum_freed; + size_t max_freed, sum_freed, total_size; sexp_heap h; size = sexp_heap_align(size); res = sexp_try_alloc(ctx, size); if (! res) { max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed)); - h = sexp_heap_last(sexp_context_heap(ctx)); + for (total_size=0, h=sexp_context_heap(ctx); h->next; h=h->next) + total_size += h->size; + total_size += h->size; if (((max_freed < size) - || ((h->size - sum_freed) > (h->size*SEXP_GROW_HEAP_RATIO))) - && ((! SEXP_MAXIMUM_HEAP_SIZE) || (h->size < SEXP_MAXIMUM_HEAP_SIZE))) + || ((total_size > sum_freed) + && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO))) + && ((!SEXP_MAXIMUM_HEAP_SIZE) || (total_size < SEXP_MAXIMUM_HEAP_SIZE))) sexp_grow_heap(ctx, size); res = sexp_try_alloc(ctx, size); if (! res) From aa0af809931230aa42e266a7fd14b25e65dc6189 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 5 May 2010 22:09:18 +0900 Subject: [PATCH 418/535] replacing sprintf with snprintf to handle numeric formatting overflow --- sexp.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/sexp.c b/sexp.c index 295492f0..3703ecfd 100644 --- a/sexp.c +++ b/sexp.c @@ -1132,7 +1132,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { } else #endif { - i = sprintf(numbuf, "%.15g", f); + i = snprintf(numbuf, 20, "%.15g", f); if (f == trunc(f) && ! strchr(numbuf, '.')) { numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; } @@ -1191,7 +1191,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { break; } } else if (sexp_fixnump(obj)) { - sprintf(numbuf, "%ld", sexp_unbox_fixnum(obj)); + snprintf(numbuf, 20, "%ld", sexp_unbox_fixnum(obj)); sexp_write_string(ctx, numbuf, out); #if SEXP_USE_IMMEDIATE_FLONUMS } else if (sexp_flonump(obj)) { @@ -1203,7 +1203,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { } else #endif { - i = sprintf(numbuf, "%.8g", f); + i = snprintf(numbuf, 20, "%.8g", f); if (f == trunc(f) && ! strchr(numbuf, '.')) { numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; } From 147686a4523760564812c8d7b9438b0178556b29 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 5 May 2010 22:11:30 +0900 Subject: [PATCH 419/535] increasing numeric output buffer size --- sexp.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/sexp.c b/sexp.c index 3703ecfd..aea6d4f0 100644 --- a/sexp.c +++ b/sexp.c @@ -1080,6 +1080,8 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { return p; } +#define NUMBUF_LEN 32 + sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { #if SEXP_USE_HUFF_SYMS unsigned long res, c; @@ -1088,7 +1090,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { long i=0; double f; sexp x, *elts; - char *str=NULL, numbuf[20]; + char *str=NULL, numbuf[NUMBUF_LEN]; if (! obj) { sexp_write_string(ctx, "#", out); /* shouldn't happen */ @@ -1132,7 +1134,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { } else #endif { - i = snprintf(numbuf, 20, "%.15g", f); + i = snprintf(numbuf, NUMBUF_LEN, "%.15g", f); if (f == trunc(f) && ! strchr(numbuf, '.')) { numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; } @@ -1191,7 +1193,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { break; } } else if (sexp_fixnump(obj)) { - snprintf(numbuf, 20, "%ld", sexp_unbox_fixnum(obj)); + snprintf(numbuf, NUMBUF_LEN, "%ld", sexp_unbox_fixnum(obj)); sexp_write_string(ctx, numbuf, out); #if SEXP_USE_IMMEDIATE_FLONUMS } else if (sexp_flonump(obj)) { @@ -1203,7 +1205,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { } else #endif { - i = snprintf(numbuf, 20, "%.8g", f); + i = snprintf(numbuf, NUMBUF_LEN, "%.8g", f); if (f == trunc(f) && ! strchr(numbuf, '.')) { numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; } From 73a4605a595c7a3af5382e6e4c99084fcf6a436a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 13 May 2010 00:46:19 +0900 Subject: [PATCH 420/535] adding stty module --- Makefile | 8 +- lib/chibi/stty.module | 10 ++ lib/chibi/stty.scm | 224 ++++++++++++++++++++++++++++++++++++++++++ lib/chibi/stty.stub | 96 ++++++++++++++++++ 4 files changed, 336 insertions(+), 2 deletions(-) create mode 100644 lib/chibi/stty.module create mode 100644 lib/chibi/stty.scm create mode 100644 lib/chibi/stty.stub diff --git a/Makefile b/Makefile index d22b2dfa..60a3213d 100644 --- a/Makefile +++ b/Makefile @@ -92,7 +92,8 @@ COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \ lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \ lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \ - lib/chibi/io/io$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \ + lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) libs: $(COMPILED_LIBS) @@ -108,7 +109,7 @@ include/chibi/install.h: Makefile sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< -eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile +eval.o: eval.c opcodes.c vm.c opt/x86.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile @@ -163,6 +164,9 @@ test-build: test-numbers: chibi-scheme$(EXE) LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/numeric-tests.scm +test-flonums: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/flonum-tests.scm + test-hash: chibi-scheme$(EXE) LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/hash-tests.scm diff --git a/lib/chibi/stty.module b/lib/chibi/stty.module new file mode 100644 index 00000000..786a0d4b --- /dev/null +++ b/lib/chibi/stty.module @@ -0,0 +1,10 @@ + +(define-module (chibi stty) + (export stty with-stty TCSANOW TCSADRAIN TCSAFLUSH) + (import-immutable (scheme) + (srfi 33) + (srfi 69)) + (include-shared "stty") + (include "stty.scm") + ) + diff --git a/lib/chibi/stty.scm b/lib/chibi/stty.scm new file mode 100644 index 00000000..3e819b54 --- /dev/null +++ b/lib/chibi/stty.scm @@ -0,0 +1,224 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; symbolic representation of attributes + +(define stty-lookup (make-hash-table eq?)) + +(for-each + (lambda (c) + (let ((type (cadr c)) + (value (caddr c))) + (hash-table-set! stty-lookup (car c) (cdr c)))) + + ;; ripped from the stty man page, then trimmed down to what seemed + ;; available on most systems + + `(;; characters + ;;(dsusp char ,VDSUSP) ; CHAR will send a terminal stop signal + (eof char ,VEOF) ; CHAR will send an EOF (terminate input) + (eol char ,VEOL) ; CHAR will end the line + (eol2 char ,VEOL2) ; alternate CHAR for ending the line + (erase char ,VERASE) ; CHAR will erase the last character typed + (intr char ,VINTR) ; CHAR will send an interrupt signal + (kill char ,VKILL) ; CHAR will erase the current line + (lnext char ,VLNEXT) ; CHAR will enter the next character quoted + (quit char ,VQUIT) ; CHAR will send a quit signal + (rprnt char ,VREPRINT) ; CHAR will redraw the current line + (start char ,VSTART) ; CHAR will restart output after stopping it + (stop char ,VSTOP) ; CHAR will stop the output + (susp char ,VSUSP) ; CHAR will send a terminal stop signal + (werase char ,VWERASE) ; CHAR will erase the last word typed + + ;; special settings + (cols special #f) ; tell the kernel that the terminal has N columns + (columns special #f) ; same as cols N + (ispeed special #f) ; set the input speed to N + (line special #f) ; use line discipline N + (min special #f) ; with -icanon, set N characters minimum for a completed read + (ospeed special #f) ; set the output speed to N + (rows special #f) ; tell the kernel that the terminal has N rows + (size special #f) ; print the number of rows and columns according to the kernel + (speed special #f) ; print the terminal speed + (time special #f) ; with -icanon, set read timeout of N tenths of a second + + ;; control settings + (clocal control ,CLOCAL) ; disable modem control signals + (cread control ,CREAD) ; allow input to be received + (crtscts control ,CRTSCTS) ; enable RTS/CTS handshaking + (cs5 control ,CS5) ; set character size to 5 bits + (cs6 control ,CS6) ; set character size to 6 bits + (cs7 control ,CS7) ; set character size to 7 bits + (cs8 control ,CS8) ; set character size to 8 bits + (cstopb control ,CSTOPB) ; use two stop bits per character (one with `-') + (hup control ,HUPCL) ; send a hangup signal when the last process closes the tty + (hupcl control ,HUPCL) ; same as [-]hup + (parenb control ,PARENB) ; generate parity bit in output and expect parity bit in input + (parodd control ,PARODD) ; set odd parity (even with `-') + + ;; input settings + (brkint input ,BRKINT) ; breaks cause an interrupt signal + (icrnl input ,ICRNL) ; translate carriage return to newline + (ignbrk input ,IGNBRK) ; ignore break characters + (igncr input ,IGNCR) ; ignore carriage return + (ignpar input ,IGNPAR) ; ignore characters with parity errors + (imaxbel input ,IMAXBEL) ; * beep and do not flush a full input buffer on a character + (inlcr input ,INLCR) ; translate newline to carriage return + (inpck input ,INPCK) ; enable input parity checking + (istrip input ,ISTRIP) ; clear high (8th) bit of input characters + ;;(iuclc input ,IUCLC) ; * translate uppercase characters to lowercase + (ixany input ,IXANY) ; * let any character restart output, not only start character + (ixoff input ,IXOFF) ; enable sending of start/stop characters + (ixon input ,IXON) ; enable XON/XOFF flow control + (parmrk input ,PARMRK) ; mark parity errors (with a 255-0-character sequence) + (tandem input ,IXOFF) ; same as [-]ixoff + + ;; output settings + ;;(bs0 output ,BS0) ; backspace delay style, N in [0..1] + ;;(bs1 output ,BS1) ; backspace delay style, N in [0..1] + ;;(cr0 output ,CR0) ; carriage return delay style, N in [0..3] + ;;(cr1 output ,CR1) ; carriage return delay style, N in [0..3] + ;;(cr2 output ,CR2) ; carriage return delay style, N in [0..3] + ;;(cr3 output ,CR3) ; carriage return delay style, N in [0..3] + ;;(ff0 output ,FF0) ; form feed delay style, N in [0..1] + ;;(ff1 output ,FF1) ; form feed delay style, N in [0..1] + ;;(nl0 output ,NL0) ; newline delay style, N in [0..1] + ;;(nl1 output ,NL1) ; newline delay style, N in [0..1] + (ocrnl output ,OCRNL) ; translate carriage return to newline + ;;(ofdel output ,OFDEL) ; use delete characters for fill instead of null characters + ;;(ofill output ,OFILL) ; use fill (padding) characters instead of timing for delays + ;;(olcuc output ,OLCUC) ; translate lowercase characters to uppercase + (onlcr output ,ONLCR) ; translate newline to carriage return-newline + (onlret output ,ONLRET) ; newline performs a carriage return + (onocr output ,ONOCR) ; do not print carriage returns in the first column + (opost output ,OPOST) ; postprocess output + (tab0 output #f) ; horizontal tab delay style, N in [0..3] + (tab1 output #f) ; horizontal tab delay style, N in [0..3] + (tab2 output #f) ; horizontal tab delay style, N in [0..3] + (tab3 output #f) ; horizontal tab delay style, N in [0..3] + (tabs output #f) ; same as tab0 + ;;(-tabs output #f) ; same as tab3 + ;;(vt0 output ,VT0) ; vertical tab delay style, N in [0..1] + ;;(vt1 output ,VT1) ; vertical tab delay style, N in [0..1] + + ;; local settings + (crterase local ,ECHOE) ; echo erase characters as backspace-space-backspace + (crtkill local ,ECHOKE) ; kill all line by obeying the echoprt and echoe settings + ;;(-crtkill local #f) ; kill all line by obeying the echoctl and echok settings + (ctlecho local ,ECHOCTL) ; echo control characters in hat notation (`^c') + (echo local ,ECHO) ; echo input characters + (echoctl local ,ECHOCTL) ; same as [-]ctlecho + (echoe local ,ECHOE) ; same as [-]crterase + ;;(echok local ,ECHOK) ; echo a newline after a kill character + (echoke local ,ECHOKE) ; same as [-]crtkill + (echonl local ,ECHONL) ; echo newline even if not echoing other characters + (echoprt local ,ECHOPRT) ; echo erased characters backward, between `\' and '/' + (icanon local ,ICANON) ; enable erase, kill, werase, and rprnt special characters + ;;(iexten local ,IEXTEN) ; enable non-POSIX special characters + (isig local ,ISIG) ; enable interrupt, quit, and suspend special characters + (noflsh local ,NOFLSH) ; disable flushing after interrupt and quit special characters + (prterase local ,ECHOPRT) ; same as [-]echoprt + (tostop local ,TOSTOP) ; stop background jobs that try to write to the terminal + ;;(xcase local ,XCASE) ; with icanon, escape with `\' for uppercase characters + + ;; combination settings + (LCASE combine (lcase)) + (cbreak combine (not icanon)) + (cooked combine (brkint ignpar istrip icrnl ixon opost isig icanon)) + ; also eof and eol characters + ; to their default values + (crt combine (echoe echoctl echoke)) + (dec combine (echoe echoctl echoke (not ixany))) + ; also intr ^c erase 0177 kill ^u + (decctlq combine (ixany)) + (ek combine ()) ; erase and kill characters to their default values + (evenp combine (parenb (not parodd) cs7)) + ;;(-evenp combine #f) ; same as -parenb cs8 + (lcase combine (xcase iuclc olcuc)) + (litout combine (cs8 (not parenb istrip opost))) + ;;(-litout combine #f) ; same as parenb istrip opost cs7 + (nl combine (not icrnl onlcr)) + ;;(-nl combine #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret + (oddp combine (parenb parodd cs7)) + (parity combine (evenp)) ; same as [-]evenp + (pass8 combine (cs8 (not parenb istrip))) + ;;(-pass8 combine #f) ; same as parenb istrip cs7 + (raw combine (not ignbrk brkint ignpar parmrk + inpck istrip inlcr igncr icrnl)) + (ixon combine (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc + ;;(time combine #f) ; 0 + ;;(-raw combine #f) ; same as cooked + (sane combine (cread brkint icrnl imaxbel opost onlcr + isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0 + echo echoe echoctl echoke ;; iexten echok + (not ignbrk igncr ixoff ixany inlcr ;; iuclc + ocrnl onocr onlret ;; olcuc ofill ofdel + echonl noflsh tostop echoprt))) ;; xcase + ; plus all special characters to + ; their default values + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; high-level interface + +(define (port? x) (or (input-port? x) (output-port? x))) + +(define (stty . args) + (let* ((port (if (and (pair? args) (port? (car args))) + (car args) + (current-output-port))) + (attr (get-terminal-attributes port))) + ;; parse change requests + (let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args)) + (iflag (term-attrs-iflag attr)) + (oflag (term-attrs-oflag attr)) + (cflag (term-attrs-cflag attr)) + (lflag (term-attrs-lflag attr)) + (invert? #f) + (return (lambda (iflag oflag cflag lflag) + (term-attrs-iflag-set! attr iflag) + (term-attrs-oflag-set! attr oflag) + (term-attrs-cflag-set! attr cflag) + (term-attrs-lflag-set! attr lflag) + (set-terminal-attributes! port TCSANOW attr)))) + (define (join old new) + (if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new))) + (cond + ((pair? lst) + (let ((command (car lst))) + (cond + ((pair? command) ;; recurse on sub-expr + (lp command iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((eq? command 'not) ;; toggle current setting + (lp (cdr lst) iflag oflag cflag lflag (not invert?) return)) + (else + (let ((x (hash-table-ref/default stty-lookup command #f))) + (case (and x (car x)) + ((input) + (lp (cdr lst) (join iflag (cadr x)) oflag cflag lflag invert? return)) + ((output) + (lp (cdr lst) iflag (join oflag (cadr x)) cflag lflag invert? return)) + ((control) + (lp (cdr lst) iflag oflag (join cflag (cadr x)) lflag invert? return)) + ((local) + (lp (cdr lst) iflag oflag cflag (join lflag (cadr x)) invert? return)) + ((char) + ;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0)) + (lp (cddr lst) iflag oflag cflag lflag invert? return)) + ((combine) ;; recurse on def of this command + (lp (cadr x) iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((special) + (error "special settings not yet supported" command)) + (else + (error "unknown stty command" command)))))))) + (else + (return iflag oflag cflag lflag)))))) + +(define (with-stty setting thunk . o) + (let* ((port (if (pair? o) (car o) (current-input-port))) + (orig-attrs (get-terminal-attributes port))) + (dynamic-wind + (lambda () (stty setting)) + thunk + (lambda () (set-terminal-attributes! port TCSANOW orig-attrs))))) diff --git a/lib/chibi/stty.stub b/lib/chibi/stty.stub new file mode 100644 index 00000000..40a4a20b --- /dev/null +++ b/lib/chibi/stty.stub @@ -0,0 +1,96 @@ + +(c-system-include "termios.h") + +(define-c-struct termios + predicate: term-attrs? + constructor: (make-term-attrs) + ;;destructor: free-term-attrs + (unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!) + (unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!) + (unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!) + (unsigned-long c_lflag term-attrs-lflag term-attrs-lflag-set!) + ;;(unsigned-char (c_cc 22) term-attrs-cc term-attrs-cc-set!) + (unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!) + (unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!)) + +(define-c-const int TCSANOW) +(define-c-const int TCSADRAIN) +(define-c-const int TCSAFLUSH) +;; (define-c-const int TCSASOFT) + +(define-c-const unsigned-long IGNBRK) +(define-c-const unsigned-long BRKINT) +(define-c-const unsigned-long IGNPAR) +(define-c-const unsigned-long PARMRK) +(define-c-const unsigned-long INPCK) +(define-c-const unsigned-long ISTRIP) +(define-c-const unsigned-long INLCR) +(define-c-const unsigned-long IGNCR) +(define-c-const unsigned-long ICRNL) +(define-c-const unsigned-long IXON) +(define-c-const unsigned-long IXOFF) +(define-c-const unsigned-long IXANY) +(define-c-const unsigned-long IMAXBEL) +;; (define-c-const unsigned-long IUCLC) + +(define-c-const unsigned-long OPOST) +(define-c-const unsigned-long ONLCR) +;; (define-c-const unsigned-long OXTABS) +;; (define-c-const unsigned-long ONOEOT) +(define-c-const unsigned-long OCRNL) +;; (define-c-const unsigned-long OLCUC) +(define-c-const unsigned-long ONOCR) +(define-c-const unsigned-long ONLRET) + +(define-c-const unsigned-long CSIZE) +(define-c-const unsigned-long CS5) +(define-c-const unsigned-long CS6) +(define-c-const unsigned-long CS7) +(define-c-const unsigned-long CS8) +(define-c-const unsigned-long CSTOPB) +(define-c-const unsigned-long CREAD) +(define-c-const unsigned-long PARENB) +(define-c-const unsigned-long PARODD) +(define-c-const unsigned-long HUPCL) +(define-c-const unsigned-long CLOCAL) +;; (define-c-const unsigned-long CCTS_OFLOW) +(define-c-const unsigned-long CRTSCTS) +;; (define-c-const unsigned-long CRTS_IFLOW) +;; (define-c-const unsigned-long MDMBUF) + +(define-c-const unsigned-long ECHOKE) +(define-c-const unsigned-long ECHOE) +(define-c-const unsigned-long ECHO) +(define-c-const unsigned-long ECHONL) +(define-c-const unsigned-long ECHOPRT) +(define-c-const unsigned-long ECHOCTL) +(define-c-const unsigned-long ISIG) +(define-c-const unsigned-long ICANON) +;; (define-c-const unsigned-long ALTWERASE) +(define-c-const unsigned-long IEXTEN) +;; (define-c-const unsigned-long EXTPROC) +(define-c-const unsigned-long TOSTOP) +(define-c-const unsigned-long FLUSHO) +;; (define-c-const unsigned-long NOKERNINFO) +(define-c-const unsigned-long PENDIN) +(define-c-const unsigned-long NOFLSH) + +(define-c-const unsigned-long VEOF) +(define-c-const unsigned-long VEOL) +(define-c-const unsigned-long VEOL2) +(define-c-const unsigned-long VERASE) +;; (define-c-const unsigned-long VERASE2) +(define-c-const unsigned-long VWERASE) +(define-c-const unsigned-long VINTR) +(define-c-const unsigned-long VKILL) +(define-c-const unsigned-long VQUIT) +(define-c-const unsigned-long VSUSP) +(define-c-const unsigned-long VSTART) +(define-c-const unsigned-long VSTOP) +;; (define-c-const unsigned-long VDSUSP) +(define-c-const unsigned-long VLNEXT) +(define-c-const unsigned-long VREPRINT) +;; (define-c-const unsigned-long VSTATUS) + +(define-c errno (get-terminal-attributes "tcgetattr") (port-or-fd (result termios))) +(define-c errno (set-terminal-attributes! "tcsetattr") (port-or-fd int termios)) From f8a32963725d11177ad3c8769c610c4ad1ed7d39 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 15 May 2010 13:05:50 +0900 Subject: [PATCH 421/535] moving apply to vm.c copying lambda param lists on creation --- eval.c | 461 +++------------------------------------ include/chibi/eval.h | 4 +- include/chibi/features.h | 18 ++ include/chibi/sexp.h | 20 +- sexp.c | 12 + vm.c | 429 ++++++++++++++++++++++++++++++++++++ 6 files changed, 501 insertions(+), 443 deletions(-) diff --git a/eval.c b/eval.c index d5babf23..b35b8891 100644 --- a/eval.c +++ b/eval.c @@ -169,7 +169,7 @@ static void shrink_bcode (sexp ctx, sexp_uint_t i) { sexp tmp; if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) { tmp = sexp_alloc_bytecode(ctx, i); - sexp_bytecode_name(tmp) = SEXP_FALSE; + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); sexp_bytecode_length(tmp) = i; sexp_bytecode_literals(tmp) = sexp_bytecode_literals(sexp_context_bc(ctx)); @@ -197,30 +197,13 @@ static void expand_bcode (sexp ctx, sexp_uint_t size) { } } -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 ctx, sexp_uint_t val) { - unsigned char *data; - expand_bcode(ctx, sizeof(sexp)); - data = sexp_bytecode_data(sexp_context_bc(ctx)); - sexp_context_align_pos(ctx); - *((sexp_uint_t*)(&(data[sexp_context_pos(ctx)]))) = val; - sexp_context_pos(ctx) += sizeof(sexp); -} - -static void emit_push (sexp ctx, sexp obj) { - emit(ctx, SEXP_OP_PUSH); - emit_word(ctx, (sexp_uint_t)obj); - if (sexp_pointerp(obj) && ! sexp_symbolp(obj)) - sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); -} +static void emit_enter (sexp ctx); +static void emit_return (sexp ctx); +static void bless_bytecode (sexp ctx, sexp bc); static sexp finalize_bytecode (sexp ctx) { sexp bc; - emit(ctx, SEXP_OP_RET); + emit_return(ctx); shrink_bcode(ctx, sexp_context_pos(ctx)); bc = sexp_context_bc(ctx); if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */ @@ -231,11 +214,17 @@ static sexp finalize_bytecode (sexp ctx) { else sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc)); } + bless_bytecode(ctx, bc); return bc; } -sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args, - sexp bc, sexp vars) { +static void emit (sexp ctx, unsigned char c) { + expand_bcode(ctx, 1); + sexp_bytecode_data(sexp_context_bc(ctx))[sexp_context_pos(ctx)++] = c; +} + +sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp flags, + sexp num_args, sexp bc, sexp vars) { 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; @@ -303,6 +292,14 @@ static sexp sexp_make_lit (sexp ctx, sexp value) { return res; } +/************************* backend ***************************/ + +#if SEXP_USE_NATIVE_X86 +#include "opt/x86.c" +#else +#include "vm.c" +#endif + /****************************** contexts ******************************/ #define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) @@ -325,9 +322,10 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_gc_var2(tmp, vec); ctx = sexp_make_child_context(ctx, NULL); sexp_gc_preserve2(ctx, tmp, vec); - tmp = sexp_intern(ctx, "*current-exception-handler*", -1); + vec = sexp_intern(ctx, "*current-exception-handler*", -1); sexp_global(ctx, SEXP_G_ERR_HANDLER) - = sexp_env_cell_create(ctx, sexp_context_env(ctx), tmp, SEXP_FALSE, NULL); + = sexp_env_cell_create(ctx, sexp_context_env(ctx), vec, SEXP_FALSE, NULL); +#if ! SEXP_USE_NATIVE_X86 emit(ctx, SEXP_OP_RESUMECC); sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); ctx = sexp_make_child_context(ctx, NULL); @@ -338,6 +336,7 @@ void sexp_init_eval_context_globals (sexp ctx) { = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) = sexp_intern(ctx, "final-resumer", -1); +#endif sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL; sexp_add_path(ctx, sexp_default_module_dir); sexp_add_path(ctx, getenv(SEXP_MODULE_PATH_VAR)); @@ -530,7 +529,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { 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)); + res = sexp_make_lambda(ctx, sexp_copy_list(ctx, sexp_cadr(x))); ctx2 = sexp_make_child_context(ctx, res); tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); @@ -799,328 +798,7 @@ static sexp analyze (sexp ctx, sexp object) { sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} -static sexp_sint_t sexp_context_make_label (sexp ctx) { - sexp_sint_t label; - sexp_context_align_pos(ctx); - 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 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, SEXP_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, SEXP_OP_JUMP_UNLESS); - sexp_context_depth(ctx)--; - label1 = sexp_context_make_label(ctx); - generate(ctx, sexp_cnd_pass(cnd)); - sexp_context_tailp(ctx) = tailp; - emit(ctx, SEXP_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, SEXP_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, SEXP_OP_CLOSURE_REF); - emit_word(ctx, i); - } - if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) - emit(ctx, SEXP_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) - ? SEXP_OP_GLOBAL_REF : SEXP_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, SEXP_OP_SET_CDR); - } else { - lambda = sexp_ref_loc(ref); - if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { - /* stack or closure mutable vars are boxed */ - generate_ref(ctx, ref, 0); - emit(ctx, SEXP_OP_SET_CDR); - } else { - /* internally defined variable */ - emit(ctx, SEXP_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, inv_default=0; - sexp_gc_var1(ls); - sexp_gc_preserve1(ctx, ls); - - num_args = sexp_unbox_fixnum(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_data(op) - && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { - if (sexp_opcode_inverse(op)) { - inv_default = 1; - } else { - emit_push(ctx, sexp_opcode_data(op)); - if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); - sexp_context_depth(ctx)++; - num_args++; - } - } - - /* push the arguments onto the stack in reverse order */ - ls = ((sexp_opcode_inverse(op) - && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC)) - ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); - for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) - generate(ctx, sexp_car(ls)); - - /* push the default for inverse opcodes */ - if (inv_default) { - emit_push(ctx, sexp_opcode_data(op)); - if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); - sexp_context_depth(ctx)++; - num_args++; - } - - /* emit the actual operator call */ - switch (sexp_opcode_class(op)) { - case SEXP_OPC_ARITHMETIC: - /* fold variadic arithmetic operators */ - for (i=num_args-1; i>0; i--) - emit(ctx, sexp_opcode_code(op)); - break; - case SEXP_OPC_ARITHMETIC_CMP: - if (num_args > 2) { - emit(ctx, SEXP_OP_STACK_REF); - emit_word(ctx, 2); - emit(ctx, SEXP_OP_STACK_REF); - emit_word(ctx, 2); - emit(ctx, sexp_opcode_code(op)); - emit(ctx, SEXP_OP_AND); - for (i=num_args-2; i>0; i--) { - emit(ctx, SEXP_OP_STACK_REF); - emit_word(ctx, 3); - emit(ctx, SEXP_OP_STACK_REF); - emit_word(ctx, 3); - emit(ctx, sexp_opcode_code(op)); - emit(ctx, SEXP_OP_AND); - emit(ctx, SEXP_OP_AND); - } - } else - emit(ctx, sexp_opcode_code(op)); - break; - case SEXP_OPC_FOREIGN: - emit(ctx, sexp_opcode_code(op)); - emit_word(ctx, (sexp_uint_t)op); - break; - case SEXP_OPC_TYPE_PREDICATE: - case SEXP_OPC_GETTER: - case SEXP_OPC_SETTER: - case SEXP_OPC_CONSTRUCTOR: - emit(ctx, sexp_opcode_code(op)); - if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) - || sexp_opcode_code(op) == SEXP_OP_MAKE) { - if (sexp_opcode_data(op)) - emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); - if (sexp_opcode_data2(op)) - emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); - } - break; - case SEXP_OPC_PARAMETER: - emit_push(ctx, sexp_opcode_data(op)); - emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); - break; - default: - emit(ctx, sexp_opcode_code(op)); - } - - sexp_context_depth(ctx) -= (num_args-1); - sexp_gc_release1(ctx); -} - -static void generate_general_app (sexp ctx, sexp app) { - sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), - tailp = sexp_context_tailp(ctx); - sexp_gc_var1(ls); - sexp_gc_preserve1(ctx, 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 ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); - emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); - - sexp_context_tailp(ctx) = tailp; - sexp_context_depth(ctx) -= len; - sexp_gc_release1(ctx); -} - -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_var2(tmp, bc); - sexp_gc_preserve2(ctx, tmp, 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_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); - 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, SEXP_OP_LOCAL_REF); - emit_word(ctx2, k); - emit_push(ctx2, sexp_car(ls)); - emit(ctx2, SEXP_OP_CONS); - emit(ctx2, SEXP_OP_LOCAL_SET); - emit_word(ctx2, k); - emit(ctx2, SEXP_OP_DROP); - } - } - sexp_context_tailp(ctx2) = 1; - generate(ctx2, sexp_lambda_body(lambda)); - flags = sexp_make_fixnum((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_ZERO, 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, SEXP_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_fixnum(k)); - emit(ctx, SEXP_OP_STACK_REF); - emit_word(ctx, 3); - emit(ctx, SEXP_OP_VECTOR_SET); - emit(ctx, SEXP_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, SEXP_OP_MAKE_PROCEDURE); - } - sexp_gc_release2(ctx); -} - -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); - } -} +/********************** free varable analysis *************************/ static sexp insert_free_var (sexp ctx, sexp x, sexp fv) { sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; @@ -1188,50 +866,6 @@ sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) { return fv1; } -static sexp make_param_list (sexp ctx, sexp_uint_t i) { - sexp_gc_var1(res); - sexp_gc_preserve1(ctx, res); - res = SEXP_NULL; - for ( ; i>0; i--) - res = sexp_cons(ctx, sexp_make_fixnum(i), res); - sexp_gc_release1(ctx); - return res; -} - -static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { - sexp ls, bc, res, env; - sexp_gc_var5(params, ref, refs, lambda, ctx2); - if (i == sexp_opcode_num_args(op)) { /* return before preserving */ - if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); - } else if (i < sexp_opcode_num_args(op)) { - return sexp_compile_error(ctx, "not enough args for opcode", op); - } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ - return sexp_compile_error(ctx, "too many args for opcode", op); - } - sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); - params = make_param_list(ctx, i); - lambda = sexp_make_lambda(ctx, params); - ctx2 = sexp_make_child_context(ctx, lambda); - env = sexp_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), sexp_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_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); - if (i == sexp_opcode_num_args(op)) - sexp_opcode_proc(op) = res; - sexp_gc_release5(ctx); - return res; -} - -#include "vm.c" - /************************ library procedures **************************/ static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) { @@ -1487,19 +1121,6 @@ static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, se /************************** optimizations *****************************/ -sexp sexp_apply_optimization (sexp ctx, sexp proc, sexp ast) { - sexp res; - sexp_gc_var1(args); - if (sexp_opcodep(proc)) { - res = ((sexp_proc2)sexp_opcode_func(proc))(ctx sexp_api_pass(proc, 1), ast); - } else { - sexp_gc_preserve1(ctx, args); - res = sexp_apply(ctx, proc, args=sexp_list1(ctx, ast)); - sexp_gc_release1(ctx); - } - return res; -} - #if SEXP_USE_SIMPLIFY #include "opt/simplify.c" #endif @@ -1889,31 +1510,6 @@ sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, se /************************** eval interface ****************************/ -sexp sexp_apply (sexp ctx, sexp proc, sexp args) { - sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); - sexp_sint_t top = sexp_context_top(ctx), len, offset; - len = sexp_unbox_fixnum(sexp_length(ctx, args)); - if (sexp_opcodep(proc)) - proc = make_opcode_procedure(ctx, proc, len); - if (! sexp_procedurep(proc)) { - res = sexp_exceptionp(proc) ? proc : - sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); - } else { - offset = top + len; - for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) - stack[--offset] = sexp_car(ls); - stack[top] = sexp_make_fixnum(len); - top++; - stack[top++] = SEXP_ZERO; - stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); - stack[top++] = SEXP_ZERO; - sexp_context_top(ctx) = top; - res = sexp_vm(ctx, proc); - if (! res) res = SEXP_VOID; /* shouldn't happen */ - } - return res; -} - sexp sexp_compile (sexp ctx, sexp x) { sexp_gc_var3(ast, vec, res); sexp_gc_preserve3(ctx, ast, vec, res); @@ -1923,8 +1519,9 @@ sexp sexp_compile (sexp ctx, sexp x) { } else { res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); for ( ; sexp_pairp(res); res=sexp_cdr(res)) - ast = sexp_apply_optimization(ctx, sexp_cdar(res), ast); + ast = sexp_apply1(ctx, sexp_cdar(res), ast); sexp_free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + emit_enter(ctx); generate(ctx, ast); res = finalize_bytecode(ctx); vec = sexp_make_vector(ctx, 0, SEXP_VOID); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 1994bc74..6c16c277 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -129,7 +129,6 @@ SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj); SEXP_API sexp sexp_analyze (sexp context, sexp x); SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); -SEXP_API sexp sexp_apply_optimization (sexp context, sexp proc, sexp ast); SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); SEXP_API int sexp_param_index (sexp lambda, sexp name); SEXP_API sexp sexp_eval_op (sexp context sexp_api_params(self, n), sexp obj, sexp env); @@ -152,7 +151,7 @@ SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); -SEXP_API sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args, sexp bc, sexp vars); +SEXP_API sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp flags, sexp num_args, sexp bc, sexp vars); SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); @@ -170,6 +169,7 @@ SEXP_API sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, /* simplify primitive API interface */ #define sexp_make_synclo(ctx, a, b, c) sexp_make_synclo_op(ctx sexp_api_pass(NULL, 3) a, b, c) +#define sexp_make_procedure(ctx, f, n, b, v) sexp_make_procedure_op(ctx sexp_api_pass(NULL, 4), f, n, b, v) #define sexp_make_env(ctx) sexp_make_env_op(ctx sexp_api_pass(NULL, 0)) #define sexp_make_null_env(ctx, v) sexp_make_null_env_op(ctx sexp_api_pass(NULL, 0), v) #define sexp_make_standard_env(ctx) sexp_make_standard_env_op(ctx sexp_api_pass(NULL, 0)) diff --git a/include/chibi/features.h b/include/chibi/features.h index fdb6fe98..a3a7d7b2 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -7,6 +7,9 @@ /* option will disable any not explicitly enabled. */ /* #define SEXP_USE_NO_FEATURES 1 */ +/* uncomment this to enable the experimental native x86 backend */ +/* #define SEXP_USE_NATIVE_X86 1 */ + /* uncomment this to disable the module system */ /* Currently this just loads the config.scm from main and */ /* sets up an (import (module name)) macro. */ @@ -206,6 +209,10 @@ #define SEXP_USE_NO_FEATURES 0 #endif +#ifndef SEXP_USE_NATIVE_X86 +#define SEXP_USE_NATIVE_X86 0 +#endif + #ifndef SEXP_USE_MODULES #define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES #endif @@ -338,6 +345,17 @@ #define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES #endif +#if SEXP_USE_NATIVE_X86 +#undef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 1 +#undef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS 0 +#undef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS 0 +#undef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY 0 +#endif + #ifndef SEXP_USE_ALIGNED_BYTECODE #if defined(__arm__) #define SEXP_USE_ALIGNED_BYTECODE 1 diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 05cdb7b5..9cd0807f 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -41,21 +41,21 @@ typedef unsigned long size_t; #include /* 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) + * bits end in 00: pointer + * 01: fixnum + * 011: immediate flonum (optional) + * 111: immediate symbol (optional) + * 000110: char + * 001110: unique immediate (NULL, TRUE, FALSE) */ #define SEXP_FIXNUM_BITS 2 #define SEXP_IMMEDIATE_BITS 3 -#define SEXP_EXTENDED_BITS 4 +#define SEXP_EXTENDED_BITS 6 #define SEXP_FIXNUM_MASK 3 #define SEXP_IMMEDIATE_MASK 7 -#define SEXP_EXTENDED_MASK 15 +#define SEXP_EXTENDED_MASK 63 #define SEXP_POINTER_TAG 0 #define SEXP_FIXNUM_TAG 1 @@ -208,7 +208,7 @@ struct sexp_struct { sexp kind, message, irritants, procedure, source; } exception; struct { - char sign; + signed char sign; sexp_uint_t length; sexp_uint_t data[]; } bignum; @@ -837,6 +837,7 @@ SEXP_API sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) SEXP_API sexp sexp_listp_op(sexp ctx sexp_api_params(self, n), sexp obj); SEXP_API sexp sexp_reverse_op(sexp ctx sexp_api_params(self, n), sexp ls); SEXP_API sexp sexp_nreverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_copy_list_op(sexp ctx sexp_api_params(self, n), sexp ls); SEXP_API sexp sexp_append2_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b); SEXP_API sexp sexp_memq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); SEXP_API sexp sexp_assq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); @@ -913,6 +914,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) #define sexp_length(ctx, x) sexp_length_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_reverse(ctx, x) sexp_reverse_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_copy_list(ctx, x) sexp_copy_list_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_cons(ctx, a, b) sexp_cons_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_append2(ctx, a, b) sexp_append2_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx sexp_api_pass(NULL, 2), a, b); diff --git a/sexp.c b/sexp.c index aea6d4f0..35861be0 100644 --- a/sexp.c +++ b/sexp.c @@ -547,6 +547,18 @@ sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { return b; } +sexp sexp_copy_list_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp tmp; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + if (! sexp_pairp(ls)) return ls; + tmp = res = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + for (ls=sexp_cdr(ls); sexp_pairp(ls); ls=sexp_cdr(ls), tmp=sexp_cdr(tmp)) + sexp_cdr(tmp) = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + sexp_gc_release1(ctx); + return res; +} + sexp sexp_append2_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { sexp_gc_var2(a1, b1); sexp_gc_preserve2(ctx, a1, b1); diff --git a/vm.c b/vm.c index e0edd053..6a53e941 100644 --- a/vm.c +++ b/vm.c @@ -2,6 +2,396 @@ /* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ +/************************* code generation ****************************/ + +static void emit_word (sexp ctx, sexp_uint_t val) { + unsigned char *data; + expand_bcode(ctx, sizeof(sexp)); + data = sexp_bytecode_data(sexp_context_bc(ctx)); + sexp_context_align_pos(ctx); + *((sexp_uint_t*)(&(data[sexp_context_pos(ctx)]))) = val; + sexp_context_pos(ctx) += sizeof(sexp); +} + +static void emit_push (sexp ctx, sexp obj) { + emit(ctx, SEXP_OP_PUSH); + emit_word(ctx, (sexp_uint_t)obj); + if (sexp_pointerp(obj) && ! sexp_symbolp(obj)) + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); +} + +static void emit_enter (sexp ctx) {return;} +static void bless_bytecode (sexp ctx, sexp bc) {return;} + +static void emit_return (sexp ctx) { + emit(ctx, SEXP_OP_RET); +} + +static sexp_sint_t sexp_context_make_label (sexp ctx) { + sexp_sint_t label; + sexp_context_align_pos(ctx); + 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 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, SEXP_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, SEXP_OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, SEXP_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, SEXP_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, SEXP_OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, SEXP_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) + ? SEXP_OP_GLOBAL_REF : SEXP_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, SEXP_OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, SEXP_OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, SEXP_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, inv_default=0; + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); + + num_args = sexp_unbox_fixnum(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_data(op) + && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { + if (sexp_opcode_inverse(op)) { + inv_default = 1; + } else { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + } + + /* push the arguments onto the stack in reverse order */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC)) + ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the default for inverse opcodes */ + if (inv_default) { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case SEXP_OPC_ARITHMETIC: + /* fold variadic arithmetic operators */ + for (i=num_args-1; i>0; i--) + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + emit(ctx, SEXP_OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_FOREIGN: + emit(ctx, sexp_opcode_code(op)); + emit_word(ctx, (sexp_uint_t)op); + break; + case SEXP_OPC_TYPE_PREDICATE: + case SEXP_OPC_GETTER: + case SEXP_OPC_SETTER: + case SEXP_OPC_CONSTRUCTOR: + emit(ctx, sexp_opcode_code(op)); + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE) { + if (sexp_opcode_data(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); + if (sexp_opcode_data2(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + } + break; + case SEXP_OPC_PARAMETER: + emit_push(ctx, sexp_opcode_data(op)); + emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + sexp_context_depth(ctx) -= (num_args-1); + sexp_gc_release1(ctx); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, 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 ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); + + sexp_context_tailp(ctx) = tailp; + sexp_context_depth(ctx) -= len; + sexp_gc_release1(ctx); +} + +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_var2(tmp, bc); + sexp_gc_preserve2(ctx, tmp, 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_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); + 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, SEXP_OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, SEXP_OP_CONS); + emit(ctx2, SEXP_OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, SEXP_OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_fixnum((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_ZERO, 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, SEXP_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_fixnum(k)); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_VECTOR_SET); + emit(ctx, SEXP_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, SEXP_OP_MAKE_PROCEDURE); + } + sexp_gc_release2(ctx); +} + +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 make_param_list (sexp ctx, sexp_uint_t i) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_fixnum(i), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ls, bc, res, env; + sexp_gc_var5(params, ref, refs, lambda, ctx2); + if (i == sexp_opcode_num_args(op)) { /* return before preserving */ + if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); + } else if (i < sexp_opcode_num_args(op)) { + return sexp_compile_error(ctx, "not enough args for opcode", op); + } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ + return sexp_compile_error(ctx, "too many args for opcode", op); + } + sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = sexp_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), sexp_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_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + sexp_gc_release5(ctx); + return res; +} + /*********************** the virtual machine **************************/ static sexp sexp_save_stack (sexp ctx, sexp *stack, sexp_uint_t to) { @@ -795,3 +1185,42 @@ sexp sexp_vm (sexp ctx, sexp proc) { return _ARG1; } +/******************************* apply ********************************/ + +static sexp sexp_apply1 (sexp ctx, sexp f, sexp x) { + sexp res; + sexp_gc_var1(args); + if (sexp_opcodep(f)) { + res = ((sexp_proc2)sexp_opcode_func(f))(ctx sexp_api_pass(f, 1), x); + } else { + sexp_gc_preserve1(ctx, args); + res = sexp_apply(ctx, f, args=sexp_list1(ctx, x)); + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_apply (sexp ctx, sexp proc, sexp args) { + sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx), len, offset; + len = sexp_unbox_fixnum(sexp_length(ctx, args)); + if (sexp_opcodep(proc)) + proc = make_opcode_procedure(ctx, proc, len); + if (! sexp_procedurep(proc)) { + res = sexp_exceptionp(proc) ? proc : + sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); + } else { + offset = top + len; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) + stack[--offset] = sexp_car(ls); + stack[top] = sexp_make_fixnum(len); + top++; + stack[top++] = SEXP_ZERO; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + stack[top++] = SEXP_ZERO; + sexp_context_top(ctx) = top; + res = sexp_vm(ctx, proc); + if (! res) res = SEXP_VOID; /* shouldn't happen */ + } + return res; +} From 14c4d0b57dee99ed06727670014b92ae02e75bed Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 15 May 2010 13:07:01 +0900 Subject: [PATCH 422/535] named let evaluates the initial bindings outside the scope of the loop (fixes 8.2 in r5rs_pitfalls.scm) --- lib/init.scm | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/lib/init.scm b/lib/init.scm index b7f40fe0..d5191caf 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -219,13 +219,17 @@ (if (every (lambda (x) (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) bindings) - (if (identifier? (cadr expr)) - `(,(rename 'letrec) ((,(cadr expr) - (,(rename 'lambda) ,(map car bindings) - ,@(cdddr expr)))) - ,(cons (cadr expr) (map cadr bindings))) - `((,(rename 'lambda) ,(map car bindings) ,@(cddr expr)) - ,@(map cadr bindings))) + ((lambda (vars vals) + (if (identifier? (cadr expr)) + `((,(rename 'lambda) ,vars + (,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,vars + ,@(cdddr expr)))) + (,(cadr expr) ,@vars))) + ,@vals) + `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals))) + (map car bindings) + (map cadr bindings)) (error "bad let syntax" expr))) (if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) From 102b946b9daea4d21cd656f6e78f237b983a47b6 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 15 May 2010 13:08:33 +0900 Subject: [PATCH 423/535] getting current-in/out/err-ports without using eval in repl loop --- main.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main.c b/main.c index ef97201b..99e4c196 100644 --- a/main.c +++ b/main.c @@ -27,9 +27,9 @@ static void repl (sexp ctx) { sexp_env_define(ctx, sexp_context_env(ctx), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); sexp_context_tracep(ctx) = 1; - in = sexp_eval_string(ctx, "(current-input-port)", -1, env); - out = sexp_eval_string(ctx, "(current-output-port)", -1, env); - err = sexp_eval_string(ctx, "(current-error-port)", -1, env); + in = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE); + out = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE); + err = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE); sexp_port_sourcep(in) = 1; while (1) { sexp_write_string(ctx, "> ", out); From aaf3f84c22fd6abe827177f3bbade9e562d62c9e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 15 May 2010 14:42:19 +0900 Subject: [PATCH 424/535] only warning when a non-procedure is found in an operator position --- eval.c | 52 ++++++++++++++++++++++++-------------------- include/chibi/eval.h | 2 +- main.c | 2 +- 3 files changed, 31 insertions(+), 25 deletions(-) diff --git a/eval.c b/eval.c index b35b8891..fad48e8c 100644 --- a/eval.c +++ b/eval.c @@ -41,6 +41,24 @@ sexp sexp_compile_error (sexp ctx, const char *message, sexp o) { return exn; } +static void sexp_warn (sexp ctx, char *msg, sexp x) { + sexp out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) { + sexp_write_string(ctx, "WARNING: ", out); + sexp_write_string(ctx, msg, out); + sexp_write(ctx, x, out); + sexp_write_char(ctx, '\n', out); + } +} + +void sexp_warn_undefs (sexp ctx, sexp from, sexp to) { + sexp x; + for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x)) + if (sexp_cdar(x) == SEXP_UNDEF) + sexp_warn(ctx, "reference to undefined variable", sexp_caar(x)); +} + + /********************** environment utilities ***************************/ static sexp sexp_env_cell_loc (sexp env, sexp key, sexp *varenv) { @@ -768,13 +786,13 @@ static sexp analyze (sexp ctx, sexp object) { 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); + 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))))))) + sexp_warn(ctx, "invalid operand in application: ", x); + res = analyze_app(ctx, x); } } else if (sexp_idp(x)) { res = analyze_var_ref(ctx, x, NULL); @@ -898,16 +916,6 @@ static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) { return sexp_finalize_port(ctx sexp_api_pass(self, n), port); } -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); - } -} - #if SEXP_USE_DL #ifdef __MINGW32__ #include @@ -983,8 +991,8 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { } #endif #if SEXP_USE_WARN_UNDEFS - if (sexp_oportp(out) && ! sexp_exceptionp(res)) - sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out); + if (! sexp_exceptionp(res)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); #endif return res; } @@ -1472,7 +1480,7 @@ sexp sexp_make_standard_env_op (sexp ctx sexp_api_params(self, n), sexp version) } sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) { - sexp oldname, newname, value, out; + sexp oldname, newname, value; if (! sexp_envp(to)) to = sexp_context_env(ctx); if (! sexp_envp(from)) from = sexp_context_env(ctx); if (sexp_not(ls)) { @@ -1497,10 +1505,8 @@ sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, se if (value != SEXP_UNDEF) { sexp_env_define(ctx, to, newname, value); #if SEXP_USE_WARN_UNDEFS - } else if (sexp_oportp(out=sexp_current_error_port(ctx))) { - sexp_write_string(ctx, "WARNING: importing undefined variable: ", out); - sexp_write(ctx, oldname, out); - sexp_write_char(ctx, '\n', out); + } else { + sexp_warn(ctx, "importing undefined variable: ", oldname); #endif } } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 6c16c277..df97eb1e 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -149,7 +149,7 @@ SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_env_cell (sexp env, sexp sym); SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); -SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); +SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); SEXP_API sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp flags, sexp num_args, sexp bc, sexp vars); SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); diff --git a/main.c b/main.c index 99e4c196..c1d3fe54 100644 --- a/main.c +++ b/main.c @@ -47,7 +47,7 @@ static void repl (sexp ctx) { sexp_print_exception(ctx, res, err); } else { #if SEXP_USE_WARN_UNDEFS - sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, err); + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); #endif if (res != SEXP_VOID) { sexp_write(ctx, res, out); From 87d13c3a46e781d274926ff2ac3cb4364676c1b4 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 15 May 2010 15:04:15 +0900 Subject: [PATCH 425/535] internal defines inside local scopes introduced byu let(rec)-syntax are now analyzed within the correct syntactic scope. fixes r5rs_pitfalls.scm 8.3. --- eval.c | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/eval.c b/eval.c index fad48e8c..e395ea57 100644 --- a/eval.c +++ b/eval.c @@ -535,7 +535,7 @@ static sexp analyze_set (sexp ctx, sexp x) { #define sexp_return(res, val) do {res=val; goto cleanup;} while (0) static sexp analyze_lambda (sexp ctx, sexp x) { - sexp name, ls; + sexp name, ls, ctx3; sexp_gc_var6(res, body, tmp, value, defs, ctx2); sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2); /* verify syntax */ @@ -558,17 +558,18 @@ static sexp analyze_lambda (sexp ctx, sexp x) { 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); - tmp = sexp_cons(ctx2, sexp_cdadr(tmp), sexp_cddr(tmp)); - value = analyze_lambda(ctx2, sexp_cons(ctx2, SEXP_VOID, tmp)); + ctx3 = sexp_cdr(tmp); + if (sexp_pairp(sexp_caar(tmp))) { + name = sexp_caaar(tmp); + tmp = sexp_cons(ctx3, sexp_cdaar(tmp), sexp_cdar(tmp)); + value = analyze_lambda(ctx3, sexp_cons(ctx3, SEXP_VOID, tmp)); } else { - name = sexp_cadr(tmp); - value = analyze(ctx2, sexp_caddr(tmp)); + name = sexp_caar(tmp); + value = analyze(ctx3, sexp_cadar(tmp)); } if (sexp_exceptionp(value)) sexp_return(res, value); - sexp_push(ctx2, defs, - sexp_make_set(ctx2, analyze_var_ref(ctx2, name, NULL), value)); + sexp_push(ctx3, defs, + sexp_make_set(ctx3, analyze_var_ref(ctx3, name, NULL), value)); } if (sexp_pairp(defs)) { if (! sexp_seqp(body)) { @@ -620,7 +621,8 @@ static sexp analyze_define (sexp ctx, sexp x) { 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); + tmp = sexp_cons(ctx, sexp_cdr(x), ctx); + sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp); res = SEXP_VOID; } else { if (sexp_synclop(name)) name = sexp_synclo_expr(name); From 3002d71a65f53a53b2a79304225faac3ae364462 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 15 May 2010 15:25:43 +0900 Subject: [PATCH 426/535] updating stty with get-terminal-width (debated creating a full ioctl module, but all you really want from ioctl is the TIOCGWINSZ command) --- lib/chibi/stty.module | 7 ++++--- lib/chibi/stty.scm | 13 ++++++++++++- lib/chibi/stty.stub | 18 ++++++++++++++---- 3 files changed, 30 insertions(+), 8 deletions(-) diff --git a/lib/chibi/stty.module b/lib/chibi/stty.module index 786a0d4b..4540cb18 100644 --- a/lib/chibi/stty.module +++ b/lib/chibi/stty.module @@ -1,10 +1,11 @@ (define-module (chibi stty) - (export stty with-stty TCSANOW TCSADRAIN TCSAFLUSH) + (export stty with-stty with-raw-io + get-terminal-width get-terminal-dimensions + TCSANOW TCSADRAIN TCSAFLUSH) (import-immutable (scheme) (srfi 33) (srfi 69)) (include-shared "stty") - (include "stty.scm") - ) + (include "stty.scm")) diff --git a/lib/chibi/stty.scm b/lib/chibi/stty.scm index 3e819b54..b4aee004 100644 --- a/lib/chibi/stty.scm +++ b/lib/chibi/stty.scm @@ -205,7 +205,7 @@ ((char) ;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0)) (lp (cddr lst) iflag oflag cflag lflag invert? return)) - ((combine) ;; recurse on def of this command + ((combine) (lp (cadr x) iflag oflag cflag lflag invert? (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) ((special) @@ -222,3 +222,14 @@ (lambda () (stty setting)) thunk (lambda () (set-terminal-attributes! port TCSANOW orig-attrs))))) + +(define (with-raw-io port thunk) + (with-stty '(not icanon echo) thunk port)) + +(define (get-terminal-width x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (winsize-col ws)))) + +(define (get-terminal-dimensions x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (list (winsize-col ws) (winsize-row ws))))) diff --git a/lib/chibi/stty.stub b/lib/chibi/stty.stub index 40a4a20b..3c5939c5 100644 --- a/lib/chibi/stty.stub +++ b/lib/chibi/stty.stub @@ -1,10 +1,10 @@ (c-system-include "termios.h") +(c-system-include "sys/ioctl.h") (define-c-struct termios predicate: term-attrs? constructor: (make-term-attrs) - ;;destructor: free-term-attrs (unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!) (unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!) (unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!) @@ -13,10 +13,18 @@ (unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!) (unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!)) +(define-c-struct winsize + predicate: winsize? + (unsigned-short ws_row winsize-row) + (unsigned-short ws_col winsize-col)) + +(define-c errno ioctl (port-or-fd unsigned-long (result winsize))) + +(define-c-const int TIOCGWINSZ) + (define-c-const int TCSANOW) (define-c-const int TCSADRAIN) (define-c-const int TCSAFLUSH) -;; (define-c-const int TCSASOFT) (define-c-const unsigned-long IGNBRK) (define-c-const unsigned-long BRKINT) @@ -92,5 +100,7 @@ (define-c-const unsigned-long VREPRINT) ;; (define-c-const unsigned-long VSTATUS) -(define-c errno (get-terminal-attributes "tcgetattr") (port-or-fd (result termios))) -(define-c errno (set-terminal-attributes! "tcsetattr") (port-or-fd int termios)) +(define-c errno (get-terminal-attributes "tcgetattr") + (port-or-fd (result termios))) +(define-c errno (set-terminal-attributes! "tcsetattr") + (port-or-fd int termios)) From 4066d8563b900d79f48357901667f3ca39b0273c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 16 May 2010 18:08:55 +0900 Subject: [PATCH 427/535] initial edit-line module (readline replacement in pure scheme) --- lib/chibi/term/edit-line.module | 5 + lib/chibi/term/edit-line.scm | 492 ++++++++++++++++++++++++++++++++ 2 files changed, 497 insertions(+) create mode 100644 lib/chibi/term/edit-line.module create mode 100644 lib/chibi/term/edit-line.scm diff --git a/lib/chibi/term/edit-line.module b/lib/chibi/term/edit-line.module new file mode 100644 index 00000000..d8116473 --- /dev/null +++ b/lib/chibi/term/edit-line.module @@ -0,0 +1,5 @@ + +(define-module (chibi term edit-line) + (export edit-line edit-line-repl) + (import-immutable (scheme) (chibi stty) (srfi 9)) + (include "edit-line.scm")) diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm new file mode 100644 index 00000000..6c63f5d9 --- /dev/null +++ b/lib/chibi/term/edit-line.scm @@ -0,0 +1,492 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; vt100 terminal utilities + +(define (terminal-escape out ch arg) + (write-char (integer->char 27) out) + (write-char #\[ out) + (if arg (display arg out)) + (write-char ch out)) + +;; we use zero-based columns +(define (terminal-goto-col out n) (terminal-escape out #\G (+ n 1))) +(define (terminal-up out n) (terminal-escape out #\A n)) +(define (terminal-down out n) (terminal-escape out #\B n)) +(define (terminal-clear-below out) (terminal-escape out #\J #f)) +(define (terminal-clear-right out) (terminal-escape out #\K #f)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; history + +(define maximum-history-size 128) + +(define-record-type history + (%make-history remaining past future) + history? + (remaining history-remaining history-remaining-set!) + (past history-past history-past-set!) + (future history-future history-future-set!)) + +(define (make-history . o) + (%make-history (if (pair? o) (car o) maximum-history-size) '() '())) + +(define (history-current h) + (let ((p (history-past h))) + (and (pair? p) (car p)))) + +(define (history->list h) + (let ((past (history-past h)) (future (history-future h))) + (if (pair? past) (cons (car past) (append future (cdr past))) future))) + +(define (history-flatten! h) + (history-past-set! h (history->list h)) + (history-future-set! h '())) + +(define (drop-last ls) (reverse (cdr (reverse ls)))) + +(define (history-past-push! h x) + (if (positive? (history-remaining h)) + (history-remaining-set! h (- (history-remaining h) 1)) + (if (pair? (history-past h)) + (history-past-set! h (drop-last (history-past h))) + (history-future-set! h (drop-last (history-future h))))) + (history-past-set! h (cons x (history-past h)))) + +(define (history-insert! h x) + (history-flatten! h) + (history-past-push! h x)) + +(define (history-commit! h x) + (cond + ((pair? (history-future h)) + (history-past-set! + h (cons x (append (drop-last (history-future h)) (history-past h)))) + (history-future-set! h '())) + (else + (history-insert! h x)))) + +(define (history-prev! h) + (let ((past (history-past h))) + (and (pair? past) + (pair? (cdr past)) + (begin + (history-future-set! h (cons (car past) (history-future h))) + (history-past-set! h (cdr past)) + (cadr past))))) + +(define (history-next! h) + (let ((future (history-future h))) + (and (pair? future) + (begin + (history-past-set! h (cons (car future) (history-past h))) + (history-future-set! h (cdr future)) + (car future))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; char and string utils + +(define (char-word-constituent? ch) + (or (char-alphabetic? ch) (char-numeric? ch) + (memv ch '(#\_ #\- #\+ #\:)))) + +(define (char-non-word-constituent? ch) (not (char-word-constituent? ch))) + +(define (string-copy! dst dstart src start end) + (if (>= start dstart) + (do ((i start (+ i 1)) (j dstart (+ j 1))) + ((= i end)) + (string-set! dst j (string-ref src i))) + (do ((i (- end 1) (- i 1)) (j (+ dstart (- end start 1)) (- j 1))) + ((< i start)) + (string-set! dst j (string-ref src i))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; buffers + +(define-record-type buffer + (%make-buffer refresh? min pos row max-row col gap width string history) + buffer? + (refresh? buffer-refresh? buffer-refresh?-set!) + (min buffer-min buffer-min-set!) + (pos buffer-pos buffer-pos-set!) + (row buffer-row buffer-row-set!) + (max-row buffer-max-row buffer-max-row-set!) + (col buffer-col buffer-col-set!) + (gap buffer-gap buffer-gap-set!) + (width buffer-width buffer-width-set!) + (string buffer-string buffer-string-set!) + (history buffer-history buffer-history-set!)) + +(define default-buffer-size 256) +(define default-buffer-width 80) + +(define (make-buffer) + (%make-buffer #f 0 0 0 0 0 default-buffer-size default-buffer-width + (make-string default-buffer-size) '())) + +(define (buffer->string buf) + (let ((str (buffer-string buf))) + (string-append (substring str (buffer-min buf) (buffer-pos buf)) + (substring str (buffer-gap buf) (string-length str))))) + +(define (buffer-right-length buf) + (- (string-length (buffer-string buf)) (buffer-gap buf))) +(define (buffer-length buf) + (+ (buffer-pos buf) (buffer-right-length buf))) +(define (buffer-free-space buf) + (- (buffer-gap buf) (buffer-pos buf))) + +(define (buffer-clamp buf n) + (max (buffer-min buf) (min n (buffer-length buf)))) + +(define (buffer-resize buf n) + (cond ((<= (buffer-free-space buf) n) + (let* ((right-len (buffer-right-length buf)) + (new-len (* 2 (max n (buffer-length buf)))) + (new-gap (- new-len right-len)) + (new (make-string new-len)) + (old (buffer-string buf))) + (string-copy! new 0 old 0 (buffer-pos buf)) + (string-copy! new new-gap old (buffer-gap buf) (string-length old)) + (buffer-string-set! buf new) + (buffer-gap-set! buf new-gap))))) + +(define (buffer-update-position! buf) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (end (string-length (buffer-string buf))) + (width (buffer-width buf))) + (let lp ((i 0) (row 0) (col 0)) ;; update row/col + (cond ((= i pos) + (buffer-row-set! buf row) + (buffer-col-set! buf col) + (lp gap row col)) + ((>= i end) + (buffer-max-row-set! + buf (if (and (zero? col) (> row 0)) (- row 1) row))) + ((= (+ col 1) width) + (lp (+ i 1) (+ row 1) 0)) + (else + (lp (+ i 1) row (+ col 1))))))) + +(define (buffer-draw buf out) + (let* ((gap (buffer-gap buf)) + (str (buffer-string buf)) + (end (string-length str)) + (old-row (buffer-row buf)) + (old-col (buffer-col buf))) + (buffer-update-position! buf) + ;; goto start of input + (terminal-goto-col out 0) + (if (positive? old-row) + (terminal-up out old-row)) + ;; clear and display new buffer + (terminal-clear-below out) + (display (substring str 0 (buffer-pos buf)) out) + (display (substring str (buffer-gap buf) end) out) + ;; move to next line if point at eol + (if (and (zero? (buffer-col buf)) (positive? (buffer-row buf))) + (write-char #\space out)) + ;; move to correct row then col + (if (< (buffer-row buf) (buffer-max-row buf)) + (terminal-up out (- (buffer-max-row buf) (buffer-row buf)))) + (terminal-goto-col out (buffer-col buf)))) + +(define (buffer-refresh buf out) + (cond ((buffer-refresh? buf) + (buffer-draw buf out) + (buffer-refresh?-set! buf #f)))) + +(define (buffer-goto! buf out n) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (n (buffer-clamp buf n))) + (cond ((not (= n pos)) + (buffer-update-position! buf) ;; XXXX shouldn't be needed + (if (< n pos) + (string-copy! str (- gap (- pos n)) str n pos) + (string-copy! str pos str gap (+ gap (- n pos)))) + (buffer-pos-set! buf n) + (buffer-gap-set! buf (+ gap (- n pos))) + (cond + ((not (buffer-refresh? buf)) + (let ((old-row (buffer-row buf))) + (buffer-update-position! buf) + (let ((row-diff (- old-row (buffer-row buf)))) + (cond ((> row-diff 0) (terminal-up out row-diff)) + ((< row-diff 0) (terminal-down out (- row-diff))))) + (terminal-goto-col out (buffer-col buf))))))))) + +(define (buffer-insert! buf out x) + (let ((len (if (char? x) 1 (string-length x))) + (pos (buffer-pos buf))) + (buffer-resize buf len) + (if (char? x) + (string-set! (buffer-string buf) pos x) + (string-copy! (buffer-string buf) pos x 0 len)) + (buffer-pos-set! buf (+ (buffer-pos buf) len)) + (cond + ((buffer-refresh? buf)) + ((and (= (buffer-gap buf) (string-length (buffer-string buf))) + (< (+ (buffer-col buf) len) (buffer-width buf))) + ;; fast path - append to end of buffer w/o wrapping to next line + (display x out) + (buffer-col-set! buf (+ (buffer-col buf) len))) + (else + (buffer-refresh?-set! buf #t))))) + +(define (buffer-delete! buf out start end) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (start (buffer-clamp buf start)) + (end (buffer-clamp buf end))) + (if (not (buffer-refresh? buf)) + (if (and (= start pos) (>= end (buffer-length buf))) + (terminal-clear-below out) + (buffer-refresh?-set! buf #t))) + (cond ((< end pos) + (string-copy! str start str end pos) + (buffer-pos-set! buf (+ start (- pos end)))) + ((> start gap) + (string-copy! str start str gap (+ gap (- end start))) + (buffer-gap-set! buf (+ gap (- end start)))) + (else + (buffer-pos-set! buf (min pos start)) + (buffer-gap-set! buf (max gap (+ pos (- gap pos) (- end pos)))))))) + +(define (buffer-skip buf pred) + (let* ((str (buffer-string buf)) (end (string-length str))) + (let lp ((i (buffer-gap buf))) + (if (or (>= i end) (not (pred (string-ref str i)))) + (+ (- i (buffer-gap buf)) (buffer-pos buf)) + (lp (+ i 1)))))) + +(define (buffer-skip-reverse buf pred) + (let ((str (buffer-string buf))) + (let lp ((i (- (buffer-pos buf) 1))) + (if (or (< i 0) (not (pred (string-ref str i)))) i (lp (- i 1)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; keymaps + +(define keymap? pair?) + +(define (make-keymap . o) + (cons (make-vector 256 #f) (and (pair? o) (car o)))) + +(define (make-sparse-keymap . o) + (cons '() (and (pair? o) (car o)))) + +(define (make-printable-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (do ((i #x20 (+ i 1))) ((= i #x7F) keymap) + (vector-set! v i command/self-insert)))) + +(define (make-standard-escape-bracket-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 65 command/backward-history) + (vector-set! v 66 command/forward-history) + (vector-set! v 67 command/forward-char) + (vector-set! v 68 command/backward-char) + keymap)) + +(define (make-standard-escape-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 8 command/backward-delete-word) + (vector-set! v 91 (make-standard-escape-bracket-keymap)) + (vector-set! v 98 command/backward-word) + (vector-set! v 100 command/forward-delete-word) + (vector-set! v 102 command/forward-word) + (vector-set! v 127 command/backward-delete-word) + keymap)) + +(define (make-standard-keymap) + (let* ((keymap (make-printable-keymap)) + (v (car keymap))) + (vector-set! v 1 command/beggining-of-line) + (vector-set! v 2 command/backward-char) + (vector-set! v 4 command/forward-delete-char) + (vector-set! v 5 command/end-of-line) + (vector-set! v 6 command/forward-char) + (vector-set! v 8 command/backward-delete-char) + (vector-set! v 10 command/enter) + (vector-set! v 11 command/forward-delete-line) + (vector-set! v 12 command/refresh) + (vector-set! v 13 command/enter) + (vector-set! v 21 command/backward-delete-line) + (vector-set! v 27 (make-standard-escape-keymap)) + (vector-set! v 127 command/backward-delete-char) + keymap)) + +(define (keymap-lookup keymap n) + (let ((table (car keymap))) + (or (if (vector? table) + (and (< n (vector-length table)) (vector-ref table n)) + (cond ((assv n table) => cdr) (else #f))) + (if (keymap? (cdr keymap)) + (keymap-lookup (cdr keymap) n) + (cdr keymap))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; commands + +(define (command/self-insert ch buf out return) + (buffer-insert! buf out ch)) + +(define (command/enter ch buf out return) + (command/end-of-line ch buf out return) + (newline out) + (return)) + +(define (command/beep ch buf out return) + (write-char (integer->char 7) out)) + +(define (command/refresh ch buf out return) + (buffer-draw buf out)) + +(define (command/beggining-of-line ch buf out return) + (buffer-goto! buf out 0)) + +(define (command/end-of-line ch buf out return) + (buffer-goto! buf out (buffer-length buf))) + +(define (command/forward-char ch buf out return) + (buffer-goto! buf out (+ (buffer-pos buf) 1))) + +(define (command/backward-char ch buf out return) + (buffer-goto! buf out (- (buffer-pos buf) 1))) + +(define (command/forward-delete-char ch buf out return) + (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1))) + +(define (command/backward-delete-char ch buf out return) + (buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf))) + +(define (command/forward-delete-line ch buf out return) + (buffer-delete! buf out (buffer-pos buf) (buffer-length buf))) + +(define (command/backward-delete-line ch buf out return) + (buffer-delete! buf out 0 (buffer-pos buf))) + +(define (command/backward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-past history))) + (if (null? (history-future history)) + (history-insert! history (buffer->string buf))) + (cond + ((pair? (cdr (history-past history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (buffer-insert! buf out (history-prev! history)))))))) + +(define (command/forward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-future history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (let ((res (buffer-insert! buf out (history-next! history)))) + (if (null? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + res))))) + +(define (command/forward-word ch buf out return) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-goto! buf out (buffer-skip buf char-word-constituent?))) + +(define (command/backward-word ch buf out return) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (buffer-goto! buf out (+ (buffer-skip-reverse buf char-word-constituent?) 1))) + +(define (command/forward-delete-word ch buf out return) + (let ((start (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-delete! buf out start (buffer-skip buf char-word-constituent?)))) + +(define (command/backward-delete-word ch buf out return) + (let ((end (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (let ((start (buffer-skip-reverse buf char-word-constituent?))) + (buffer-delete! buf out (+ start 1) end)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; line-editing + +(define standard-keymap (make-standard-keymap)) + +(define (get-key ls key . o) + (let ((x (memq key ls))) + (if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o))))) + +(define (with-leading-ports ls proc) + (if (and (pair? ls) (input-port? (car ls))) + (if (and (pair? (cdr ls)) (output-port? (cadr ls))) + (proc (car ls) (cadr ls) (cddr ls)) + (proc (car ls) (current-output-port) (cdr ls))) + (proc (current-input-port) (current-output-port) ls))) + +(define (make-line-editor . args) + (let* ((prompt (get-key args 'prompt: "> ")) + (history (get-key args 'history:)) + (terminal-width (get-key args 'terminal-width:)) + (keymap (get-key args 'keymap: standard-keymap))) + (lambda (in out) + (let* ((width (or terminal-width (get-terminal-width out))) + (buf (make-buffer)) + (done? #f) + (return (lambda o (set! done? #t)))) + (buffer-refresh?-set! buf #t) + (buffer-width-set! buf width) + (buffer-insert! buf out prompt) + (buffer-min-set! buf (string-length prompt)) + (buffer-history-set! buf history) + (buffer-refresh buf out) + (flush-output out) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp ((kmap keymap)) + (let ((ch (read-char in))) + (if (eof-object? ch) + (buffer->string buf) + (let ((x (keymap-lookup kmap (char->integer ch)))) + (cond + ((keymap? x) + (lp x)) + ((procedure? x) + (x ch buf out return) + (buffer-refresh buf out) + (if done? (buffer->string buf) (lp keymap))) + (else + ;;(command/beep ch buf out return) + (lp keymap))))))))))))) + +(define (edit-line . args) + (with-leading-ports + args + (lambda (in out rest) ((apply make-line-editor rest) in out)))) + +(define (edit-line-repl . args) + (with-leading-ports + args + (lambda (in out rest) + (let ((eval (get-key rest 'eval: (lambda (x) x))) + (print (get-key rest 'write: write)) + (history (or (get-key rest 'history:) (make-history)))) + (let ((edit-line + (apply make-line-editor 'no-stty?: #t 'history: history rest))) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp () + (let ((line (edit-line in out))) + (if (pair? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + (history-commit! history line) + (print (eval line) out) + (newline out) + (lp)))))))))) From 5d21ee0b7c2d82d401db055a9031c62012abe328 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 18 May 2010 07:33:16 +0900 Subject: [PATCH 428/535] removing dependency on x86.c --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 60a3213d..7949a71b 100644 --- a/Makefile +++ b/Makefile @@ -109,7 +109,7 @@ include/chibi/install.h: Makefile sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< -eval.o: eval.c opcodes.c vm.c opt/x86.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile +eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile From b0bc96fc055ab009a0ebf6f812e4f0a0ca697132 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 13 Jun 2010 22:58:09 +0900 Subject: [PATCH 429/535] fixing symbol sorting --- lib/srfi/95.module | 2 +- lib/srfi/95/qsort.c | 53 ++++++++++++++++++++++++++++++++++++++++++-- tests/sort-tests.scm | 6 +++++ 3 files changed, 58 insertions(+), 3 deletions(-) diff --git a/lib/srfi/95.module b/lib/srfi/95.module index 25e0d3ff..43bab9dd 100644 --- a/lib/srfi/95.module +++ b/lib/srfi/95.module @@ -1,6 +1,6 @@ (define-module (srfi 95) - (export sorted? merge merge! sort sort!) + (export sorted? merge merge! sort sort! object-cmp) (import-immutable (scheme)) (include-shared "95/qsort") (include "95/sort.scm")) diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c index 438820f9..4b5d36aa 100644 --- a/lib/srfi/95/qsort.c +++ b/lib/srfi/95/qsort.c @@ -4,6 +4,10 @@ #include "chibi/eval.h" +#if SEXP_USE_HUFF_SYMS +#include "../../../opt/sexp-hufftabs.c" +#endif + #define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var) static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) { @@ -32,8 +36,28 @@ static int sexp_basic_comparator (sexp op) { return 0; } +#if SEXP_USE_HUFF_SYMS +static int sexp_isymbol_compare (sexp ctx, sexp a, sexp b) { + int res, res2, tmp; + sexp_uint_t c = ((sexp_uint_t)a)>>3, d = ((sexp_uint_t)b)>>3; + while (c && d) { +#include "../../../opt/sexp-unhuff.c" +#define c d +#define res res2 +#include "../../../opt/sexp-unhuff.c" +#undef c +#undef res + if ((tmp=res-res2) != 0) + return tmp; + } + return c ? 1 : d ? -1 : 0; +} +#endif + static int sexp_object_compare (sexp ctx, sexp a, sexp b) { int res; + if (a == b) + return 0; if (sexp_pointerp(a)) { if (sexp_pointerp(b)) { if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) { @@ -49,22 +73,46 @@ static int sexp_object_compare (sexp ctx, sexp a, sexp b) { case SEXP_STRING: res = strcmp(sexp_string_data(a), sexp_string_data(b)); break; + case SEXP_SYMBOL: + res = strcmp(sexp_string_data(sexp_symbol_string(a)), + sexp_string_data(sexp_symbol_string(b))); + break; default: res = 0; break; } } +#if SEXP_USE_HUFF_SYMS + } else if (sexp_lsymbolp(a) && sexp_isymbolp(b)) { + res = sexp_object_compare(ctx, sexp_symbol_string(a), + sexp_write_to_string(ctx, b)); +#endif } else { res = 1; } } else if (sexp_pointerp(b)) { - res = -1; +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_lsymbolp(b)) + res = sexp_object_compare(ctx, sexp_symbol_string(b), + sexp_write_to_string(ctx, a)); + else +#endif + res = -1; } else { - res = (sexp_sint_t)a - (sexp_sint_t)b; +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_isymbolp(b)) + return sexp_isymbol_compare(ctx, a, b); + else +#endif + res = (sexp_sint_t)a - (sexp_sint_t)b; } return res; } +static sexp sexp_object_compare_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + return sexp_make_fixnum(sexp_object_compare(ctx, a, b)); +} + static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) { sexp_sint_t mid, i, j; sexp tmp, tmp2; @@ -174,6 +222,7 @@ static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, } sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "object-cmp", 2, sexp_object_compare_op); sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE); return SEXP_VOID; } diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm index a0cc92f4..5471e648 100644 --- a/tests/sort-tests.scm +++ b/tests/sort-tests.scm @@ -47,5 +47,11 @@ (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) (lambda (a b) (< (car a) (car b)))) '((1) (2) (3) (4) (5) (6) (7) (8) (9))) +(test "sort 1-char symbols" (sort '(h b k d a c j i e g f)) + '(a b c d e f g h i j k)) +(test "sort short symbols" (sort '(h b aa k d a ee c j i e g f)) + '(a aa b c d e ee f g h i j k)) +(test "sort long symbols" (sort '(h b aa k d a ee c j i bzzzzzzzzzzzzzzzzzzzzzzz e g f)) + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz c d e ee f g h i j k)) (test-report) From a24de22094429035d7a68f28441993256b5ac45c Mon Sep 17 00:00:00 2001 From: foof Date: Mon, 21 Jun 2010 14:42:36 +0000 Subject: [PATCH 430/535] gc bug fixes, adding optional gc debugging utils --- eval.c | 26 ++++++++++++---------- gc.c | 48 +++++++++++++++++++++++++++++++++------- include/chibi/features.h | 23 ++++++++++++++++++- include/chibi/sexp.h | 28 ++++++++++++++++++----- lib/chibi/disasm.c | 2 +- sexp.c | 16 ++++++++++---- vm.c | 2 +- 7 files changed, 113 insertions(+), 32 deletions(-) diff --git a/eval.c b/eval.c index e395ea57..9123cd60 100644 --- a/eval.c +++ b/eval.c @@ -337,18 +337,18 @@ static void sexp_add_path (sexp ctx, const char *str) { } void sexp_init_eval_context_globals (sexp ctx) { - sexp_gc_var2(tmp, vec); + sexp_gc_var3(tmp, vec, ctx2); ctx = sexp_make_child_context(ctx, NULL); - sexp_gc_preserve2(ctx, tmp, vec); + sexp_gc_preserve3(ctx, tmp, vec, ctx2); vec = sexp_intern(ctx, "*current-exception-handler*", -1); sexp_global(ctx, SEXP_G_ERR_HANDLER) = sexp_env_cell_create(ctx, sexp_context_env(ctx), vec, SEXP_FALSE, NULL); #if ! SEXP_USE_NATIVE_X86 emit(ctx, SEXP_OP_RESUMECC); sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); - ctx = sexp_make_child_context(ctx, NULL); - emit(ctx, SEXP_OP_DONE); - tmp = finalize_bytecode(ctx); + ctx2 = sexp_make_child_context(ctx, NULL); + emit(ctx2, SEXP_OP_DONE); + tmp = finalize_bytecode(ctx2); vec = sexp_make_vector(ctx, 0, SEXP_VOID); sexp_global(ctx, SEXP_G_FINAL_RESUMER) = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); @@ -362,7 +362,7 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); tmp = sexp_c_string(ctx, ".", 1); sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); - sexp_gc_release2(ctx); + sexp_gc_release3(ctx); } sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size) { @@ -390,10 +390,12 @@ sexp sexp_make_child_context (sexp ctx, sexp lambda) { sexp_context_stack(ctx), sexp_context_env(ctx), 0); - sexp_context_lambda(res) = lambda; - sexp_context_top(res) = sexp_context_top(ctx); - sexp_context_fv(res) = sexp_context_fv(ctx); - sexp_context_tracep(res) = sexp_context_tracep(ctx); + if (! sexp_exceptionp(res)) { + sexp_context_lambda(res) = lambda; + sexp_context_top(res) = sexp_context_top(ctx); + sexp_context_fv(res) = sexp_context_fv(ctx); + sexp_context_tracep(res) = sexp_context_tracep(ctx); + } return res; } @@ -547,7 +549,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { 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_copy_list(ctx, sexp_cadr(x))); + res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x))); ctx2 = sexp_make_child_context(ctx, res); tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); @@ -581,7 +583,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { } sexp_lambda_body(res) = body; cleanup: - sexp_gc_release1(ctx); + sexp_gc_release6(ctx); return res; } diff --git a/gc.c b/gc.c index bb5e7b87..fb15ec13 100644 --- a/gc.c +++ b/gc.c @@ -8,21 +8,21 @@ #include #endif -#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair)) - #if SEXP_64_BIT #define sexp_heap_align(n) sexp_align(n, 5) #else #define sexp_heap_align(n) sexp_align(n, 4) #endif +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(sexp_sizeof(pair))) + #define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1)) #if SEXP_USE_GLOBAL_HEAP sexp_heap sexp_global_heap; #endif -#if SEXP_USE_DEBUG_GC +#if SEXP_USE_CONSERVATIVE_GC static sexp* stack_base; #endif @@ -41,6 +41,25 @@ sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) { return res; } +#if SEXP_USE_SAFE_GC_MARK +static int sexp_in_heap(sexp ctx, sexp_uint_t x) { + sexp_heap h; + if (x & (sexp_heap_align(1)-1)) { + fprintf(stderr, "invalid heap alignment: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; + } + for (h=sexp_context_heap(ctx); h; h=h->next) + if (((sexp_uint_t)h < x) && (x < (sexp_uint_t)(h->data + h->size))) + return 1; + fprintf(stderr, "invalid object outside heap: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; +} +#endif + +#if SEXP_USE_DEBUG_GC +#include "opt/gc_debug.c" +#endif + void sexp_mark (sexp ctx, sexp x) { sexp_sint_t i, len; sexp t, *p; @@ -48,6 +67,16 @@ void sexp_mark (sexp ctx, sexp x) { loop: if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x)) return; +#if SEXP_USE_SAFE_GC_MARK + if (! sexp_in_heap(ctx, (sexp_uint_t)x)) + return; +#endif +#if SEXP_USE_HEADER_MAGIC + if (sexp_pointer_magic(x) != SEXP_POINTER_MAGIC && sexp_pointer_tag(x) != SEXP_TYPE + && sexp_pointer_tag(x) != SEXP_OPCODE && sexp_pointer_tag(x) != SEXP_CORE + && sexp_pointer_tag(x) != SEXP_STACK) + return; +#endif sexp_gc_mark(x) = 1; if (sexp_contextp(x)) for (saves=sexp_context_saves(x); saves; saves=saves->next) @@ -63,7 +92,7 @@ void sexp_mark (sexp ctx, sexp x) { } } -#if SEXP_USE_DEBUG_GC +#if SEXP_USE_CONSERVATIVE_GC int stack_references_pointer_p (sexp ctx, sexp x) { sexp *p; for (p=(&x)+1; pnext) { p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); q = h->free_list; - end = (sexp) ((char*)h->data + h->size); + end = (sexp) ((char*)h->data + h->size - sexp_heap_align(sexp_sizeof(pair))); while (p < end) { /* find the preceding and succeeding free list pointers */ for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) @@ -148,6 +177,9 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) { sexp_mark(ctx, sexp_symbol_table[i]); #endif sexp_mark(ctx, ctx); +#if SEXP_USE_DEBUG_GC + sexp_sweep_stats(ctx, 2, NULL, "* \x1B[31mFREE:\x1B[0m "); +#endif res = sexp_sweep(ctx, sum_freed); return res; } @@ -166,7 +198,7 @@ sexp_heap sexp_make_heap (size_t 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))); + 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)); @@ -308,13 +340,13 @@ sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { #endif void sexp_gc_init (void) { -#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_DEBUG_GC +#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_CONSERVATIVE_GC sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); #endif #if SEXP_USE_GLOBAL_HEAP sexp_global_heap = sexp_make_heap(size); #endif -#if SEXP_USE_DEBUG_GC +#if SEXP_USE_CONSERVATIVE_GC /* the +32 is a hack, but this is just for debugging anyway */ stack_base = ((sexp*)&size) + 32; #endif diff --git a/include/chibi/features.h b/include/chibi/features.h index a3a7d7b2..562d0d49 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -66,6 +66,15 @@ /* uncomment this to add conservative checks to the native GC */ /* Please mail the author if enabling this makes a bug */ /* go away and you're not working on your own C extension. */ +/* #define SEXP_USE_CONSERVATIVE_GC 1 */ + +/* uncomment this to add additional native checks to only mark objects in the heap */ +/* #define SEXP_USE_SAFE_GC_MARK 1 */ + +/* uncomment this to add additional native gc checks to verify a magic header */ +/* #define SEXP_USE_HEADER_MAGIC 1 */ + +/* uncomment this to add very verbose debugging stats to the native GC */ /* #define SEXP_USE_DEBUG_GC 1 */ /* uncomment this to make the heap common to all contexts */ @@ -175,7 +184,7 @@ #define SEXP_MAXIMUM_HEAP_SIZE 0 #endif #ifndef SEXP_MINIMUM_HEAP_SIZE -#define SEXP_MINIMUM_HEAP_SIZE 512*1024 +#define SEXP_MINIMUM_HEAP_SIZE 8*1024 #endif /* if after GC more than this percentage of memory is still in use, */ @@ -257,6 +266,18 @@ #define SEXP_USE_DEBUG_GC 0 #endif +#ifndef SEXP_USE_SAFE_GC_MARK +#define SEXP_USE_SAFE_GC_MARK 0 +#endif + +#ifndef SEXP_USE_CONSERVATIVE_GC +#define SEXP_USE_CONSERVATIVE_GC 0 +#endif + +#ifndef SEXP_USE_HEADER_MAGIC +#define SEXP_USE_HEADER_MAGIC 0 +#endif + #ifndef SEXP_USE_GLOBAL_HEAP #if SEXP_USE_BOEHM || SEXP_USE_MALLOC #define SEXP_USE_GLOBAL_HEAP 1 diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 9cd0807f..004b1c6a 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -64,6 +64,10 @@ typedef unsigned long size_t; #define SEXP_CHAR_TAG 6 #define SEXP_EXTENDED_TAG 14 +#ifndef SEXP_POINTER_MAGIC +#define SEXP_POINTER_MAGIC 0xFDCA9764uL /* arbitrary */ +#endif + #if SEXP_USE_HASH_SYMS #define SEXP_SYMBOL_TABLE_SIZE 389 #else @@ -105,8 +109,8 @@ enum sexp_types { SEXP_NUM_CORE_TYPES }; -typedef unsigned long sexp_uint_t; -typedef long sexp_sint_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; #if SEXP_64_BIT typedef unsigned int sexp_tag_t; #else @@ -154,12 +158,16 @@ struct sexp_heap_t { sexp_uint_t size; sexp_free_list free_list; sexp_heap next; + /* note this must be aligned on a proper heap boundary, */ + /* so we can't just use char data[] */ char *data; }; struct sexp_gc_var_t { sexp *var; - /* char *name; */ +#if SEXP_USE_CONSERVATIVE_GC + char *name; +#endif struct sexp_gc_var_t *next; }; @@ -168,6 +176,9 @@ struct sexp_struct { char gc_mark; unsigned int immutablep:1; unsigned int freep:1; +#if SEXP_USE_HEADER_MAGIC + unsigned int magic; +#endif union { /* basic types */ double flonum; @@ -314,10 +325,16 @@ struct sexp_struct { sexp x = SEXP_VOID; \ struct sexp_gc_var_t y = {NULL, NULL}; +#if SEXP_USE_CONSERVATIVE_GC +#define sexp_gc_preserve_name(ctx, x, y) (y).name = #x +#else +#define sexp_gc_preserve_name(ctx, x, y) +#endif + #define sexp_gc_preserve(ctx, x, y) \ do { \ + sexp_gc_preserve_name(ctx, x, y); \ (y).var = &(x); \ - /* (y).name = #x; */ \ (y).next = sexp_context_saves(ctx); \ sexp_context_saves(ctx) = &(y); \ } while (0) @@ -403,6 +420,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_flags(x) ((x)->flags) #define sexp_immutablep(x) ((x)->immutablep) #define sexp_freep(x) ((x)->freep) +#define sexp_pointer_magic(x) ((x)->magic) #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) @@ -829,7 +847,7 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); #define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) -SEXP_API sexp sexp_make_context(sexp ctx, sexp_uint_t size); +SEXP_API sexp sexp_make_context(sexp ctx, size_t size); SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); SEXP_API sexp sexp_cons_op(sexp ctx sexp_api_params(self, n), sexp head, sexp tail); SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index 57dcf94d..21262128 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -74,7 +74,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { case SEXP_OP_FCALL4: case SEXP_OP_FCALL5: case SEXP_OP_FCALL6: - sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); + sexp_printf(ctx, out, "%d", (sexp_sint_t) ((sexp*)ip)[0]); ip += sizeof(sexp); break; case SEXP_OP_SLOT_REF: diff --git a/sexp.c b/sexp.c index 35861be0..9ed7c016 100644 --- a/sexp.c +++ b/sexp.c @@ -49,7 +49,12 @@ 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 && ! sexp_exceptionp(res)) sexp_pointer_tag(res) = tag; + if (res && ! sexp_exceptionp(res)) { + sexp_pointer_tag(res) = tag; +#if SEXP_USE_HEADER_MAGIC + sexp_pointer_magic(res) = SEXP_POINTER_MAGIC; +#endif + } return res; } @@ -266,7 +271,7 @@ sexp sexp_bootstrap_context (sexp_uint_t size) { } #endif -sexp sexp_make_context (sexp ctx, sexp_uint_t size) { +sexp sexp_make_context (sexp ctx, size_t size) { sexp_gc_var1(res); if (ctx) sexp_gc_preserve1(ctx, res); #if ! SEXP_USE_GLOBAL_HEAP @@ -550,8 +555,8 @@ sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { sexp sexp_copy_list_op (sexp ctx sexp_api_params(self, n), sexp ls) { sexp tmp; sexp_gc_var1(res); - sexp_gc_preserve1(ctx, res); if (! sexp_pairp(ls)) return ls; + sexp_gc_preserve1(ctx, res); tmp = res = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); for (ls=sexp_cdr(ls); sexp_pairp(ls); ls=sexp_cdr(ls), tmp=sexp_cdr(tmp)) sexp_cdr(tmp) = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); @@ -664,6 +669,9 @@ sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); if (sexp_exceptionp(s)) return s; sexp_pointer_tag(s) = SEXP_STRING; +#if SEXP_USE_HEADER_MAGIC + sexp_pointer_magic(s) = SEXP_POINTER_MAGIC; +#endif sexp_string_length(s) = clen; if (sexp_charp(ch)) memset(sexp_string_data(s), sexp_unbox_character(ch), clen); @@ -1205,7 +1213,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { break; } } else if (sexp_fixnump(obj)) { - snprintf(numbuf, NUMBUF_LEN, "%ld", sexp_unbox_fixnum(obj)); + snprintf(numbuf, NUMBUF_LEN, "%d", sexp_unbox_fixnum(obj)); sexp_write_string(ctx, numbuf, out); #if SEXP_USE_IMMEDIATE_FLONUMS } else if (sexp_flonump(obj)) { diff --git a/vm.c b/vm.c index 6a53e941..88bf4fcc 100644 --- a/vm.c +++ b/vm.c @@ -421,7 +421,7 @@ static sexp_uint_t sexp_restore_stack (sexp saved, sexp *current) { #define _PUSH(x) (stack[top++]=(x)) #if SEXP_USE_ALIGNED_BYTECODE -#define _ALIGN_IP() ip = (unsigned char *)sexp_word_align((unsigned long)ip) +#define _ALIGN_IP() ip = (unsigned char *)sexp_word_align((sexp_uint_t)ip) #else #define _ALIGN_IP() #endif From 47a1c6111727447ed430f58cc4549ded0a30b972 Mon Sep 17 00:00:00 2001 From: foof Date: Tue, 22 Jun 2010 13:30:24 +0000 Subject: [PATCH 431/535] need to free the buffer when using open_memstream (unlike how it's done in the sample in the manpage) --- sexp.c | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/sexp.c b/sexp.c index 9ed7c016..41e72cc1 100644 --- a/sexp.c +++ b/sexp.c @@ -61,12 +61,11 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port) { if (sexp_port_openp(port)) { sexp_port_openp(port) = 0; - if (sexp_port_stream(port) && ! sexp_port_no_closep(port)) + if (sexp_port_stream(port) && ! sexp_port_no_closep(port)) { fclose(sexp_port_stream(port)); -#if ! SEXP_USE_STRING_STREAMS - if (sexp_port_buf(port) && sexp_oportp(port)) - free(sexp_port_buf(port)); -#endif + if (sexp_port_buf(port) && sexp_oportp(port)) + free(sexp_port_buf(port)); + } } return SEXP_VOID; } From 998951cab0c32dfa9c5eb290675497c25a846a32 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 22 Jun 2010 13:32:04 +0000 Subject: [PATCH 432/535] using memmove instead of memcpy for potentially overlapping bignum copies --- opt/bignum.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/opt/bignum.c b/opt/bignum.c index 5ad40e70..09c82ded 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -79,13 +79,13 @@ sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); if (! dst || sexp_bignum_length(dst) < len) { dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); - memcpy(dst, a, size); + memmove(dst, a, size); sexp_bignum_length(dst) = len; } else { memset(dst->value.bignum.data, 0, sexp_bignum_length(dst)*sizeof(sexp_uint_t)); - memcpy(dst->value.bignum.data, a->value.bignum.data, - sexp_bignum_length(a)*sizeof(sexp_uint_t)); + memmove(dst->value.bignum.data, a->value.bignum.data, + sexp_bignum_length(a)*sizeof(sexp_uint_t)); } return dst; } From 93e2927e9adb80399d011b4cfc68bf0c7257de6b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 22 Jun 2010 13:33:24 +0000 Subject: [PATCH 433/535] destroying context at end of main (this is continuing a streak of valgrind errors) --- main.c | 1 + 1 file changed, 1 insertion(+) diff --git a/main.c b/main.c index c1d3fe54..7ecc913f 100644 --- a/main.c +++ b/main.c @@ -207,6 +207,7 @@ void run_main (int argc, char **argv) { } sexp_gc_release2(ctx); + sexp_destroy_context(ctx); } int main (int argc, char **argv) { From 09a9970f269b960ee57edd2abd57aa74ca794d1b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 22 Jun 2010 22:48:09 +0900 Subject: [PATCH 434/535] 64-bit fixes --- .hgignore | 28 + AUTHORS | 24 + COPYING | 24 + Makefile | 215 +++ README | 440 ++++++ RELEASE | 1 + TODO | 150 ++ VERSION | 1 + doc/chibi-scheme.1 | 133 ++ eval.c | 1579 +++++++++++++++++++++ gc.c | 354 +++++ include/chibi/bignum.h | 43 + include/chibi/eval.h | 192 +++ include/chibi/features.h | 403 ++++++ include/chibi/sexp.h | 966 +++++++++++++ lib/chibi/ast.c | 79 ++ lib/chibi/ast.module | 15 + lib/chibi/base64.module | 7 + lib/chibi/base64.scm | 351 +++++ lib/chibi/disasm.c | 116 ++ lib/chibi/disasm.module | 5 + lib/chibi/filesystem.module | 27 + lib/chibi/filesystem.scm | 43 + lib/chibi/filesystem.stub | 118 ++ lib/chibi/heap-stats.c | 129 ++ lib/chibi/heap-stats.module | 6 + lib/chibi/io.module | 13 + lib/chibi/io/io.scm | 170 +++ lib/chibi/io/io.stub | 27 + lib/chibi/io/port.c | 196 +++ lib/chibi/loop.module | 9 + lib/chibi/loop/loop.scm | 365 +++++ lib/chibi/macroexpand.module | 6 + lib/chibi/macroexpand.scm | 85 ++ lib/chibi/match.module | 6 + lib/chibi/match/match.scm | 670 +++++++++ lib/chibi/mime.module | 7 + lib/chibi/mime.scm | 410 ++++++ lib/chibi/net.module | 11 + lib/chibi/net.scm | 32 + lib/chibi/net.stub | 25 + lib/chibi/net/http.module | 7 + lib/chibi/net/http.scm | 180 +++ lib/chibi/pathname.module | 7 + lib/chibi/pathname.scm | 180 +++ lib/chibi/process.module | 17 + lib/chibi/process.stub | 72 + lib/chibi/quoted-printable.module | 7 + lib/chibi/quoted-printable.scm | 157 +++ lib/chibi/signal.c | 62 + lib/chibi/stty.module | 11 + lib/chibi/stty.scm | 235 ++++ lib/chibi/stty.stub | 106 ++ lib/chibi/system.module | 15 + lib/chibi/system.stub | 34 + lib/chibi/term/edit-line.module | 5 + lib/chibi/term/edit-line.scm | 492 +++++++ lib/chibi/time.module | 12 + lib/chibi/time.stub | 46 + lib/chibi/uri.module | 10 + lib/chibi/uri.scm | 306 ++++ lib/config.scm | 177 +++ lib/init.scm | 875 ++++++++++++ lib/srfi/1.module | 31 + lib/srfi/1/alists.scm | 14 + lib/srfi/1/constructors.scm | 36 + lib/srfi/1/deletion.scm | 25 + lib/srfi/1/fold.scm | 115 ++ lib/srfi/1/lset.scm | 51 + lib/srfi/1/misc.scm | 54 + lib/srfi/1/predicates.scm | 42 + lib/srfi/1/search.scm | 54 + lib/srfi/1/selectors.scm | 59 + lib/srfi/11.module | 28 + lib/srfi/16.module | 24 + lib/srfi/2.module | 16 + lib/srfi/26.module | 24 + lib/srfi/27.module | 11 + lib/srfi/27/constructors.scm | 10 + lib/srfi/27/rand.c | 204 +++ lib/srfi/33.module | 17 + lib/srfi/33/bit.c | 303 ++++ lib/srfi/33/bitwise.scm | 61 + lib/srfi/39.module | 25 + lib/srfi/6.module | 5 + lib/srfi/69.module | 17 + lib/srfi/69/hash.c | 242 ++++ lib/srfi/69/interface.scm | 115 ++ lib/srfi/69/type.scm | 12 + lib/srfi/8.module | 10 + lib/srfi/9.module | 85 ++ lib/srfi/95.module | 7 + lib/srfi/95/qsort.c | 228 +++ lib/srfi/95/sort.scm | 70 + lib/srfi/98.module | 5 + lib/srfi/98/env.c | 48 + main.c | 217 +++ mkfile | 28 + opcodes.c | 154 ++ opt/bignum.c | 775 +++++++++++ opt/plan9-opcodes.c | 19 + opt/plan9.c | 351 +++++ opt/sexp-huff.c | 128 ++ opt/sexp-hufftabs.c | 92 ++ opt/sexp-unhuff.c | 71 + opt/simplify.c | 143 ++ sexp.c | 1776 ++++++++++++++++++++++++ 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 | 48 + tests/basic/test10-unhygiene.res | 6 + tests/basic/test10-unhygiene.scm | 49 + tests/build/build-opts.txt | 21 + tests/build/build-tests.sh | 37 + tests/hash-tests.scm | 74 + tests/install/install-tests.pl | 57 + tests/install/run-install-test.sh | 12 + tests/loop-tests.scm | 202 +++ tests/match-tests.scm | 196 +++ tests/numeric-tests.scm | 150 ++ tests/r5rs-tests.scm | 483 +++++++ tests/sort-tests.scm | 57 + tools/genstatic.scm | 135 ++ tools/genstubs.scm | 1237 +++++++++++++++++ vm.c | 1226 ++++++++++++++++ 142 files changed, 20448 insertions(+) create mode 100644 .hgignore create mode 100644 AUTHORS create mode 100644 COPYING create mode 100644 Makefile create mode 100644 README create mode 100644 RELEASE create mode 100644 TODO create mode 100644 VERSION create mode 100644 doc/chibi-scheme.1 create mode 100644 eval.c create mode 100644 gc.c create mode 100644 include/chibi/bignum.h create mode 100644 include/chibi/eval.h create mode 100644 include/chibi/features.h create mode 100644 include/chibi/sexp.h create mode 100644 lib/chibi/ast.c create mode 100644 lib/chibi/ast.module create mode 100644 lib/chibi/base64.module create mode 100644 lib/chibi/base64.scm create mode 100644 lib/chibi/disasm.c create mode 100644 lib/chibi/disasm.module create mode 100644 lib/chibi/filesystem.module create mode 100644 lib/chibi/filesystem.scm create mode 100644 lib/chibi/filesystem.stub create mode 100644 lib/chibi/heap-stats.c create mode 100644 lib/chibi/heap-stats.module create mode 100644 lib/chibi/io.module create mode 100644 lib/chibi/io/io.scm create mode 100644 lib/chibi/io/io.stub create mode 100644 lib/chibi/io/port.c create mode 100644 lib/chibi/loop.module create mode 100644 lib/chibi/loop/loop.scm create mode 100644 lib/chibi/macroexpand.module create mode 100644 lib/chibi/macroexpand.scm create mode 100644 lib/chibi/match.module create mode 100644 lib/chibi/match/match.scm create mode 100644 lib/chibi/mime.module create mode 100644 lib/chibi/mime.scm create mode 100644 lib/chibi/net.module create mode 100644 lib/chibi/net.scm create mode 100644 lib/chibi/net.stub create mode 100644 lib/chibi/net/http.module create mode 100644 lib/chibi/net/http.scm create mode 100644 lib/chibi/pathname.module create mode 100644 lib/chibi/pathname.scm create mode 100644 lib/chibi/process.module create mode 100644 lib/chibi/process.stub create mode 100644 lib/chibi/quoted-printable.module create mode 100644 lib/chibi/quoted-printable.scm create mode 100644 lib/chibi/signal.c create mode 100644 lib/chibi/stty.module create mode 100644 lib/chibi/stty.scm create mode 100644 lib/chibi/stty.stub create mode 100644 lib/chibi/system.module create mode 100644 lib/chibi/system.stub create mode 100644 lib/chibi/term/edit-line.module create mode 100644 lib/chibi/term/edit-line.scm create mode 100644 lib/chibi/time.module create mode 100644 lib/chibi/time.stub create mode 100644 lib/chibi/uri.module create mode 100644 lib/chibi/uri.scm create mode 100644 lib/config.scm create mode 100644 lib/init.scm create mode 100644 lib/srfi/1.module create mode 100644 lib/srfi/1/alists.scm create mode 100644 lib/srfi/1/constructors.scm create mode 100644 lib/srfi/1/deletion.scm create mode 100644 lib/srfi/1/fold.scm create mode 100644 lib/srfi/1/lset.scm create mode 100644 lib/srfi/1/misc.scm create mode 100644 lib/srfi/1/predicates.scm create mode 100644 lib/srfi/1/search.scm create mode 100644 lib/srfi/1/selectors.scm create mode 100644 lib/srfi/11.module create mode 100644 lib/srfi/16.module create mode 100644 lib/srfi/2.module create mode 100644 lib/srfi/26.module create mode 100644 lib/srfi/27.module create mode 100644 lib/srfi/27/constructors.scm create mode 100644 lib/srfi/27/rand.c create mode 100644 lib/srfi/33.module create mode 100644 lib/srfi/33/bit.c create mode 100644 lib/srfi/33/bitwise.scm create mode 100644 lib/srfi/39.module create mode 100644 lib/srfi/6.module create mode 100644 lib/srfi/69.module create mode 100644 lib/srfi/69/hash.c create mode 100644 lib/srfi/69/interface.scm create mode 100644 lib/srfi/69/type.scm create mode 100644 lib/srfi/8.module create mode 100644 lib/srfi/9.module create mode 100644 lib/srfi/95.module create mode 100644 lib/srfi/95/qsort.c create mode 100644 lib/srfi/95/sort.scm create mode 100644 lib/srfi/98.module create mode 100644 lib/srfi/98/env.c create mode 100644 main.c create mode 100644 mkfile create mode 100644 opcodes.c create mode 100644 opt/bignum.c create mode 100644 opt/plan9-opcodes.c create mode 100644 opt/plan9.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 opt/simplify.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/build/build-opts.txt create mode 100755 tests/build/build-tests.sh create mode 100644 tests/hash-tests.scm create mode 100755 tests/install/install-tests.pl create mode 100755 tests/install/run-install-test.sh create mode 100644 tests/loop-tests.scm create mode 100644 tests/match-tests.scm create mode 100644 tests/numeric-tests.scm create mode 100644 tests/r5rs-tests.scm create mode 100644 tests/sort-tests.scm create mode 100755 tools/genstatic.scm create mode 100755 tools/genstubs.scm create mode 100644 vm.c diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..d1af4846 --- /dev/null +++ b/.hgignore @@ -0,0 +1,28 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dylib +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +clibs.c +chibi-scheme +chibi-scheme-static +include/chibi/install.h +lib/chibi/filesystem.c +lib/chibi/io/io.c +lib/chibi/net.c +lib/chibi/process.c +lib/chibi/system.c +lib/chibi/time.c diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 00000000..df7959c1 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,24 @@ +Alex Shinn wrote the initial version of chibi-scheme and all +distributed modules. + +The `dynamic-wind' implementation is adapted from the implementation +in the appendix to the Scheme48 reference manual, reportedly first +written by Chris Hanson and John Lamping. + +Thanks to the following people for patches: + + * Andreas Rottman + * Bruno Deferrari + * Derrick Eddington + * Felix Winkelmann + * Gregor Klinke + * John Cowan + * John Samsa + * Lars J Aas + * Lorenzo Campedelli + * sladegen + +If you would prefer not to be listed, or are one of the users listed +without a full name, please contact me. If you've made a contribution +and are not listed, please accept my apologies and contact me +immediately! diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..1fcee28e --- /dev/null +++ b/COPYING @@ -0,0 +1,24 @@ +Copyright (c) 2009 Alex Shinn +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..7949a71b --- /dev/null +++ b/Makefile @@ -0,0 +1,215 @@ +# -*- makefile-gmake -*- + +.PHONY: all libs doc dist clean cleaner test install uninstall +.PRECIOUS: %.c + +# install configuration + +CC ?= cc +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +SOLIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi +LIBDIR ?= $(PREFIX)/lib/chibi +MANDIR ?= $(PREFIX)/share/man/man1 + +DESTDIR ?= + +GENSTUBS ?= ./tools/genstubs.scm +GENSTATIC ?= ./tools/genstatic.scm + +######################################################################## +# system configuration - if not using GNU make, set PLATFORM and the +# following flags as necessary. + +# +LIBDL = -ldl + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +PLATFORM=unix +endif +endif +endif + +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0 +else +ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL -DSEXP_USE_DEBUG=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +STATICFLAGS = -DSEXP_USE_DL=0 +LIBDL = +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static -DSEXP_USE_DL=0 +endif +endif + +ifeq ($(USE_BOEHM),1) +SEXP_USE_BOEHM = 1 +endif + +ifeq ($(SEXP_USE_BOEHM),1) +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DSEXP_USE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude +endif + +ifeq ($(SEXP_USE_DL),0) +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS) +else +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm +XCFLAGS := -Wall -g3 $(CFLAGS) +endif + +######################################################################## + +all: chibi-scheme$(EXE) libs + +COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ + lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \ + lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \ + lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \ + lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \ + lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + +libs: $(COMPILED_LIBS) + +INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h + +include/chibi/install.h: Makefile + echo '#define sexp_so_extension "'$(SO)'"' > $@ + echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@ + echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ + echo '#define sexp_version "'`cat VERSION`'"' >> $@ + echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@ + +sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< + +libchibi-sexp$(SO): sexp.o + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) + +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 $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm + +clibs.c: $(GENSTATIC) lib lib/chibi lib/srfi + make chibi-scheme$(EXE) + make libs + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTATIC) $< > $@ + +%.c: %.stub $(GENSTUBS) + make chibi-scheme$(EXE) + -LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTUBS) $< + +lib/%$(SO): lib/%.c $(INCLUDES) + -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +clean: + rm -f *.o *.i *.s *.8 + find lib -name \*$(SO) -exec rm -f '{}' \; + rm -f tests/basic/*.out tests/basic/*.err + +cleaner: clean + rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h + rm -rf *.dSYM + +test-basic: chibi-scheme$(EXE) + @for f in tests/basic/*.scm; do \ + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + +test-build: + ./tests/build/build-tests.sh + +test-numbers: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/numeric-tests.scm + +test-flonums: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/flonum-tests.scm + +test-hash: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/hash-tests.scm + +test-match: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/match-tests.scm + +test-loop: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/loop-tests.scm + +test-sort: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm + +test: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/r5rs-tests.scm + +install: chibi-scheme$(EXE) + mkdir -p $(DESTDIR)$(BINDIR) + cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ + cp tools/genstubs.scm $(DESTDIR)$(BINDIR)/ + mkdir -p $(DESTDIR)$(MODDIR) + cp -r lib/* $(DESTDIR)$(MODDIR)/ + mkdir -p $(DESTDIR)$(INCDIR) + cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ + mkdir -p $(DESTDIR)$(LIBDIR) + mkdir -p $(DESTDIR)$(SOLIBDIR) + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ + mkdir -p $(DESTDIR)$(MANDIR) + cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/ + -if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + +uninstall: + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE) + rm -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO) + rm -f $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a + cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -rf $(DESTDIR)$(MODDIR) + +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..69965ea7 --- /dev/null +++ b/README @@ -0,0 +1,440 @@ + + 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. + +------------------------------------------------------------------------ +INSTALLING + +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 chibi/features.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 CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 + +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 features.h file, or +directly from make with: + + make SEXP_USE_BOEHM=1 + +To compile a static executable, use + + make chibi-scheme-static SEXP_USE_DL=0 + +To compile a static executable with all C libraries statically +included, first you need to create a clibs.c file, which can be done +with: + + make clibs.c + +or edited manually. Be sure to run this with a non-static +chibi-scheme. Then you can make the static executable with: + + make cleaner + make chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS + +------------------------------------------------------------------------ +CHIBI-SCHEME LANGUAGE + +The default language is mostly compatible with the R5RS, with all +differences made by design, not through difficulty of implementation. +The following procedures are omitted: + + transcript-on and transcript-off (because they're silly) + rationalize (pending the addition of rational numbers) + +Apart from this, chibi-scheme is case-sensitive, unlike the R5RS. +The default configuration includes fixnums, flonums and bignums +but no exact rationals or complex numbers. + +Full continuations are supported, but currently continuations don't +take C code into account. The only higher-order C functions in the +standard environment are LOAD and EVAL. + +LOAD is extended to accept an optional environment argument, like +EVAL. You can also LOAD shared libraries in addition to Scheme source +files - in this case the function sexp_init_library is automatically +called with the following signature: + + sexp_init_library(sexp context, sexp environment) + +SYNTAX-RULES macros are provided by default, with the extensions from +SRFI-46. In addition, low-level hygienic macros are provided with +a syntactic-closures interface, including SC-MACRO-TRANSFORMER, +RSC-MACRO-TRANSFORMER, and ER-MACRO-TRANSFORMER. A good introduction +to syntactic-closures can be found at: + + http://community.schemewiki.org/?syntactic-closures + +IDENTIFIER?, IDENTIFIER->SYMBOL, IDENTIFIER=?, and +MAKE-SYNTACTIC-CLOSURE and STRIP-SYNTACTIC-CLOSURES are provided. + +SRFI-0's COND-EXPAND is provided, with the feature `chibi'. + +STRING-CONCATENATE concatenates a list of strings. + +------------------------------------------------------------------------ +TYPES + +You can define new data types with SRFI-9. This is just syntactic +sugar for the following more primitive type constructors: + +(register-simple-type ) + => ; a fixnum + +(make-type-predicate ) + => ; takes 1 arg, returns #t iff that arg is of the type + +(make-constructor ) + => ; takes 0 args, returns a newly allocated instance of type + +(make-getter ) + => ; takes 1 args, retrieves the field located at the index + +(make-setter ) + => ; takes 2 args, sets the field located at the index + +------------------------------------------------------------------------ +MODULE SYSTEM + +A configurable module system, in the style of the Scheme48 module +system, is provided by default. + +Modules names are hierarchical lists of symbols or numbers. The +definition of the module (foo bar baz) is searched for in the file +foo/bar/baz.module. This file should contain an expression of the +form: + + (define-module (foo bar baz) + ...) + +where can be any of + + (export ...) - specify an export list + (import ...) - specify one or more imports + (import-immutable ...) - specify an immutable import + (body ...) - inline Scheme code + (include ...) - load one or more files + (include-shared ...) - dynamic load a library + + can either be a module name or any of + + (only ...) + (except ...) + (rename ( ) ...) + (prefix ) + +The can be composed and perform basic selection and renaming of +individual identifiers from the given module. + +Files are loaded relative to the .module file, and are written with +their extension (so you can use whatever suffix you prefer - .scm, +.ss, .sls, etc.). + +Shared modules, on the other hand, should be specified _without_ the +extension - the correct suffix will be added portably (e.g. .so for +Unix and .dylib for OS X). + +You may also use COND-EXPAND and arbitrary macro expansions in a +module definition to generate . + +------------------------------------------------------------------------ +MODULES + +The default environment is (scheme) - you almost always want to import +this. + +Currently you can load the following SRFIs with (import (srfi N)): + + (srfi 0) - cond-expand + (srfi 1) - list library + (srfi 2) - and-let* + (srfi 6) - basic string ports + (srfi 8) - receive + (srfi 9) - define-record-type + (srfi 11) - let-values/let*-values + (srfi 16) - case-lambda + (srfi 22) - running scheme scripts on Unix + (srfi 23) - error reporting mechanism + (srfi 26) - cut/cute partial application + (srfi 27) - sources of random bits + (srfi 33) - bitwise operators + (srfi 39) - prameter objects + (srfi 46) - basic syntax-rules extensions + (srfi 62) - s-expression comments + (srfi 69) - basic hash tables + (srfi 95) - sorting and merging + (srfi 98) - environment access + +although 0, 22, 23, 46 and 62 are built into the default environment +so there's no need to import them. + +Included non-standard modules are put in the (chibi) module namespace. +The following additional modules are available: + + (chibi net) - networking interface + (chibi filesystem) - local filesystem and file descriptor interface + (chibi process) - processes and signals + (chibi system) - host system and user information + (chibi time) - time and date library + (chibi match) - pattern-matching library + (chibi loop) - extensible loop syntax + (chibi pathname) - pathname manipulation utilities + (chibi uri) - URI parsing and construction utilities + (chibi macroexpand) - macro expansion utility + (chibi ast) - interface to the internal Abstract Syntax Tree + (chibi disasm) - disassembly utility for the chibi VM + (chibi heap-stats) - debugging tool to analyze or dump the heap + +------------------------------------------------------------------------ +C INTERFACE + +See the file main.c for an example of using chibi-scheme as a library. + +The basic usage involves creating a context for evaluation and loading +or evaluating Scheme source with it. Begin by including the eval.h +header file: + + #include + +then call + + sexp_scheme_init(); + +with no parameters to initialize any globals (this actually does +nothing in the standard configuration but is a good idea to call +anyway). + +Then you can use the following to create and manipulate contexts: + + sexp_make_eval_context(context, stack, environment, heap_size) + Creates a new context with the given stack and environment. + If context is non-NULL, this will be the "parent" context and + the two contexts will share a heap. Otherwise, a new heap + will be allocated with heap_size, or a default size if heap_size + is zero. stack and environment may both also be NULL (and _must_ + be NULL if context is NULL) and will be given standard defaults. + + Thus the to create your first context you generally call: + + sexp_make_eval_context(NULL, NULL, NULL, 0) + + You can create as many contexts as you want, and other than those + sharing a heap they are all independent and thread-safe. + + sexp_load_standard_env(context, env, version) + Loads the init.scm file in the environment env. Version refers + to the RnRS version number and should always be SEXP_FIVE. The + environment created with sexp_make_eval_context only contains + core syntactic forms and C primitives (thus for example it has + CAR but not CADR or LIST), so to get a full featured + environment, plus a module system with which to load additional + modules, you want to use this. + + sexp_destroy_context(context) + Signals that you no longer need context, or any other context + sharing the heap. It will thus free() the context and heap and + all associated memory. Does nothing if using the Boehm GC. + +Environments can be handled with the following: + + sexp_context_env(context) + A macro returning the default environment associated with context. + + sexp_env_define(context, env, symbol, value) + Define a variable in an environment. + + sexp_env_ref(env, symbol, dflt) + Fetch the binding for symbol from the environment env, + returning the default dflt if the symbol is unbound. + +You can evaluate code with the following utility: + + sexp_eval(context, expr, env) + Evaluates an s-expression in an environment. + env can be NULL to use the context's default env. + + sexp_eval_string(context, str, env) + Reads an s-expression from str and evaluates it in env. + + sexp_load(context, file, env) + Read and eval all top-level forms from file in environment env. + As described in LOAD above, file may be a shared library. + +To define new primitive functions from C, use sexp_define_foreign, +which takes a Scheme environment, a name, a number of arguments the C +function takes (not counting the context argument), and a C function. + + /* sexp_define_foreign(context, env, name, num_args, f) */ + + sexp add (sexp context, sexp x, sexp y) { + return sexp_fx_add(x, y); + } + + sexp_define_foreign(context, env, "add", 2, add); + +You can also define functions with a single optional argument: + + sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); + +See the SRFI-69 implementation for more detailed examples of this. + +------------------------------------------------------------------------ +FFI + +Simple C FFI. "genstubs.scm file.stub" will read in the C function +FFI definitions from file.stub and output the appropriate C +wrappers into file.c. You can then compile that file with: + + cc -fPIC -shared file.c -lchibi-scheme + +(or using whatever flags are appropriate to generate shared libs on +your platform) and then the generated .so file can be loaded +directly with LOAD, or portably using (include-shared "file") in a +module definition (note that include-shared uses no suffix). + +The goal of this interface is to make access to C types and +functions easy, without requiring the user to write any C code. +That means the stubber needs to be intelligent about various C +calling conventions and idioms, such as return values passed in +actual parameters. Writing C by hand is still possible, and +several of the core modules provide C interfaces directly without +using the stubber. + +================================ + +Struct Interface + +(define-c-struct struct-name + [predicate: predicate-name] + [constructor: constructor-name] + [finalizer: c_finalizer_name] + (type c_field_name getter-name setter-name) ...) + + +================================ + + +Function Interface + +(define-c return-type name-spec (arg-type ...)) + +where name-space is either a symbol name, or a list of +(scheme-name c_name). If just a symbol, the C name is taken +to be the same with -'s replaced by _'s. + +arg-type is a type suitable for input validation and conversion. + +================================ + + +Types + +Types + +Basic Types + void + boolean + char + sexp (no conversions) + +Integer Types: + signed-char short int long + unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t + time_t (in seconds, but using the chibi epoch of 2010/01/01) + errno (as a return type returns #f on error) + +Float Types: + float double long-double + +String Types: + string - a null-terminated char* + env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme + in addition you can use (array char) as a string + +Port Types: + input-port output-port + +Struct Types: + +Struct types are by default just referred to by the bare +struct-name from define-c-struct, and it is assumed you want a +pointer to that type. To refer to the full struct, use the struct +modifier, as in (struct struct-name). + +Type modifiers + +Any type may also be written as a list of modifiers followed by the +type itself. The supported modifiers are: + +const: prepends the "const" C type modifier + * as a return or result parameter, makes non-immediates immutable + +free: it's Scheme's responsibility to "free" this resource + * as a return or result parameter, registers the freep flag + this causes the type finalizer to be run when GCed + +maybe-null: this pointer type may be NULL + * as a result parameter, NULL is translated to #f + normally this would just return a wrapped NULL pointer + * as an input parameter, #f is translated to NULL + normally this would be a type error + +pointer: create a pointer to this type + * as a return parameter, wraps the result in a vanilla cpointer + * as a result parameter, boxes then unboxes the value + +struct: treat this struct type as a struct, not a pointer + * as an input parameter, dereferences the pointer + * as a type field, indicates a nested struct + +link: add a gc link + * as a field getter, link to the parent object, so the + parent won't be GCed so long as we have a reference + to the child. this behavior is automatic for nested + structs. + +result: return a result in this parameter + * if there are multiple results (including the return type), + they are all returned in a list + * if there are any result parameters, a return type + of errno returns #f on failure, and as eliminated + from the list of results otherwise + +(value ): specify a fixed value + * as an input parameter, this parameter is not provided + in the Scheme API but always passed as + +(default ): specify a default value + * as the final input parameter, makes the Scheme parameter + optional, defaulting to + +(array []) an array type + * length must be specified for return and result parameters + * if specified, length can be any of + ** an integer, for a fixed size + ** the symbol null, indicating a NULL-terminated array diff --git a/RELEASE b/RELEASE new file mode 100644 index 00000000..35f6fb33 --- /dev/null +++ b/RELEASE @@ -0,0 +1 @@ +lithium diff --git a/TODO b/TODO new file mode 100644 index 00000000..3e01c1f5 --- /dev/null +++ b/TODO @@ -0,0 +1,150 @@ +-*- org -*- + +* compiler +** DONE ast rewrite + - State "DONE" [2009-04-09 Thu 14:32] +** DONE call/cc support + - State "DONE" [2009-04-09 Thu 14:36] +** DONE exceptions + - State "DONE" [2009-04-09 Thu 14:45] +** TODO native x86 backend +** TODO fasl/image files +** DONE shared stack on EVAL + - State "DONE" [2009-12-26 Sat 08:22] + +* compiler optimizations +** DONE constant folding + - State "DONE" [2009-12-16 Wed 23:25] +** DONE simplification pass, dead-code elimination + - State "DONE" [2009-12-18 Fri 14:14] + This is important in particular for the output generated by + syntax-rules. +** TODO lambda lift + The current closure representation is not very efficient, so this + would help a lot. +** TODO inlining (and disabling primitive inlining) + Being able to redefine procedures is important though. +** TODO unsafe operations + Possibly, don't want to make things too complicated or unstable. +** TODO plugin infrastructure +** TODO type inference with warnings + +* macros +** DONE hygiene + - State "DONE" [2009-04-09 Thu 14:41] +** DONE hygienic nested let-syntax + - State "DONE" [2009-12-08 Tue 14:41] +** DONE macroexpand utility + - State "DONE" [2009-12-08 Tue 14:41] +** DONE SRFI-46 basic syntax-rules extensions + - State "DONE" [2009-12-26 Sat 07:59] +** DONE (... ...) support + - State "DONE" [2009-12-26 Sat 02:06] +** TODO compiler macros +** TODO syntax-rules common pattern reduction +** TODO syntax-rules loop optimization + +* garbage collection +** DONE precise gc rewrite + - State "DONE" [2009-06-22 Mon 14:27] +** DONE fix heap growing + - State "DONE" [2009-06-22 Mon 14:29] +** DONE separate gc heaps + - State "DONE" [2009-12-08 Tue 14:29] +** DONE add finalizers + - State "DONE" [2009-12-08 Tue 14:29] +** TODO support weak references + +* runtime +** DONE bignums + - State "DONE" [2009-07-07 Tue 14:42] +** TODO unicode +** TODO threads +** DONE virtual ports + - State "DONE" [2010-01-02 Sat 20:12] +** DONE dynamic-wind + - State "DONE" [2009-12-26 Sat 01:51] + Adapted a version from Scheme48. +** DONE recursive disasm + - State "DONE" [2009-12-18 Fri 14:15] + +* FFI +** DONE libdl support + - State "DONE" [2009-12-08 Tue 14:45] +** DONE opcode generation interface + - State "DONE" [2009-11-15 Sun 14:45] +** DONE stub generator + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE define-c-struct + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE define-c + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE array return types + - State "DONE" [2009-12-26 Sat 01:49] +*** DONE pre-buffered string types (like getcwd) + - State "DONE" [2009-12-26 Sat 01:49] + +* module system +** DONE scheme48-like config language + - State "DONE" [2009-10-13 Tue 14:38] +** DONE shared library includes + - State "DONE" [2009-12-08 Tue 14:39] +** DONE only/except/rename/prefix modifiers + - State "DONE" [2009-12-16 Wed 18:57] +** TODO scheme-complete.el support +** DONE access individual modules from repl + - State "DONE" [2009-12-26 Sat 01:49] + +* core modules +** DONE SRFI-0 cond-expand + - State "DONE" [2009-12-16 Wed 20:12] +** DONE SRFI-9 define-record-type + - State "DONE" [2009-12-08 Tue 14:50] +** DONE SRFI-69 hash-tables + - State "DONE" [2009-11-15 Sun 14:50] +** DONE match library + - State "DONE" [2009-12-08 Tue 14:54] +** DONE loop library + - State "DONE" [2009-12-08 Tue 14:54] +** TODO network interface +** TODO posix interface + Splitting this into several parts. +*** DONE filesystem interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE process interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE time interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE host system interface + - State "DONE" [2010-01-02 Sat 20:12] +** DONE pathname library + - State "DONE" [2009-12-16 Wed 18:58] +** DONE uri library + - State "DONE" [2009-12-16 Wed 18:58] +** TODO http library +** TODO show (formatting) library +** TODO zip library +** TODO tar library +** TODO md5sum library + +* ports +** DONE basic mingw support + - State "DONE" [2009-06-22 Mon 14:36] +** DONE Plan 9 support + - State "DONE" [2009-08-10 Mon 14:37] +** DONE 64-bit support + - State "DONE" [2009-11-01 Sun 14:37] +** TODO iPhone support +** TODO bare-metal support + +* miscellaneous +** TODO overall cleanup +** TODO user documentation +** TODO thorough source documentation +** TODO full test suite for libraries + +* distribution +** TODO packaging format +** TODO code repository with fetch+install tool +** TODO translator to/from other implementations + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..be586341 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.3 diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1 new file mode 100644 index 00000000..b84620d5 --- /dev/null +++ b/doc/chibi-scheme.1 @@ -0,0 +1,133 @@ +.TH "chibi-scheme" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-scheme \- a tiny Scheme interpreter + +.SH SYNOPSIS +.B chibi-scheme +[-qV] +[-I +.I path +] +[-A +.I path +] +[-m +.I module +] +[-l +.I file +] +[-e +.I expr +] +[-p +.I expr +] +[--] +[ +.I script argument ... +] +.br +.sp 0.3 + +.SH DESCRIPTION +.I chibi-scheme +is a sample interactive Scheme interpreter for the +.I chibi-scheme +library. It serves as an example of how to embed +.I chibi-scheme +in applications, and can be useful on its own for writing +scripts and interactive development. + +When +.I script +is given, the script will be loaded with SRFI-22 semantics, +calling the procedure +.I main +(if defined) with a single parameter as a list of the +command-line arguments beginning with the script name. + +Otherwise, if no script is given and no -e or -p options +are given an interactive repl is entered, reading, evaluating, +then printing expressions until EOF is reached. The repl +provided is very minimal - if you want readline +completion you may want to wrap it with the +.I rlwrap(1) +program. Signals aren't caught either - to enable handling keyboard +interrupts you can use the (chibi process) module. + +.SH OPTIONS +.TP 5 +.BI -V +Prints the version information and exits. +.TP +.BI -q +Don't load the initialization file. The resulting +environment will only contain the core syntactic forms +and primitives coded in C. +.TP +.BI -h size +Specifies the initial size of the heap, in bytes. +.I size +can be any integer value, optionally suffixed by +"K" for kilobytes, or "M" for megabytes. +.I -h +must be specified before any options which load or +evaluate Scheme code. +.TP +.BI -I path +Inserts +.I path +on front of the load path list. +.TP +.BI -A path +Appends +.I path +to the load path list. +.TP +.BI -m module +Imports +.I module +as though "(import +.I module +)" were evaluated. However, to reduce the need for shell +escapes, modules are written in a dot notation, so that the module +.I (foo bar) +is written as +.I foo.bar +.TP +.BI -l file +Loads the Scheme source from the file +.I file +searched for in the default load path. +.TP +.BI -e expr +Evaluates the Scheme expression +.I expr. +.TP +.BI -p expr +Evaluates the Scheme expression +.I expr +then prints the result to stdout. + +.SH ENVIRONMENT +.TP +.B CHIBI_MODULE_PATH +.TQ +A colon separated list of directories to search for module +files, inserted before the system default load paths. + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +More detailed information can be found in the README file +included in the distribution. + +The chibi-scheme home-page: +.br +http://code.google.com/p/chibi-scheme/ diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..9123cd60 --- /dev/null +++ b/eval.c @@ -0,0 +1,1579 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +#if SEXP_USE_DEBUG_VM +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { + int i; + if (! sexp_oportp(out)) out = sexp_current_error_port(ctx); + 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))))))) + sexp_warn(ctx, "invalid operand in application: ", x); + res = analyze_app(ctx, x); + } + } else if (sexp_idp(x)) { + res = analyze_var_ref(ctx, x, NULL); + } else if (sexp_synclop(x)) { + tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(tmp) = sexp_synclo_env(x); + sexp_context_fv(tmp) = sexp_append2(tmp, + sexp_synclo_free_vars(x), + sexp_context_fv(tmp)); + x = sexp_synclo_expr(x); + res = analyze(tmp, x); + } else { + res = x; + } + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res)) + && sexp_pairp(x)) + sexp_exception_source(res) = sexp_pair_source(x); + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} + +/********************** free varable analysis *************************/ + +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_var1(res); + if (sexp_nullp(fv2)) + return fv1; + sexp_gc_preserve1(ctx, res); + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, 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_release1(ctx); + return res; +} + +sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) { + sexp_gc_var2(fv1, fv2); + sexp_gc_preserve2(ctx, fv1, fv2); + fv1 = fv; + if (sexp_lambdap(x)) { + fv1 = sexp_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 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_cndp(x)) { + fv1 = sexp_free_vars(ctx, sexp_cnd_test(x), fv); + fv1 = sexp_free_vars(ctx, sexp_cnd_pass(x), fv1); + fv1 = sexp_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 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_setp(x)) { + fv1 = sexp_free_vars(ctx, sexp_set_value(x), fv); + fv1 = sexp_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 = sexp_free_vars(ctx, sexp_synclo_expr(x), fv); + } + sexp_gc_release2(ctx); + return fv1; +} + +/************************ library procedures **************************/ + +static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) { + sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn); + return sexp_exception_kind(exn); +} + +static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) { + FILE *in; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + in = fopen(sexp_string_data(path), "r"); + if (! in) + return sexp_user_exception(ctx, self, "couldn't open input file", path); + return sexp_make_input_port(ctx, in, path); +} + +static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) { + FILE *out; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + out = fopen(sexp_string_data(path), "w"); + if (! out) + return sexp_user_exception(ctx, self, "couldn't open output file", path); + return sexp_make_output_port(ctx, out, path); +} + +static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) { + sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port); + if (! sexp_port_openp(port)) + return sexp_user_exception(ctx, self, "port already closed", port); + return sexp_finalize_port(ctx sexp_api_pass(self, n), port); +} + +#if SEXP_USE_DL +#ifdef __MINGW32__ +#include +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + HINSTANCE handle = LoadLibraryA(sexp_string_data(file)); + if(!handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = (sexp_proc2) GetProcAddress(handle, "sexp_init_library"); + if(!init) { + FreeLibrary(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx sexp_api_pass(NULL, 1), env); +} +#else +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); + if (! handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = dlsym(handle, "sexp_init_library"); + if (! init) { + dlclose(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx sexp_api_pass(NULL, 1), env); +} +#endif +#endif + +sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { +#if SEXP_USE_DL + char *suffix; +#endif + sexp tmp, out=SEXP_FALSE; + sexp_gc_var4(ctx2, x, in, res); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); +#if SEXP_USE_DL + suffix = sexp_string_data(source) + + sexp_string_length(source) - strlen(sexp_so_extension); + if (strcmp(suffix, sexp_so_extension) == 0) { + res = sexp_load_dl(ctx, source, env); + } else { +#endif + sexp_gc_preserve4(ctx, ctx2, x, in, res); + res = SEXP_VOID; + in = sexp_open_input_file(ctx, source); + out = sexp_current_error_port(ctx); + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0); + sexp_context_parent(ctx2) = ctx; + tmp = sexp_env_bindings(env); + sexp_context_tailp(ctx2) = 0; + if (sexp_exceptionp(in)) { + if (sexp_not(out)) out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) + 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, env); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); + } + sexp_gc_release4(ctx); +#if SEXP_USE_DL + } +#endif +#if SEXP_USE_WARN_UNDEFS + if (! sexp_exceptionp(res)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + return res; +} + +#if SEXP_USE_MATH + +#if SEXP_USE_BIGNUMS +#define maybe_convert_bignum(z) \ + else if (sexp_bignump(z)) d = sexp_bignum_to_double(z); +#else +#define maybe_convert_bignum(z) +#endif + +#define define_math_op(name, cname) \ + static sexp name (sexp ctx sexp_api_params(self, n), sexp z) { \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_fixnump(z)) \ + d = (double)sexp_unbox_fixnum(z); \ + maybe_convert_bignum(z) \ + else \ + return sexp_type_exception(ctx, self, SEXP_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_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) { + double d, r; + if (sexp_flonump(z)) + d = sexp_flonum_value(z); + else if (sexp_fixnump(z)) + d = (double)sexp_unbox_fixnum(z); + maybe_convert_bignum(z) /* XXXX add bignum sqrt */ + else + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); + r = sqrt(d); + if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) + return sexp_make_fixnum(round(r)); + else + return sexp_make_flonum(ctx, r); +} + +#endif + +static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { + long double f, x1, e1; + sexp res; +#if SEXP_USE_BIGNUMS + if (sexp_bignump(e)) { /* bignum exponent needs special handling */ + if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) + res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ + else if (x == SEXP_ONE) + res = SEXP_ONE; /* 1.0 */ + else if (sexp_flonump(x)) + res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); + else + res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */ + } else if (sexp_bignump(x)) { + res = sexp_bignum_expt(ctx, x, e); + } else { +#endif + if (sexp_fixnump(x)) + x1 = sexp_unbox_fixnum(x); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + if (sexp_fixnump(e)) + e1 = sexp_unbox_fixnum(e); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, e); + f = pow(x1, e1); + if ((f > SEXP_MAX_FIXNUM) || (f < SEXP_MIN_FIXNUM) +#if SEXP_USE_FLONUMS + || (! sexp_fixnump(x)) || (! sexp_fixnump(e)) +#endif + ) { +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(x) && sexp_fixnump(e)) + res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); + else +#endif +#if SEXP_USE_FLONUMS + res = sexp_make_flonum(ctx, f); +#else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#endif + } else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#if SEXP_USE_BIGNUMS + } +#endif + return res; +} + +static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, sexp str2, sexp ci) { + sexp_sint_t len1, len2, len, diff; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2); + len1 = sexp_string_length(str1); + len2 = sexp_string_length(str2); + len = ((len1= SEXP_OPC_NUM_OP_CLASSES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode class", op_class); + else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) + || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code); + else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_arg1_type(res) = sexp_unbox_fixnum(arg1t); + sexp_opcode_arg2_type(res) = sexp_unbox_fixnum(arg2t); + sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_data(res) = data; + sexp_opcode_data2(res) = data2; + sexp_opcode_func(res) = func; + sexp_opcode_name(res) = strdup(sexp_string_data(name)); + } + return res; +} + +sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res; + if (num_args > 6) { + res = sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); + } else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; + sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1; + if (flags & 1) num_args--; + sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; + sexp_opcode_name(res) = name; + sexp_opcode_data(res) = data; + sexp_opcode_func(res) = f; + } + return res; +} + +sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp_gc_var1(op); + sexp_gc_preserve1(ctx, op); + sexp res = SEXP_VOID; + op = sexp_make_foreign(ctx, name, num_args, flags, f, data); + if (sexp_exceptionp(op)) + res = op; + else + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), op); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, + sexp_proc1 f, const char *param) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_intern(ctx, param, -1); + tmp = sexp_env_cell(env, tmp); + res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_TYPE_DEFS + +sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), + sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); +} + +sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + sexp_uint_t type_size; + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); + type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), + sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, + sexp_make_fixnum(type_size), NULL); +} + +sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); + return + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER), + sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); + return + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER), + sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +#endif + +#if SEXP_USE_STATIC_LIBS +#include "clibs.c" +#endif + +/*********************** standard environment *************************/ + +static struct sexp_struct core_forms[] = { + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE, "define"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SET, "set!"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LAMBDA, "lambda"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_IF, "if"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_BEGIN, "begin"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_QUOTE, "quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LET_SYNTAX, "let-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}}}, +}; + +sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) { + 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; + return e; +} + +sexp sexp_make_null_env_op (sexp ctx sexp_api_params(self, n), sexp version) { + sexp_uint_t i; + sexp e = sexp_make_env(ctx); + for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i]), -1), + sexp_copy_core(ctx, &core_forms[i])); + return e; +} + +sexp sexp_make_primitive_env (sexp ctx, sexp version) { + int i; + sexp_gc_var3(e, op, sym); + sexp_gc_preserve3(ctx, e, op, sym); + e = sexp_make_null_env(ctx, version); + for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { + op = sexp_copy_opcode(ctx, &opcodes[i]); + if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1); + sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); + } + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op), -1), op); + } + sexp_gc_release3(ctx); + return e; +} + +sexp sexp_find_module_file (sexp ctx, const char *file) { + sexp res=SEXP_FALSE, ls; + char *dir, *path; + sexp_uint_t slash, dirlen, filelen, len; +#ifdef PLAN9 +#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0) + unsigned char buf[128]; +#else +#define file_exists_p(path, buf) (! stat(path, buf)) + struct stat buf_str; + struct stat *buf = &buf_str; +#endif + + filelen = strlen(file); + + ls = sexp_global(ctx, SEXP_G_MODULE_PATH); + for ( ; sexp_pairp(ls) && sexp_not(res); ls=sexp_cdr(ls)) { + dir = sexp_string_data(sexp_car(ls)); + dirlen = sexp_string_length(sexp_car(ls)); + slash = dir[dirlen-1] == '/'; + len = dirlen+filelen+2-slash; + path = (char*) malloc(len); + memcpy(path, dir, dirlen); + if (! slash) path[dirlen] = '/'; + memcpy(path+len-filelen-1, file, filelen); + path[len-1] = '\0'; + if (file_exists_p(path, buf)) + res = sexp_c_string(ctx, path, len-1); + free(path); + } + + return res; +} + +#define sexp_file_not_found "couldn't find file in module path" + +sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { + sexp res; + sexp_gc_var1(path); + sexp_gc_preserve1(ctx, path); + path = sexp_find_module_file(ctx, file); + if (sexp_stringp(path)) { + res = sexp_load(ctx, path, env); + } else { + path = sexp_c_string(ctx, file, -1); + res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path); + } + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_MODULES +static sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + return sexp_find_module_file(ctx, sexp_string_data(file)); +} +sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + return sexp_load_module_file(ctx, sexp_string_data(file), env); +} +#endif + +sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp) { + sexp ls; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dir); + if (sexp_truep(appendp)) { + if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { + for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) + ; + sexp_cdr(ls) = sexp_list1(ctx, dir); + } else { + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir); + } + } else { + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir); + } + return SEXP_VOID; +} + +sexp sexp_load_standard_parameters (sexp ctx, sexp e) { + /* add io port and interaction env parameters */ + sexp p = sexp_make_input_port(ctx, stdin, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p); + p = sexp_make_output_port(ctx, stdout, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p); + p = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); + return SEXP_VOID; +} + +sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { + sexp_gc_var3(op, tmp, sym); + sexp_gc_preserve3(ctx, op, tmp, sym); + sexp_load_standard_parameters(ctx, e); +#if SEXP_USE_DL + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1), + tmp=sexp_c_string(ctx, sexp_so_extension, -1)); +#endif + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform, -1)); +#if SEXP_USE_DL + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading", -1)); +#endif +#if SEXP_USE_MODULES + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules", -1)); +#endif +#if SEXP_USE_BOEHM + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); +#endif + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); + sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; +#if SEXP_USE_SIMPLIFY + op = sexp_make_foreign(ctx, "simplify", 1, 0, + (sexp_proc1)sexp_simplify, SEXP_VOID); + tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); +#endif + /* load init.scm */ + tmp = sexp_load_module_file(ctx, sexp_init_file, e); + /* load and bind config env */ +#if SEXP_USE_MODULES + if (! sexp_exceptionp(tmp)) { + sym = sexp_intern(ctx, "*config-env*", -1); + if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { + tmp = sexp_make_env(ctx); + if (! sexp_exceptionp(tmp)) { + sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; + sexp_env_parent(tmp) = e; + op = sexp_load_module_file(ctx, sexp_config_file, tmp); + if (sexp_exceptionp(op)) + sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); + sexp_env_define(ctx, tmp, sym, tmp); + } + } + sexp_env_define(ctx, e, sym, tmp); + } +#endif +#if SEXP_USE_STATIC_LIBS + sexp_init_all_libraries(ctx, e); +#endif + sexp_gc_release3(ctx); + return sexp_exceptionp(tmp) ? tmp : e; +} + +sexp sexp_make_standard_env_op (sexp ctx sexp_api_params(self, n), sexp version) { + sexp_gc_var1(env); + sexp_gc_preserve1(ctx, env); + env = sexp_make_primitive_env(ctx, version); + if (! sexp_exceptionp(env)) sexp_load_standard_env(ctx, env, version); + sexp_gc_release1(ctx); + return env; +} + +sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) { + sexp oldname, newname, value; + if (! sexp_envp(to)) to = sexp_context_env(ctx); + if (! sexp_envp(from)) from = sexp_context_env(ctx); + if (sexp_not(ls)) { + if (sexp_truep(immutp)) { + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_parent(to) = value; + sexp_immutablep(value) = 1; + sexp_env_bindings(value) = sexp_env_bindings(from); + } else { + for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls)); + } + } else { + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (sexp_pairp(sexp_car(ls))) { + newname = sexp_caar(ls); oldname = sexp_cdar(ls); + } else { + newname = oldname = sexp_car(ls); + } + value = sexp_env_ref(from, oldname, SEXP_UNDEF); + if (value != SEXP_UNDEF) { + sexp_env_define(ctx, to, newname, value); +#if SEXP_USE_WARN_UNDEFS + } else { + sexp_warn(ctx, "importing undefined variable: ", oldname); +#endif + } + } + } + return SEXP_VOID; +} + +/************************** eval interface ****************************/ + +sexp sexp_compile (sexp ctx, sexp x) { + sexp_gc_var3(ast, vec, res); + sexp_gc_preserve3(ctx, ast, vec, res); + ast = sexp_analyze(ctx, x); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(res); res=sexp_cdr(res)) + ast = sexp_apply1(ctx, sexp_cdar(res), ast); + sexp_free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + emit_enter(ctx); + generate(ctx, ast); + res = finalize_bytecode(ctx); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec); + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { + sexp_sint_t top; + sexp ctx2; + sexp_gc_var2(res, err_handler); + if (! env) env = sexp_context_env(ctx); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_gc_preserve2(ctx, res, err_handler); + top = sexp_context_top(ctx); + err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = SEXP_FALSE; + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0); + res = sexp_compile(ctx2, obj); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; + sexp_context_top(ctx) = top; + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_eval_string (sexp ctx, const char *str, sexp_sint_t len, sexp env) { + sexp res; + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); + obj = sexp_read_from_string(ctx, str, len); + res = sexp_eval(ctx, obj, env); + sexp_gc_release1(ctx); + return res; +} + +void sexp_scheme_init (void) { + if (! scheme_initialized_p) { + scheme_initialized_p = 1; + sexp_init(); + } +} diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..fb15ec13 --- /dev/null +++ b/gc.c @@ -0,0 +1,354 @@ +/* gc.c -- simple mark&sweep garbage collector */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +#if SEXP_USE_MMAP_GC +#include +#endif + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(sexp_sizeof(pair))) + +#define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1)) + +#if SEXP_USE_GLOBAL_HEAP +sexp_heap sexp_global_heap; +#endif + +#if SEXP_USE_CONSERVATIVE_GC +static sexp* stack_base; +#endif + +static sexp_heap sexp_heap_last (sexp_heap h) { + while (h->next) h = h->next; + return h; +} + +sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) { + sexp_uint_t res; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) + return sexp_heap_align(1); + t = sexp_object_type(ctx, x); + res = sexp_type_size_of_object(t, x); + return res; +} + +#if SEXP_USE_SAFE_GC_MARK +static int sexp_in_heap(sexp ctx, sexp_uint_t x) { + sexp_heap h; + if (x & (sexp_heap_align(1)-1)) { + fprintf(stderr, "invalid heap alignment: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; + } + for (h=sexp_context_heap(ctx); h; h=h->next) + if (((sexp_uint_t)h < x) && (x < (sexp_uint_t)(h->data + h->size))) + return 1; + fprintf(stderr, "invalid object outside heap: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; +} +#endif + +#if SEXP_USE_DEBUG_GC +#include "opt/gc_debug.c" +#endif + +void sexp_mark (sexp ctx, sexp x) { + 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; +#if SEXP_USE_SAFE_GC_MARK + if (! sexp_in_heap(ctx, (sexp_uint_t)x)) + return; +#endif +#if SEXP_USE_HEADER_MAGIC + if (sexp_pointer_magic(x) != SEXP_POINTER_MAGIC && sexp_pointer_tag(x) != SEXP_TYPE + && sexp_pointer_tag(x) != SEXP_OPCODE && sexp_pointer_tag(x) != SEXP_CORE + && sexp_pointer_tag(x) != SEXP_STACK) + return; +#endif + sexp_gc_mark(x) = 1; + if (sexp_contextp(x)) + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) sexp_mark(ctx, *(saves->var)); + t = sexp_object_type(ctx, x); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len = sexp_type_num_slots_of_object(t, x) - 1; + if (len >= 0) { + for (i=0; inext) { + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); + q = h->free_list; + end = (sexp) ((char*)h->data + h->size - sexp_heap_align(sexp_sizeof(pair))); + while (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) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + r->size); + continue; + } + size = sexp_heap_align(sexp_allocated_bytes(ctx, p)); + if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + /* free p */ + finalizer = sexp_type_finalize(sexp_object_type(ctx, p)); + if (finalizer) finalizer(ctx sexp_api_pass(NULL, 1), 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); + } + } + } + if (sum_freed_ptr) *sum_freed_ptr = sum_freed; + return sexp_make_fixnum(max_freed); +} + +sexp sexp_gc (sexp ctx, size_t *sum_freed) { + sexp res; +#if SEXP_USE_GLOBAL_SYMBOLS + int i; + 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(sexp_context_heap(ctx)); + 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=sexp_context_heap(ctx); 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, total_size; + sexp_heap h; + size = sexp_heap_align(size); + res = sexp_try_alloc(ctx, size); + if (! res) { + max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed)); + for (total_size=0, h=sexp_context_heap(ctx); h->next; h=h->next) + total_size += h->size; + total_size += h->size; + if (((max_freed < size) + || ((total_size > sum_freed) + && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO))) + && ((!SEXP_MAXIMUM_HEAP_SIZE) || (total_size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); + if (! res) + res = sexp_global(ctx, SEXP_G_OOM_ERROR); + } + return res; +} + +#if ! SEXP_USE_GLOBAL_HEAP + +sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { + sexp_sint_t i, off, len, freep; + sexp_heap to, from = sexp_context_heap(ctx); + sexp_free_list q; + sexp p, p2, t, end, *v; + freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP); + + /* validate input, creating a new heap if needed */ + if (from->next) { + return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx); + } else if (! dst || sexp_not(dst)) { + to = sexp_make_heap(from->size); + dst = (sexp) ((char*)ctx + ((char*)to - (char*)from)); + } else if (! sexp_contextp(dst)) { + return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst); + } else if (sexp_context_heap(dst)->size < from->size) { + return sexp_user_exception(ctx, NULL, "destination context too small", dst); + } else { + to = sexp_context_heap(dst); + } + + /* copy the raw data */ + off = (char*)to - (char*)from; + memcpy(to, from, sexp_heap_pad_size(from->size)); + to->free_list = (sexp_free_list) ((char*)to->free_list + off); + to->data += off; + end = (sexp) (from->data + from->size); + + /* adjust the free list */ + for (q=to->free_list; q->next; q=q->next) + q->next = (sexp_free_list) ((char*)q->next + off); + + /* adjust if the destination is larger */ + if (from->size < to->size) { + if (((char*)q + q->size - off) >= (char*)end) { + q->size += (to->size - from->size); + } else { + q->next = (sexp_free_list) ((char*)end + off); + q->next->next = NULL; + q->next->size = (to->size - from->size); + } + } + + /* adjust data by traversing over the _original_ heap */ + p = (sexp) (from->data + sexp_heap_align(sexp_sizeof(pair))); + q = from->free_list; + while (p < end) { + /* find the next free list pointer */ + for ( ; q && ((char*)q < (char*)p); q=q->next) + ; + if ((char*)q == (char*)p) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + q->size); + } else { + t = sexp_object_type(ctx, p); + len = sexp_type_num_slots_of_object(t, p); + p2 = (sexp)((char*)p + off); + v = (sexp*) ((char*)p2 + sexp_type_field_base(t)); + /* offset any pointers in the _destination_ heap */ + for (i=0; istring */ +/* will not be available by default. */ +/* #define SEXP_USE_STRING_STREAMS 0 */ + +/* uncomment this to disable automatic closing of ports */ +/* If enabled, the underlying FILE* for file ports will be */ +/* automatically closed when they're garbage collected. Doesn't */ +/* apply to stdin/stdout/stderr. */ +/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */ + +/* uncomment this to use the normal 1970 unix epoch */ +/* By default chibi uses an datetime epoch starting at */ +/* 2010/01/01 00:00:00 in order to be able to represent */ +/* more common times as fixnums. */ +/* #define SEXP_USE_2010_EPOCH 0 */ + +/* uncomment this to disable stack overflow checks */ +/* By default stacks are fairly small, so it's good to leave */ +/* this enabled. */ +/* #define SEXP_USE_CHECK_STACK 0 */ + +/* #define SEXP_USE_DEBUG_VM 0 */ +/* Experts only. */ +/* For *very* verbose output on every VM operation. */ + +/* uncomment this to make the VM adhere to alignment rules */ +/* This is required on some platforms, e.g. ARM */ +/* #define SEXP_USE_ALIGNED_BYTECODE */ + +/************************************************************************/ +/* These settings are configurable but only recommended for */ +/* experienced users, and only apply when using the native GC. */ +/************************************************************************/ + +/* the initial heap size in bytes */ +#ifndef SEXP_INITIAL_HEAP_SIZE +#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) +#endif + +/* the maximum heap size in bytes - if 0 there is no limit */ +#ifndef SEXP_MAXIMUM_HEAP_SIZE +#define SEXP_MAXIMUM_HEAP_SIZE 0 +#endif +#ifndef SEXP_MINIMUM_HEAP_SIZE +#define SEXP_MINIMUM_HEAP_SIZE 8*1024 +#endif + +/* if after GC more than this percentage of memory is still in use, */ +/* and we've not exceeded the maximum size, grow the heap */ +#ifndef SEXP_GROW_HEAP_RATIO +#define SEXP_GROW_HEAP_RATIO 0.75 +#endif + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#ifndef SEXP_64_BIT +#if defined(__amd64) || defined(__x86_64) +#define SEXP_64_BIT 1 +#else +#define SEXP_64_BIT 0 +#endif +#endif + +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 +#ifndef _GNU_SOURCE +#define _GNU_SOURCE +#endif +#endif + +#ifndef SEXP_USE_NO_FEATURES +#define SEXP_USE_NO_FEATURES 0 +#endif + +#ifndef SEXP_USE_NATIVE_X86 +#define SEXP_USE_NATIVE_X86 0 +#endif + +#ifndef SEXP_USE_MODULES +#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_TYPE_DEFS +#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_MAXIMUM_TYPES +#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1) +#endif + +#ifndef SEXP_USE_DL +#ifdef PLAN9 +#define SEXP_USE_DL 0 +#else +#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_STATIC_LIBS +#define SEXP_USE_STATIC_LIBS 0 +#endif + +#ifndef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 0 +#endif + +#ifndef SEXP_USE_MALLOC +#define SEXP_USE_MALLOC 0 +#endif + +#ifndef SEXP_USE_MMAP_GC +#define SEXP_USE_MMAP_GC 0 +#endif + +#ifndef SEXP_USE_DEBUG_GC +#define SEXP_USE_DEBUG_GC 0 +#endif + +#ifndef SEXP_USE_SAFE_GC_MARK +#define SEXP_USE_SAFE_GC_MARK 0 +#endif + +#ifndef SEXP_USE_CONSERVATIVE_GC +#define SEXP_USE_CONSERVATIVE_GC 0 +#endif + +#ifndef SEXP_USE_HEADER_MAGIC +#define SEXP_USE_HEADER_MAGIC 0 +#endif + +#ifndef SEXP_USE_GLOBAL_HEAP +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_HEAP 1 +#else +#define SEXP_USE_GLOBAL_HEAP 0 +#endif +#endif + +#ifndef SEXP_USE_GLOBAL_TYPES +#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS) +#endif + +#ifndef SEXP_USE_GLOBAL_SYMBOLS +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_SYMBOLS 1 +#else +#define SEXP_USE_GLOBAL_SYMBOLS 0 +#endif +#endif + +#ifndef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_INFINITIES +#if defined(PLAN9) || ! SEXP_USE_FLONUMS +#define SEXP_USE_INFINITIES 0 +#else +#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_IMMEDIATE_FLONUMS +#define SEXP_USE_IMMEDIATE_FLONUMS 0 +#endif + +#ifndef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MATH +#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_SELF_PARAMETER +#define SEXP_USE_SELF_PARAMETER 1 +#endif + +#ifndef SEXP_USE_WARN_UNDEFS +#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HUFF_SYMS +#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HASH_SYMS +#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_DEBUG_VM +#define SEXP_USE_DEBUG_VM 0 +#endif + +#ifndef SEXP_USE_STRING_STREAMS +#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_AUTOCLOSE_PORTS +#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_2010_EPOCH +#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_EPOCH_OFFSET +#if SEXP_USE_2010_EPOCH +#define SEXP_EPOCH_OFFSET 1262271600 +#else +#define SEXP_EPOCH_OFFSET 0 +#endif +#endif + +#ifndef SEXP_USE_CHECK_STACK +#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES +#endif + +#if SEXP_USE_NATIVE_X86 +#undef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 1 +#undef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS 0 +#undef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS 0 +#undef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY 0 +#endif + +#ifndef SEXP_USE_ALIGNED_BYTECODE +#if defined(__arm__) +#define SEXP_USE_ALIGNED_BYTECODE 1 +#else +#define SEXP_USE_ALIGNED_BYTECODE 0 +#endif +#endif + +#ifdef PLAN9 +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#endif + +#ifdef __MINGW32__ +#ifdef BUILDING_DLL +#define SEXP_API __declspec(dllexport) +#else +#define SEXP_API __declspec(dllimport) +#endif +#else +#define SEXP_API +#endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h new file mode 100644 index 00000000..69684c3b --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,966 @@ +/* sexp.h -- header for sexp library */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_H +#define SEXP_H + +#ifdef __cplusplus +extern "C" { +#endif + +#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" + +#include "chibi/features.h" +#include "chibi/install.h" + +#if SEXP_USE_DL +#ifndef __MINGW32__ +#include +#endif +#endif + +#ifdef PLAN9 +#include +#include +#include +#include +#include <9p.h> +typedef unsigned long size_t; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +#include +#include + +/* tagging system + * bits end in 00: pointer + * 01: fixnum + * 011: immediate flonum (optional) + * 111: immediate symbol (optional) + * 000110: char + * 001110: unique immediate (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 6 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 63 + +#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 + +#ifndef SEXP_POINTER_MAGIC +#define SEXP_POINTER_MAGIC 0xFDCA9764uL /* arbitrary */ +#endif + +#if SEXP_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_NUMBER, + SEXP_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_STRING, + SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, + SEXP_CPOINTER, + 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_CORE_TYPES +}; + +#if SEXP_64_BIT +typedef unsigned int sexp_tag_t; +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +#else +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#endif +typedef struct sexp_struct *sexp; + +#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2)) +#define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type)) +#define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type)) + +#define SEXP_UINT_T_MAX ((sexp_uint_t)-1) +#define SEXP_UINT_T_MIN (0) +#define SEXP_SINT_T_MAX __MAX_SIGNED(sexp_sint_t) +#define SEXP_SINT_T_MIN __MIN_SIGNED(sexp_sint_t) + +#define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1) +#define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1) + +#if SEXP_USE_SELF_PARAMETER +#define sexp_api_params(self, n) , sexp self, long n +#define sexp_api_pass(self, n) , self, n +#else +#define sexp_api_params(self, n) +#define sexp_api_pass(self, n) +#endif + +/* procedure types */ +typedef sexp (*sexp_proc1) (sexp sexp_api_params(self, n)); +typedef sexp (*sexp_proc2) (sexp sexp_api_params(self, n), sexp); +typedef sexp (*sexp_proc3) (sexp sexp_api_params(self, n), sexp, sexp); +typedef sexp (*sexp_proc4) (sexp sexp_api_params(self, n), sexp, sexp, sexp); +typedef sexp (*sexp_proc5) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc6) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc7) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp); + +typedef struct sexp_free_list_t *sexp_free_list; +struct sexp_free_list_t { + sexp_uint_t size; + sexp_free_list next; +}; + +typedef struct sexp_heap_t *sexp_heap; +struct sexp_heap_t { + sexp_uint_t size; + sexp_free_list free_list; + sexp_heap next; + /* note this must be aligned on a proper heap boundary, */ + /* so we can't just use char data[] */ + char *data; +}; + +struct sexp_gc_var_t { + sexp *var; +#if SEXP_USE_CONSERVATIVE_GC + char *name; +#endif + struct sexp_gc_var_t *next; +}; + +struct sexp_struct { + sexp_tag_t tag; + char gc_mark; + unsigned int immutablep:1; + unsigned int freep:1; +#if SEXP_USE_HEADER_MAGIC + unsigned int magic; +#endif + union { + /* basic types */ + double flonum; + struct { + sexp_tag_t tag; + short field_base, field_eq_len_base, field_len_base, field_len_off; + unsigned short field_len_scale; + short size_base, size_off; + unsigned short size_scale; + char *name; + sexp_proc2 finalize; + } 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; + char openp, no_closep, sourcep; + sexp_uint_t offset, line; + size_t size; + sexp name; + sexp cookie; + } port; + struct { + sexp kind, message, irritants, procedure, source; + } exception; + struct { + signed char sign; + sexp_uint_t length; + sexp_uint_t data[]; + } bignum; + struct { + sexp_uint_t length; + void *value; + sexp parent; + char body[]; + } cpointer; + /* runtime types */ + struct { + unsigned int syntacticp:1; + 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; + const char *name; + sexp data, data2, proc; + sexp_proc1 func; + } opcode; + struct { + char code; + const char *name; + } core; + /* ast types */ + struct { + sexp name, params, body, defs, locals, flags, 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_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp_heap heap; + struct sexp_gc_var_t *saves; + sexp_uint_t pos, depth, tailp, tracep; + sexp bc, lambda, stack, env, fv, parent, globals; + } 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_offsetof_slot0 (offsetof(struct sexp_struct, value)) + +#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double)) + +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) +#define sexp_alloc_bytecode(ctx, i) sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE) + +#if SEXP_USE_BIGNUMS +#include "chibi/bignum.h" +#endif + +/***************************** 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_fixnump(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_flags(x) ((x)->flags) +#define sexp_immutablep(x) ((x)->immutablep) +#define sexp_freep(x) ((x)->freep) +#define sexp_pointer_magic(x) ((x)->magic) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) +#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) + +#if SEXP_USE_IMMEDIATE_FLONUMS +union sexp_flonum_conv { + float flonum; + unsigned int bits; +}; +#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x); +#if SEXP_64_BIT +SEXP_API float sexp_flonum_value (sexp x); +SEXP_API sexp sexp_make_flonum(sexp ctx, float f); +#else +#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)(((unsigned int)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) +#endif +#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_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) +#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER)) +#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)) + +#if SEXP_USE_HUFF_SYMS +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +#else +#define sexp_symbolp(x) (sexp_lsymbolp(x)) +#endif + +#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_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) + +#define SEXP_NEG_ONE sexp_make_fixnum(-1) +#define SEXP_ZERO sexp_make_fixnum(0) +#define SEXP_ONE sexp_make_fixnum(1) +#define SEXP_TWO sexp_make_fixnum(2) +#define SEXP_THREE sexp_make_fixnum(3) +#define SEXP_FOUR sexp_make_fixnum(4) +#define SEXP_FIVE sexp_make_fixnum(5) +#define SEXP_SIX sexp_make_fixnum(6) +#define SEXP_SEVEN sexp_make_fixnum(7) +#define SEXP_EIGHT sexp_make_fixnum(8) +#define SEXP_NINE sexp_make_fixnum(9) +#define SEXP_TEN sexp_make_fixnum(10) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) + +#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x))) +#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x)) +#else +#define _or_integer_flonump(x) +#endif + +#if SEXP_USE_BIGNUMS +SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x); +SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); +#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) +#else +#define sexp_make_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_make_unsigned_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_exact_integerp(x) sexp_fixnump(x) +#endif + +#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) +#define sexp_numberp(x) (sexp_exact_integerp(x) || sexp_flonump(x)) +#else +#define sexp_fixnum_to_flonum(ctx, x) (x) +#define sexp_numberp(x) sexp_exact_integerp(x) +#endif + +#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS +#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0])) +#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0])) +#else +#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x)) +#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x)) +#endif + +#define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET) +#define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET) + +/*************************** 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_fixnum(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_fixnum(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_fixnum(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((unsigned char)sexp_string_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(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_no_closep(p) ((p)->value.port.no_closep) +#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_cpointer_freep(p) (sexp_freep(p)) +#define sexp_cpointer_length(p) ((p)->value.cpointer.length) +#define sexp_cpointer_body(p) ((p)->value.cpointer.body) +#define sexp_cpointer_parent(p) ((p)->value.cpointer.parent) +#define sexp_cpointer_value(p) ((p)->value.cpointer.value) +#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p)) + +#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_syntactic_p(x) ((x)->value.env.syntacticp) +#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_data(x) ((x)->value.opcode.data) +#define sexp_opcode_data2(x) ((x)->value.opcode.data2) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) +#define sexp_opcode_func(x) ((x)->value.opcode.func) + +#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_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) + +#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_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_globals(x) ((x)->value.context.globals) + +#if SEXP_USE_ALIGNED_BYTECODE +#define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx)) +#else +#define sexp_context_align_pos(ctx) +#endif + +#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) + +#if SEXP_USE_GLOBAL_HEAP +#if ! SEXP_USE_BOEHM +SEXP_API sexp_heap sexp_global_heap; +#endif +#define sexp_context_heap(ctx) sexp_global_heap +#else +#define sexp_context_heap(ctx) ((ctx)->value.context.heap) +#endif + +#if SEXP_USE_GLOBAL_SYMBOLS +#define sexp_context_symbols(ctx) sexp_symbol_table +#else +#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) +#endif + +#if SEXP_USE_GLOBAL_TYPES +SEXP_API struct sexp_struct *sexp_type_specs; +#define sexp_context_types(ctx) sexp_type_specs +#define sexp_type_by_index(ctx,i) (&(sexp_context_types(ctx)[i])) +#define sexp_context_num_types(ctx) sexp_num_types +#define sexp_context_type_array_size(ctx) sexp_type_array_size +#else +#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#define sexp_type_by_index(ctx,i) (sexp_context_types(ctx)[i]) +#define sexp_context_num_types(ctx) \ + sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES)) +#define sexp_context_type_array_size(ctx) \ + sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES)) +#endif + +#define sexp_object_type(ctx,x) (sexp_type_by_index(ctx, ((x)->tag))) +#define sexp_object_type_name(ctx,x) (sexp_type_name(sexp_object_type(ctx, x))) +#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i))) + +#define sexp_type_size_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \ + * sexp_type_size_scale(t) \ + + sexp_type_size_base(t)) +#define sexp_type_num_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_len_base(t)) +#define sexp_type_num_eq_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_eq_len_base(t)) + +#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_eq_len_base(x) ((x)->value.type.field_eq_len_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_type_finalize(x) ((x)->value.type.finalize) + +#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_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b))) +#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b))) +#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1))) +#define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a)))) +#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) + +#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 *****************************/ + +enum sexp_context_globals { +#if ! SEXP_USE_GLOBAL_SYMBOLS + SEXP_G_SYMBOLS, +#endif +#if ! SEXP_USE_GLOBAL_TYPES + SEXP_G_TYPES, + SEXP_G_NUM_TYPES, +#endif + SEXP_G_OOM_ERROR, /* out of memory exception object */ + SEXP_G_OOS_ERROR, /* out of stack exception object */ + SEXP_G_OPTIMIZATIONS, + SEXP_G_SIGNAL_HANDLERS, + SEXP_G_CONFIG_ENV, + SEXP_G_MODULE_PATH, + SEXP_G_QUOTE_SYMBOL, + SEXP_G_QUASIQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SPLICING_SYMBOL, + SEXP_G_EMPTY_VECTOR, + SEXP_G_CUR_IN_SYMBOL, + SEXP_G_CUR_OUT_SYMBOL, + SEXP_G_CUR_ERR_SYMBOL, + SEXP_G_INTERACTION_ENV_SYMBOL, + SEXP_G_ERR_HANDLER, + SEXP_G_RESUMECC_BYTECODE, + SEXP_G_FINAL_RESUMER, + SEXP_G_NUM_GLOBALS +}; + +#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(ctx, (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 SEXP_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)) + +SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); +SEXP_API sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, const char *str, sexp_uint_t len, sexp p); +SEXP_API sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p); +SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) + +SEXP_API sexp sexp_make_context(sexp ctx, size_t size); +SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +SEXP_API sexp sexp_cons_op(sexp ctx sexp_api_params(self, n), sexp head, sexp tail); +SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_listp_op(sexp ctx sexp_api_params(self, n), sexp obj); +SEXP_API sexp sexp_reverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_nreverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_copy_list_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_append2_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_memq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_assq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_length_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen); +SEXP_API sexp sexp_make_string_op(sexp ctx sexp_api_params(self, n), sexp len, sexp ch); +SEXP_API sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end); +SEXP_API sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep); +SEXP_API sexp sexp_intern (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b); +SEXP_API sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt); +SEXP_API sexp sexp_list_to_vector_op (sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); +SEXP_API sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp in); +SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_write_to_string (sexp ctx, sexp obj); +SEXP_API sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port); +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_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)); +SEXP_API sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port); +SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); +SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x); +SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +SEXP_API sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out); +SEXP_API void sexp_init(void); + +#define sexp_assert_type(ctx, pred, type_id, obj) if (! pred(obj)) return sexp_type_exception(ctx, self, type_id, obj) + +#define SEXP_COPY_DEFAULT SEXP_ZERO +#define SEXP_COPY_FREEP SEXP_ONE + +#if SEXP_USE_GLOBAL_HEAP +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_destroy_context (sexp ctx); +SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags); +#endif + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots); +SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); +SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj); +#define sexp_register_c_type(ctx, name, finalizer) \ + sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ + SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer) +#endif + +#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) +#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))) + +/* simplify primitive API interface */ + +#define sexp_read(ctx, in) sexp_read_op(ctx sexp_api_pass(NULL, 1), in) +#define sexp_write(ctx, obj, out) sexp_write_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_display(ctx, obj, out) sexp_display_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx sexp_api_pass(NULL, 2), e, out) +#define sexp_flush_output(ctx, obj, out) sexp_flush_output_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_listp(ctx, x) sexp_listp_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_length(ctx, x) sexp_length_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_reverse(ctx, x) sexp_reverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_copy_list(ctx, x) sexp_copy_list_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_cons(ctx, a, b) sexp_cons_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_append2(ctx, a, b) sexp_append2_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx sexp_api_pass(NULL, 2), a, b); +#define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_string_to_number(ctx, s, b) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), s, b) +#define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), l, c) +#define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_substring(ctx, a, b, c) sexp_substring_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx sexp_api_pass(NULL, 2), ls, s) +#define sexp_memq(ctx, a, b) sexp_memq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_assq(ctx, a, b) sexp_assq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_output_string_port(ctx) sexp_make_output_string_port_op(ctx sexp_api_pass(NULL, 0)) +#define sexp_make_input_string_port(ctx, s) sexp_make_input_string_port_op(ctx sexp_api_pass(NULL, 1), s) +#define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_expt(ctx, a, b) sexp_expt_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_simple_type(ctx, a, b) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j) sexp_register_type_op(ctx sexp_api_pass(NULL, 10), a, b, c, d, e, f, g, h, i, j) +#define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_make_setter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) + +#ifdef __cplusplus +} /* extern "C" */ +#endif + +#endif /* ! SEXP_H */ + diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c new file mode 100644 index 00000000..2b740f41 --- /dev/null +++ b/lib/chibi/ast.c @@ -0,0 +1,79 @@ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); + sexp_gc_release2(ctx); +} + +static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, + sexp_uint_t cindex, char* get, char *set) { + sexp type, index; + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + type = sexp_make_fixnum(ctype); + index = sexp_make_fixnum(cindex); + op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, get, -1), op); + op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, set, -1), op); + sexp_gc_release2(ctx); +} + +static sexp sexp_get_env_cell (sexp ctx sexp_api_params(self, n), sexp env, sexp id) { + sexp cell = sexp_env_cell(env, id); + while ((! cell) && sexp_synclop(id)) { + env = sexp_synclo_env(id); + id = sexp_synclo_expr(id); + } + return cell ? cell : SEXP_FALSE; +} + +static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + else if (! sexp_opcode_name(op)) + return SEXP_FALSE; + else + return sexp_intern(ctx, sexp_opcode_name(op), -1); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); + sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); + sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); + sexp_define_type_predicate(ctx, env, "set?", SEXP_SET); + sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF); + sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ); + sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); + sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); + sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); + sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); + sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze); + sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); + sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); + sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + return SEXP_VOID; +} + diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module new file mode 100644 index 00000000..497fc5ed --- /dev/null +++ b/lib/chibi/ast.module @@ -0,0 +1,15 @@ + +(define-module (chibi ast) + (export analyze env-cell opcode-name + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + lambda-name lambda-params lambda-body lambda-defs + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + cnd-test cnd-pass cnd-fail + cnd-test-set! cnd-pass-set! cnd-fail-set! + set-var set-value set-var-set! set-value-set! + ref-name ref-cell ref-name-set! ref-cell-set! + seq-ls seq-ls-set! lit-value lit-value-set!) + (import-immutable (scheme)) + (include-shared "ast")) + diff --git a/lib/chibi/base64.module b/lib/chibi/base64.module new file mode 100644 index 00000000..12324e1d --- /dev/null +++ b/lib/chibi/base64.module @@ -0,0 +1,7 @@ + +(define-module (chibi base64) + (export base64-encode base64-encode-string + base64-decode base64-decode-string + base64-encode-header) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "base64.scm")) diff --git a/lib/chibi/base64.scm b/lib/chibi/base64.scm new file mode 100644 index 00000000..3d95ad71 --- /dev/null +++ b/lib/chibi/base64.scm @@ -0,0 +1,351 @@ +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: base64-encode-string str +;; Return a base64 encoded representation of string according to the +;; official base64 standard as described in RFC3548. + +;; Procedure: base64-decode-string str +;; Return a base64 decoded representation of string, also interpreting +;; the alternate 62 & 63 valued characters as described in RFC3548. +;; Other out-of-band characters are silently stripped, and = signals +;; the end of the encoded string. No errors will be raised. + +;; Procedure: base64-encode [port] +;; Procedure: base64-decode [port] +;; Variations of the above which read and write to ports. + +;; Procedure: base64-encode-header enc str [start-col max-col nl] +;; Return a base64 encoded representation of string as above, +;; wrapped in =?ENC?B?...?= as per RFC1522, split across multiple +;; MIME-header lines as needed to keep each lines length less than +;; MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring +;; STR is already encoded according to ENC. The optional argument +;; NL is the newline separator, defaulting to CRLF. + +;; This API is compatible with the Gauche library rfc.base64. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-chop str n) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (+ i n))) + (if (>= j len) + (reverse (cons (substring str i len) res)) + (lp j (cons (substring str i j) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; constants and tables + +(define *default-max-col* 76) + +(define *outside-char* 99) ; luft-balloons +(define *pad-char* 101) ; dalmations + +(define *base64-decode-table* + (let ((res (make-vector #x100 *outside-char*))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res (+ i 65) i) + (vector-set! res (+ i 97) (+ i 26)) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 48) (+ i 52)) + (lp (+ i 1))))) + ;; extras (be liberal for different common base64 formats) + (vector-set! res (char->integer #\+) 62) + (vector-set! res (char->integer #\-) 62) + (vector-set! res (char->integer #\/) 63) + (vector-set! res (char->integer #\_) 63) + (vector-set! res (char->integer #\~) 63) + (vector-set! res (char->integer #\=) *pad-char*) + res)) + +(define (base64-decode-char c) + (vector-ref *base64-decode-table* (char->integer c))) + +(define *base64-encode-table* + (let ((res (make-vector 64))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res i (integer->char (+ i 65))) + (vector-set! res (+ i 26) (integer->char (+ i 97))) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 52) (integer->char (+ i 48))) + (lp (+ i 1))))) + (vector-set! res 62 #\+) + (vector-set! res 63 #\/) + res)) + +(define (enc i) + (vector-ref *base64-encode-table* i)) + +;; try to match common boundaries +(define decode-src-length + (lcm 76 78)) + +(define decode-dst-length + (* 3 (arithmetic-shift (+ 3 decode-src-length) -2))) + +(define encode-src-length + (* 3 1024)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; decoding + +;; Create a result buffer with the maximum possible length for the +;; input, and pass it to the internal base64-decode-string! utility. +;; If the resulting length used is exact, we can return that buffer, +;; otherwise we return the appropriate substring. +(define (base64-decode-string src) + (let* ((len (string-length src)) + (dst-len (* 3 (arithmetic-shift (+ 3 len) -2))) + (dst (make-string dst-len))) + (base64-decode-string! + src 0 len dst + (lambda (src-offset res-len b1 b2 b3) + (let ((res-len (base64-decode-finish dst res-len b1 b2 b3))) + (if (= res-len dst-len) + dst + (substring dst 0 res-len))))))) + +;; This is a little funky. +;; +;; We want to skip over "outside" characters (e.g. newlines inside +;; base64-encoded data, as would be passed in mail clients and most +;; large base64 data). This would normally mean two nested loops - +;; one for overall processing the input, and one for looping until +;; we get to a valid character. However, many Scheme compilers are +;; really bad about optimizing nested loops of primitives, so we +;; flatten this into a single loop, using conditionals to determine +;; which character is currently being read. +(define (base64-decode-string! src start end dst kont) + (let lp ((i start) + (j 0) + (b1 *outside-char*) + (b2 *outside-char*) + (b3 *outside-char*)) + (if (>= i end) + (kont i j b1 b2 b3) + (let ((c (base64-decode-char (string-ref src i)))) + (cond + ((eqv? c *pad-char*) + (kont i j b1 b2 b3)) + ((eqv? c *outside-char*) + (lp (+ i 1) j b1 b2 b3)) + ((eqv? b1 *outside-char*) + (lp (+ i 1) j c b2 b3)) + ((eqv? b2 *outside-char*) + (lp (+ i 1) j b1 c b3)) + ((eqv? b3 *outside-char*) + (lp (+ i 1) j b1 b2 c)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (string-set! dst + (+ j 2) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 2 0 b3) 6) + c))) + (lp (+ i 1) (+ j 3) + *outside-char* *outside-char* *outside-char*))))))) + +;; If requested, account for any "partial" results (i.e. trailing 2 or +;; 3 chars) by writing them into the destination (additional 1 or 2 +;; bytes) and returning the adjusted offset for how much data we've +;; written. +(define (base64-decode-finish dst j b1 b2 b3) + (cond + ((eqv? b1 *outside-char*) + j) + ((eqv? b2 *outside-char*) + (string-set! dst j (integer->char (arithmetic-shift b1 2))) + (+ j 1)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (cond + ((eqv? b3 *outside-char*) + (+ j 1)) + (else + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (+ j 2)))))) + +;; General port decoder: work in single blocks at a time to avoid +;; allocating memory (crucial for Scheme implementations that don't +;; allow large strings). +(define (base64-decode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string decode-src-length)) + (dst (make-string decode-dst-length))) + (let lp ((offset 0)) + (let ((src-len (+ offset + (read-string! decode-src-length src in offset)))) + (cond + ((= src-len decode-src-length) + ;; read a full chunk: decode, write and loop + (base64-decode-string! + src 0 decode-src-length dst + (lambda (src-offset dst-len b1 b2 b3) + (cond + ((and (< src-offset src-len) + (eqv? #\= (string-ref src src-offset))) + ;; done + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))) + ((eqv? b1 *outside-char*) + (write-string dst dst-len out) + (lp 0)) + (else + (write-string dst dst-len out) + ;; one to three chars left in buffer + (string-set! src 0 (enc b1)) + (cond + ((eqv? b2 *outside-char*) + (lp 1)) + (else + (string-set! src 1 (enc b2)) + (cond + ((eqv? b3 *outside-char*) + (lp 2)) + (else + (string-set! src 2 (enc b3)) + (lp 3)))))))))) + (else + ;; end of source - just decode and write once + (base64-decode-string! + src 0 src-len dst + (lambda (src-offset dst-len b1 b2 b3) + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; encoding + +(define (base64-encode-string str) + (let* ((len (string-length str)) + (quot (quotient len 3)) + (rem (- len (* quot 3))) + (res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2)) + (res (make-string res-len))) + (base64-encode-string! str 0 len res) + res)) + +(define (base64-encode-string! str start end res) + (let* ((res-len (string-length res)) + (limit (- end 2))) + (let lp ((i start) (j 0)) + (if (>= i limit) + (case (- end i) + ((1) + (let ((b1 (char->integer (string-ref str i)))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (arithmetic-shift (bitwise-and #b11 b1) 4))) + (string-set! res (+ j 2) #\=) + (string-set! res (+ j 3) #\=))) + ((2) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (arithmetic-shift (extract-bit-field 4 0 b2) + 2))) + (string-set! res (+ j 3) #\=)))) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1)))) + (b3 (char->integer (string-ref str (+ i 2))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 2) + (extract-bit-field 2 6 b3)))) + (string-set! res (+ j 3) (enc (bitwise-and #b111111 b3))) + (lp (+ i 3) (+ j 4))))))) + +(define (base64-encode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string encode-src-length)) + (dst (make-string + (arithmetic-shift (quotient encode-src-length 3) 2)))) + (let lp () + (let ((n (read-string! 2048 src in))) + (base64-encode-string! src 0 n dst) + (write-string dst (* 3 (quotient (+ n 3) 4)) out) + (if (= n 2048) + (lp))))))) + +(define (base64-encode-header encoding str . o) + (define (round4 i) (arithmetic-shift (arithmetic-shift i -2) 2)) + (let ((start-col (if (pair? o) (car o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?B?")) + (prefix-length (+ 2 (string-length prefix))) + (effective-max-col (round4 (- max-col prefix-length))) + (first-max-col (round4 (- effective-max-col start-col))) + (str (base64-encode-string str)) + (len (string-length str))) + (if (<= len first-max-col) + (string-append prefix str "?=") + (string-append + (if (positive? first-max-col) + (string-append + prefix (substring str 0 first-max-col) "?=" nl "\t" prefix) + "") + (string-concatenate (string-chop (substring str first-max-col len) + effective-max-col) + (string-append "?=" nl "\t" prefix)) + "?="))))) + diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c new file mode 100644 index 00000000..38b3a61a --- /dev/null +++ b/lib/chibi/disasm.c @@ -0,0 +1,116 @@ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define SEXP_DISASM_MAX_DEPTH 8 +#define SEXP_DISASM_PAD_WIDTH 4 + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", + "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", + "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", + "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", + "MUL", "DIV", "QUOTIENT", "REMAINDER", + "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", + }; + +static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { + sexp tmp; + unsigned char *ip, opcode, i; + + if (sexp_procedurep(bc)) { + bc = sexp_procedure_code(bc); + } else if (sexp_opcodep(bc)) { + sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); + return SEXP_VOID; + } else if (! sexp_bytecodep(bc)) { + return sexp_type_exception(ctx, self, SEXP_BYTECODE, bc); + } + if (! sexp_oportp(out)) { + return sexp_type_exception(ctx, self, SEXP_OPORT, out); + } + + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + sexp_write_string(ctx, "-------------- ", out); + if (sexp_truep(sexp_bytecode_name(bc))) { + sexp_write(ctx, sexp_bytecode_name(bc), out); + sexp_write_char(ctx, ' ', out); + } + sexp_printf(ctx, out, "%p\n", bc); + + ip = sexp_bytecode_data(bc); + + loop: + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + 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 SEXP_OP_STACK_REF: + case SEXP_OP_LOCAL_REF: + case SEXP_OP_LOCAL_SET: + case SEXP_OP_CLOSURE_REF: + case SEXP_OP_JUMP: + case SEXP_OP_JUMP_UNLESS: + case SEXP_OP_TYPEP: + case SEXP_OP_FCALL0: + case SEXP_OP_FCALL1: + case SEXP_OP_FCALL2: + case SEXP_OP_FCALL3: + case SEXP_OP_FCALL4: + case SEXP_OP_FCALL5: + case SEXP_OP_FCALL6: + sexp_printf(ctx, out, "%ld", (long) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case SEXP_OP_SLOT_REF: + case SEXP_OP_SLOT_SET: + case SEXP_OP_MAKE: + ip += sizeof(sexp)*2; + break; + case SEXP_OP_GLOBAL_REF: + case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_TAIL_CALL: + case SEXP_OP_CALL: + case SEXP_OP_PUSH: + tmp = ((sexp*)ip)[0]; + if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF)) + && sexp_pairp(tmp)) + tmp = sexp_car(tmp); + else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) + sexp_write_char(ctx, '\'', out); + sexp_write(ctx, tmp, out); + ip += sizeof(sexp); + break; + } + sexp_write_char(ctx, '\n', out); + if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) + && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) + disasm(ctx, self, tmp, out, depth+1); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +static sexp sexp_disasm (sexp ctx sexp_api_params(self, n), sexp bc, sexp out) { + return disasm(ctx, self, bc, out, 0); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "*current-output-port*"); + return SEXP_VOID; +} diff --git a/lib/chibi/disasm.module b/lib/chibi/disasm.module new file mode 100644 index 00000000..9017a4bc --- /dev/null +++ b/lib/chibi/disasm.module @@ -0,0 +1,5 @@ + +(define-module (chibi disasm) + (export disasm) + (import-immutable (scheme)) + (include-shared "disasm")) diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module new file mode 100644 index 00000000..ecd4af32 --- /dev/null +++ b/lib/chibi/filesystem.module @@ -0,0 +1,27 @@ + +(define-module (chibi filesystem) + (export open-input-file-descriptor open-output-file-descriptor + duplicate-file-descriptor duplicate-file-descriptor-to + close-file-descriptor renumber-file-descriptor + delete-file link-file symbolic-link-file rename-file + directory-files directory-fold create-directory delete-directory + file-status + file-device file-inode + file-mode file-num-links + file-owner file-group + file-represented-device file-size + file-block-size file-num-blocks + file-access-time file-modification-time file-change-time + file-regular? file-directory? file-character? + file-block? file-fifo? file-link? + file-socket? file-exists? + get-file-descriptor-flags set-file-descriptor-flags! + get-file-descriptor-status set-file-descriptor-status! + open/read open/write open/read-write + open/create open/exclusive open/truncate + open/append open/non-block + is-a-tty?) + (import-immutable (scheme)) + (include-shared "filesystem") + (include "filesystem.scm")) + diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm new file mode 100644 index 00000000..aa3fc69f --- /dev/null +++ b/lib/chibi/filesystem.scm @@ -0,0 +1,43 @@ +;; filesystem.scm -- additional filesystem utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (let lp ((res knil)) + (let ((file (readdir dir))) + (if file (lp (kons (dirent-name file) res)) res))))) + +(define (directory-files dir) + (directory-fold dir cons '())) + +(define (renumber-file-descriptor old new) + (and (duplicate-file-descriptor-to old new) + (close-file-descriptor old))) + +(define (file-status file) + (if (string? file) (stat file) (fstat file))) + +(define (file-device x) (stat-dev (if (stat? x) x (file-status x)))) +(define (file-inode x) (stat-ino (if (stat? x) x (file-status x)))) +(define (file-mode x) (stat-mode (if (stat? x) x (file-status x)))) +(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x)))) +(define (file-owner x) (stat-uid (if (stat? x) x (file-status x)))) +(define (file-group x) (stat-gid (if (stat? x) x (file-status x)))) +(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x)))) +(define (file-size x) (stat-size (if (stat? x) x (file-status x)))) +(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x)))) +(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x)))) +(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x)))) +(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x)))) +(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x)))) + +(define (file-regular? x) (S_ISREG (file-mode x))) +(define (file-directory? x) (S_ISDIR (file-mode x))) +(define (file-character? x) (S_ISCHR (file-mode x))) +(define (file-block? x) (S_ISBLK (file-mode x))) +(define (file-fifo? x) (S_ISFIFO (file-mode x))) +(define (file-link? x) (S_ISLNK (file-mode x))) +(define (file-socket? x) (S_ISSOCK (file-mode x))) + +(define (file-exists? x) (and (file-status x) #t)) diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub new file mode 100644 index 00000000..5656fcdc --- /dev/null +++ b/lib/chibi/filesystem.stub @@ -0,0 +1,118 @@ + +(c-system-include "sys/types.h") +(c-system-include "unistd.h") +(c-system-include "dirent.h") +(c-system-include "fcntl.h") + +(define-c-type DIR + finalizer: closedir) + +(define-c-struct dirent + (string d_name dirent-name)) + +(define-c-struct stat + predicate: stat? + (dev_t st_dev stat-dev) + (ino_t st_ino stat-ino) + (mode_t st_mode stat-mode) + (nlink_t st_nlink stat-nlinks) + (uid_t st_uid stat-uid) + (gid_t st_gid stat-gid) + (dev_t st_rdev stat-rdev) + (off_t st_size stat-size) + (blksize_t st_blksize stat-blksize) + (blkcnt_t st_blocks stat-blocks) + (time_t st_atime stat-atime) + (time_t st_mtime stat-mtime) + (time_t st_ctime stat-ctime)) + +(define-c boolean S_ISREG (mode_t)) +(define-c boolean S_ISDIR (mode_t)) +(define-c boolean S_ISCHR (mode_t)) +(define-c boolean S_ISBLK (mode_t)) +(define-c boolean S_ISFIFO (mode_t)) +(define-c boolean S_ISLNK (mode_t)) +(define-c boolean S_ISSOCK (mode_t)) + +;;(define-c-const int ("S_IFMT")) +(define-c-const int (file/socket "S_IFSOCK")) +(define-c-const int (file/link "S_IFLNK")) +(define-c-const int (file/regular "S_IFREG")) +(define-c-const int (file/block "S_IFBLK")) +(define-c-const int (file/directory "S_IFDIR")) +(define-c-const int (file/character "S_IFCHR")) +(define-c-const int (file/fifo "S_IFIFO")) +(define-c-const int (file/suid "S_ISUID")) +(define-c-const int (file/sgid "S_ISGID")) +(define-c-const int (file/sticky "S_ISVTX")) +;;(define-c-const int ("S_IRWXU")) +(define-c-const int (perm/user-read "S_IRUSR")) +(define-c-const int (perm/user-write "S_IWUSR")) +(define-c-const int (perm/user-execute "S_IXUSR")) +;;(define-c-const int ("S_IRWXG")) +(define-c-const int (perm/group-read "S_IRGRP")) +(define-c-const int (perm/group-write "S_IWGRP")) +(define-c-const int (perm/group-execute "S_IXGRP")) +;;(define-c-const int ("S_IRWXO")) +(define-c-const int (perm/others-read "S_IROTH")) +(define-c-const int (perm/others-write "S_IWOTH")) +(define-c-const int (perm/others-execute "S_IXOTH")) + +(define-c errno stat (string (result stat))) +(define-c errno fstat (int (result stat))) +(define-c errno (file-link-status "lstat") (string (result stat))) + +(define-c input-port (open-input-file-descriptor "fdopen") + (int (value "r" string))) +(define-c output-port (open-output-file-descriptor "fdopen") + (int (value "w" string))) + +(define-c errno (delete-file "unlink") (string)) +(define-c errno (link-file "link") (string string)) +(define-c errno (symbolic-link-file "symlink") (string string)) +(define-c errno (rename-file "rename") (string string)) + +(define-c non-null-string (current-directory "getcwd") + ((result (array char (auto-expand arg1))) (value 256 int))) + +(define-c errno (create-directory "mkdir") (string int)) +(define-c errno (delete-directory "rmdir") (string)) + +(define-c (free DIR) opendir (string)) +(define-c dirent readdir ((link DIR))) + +(define-c int (duplicate-file-descriptor "dup") (int)) +(define-c errno (duplicate-file-descriptor-to "dup2") (int int)) +(define-c errno (close-file-descriptor "close") (int)) + +(define-c errno (open-pipe "pipe") ((result (array int 2)))) +(define-c errno (make-fifo "mkfifo") (string (default #o644 int))) + +(define-c int (get-file-descriptor-flags "fcntl") + (int (value F_GETFD int))) +(define-c errno (set-file-descriptor-flags! "fcntl") + (int (value F_SETFD int) long)) + +(define-c int (get-file-descriptor-status "fcntl") + (int (value F_GETFL int))) +(define-c errno (set-file-descriptor-status! "fcntl") + (int (value F_SETFL int) long)) + +;; (define-c int (get-file-descriptor-lock "fcntl") +;; (int (value F_GETLK int) flock)) +;; (define-c errno (set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLK int) flock)) +;; (define-c errno (try-set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLKW int) flock)) + +(define-c-const int (open/read "O_RDONLY")) +(define-c-const int (open/write "O_WRONLY")) +(define-c-const int (open/read-write "O_RDWR")) +(define-c-const int (open/create "O_CREAT")) +(define-c-const int (open/exclusive "O_EXCL")) +(define-c-const int (open/truncate "O_TRUNC")) +(define-c-const int (open/append "O_APPEND")) +(define-c-const int (open/non-block "O_NONBLOCK")) + +(define-c boolean (is-a-tty? "isatty") (port-or-fd)) + diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c new file mode 100644 index 00000000..976b5b27 --- /dev/null +++ b/lib/chibi/heap-stats.c @@ -0,0 +1,129 @@ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define SEXP_HEAP_VECTOR_DEPTH 1 + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); + +#if SEXP_USE_GLOBAL_HEAP +#endif + +static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { + int i; + if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x) + || sexp_flonump(x) || sexp_bignump(x)) { + sexp_write(ctx, x, out); + } else if (depth <= 0) { + goto print_name; + } else if (sexp_synclop(x)) { + sexp_write_string(ctx, "#", out); + } else if (sexp_pairp(x)) { + sexp_write_char(ctx, '(', out); + sexp_print_simple(ctx, sexp_car(x), out, depth-1); + sexp_write_string(ctx, " . ", out); + sexp_print_simple(ctx, sexp_cdr(x), out, depth-1); + sexp_write_char(ctx, ')', out); + } else if (sexp_vectorp(x)) { + sexp_write_string(ctx, "#(", out); + for (i=0; i0) + sexp_write_char(ctx, ' ', out); + sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); + } + if (i", out); + } +} + +static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { + size_t freed; + sexp_uint_t stats[256], hi_type=0, i; + sexp_heap h = sexp_context_heap(ctx); + sexp p, out=SEXP_FALSE; + sexp_free_list q, r; + char *end; + sexp_gc_var3(res, tmp, name); + + if (printp) + out = sexp_env_global_ref(sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + SEXP_FALSE); + + /* run gc once to remove unused variables */ + sexp_gc(ctx, &freed); + + /* initialize stats */ + for (i=0; i<256; i++) stats[i]=0; + + /* loop over each heap chunk */ + for ( ; h; h=h->next) { + 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) { /* this is a free block, skip */ + p = (sexp) (((char*)p) + r->size); + continue; + } + /* otherwise maybe print, then increment the stat and continue */ + if (sexp_oportp(out)) { + sexp_print_simple(ctx, p, out, depth); + sexp_write_char(ctx, '\n', out); + } + stats[sexp_pointer_tag(p)]++; + if (sexp_pointer_tag(p) > hi_type) + hi_type = sexp_pointer_tag(p); + p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p))); + } + } + + /* build and return results */ + sexp_gc_preserve3(ctx, res, tmp, name); + res = SEXP_NULL; + for (i=hi_type; i>0; i--) + if (stats[i]) { + name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i), -1); + tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); + res = sexp_cons(ctx, tmp, res); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_heap_stats (sexp ctx sexp_api_params(self, n)) { + return sexp_heap_walk(ctx, 0, 0); +} + +static sexp sexp_heap_dump (sexp ctx sexp_api_params(self, n), sexp depth) { + if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) + return sexp_xtype_exception(ctx, self, "bad heap-dump depth", depth); + return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats); + sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE); + return SEXP_VOID; +} + diff --git a/lib/chibi/heap-stats.module b/lib/chibi/heap-stats.module new file mode 100644 index 00000000..c1599c35 --- /dev/null +++ b/lib/chibi/heap-stats.module @@ -0,0 +1,6 @@ + +(define-module (chibi heap-stats) + (export heap-stats heap-dump) + (import-immutable (scheme)) + (include-shared "heap-stats")) + diff --git a/lib/chibi/io.module b/lib/chibi/io.module new file mode 100644 index 00000000..ec765c04 --- /dev/null +++ b/lib/chibi/io.module @@ -0,0 +1,13 @@ + +(define-module (chibi io) + (export read-string read-string! write-string read-line write-line + port-fold port-fold-right port-map + port->list port->string-list port->sexp-list port->string + file-position set-file-position! seek/set seek/cur seek/end + make-custom-input-port make-custom-output-port + make-null-output-port make-broadcast-port make-concatenated-port + make-generated-input-port make-filtered-output-port + make-filtered-input-port) + (import-immutable (scheme)) + (include-shared "io/io") + (include "io/io.scm")) diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm new file mode 100644 index 00000000..2d4da555 --- /dev/null +++ b/lib/chibi/io/io.scm @@ -0,0 +1,170 @@ +;; io.scm -- various input/output utilities +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define eof + (call-with-input-string " " + (lambda (in) (read-char in) (read-char in)))) + +(define (string-copy! dst start src from to) + (do ((i from (+ i 1)) (j start (+ j 1))) + ((>= i to)) + (string-set! dst j (string-ref src i)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; reading and writing + +(define (write-line str . o) + (let ((out (if (pair? o) (car o) (current-output-port)))) + (display str out) + (newline out))) + +(define (read-line . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192))) + (let ((res (%read-line n in))) + (if (not res) + eof + (let ((len (string-length res))) + (if (and (> len 0) (eqv? #\newline (string-ref res (- len 1)))) + (if (and (> len 1) (eqv? #\return (string-ref res (- len 2)))) + (substring res 0 (- len 2)) + (substring res 0 (- len 1))) + res)))))) + +(define (read-string n . o) + (let ((in (if (pair? o) (car o) (current-input-port)))) + (let ((res (%read-string n in))) + (if (if (pair? res) (= 0 (car res)) #t) + eof + (cadr res))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; higher order port operations + +(define (port-fold kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp ((acc knil)) + (let ((x (read in))) + (if (eof-object? x) acc (lp (kons x acc))))))) + +(define (port-fold-right kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp () + (let ((x (read in))) + (if (eof-object? x) knil (kons x (lp))))))) + +(define (port-map fn . o) + (reverse (apply port-fold (lambda (x ls) (cons (fn x) ls)) '() o))) + +(define (port->list read in) + (port-map (lambda (x) x) read in)) + +(define (port->sexp-list in) + (port->list read in)) + +(define (port->string-list in) + (port->list read-line in)) + +(define (port->string in) + (string-concatenate (port->list (lambda (in) (read-string 1024 in)) in))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; custom port utilities + +(define (make-custom-input-port read . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-input-port read seek close))) + +(define (make-custom-output-port write . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-output-port write seek close))) + +(define (make-null-output-port) + (make-custom-output-port (lambda (str n) 0))) + +(define (make-broadcast-port . ports) + (make-custom-output-port + (lambda (str n) + (for-each (lambda (p) (write-string str n p)) ports) + n))) + +(define (make-filtered-output-port filter out) + (make-custom-output-port + (lambda (str n) + (let* ((len (string-length str)) + (s1 (if (= n len) str (substring str 0 n))) + (s2 (filter s1))) + (if (string? s2) + (write-string s2 (string-length s2) out)))))) + +(define (make-concatenated-port . ports) + (make-custom-input-port + (lambda (str n) + (if (null? ports) + 0 + (let lp ((i (read-string! str n (car ports)))) + (cond + ((>= i n) + i) + (else + (set! ports (cdr ports)) + (cond + ((null? ports) + i) + (else + (let* ((s (read-string (- n i) (car ports))) + (len (if (string? s) (string-length s) 0))) + (if (and (string? str) (> len 0)) + (string-copy! str i s 0 len)) + (lp (+ i len)))))))))))) + +(define (make-generated-input-port generator) + (let ((buf "") + (len 0) + (offset 0)) + (make-custom-input-port + (lambda (str n) + (cond + ((>= (- len offset) n) + (string-copy! str 0 buf offset (+ offset n)) + (set! offset (+ offset n)) + n) + (else + (string-copy! str 0 buf offset len) + (let lp ((i (- len offset))) + (set! buf (generator)) + (cond + ((not (string? buf)) + (set! buf "") + (set! len 0) + (set! offset 0) + (- n i)) + (else + (set! len (string-length buf)) + (set! offset 0) + (cond + ((>= (- len offset) (- n i)) + (string-copy! str i buf offset (+ offset (- n i))) + (set! offset (+ offset (- n i))) + n) + (else + (string-copy! str i buf offset len) + (lp (+ i (- len offset)))))))))))))) + +(define (make-filtered-input-port filter in) + (make-generated-input-port + (lambda () + (let ((res (read-string 1024 in))) + (if (string? res) (filter res) res))))) diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub new file mode 100644 index 00000000..07450dc0 --- /dev/null +++ b/lib/chibi/io/io.stub @@ -0,0 +1,27 @@ + +(define-c non-null-string (%read-line "fgets") + ((result (array char arg1)) int (default (current-input-port) input-port))) + +(define-c size_t (%read-string "fread") + ((result (array char arg2)) (value 1 size_t) size_t (default (current-input-port) input-port))) + +(define-c size_t (read-string! "fread") + (string (value 1 size_t) size_t (default (current-input-port) input-port))) + +(define-c size_t (write-string "fwrite") + (string (value 1 size_t) size_t (default (current-output-port) output-port))) + +(define-c-const int (seek/set "SEEK_SET")) +(define-c-const int (seek/cur "SEEK_CUR")) +(define-c-const int (seek/end "SEEK_END")) + +(define-c long (file-position "ftell") (port)) +(define-c long (set-file-position! "fseek") (port long int)) + +(c-include "port.c") + +(define-c sexp (%make-custom-input-port "sexp_make_custom_input_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) + +(define-c sexp (%make-custom-output-port "sexp_make_custom_output_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c new file mode 100644 index 00000000..947f3400 --- /dev/null +++ b/lib/chibi/io/port.c @@ -0,0 +1,196 @@ + +#include +#include + +#define SEXP_PORT_BUFFER_SIZE 1024 +#define SEXP_LAST_CONTEXT_CHECK_LIMIT 256 + +#define sexp_cookie_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO) +#define sexp_cookie_buffer(vec) sexp_vector_ref((sexp)vec, SEXP_ONE) +#define sexp_cookie_read(vec) sexp_vector_ref((sexp)vec, SEXP_TWO) +#define sexp_cookie_write(vec) sexp_vector_ref((sexp)vec, SEXP_THREE) +#define sexp_cookie_seek(vec) sexp_vector_ref((sexp)vec, SEXP_FOUR) +#define sexp_cookie_close(vec) sexp_vector_ref((sexp)vec, SEXP_FIVE) + +#if ! SEXP_USE_BOEHM +static int sexp_in_heap_p (sexp_heap h, sexp p) { + for ( ; h; h = h->next) + if (((sexp)h < p) && (p < (sexp)((char*)h + h->size))) + return 1; + return 0; +} +#endif + +static sexp sexp_last_context (sexp ctx, sexp *cstack) { + sexp res=SEXP_FALSE, p; +#if ! SEXP_USE_BOEHM + sexp_sint_t i; + sexp_heap h = sexp_context_heap(ctx); + for (i=0; i sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_read(vec), args); + sexp_gc_release2(ctx); + if (sexp_fixnump(res)) { + memcpy(buffer, sexp_string_data(sexp_cookie_buffer(vec)), sexp_unbox_fixnum(res)); + return sexp_unbox_fixnum(res); + } else { + return -1; + } +} + +#if SEXP_BSD +static int sexp_cookie_writer (void *cookie, const char *buffer, int size) +#else +static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size) +#endif +{ + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_write(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + if (size > sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_write(vec), args); + sexp_gc_release2(ctx); + return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1); +} + +#if ! SEXP_BSD +static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + args = sexp_make_integer(ctx, *position); + args = sexp_list2(ctx, args, sexp_make_fixnum(whence)); + res = sexp_apply(ctx, sexp_cookie_seek(vec), args); + if (sexp_fixnump(res)) + *position = sexp_unbox_fixnum(res); + sexp_gc_release2(ctx); + return sexp_fixnump(res); +} +#endif + +static int sexp_cookie_cleaner (void *cookie) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_close(vec))) return 0; + ctx = sexp_cookie_ctx(vec); + res = sexp_apply(ctx, sexp_cookie_close(vec), SEXP_NULL); + return (sexp_exceptionp(res) ? -1 : sexp_truep(res)); +} + +#if ! SEXP_BSD + +static cookie_io_functions_t sexp_cookie = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = (cookie_seek_function_t*)sexp_cookie_seeker, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +static cookie_io_functions_t sexp_cookie_no_seek = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = NULL, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +#endif + +#if SEXP_USE_STRING_STREAMS + +static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode, + sexp read, sexp write, + sexp seek, sexp close) { + FILE *in; + sexp res; + sexp_gc_var1(vec); + if (sexp_truep(read) && ! sexp_procedurep(read)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read); + if (sexp_truep(write) && ! sexp_procedurep(write)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write); + if (sexp_truep(seek) && ! sexp_procedurep(seek)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek); + if (sexp_truep(close) && ! sexp_procedurep(close)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close); + sexp_gc_preserve1(ctx, vec); + vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID); + sexp_cookie_ctx(vec) = ctx; + sexp_cookie_buffer(vec) + = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID); + sexp_cookie_read(vec) = read; + sexp_cookie_write(vec) = write; + sexp_cookie_seek(vec) = seek; + sexp_cookie_close(vec) = close; +#if SEXP_BSD + in = funopen(vec, + (sexp_procedurep(read) ? sexp_cookie_reader : NULL), + (sexp_procedurep(write) ? sexp_cookie_writer : NULL), + NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */ + (sexp_procedurep(close) ? sexp_cookie_cleaner : NULL)); +#else + in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek)); +#endif + if (! in) { + res = sexp_user_exception(ctx, self, "couldn't make custom port", read); + } else { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = vec; /* for gc preserving */ + } + sexp_gc_release1(ctx); + return res; +} + +#else + +static sexp sexp_make_custom_port (sexp ctx, sexp self, + char *mode, sexp read, sexp write, + sexp seek, sexp close) { + return sexp_user_exception(ctx, self, "custom ports not supported in this configuration", SEXP_NULL); +} + +#endif + +static sexp sexp_make_custom_input_port (sexp ctx, sexp self, + sexp read, sexp seek, sexp close) { + return sexp_make_custom_port(ctx, self, "r", read, SEXP_FALSE, seek, close); +} + +static sexp sexp_make_custom_output_port (sexp ctx, sexp self, + sexp write, sexp seek, sexp close) { + sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close); + sexp_pointer_tag(res) = SEXP_OPORT; + return res; +} diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module new file mode 100644 index 00000000..5b76daf8 --- /dev/null +++ b/lib/chibi/loop.module @@ -0,0 +1,9 @@ + +(define-module (chibi loop) + (export loop in-list in-lists in-port in-file up-from down-from + listing listing-reverse appending appending-reverse + summing multiplying in-string in-string-reverse + in-vector in-vector-reverse) + (import-immutable (scheme)) + (include "loop/loop.scm")) + diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm new file mode 100644 index 00000000..09e12856 --- /dev/null +++ b/lib/chibi/loop/loop.scm @@ -0,0 +1,365 @@ +;;;; loop.scm - the chibi loop (aka foof-loop) +;; +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; The loop API is compatible with Taylor Campbell's foof-loop, but +;; the iterator API is different and subject to change. All loop +;; variables may be implicitly destructured with MATCH semantics. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (assoc-pred equal elt ls) + (and (pair? ls) + (if (equal elt (car (car ls))) + (car ls) + (assoc-pred equal elt (cdr ls))))) + +(define-syntax let-keyword-form + (syntax-rules () + ((let-keyword-form + ((labeled-arg-macro-name (positional-name . params))) + . body) + (let-syntax + ((labeled-arg-macro-name + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (named '()) (posns '())) + (cond + ((pair? ls) + (if (and (list? (car ls)) (compare (caar ls) (rename '=>))) + (lp (cdr ls) (cons (cdar ls) named) posns) + (lp (cdr ls) named (cons (car ls) posns)))) + (else + (let lp ((ls (syntax-quote params)) + (posns (reverse posns)) + (args '())) + (cond + ((null? ls) + (if (pair? posns) + (error "let-keyword-form: too many args" expr) + (cons (syntax-quote positional-name) (reverse args)))) + ((assoc-pred compare (caar ls) named) + => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args)))) + ((pair? posns) + (lp (cdr ls) (cdr posns) (cons (car posns) args))) + (else + (lp (cdr ls) posns (cons (cadar ls) args)))))))))))) + . body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax loop + (syntax-rules () + ;; unnamed, implicit recursion + ((loop (vars ...) body ...) + (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop))) + ;; named, explicit recursion + ((loop name (vars ...) body ...) + (%loop name () () () () () (vars ...) body ...)))) + +;; Main LOOP macro. Separate the variables from the iterator and +;; parameters, then walk through each parameter expanding the +;; bindings, and build the final form. + +(define-syntax %loop + (syntax-rules (=> for with let while until) + ;; automatic iteration + ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body) + (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ;; do equivalents, with optional guards + ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body) + (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init step) rest ...) . body) + (%loop name l (vars ... (var init step)) c r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init) rest ...) . body) + (%loop name l (vars ... (var init var)) c r f (rest ...) . body)) + ;; user-specified terminators + ((_ name l vars (checks ...) r f ((until expr) rest ...) . body) + (%loop name l vars (checks ... expr) r f (rest ...) . body)) + ((_ name l vars (checks ...) r f ((while expr) rest ...) . body) + (%loop name l vars (checks ... (not expr)) r f (rest ...) . body)) + ;; specify a default done? + ((_ name l v c r f ()) + (%loop name l v c r f () (#f #f))) + ((_ name l v c r f () () . body) + (%loop name l v c r f () (#f #f) . body)) + ;; final expansion + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => result + . body) + (let* (lets ...) + (letrec ((tmp (lambda (var ...) + (if (or checks ...) + (let-keyword-form ((name (tmp (var step) ...))) + (let (finals ...) result)) + (let (refs ...) + (let-keyword-form ((name (tmp (var step) ...))) + (if #f #f) + . body)))))) + (tmp init ...)))) + ;; unspecified return value case + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + . body) + (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => (if #f #f) . body)) + )) + +(define-syntax %loop-next + (syntax-rules () + ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...) + name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...) + . rest) + (%loop name (lets ... new-lets ...) (vars ... new-vars ...) + (checks ... new-checks ...) (refs ... new-refs ...) + (finals ... new-finals ...) + . rest)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Iterators + +;; Each gets passed two lists, those items left of the <- and those to +;; the right, followed by a NEXT and REST continuation. + +;; Should finish with +;; +;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...) +;; (loop-vars ...) (final-vars ...) . rest) +;; +;; OUTER-VARS: bound once outside the loop in a LET* +;; CURSOR-VARS: DO-style bindings of the form (name init update) +;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t +;; LOOP-VARS: inner variables, updated in parallel after the cursors +;; FINAL-VARS: final variables, bound only in the => result + +(define-syntax in-list ; called just "IN" in ITER + (syntax-rules () + ((in-list ((var) source) next . rest) + (in-list ((var cursor) source) next . rest)) + ((in-list ((var cursor) source) next . rest) + (in-list ((var cursor succ) source) next . rest)) + ((in-list ((var cursor succ) (source)) next . rest) + (next () ; outer let bindings + ((cursor source succ)) ; iterator, init, step + ((not (pair? cursor))) ; finish tests for iterator vars + ;; step variables and values + ((var (car cursor)) + (succ (cdr cursor))) + () ; final result bindings + . rest)) + ((in-list ((var cursor succ) (source step)) next . rest) + (next () + ((cursor source succ)) + ((not (pair? cursor))) + ((var (car cursor)) + (succ (step cursor))) + () + . rest)))) + +;; Iterator from Taylor R. Campbell. If you know the number of lists +;; ahead of time it's much more efficient to iterate over each one +;; separately. +(define-syntax in-lists + (syntax-rules () + ((in-lists ((elts) lol) next . rest) + (in-lists ((elts pairs) lol) next . rest)) + ((in-lists ((elts pairs) lol) next . rest) + (in-lists ((elts pairs succ) lol) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol step)) next . rest) + (in-lists ((elts pairs succ) (lol step null?)) next . rest)) + ((in-lists ((elts pairs succ) (lol step done?)) next . rest) + (next () + ((pairs lol succ)) + ((let lp ((ls pairs)) ; an in-lined ANY + (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls)))))) + ((elts (map car pairs)) + (succ (map step pairs))) + () + . rest)) + )) + +(define-syntax define-in-indexed + (syntax-rules () + ((define-in-indexed in-type in-type-reverse length ref) + (begin + (define-syntax in-type + (syntax-rules () + ((in-type ls next . rest) + (%in-idx >= + 0 (length tmp) ref tmp ls next . rest)))) + (define-syntax in-type-reverse + (syntax-rules () + ((in-type-reverse ls next . rest) + (%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest)))) + )))) + +(define-in-indexed in-string in-string-reverse string-length string-ref) +(define-in-indexed in-vector in-vector-reverse vector-length vector-ref) + +;; helper for the above string and vector iterators +(define-syntax %in-idx + (syntax-rules () + ;; cmp inc start end ref + ((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest) + (%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest) + (next ((tmp-vec vec) (end to)) + ((index from (+ index step))) + ((ge index end)) + ((var (r tmp-vec index))) + () + . rest)) + )) + +(define-syntax in-port + (syntax-rules () + ((in-port ((var) source) next . rest) + (in-port ((var p) source) next . rest)) + ((in-port ((var p) ()) next . rest) + (in-port ((var p) ((current-input-port))) next . rest)) + ((in-port ((var p) (port)) next . rest) + (in-port ((var p) (port read-char)) next . rest)) + ((in-port ((var p) (port read-char)) next . rest) + (in-port ((var p) (port read-char eof-object?)) next . rest)) + ((in-port ((var p) (port reader eof?)) next . rest) + (next ((p port) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + () + . rest)))) + +(define-syntax in-file + (syntax-rules () + ((in-file ((var) source) next . rest) + (in-file ((var p) source) next . rest)) + ((in-file ((var p) (file)) next . rest) + (in-file ((var p) (file read-char)) next . rest)) + ((in-file ((var p) (file reader)) next . rest) + (in-file ((var p) (file reader eof-object?)) next . rest)) + ((in-file ((var p) (file reader eof?)) next . rest) + (next ((p (open-input-file file)) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + ((dummy (close-input-port p))) + . rest)))) + +(define-syntax up-from + (syntax-rules (to by) + ((up-from (() . args) next . rest) + (up-from ((var) . args) next . rest)) + ((up-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var s (+ var e))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var s (+ var 1))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var s (+ var e))) () () () . rest)) + ((up-from ((var) (start)) next . rest) + (next ((s start)) ((var s (+ var 1))) () () () . rest)) + )) + +(define-syntax down-from + (syntax-rules (to by) + ((down-from (() . args) next . rest) + (down-from ((var) . args) next . rest)) + ((down-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var (- s e) (- var e))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var (- s 1) (- var 1))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var (- s e) (- var e))) () () () + . rest)) + ((down-from ((var) (start)) next . rest) + (next ((s start)) ((var (- s 1) (- var 1))) () () () + . rest)) + )) + +(define-syntax accumulating + (syntax-rules (initial if) + ((accumulating (kons final init) ((var) . x) next . rest) + (accumulating (kons final init) ((var cursor) . x) next . rest)) + ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest) + (accumulating (kons final i) ((var cursor) x) n . rest)) + ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (if check (tmp-kons expr cursor) cursor))) + () + () + ((var (final cursor))) + . rest)) + ((accumulating (kons final init) ((var cursor) (expr)) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (tmp-kons expr cursor))) + () + () + ((var (final cursor))) + . rest)))) + +(define-syntax listing + (syntax-rules () + ((listing args next . rest) + (accumulating (cons reverse '()) args next . rest)))) + +(define-syntax listing-reverse + (syntax-rules () + ((listing-reverse args next . rest) + (accumulating (cons (lambda (x) x) '()) args next . rest)))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define-syntax appending + (syntax-rules () + ((appending args next . rest) + (accumulating (append-reverse reverse '()) args next . rest)))) + +(define-syntax appending-reverse + (syntax-rules () + ((appending-reverse args next . rest) + (accumulating (append-reverse (lambda (x) x) '()) args next . rest)))) + +(define-syntax summing + (syntax-rules () + ((summing args next . rest) + (accumulating (+ (lambda (x) x) 0) args next . rest)))) + +(define-syntax multiplying + (syntax-rules () + ((multiplying args next . rest) + (accumulating (* (lambda (x) x) 1) args next . rest)))) diff --git a/lib/chibi/macroexpand.module b/lib/chibi/macroexpand.module new file mode 100644 index 00000000..47b0e7d4 --- /dev/null +++ b/lib/chibi/macroexpand.module @@ -0,0 +1,6 @@ + +(define-module (chibi macroexpand) + (import-immutable (scheme)) + (import (chibi ast)) + (export macroexpand) + (include "macroexpand.scm")) diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm new file mode 100644 index 00000000..a040855a --- /dev/null +++ b/lib/chibi/macroexpand.scm @@ -0,0 +1,85 @@ +;; macroexpand.scm -- macro expansion utility +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; This actually analyzes the expression then reverse-engineers an +;; sexp from the result, generating a minimal amount of renames. + +(define (macroexpand x) + (ast->sexp (analyze x))) + +(define (ast-renames ast) + (define i 0) + (define renames '()) + (define (rename-symbol id) + (set! i (+ i 1)) + (string->symbol + (string-append (symbol->string (identifier->symbol id)) + "." (number->string i)))) + (define (rename-lambda lam) + (or (assq lam renames) + (let ((res (list lam))) + (set! renames (cons res renames)) + res))) + (define (rename! id lam) + (let ((cell (rename-lambda lam))) + (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell))))) + (define (check-ref id lam env) + (let ((sym (identifier->symbol id))) + (let lp1 ((ls env)) + (cond + ((pair? ls) + (let lp2 ((ls2 (car ls)) (found? #f)) + (cond + ((null? ls2) + (if (not found?) (lp1 (cdr ls)))) + ((and (eq? id (caar ls2)) (eq? lam (cdar ls2))) + (lp2 (cdr ls2) #t)) + ((eq? sym (identifier->symbol (caar ls2))) + (rename! (caar ls2) (cdar ls2)) + (lp2 (cdr ls2) found?)) + (else + (lp2 (cdr ls2) found?))))))))) + (define (flatten-dot x) + (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) + ((null? x) x) + (else (list x)))) + (define (extend-env lam env) + (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env)) + (let lp ((x ast) (env '())) + (cond + ((lambda? x) (lp (lambda-body x) (extend-env x env))) + ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env)) + ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env)) + ((set? x) (lp (set-var x) env) (lp (set-value x) env)) + ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x))) + ((pair? x) (for-each (lambda (x) (lp x env)) x)))) + renames) + +(define (get-rename id lam renames) + (let ((ls (assq lam renames))) + (if (not ls) + (identifier->symbol id) + (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id)))))) + +(define (ast->sexp ast) + (let ((renames (ast-renames ast))) + (let a2s ((x ast)) + (cond + ((lambda? x) + `(lambda ,(map (lambda (id) (get-rename id x renames)) (lambda-params x)) + ,@(map (lambda (d) `(define ,(identifier->symbol (cadr d)) #f)) (lambda-defs x)) + ,@(if (seq? (lambda-body x)) + (map a2s (seq-ls (lambda-body x))) + (list (a2s (lambda-body x)))))) + ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) + ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) + ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) + ((seq? x) `(begin ,@(map a2s (seq-ls x)))) + ((lit? x) + (let ((v (lit-value x))) + (if (or (pair? v) (null? v) (symbol? v)) `',v v))) + ((pair? x) (cons (a2s (car x)) (a2s (cdr x)))) + ((opcode? x) (or (opcode-name x) x)) + (else x))))) + diff --git a/lib/chibi/match.module b/lib/chibi/match.module new file mode 100644 index 00000000..1366176a --- /dev/null +++ b/lib/chibi/match.module @@ -0,0 +1,6 @@ + +(define-module (chibi match) + (export match match-lambda match-lambda* match-let match-letrec match-let*) + (import-immutable (scheme)) + (include "match/match.scm")) + diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm new file mode 100644 index 00000000..963b89ff --- /dev/null +++ b/lib/chibi/match/match.scm @@ -0,0 +1,670 @@ +;;;; match.scm -- portable hygienic pattern matcher +;; +;; This code is written by Alex Shinn and placed in the +;; Public Domain. All warranties are disclaimed. + +;; This is a full superset of the popular MATCH package by Andrew +;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks +;; in R6RS SYNTAX-RULES), and thus preserving hygiene. + +;; This is a simple generative pattern matcher - each pattern is +;; expanded into the required tests, calling a failure continuation if +;; the tests fail. This makes the logic easy to follow and extend, +;; but produces sub-optimal code in cases where you have many similar +;; clauses due to repeating the same tests. Nonetheless a smart +;; compiler should be able to remove the redundant tests. For +;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance +;; hit. + +;; The original version was written on 2006/11/29 and described in the +;; following Usenet post: +;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd +;; and is still available at +;; http://synthcode.com/scheme/match-simple.scm +;; It's just 80 lines for the core MATCH, and an extra 40 lines for +;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar. +;; +;; A variant of this file which uses COND-EXPAND in a few places for +;; performance can be found at +;; http://synthcode.com/scheme/match-cond-expand.scm +;; +;; 2009/11/25 - adding `***' tree search patterns +;; 2008/03/20 - fixing bug where (a ...) matched non-lists +;; 2008/03/15 - removing redundant check in vector patterns +;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) +;; 2007/09/04 - fixing quasiquote patterns +;; 2007/07/21 - allowing ellipse patterns in non-final list positions +;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse +;; (thanks to Taylor Campbell) +;; 2007/04/08 - clean up, commenting +;; 2006/12/24 - bugfixes +;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; force compile-time syntax errors with useful messages + +(define-syntax match-syntax-error + (syntax-rules () + ((_) (match-syntax-error "invalid match-syntax-error usage")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The basic interface. MATCH just performs some basic syntax +;; validation, binds the match expression to a temporary variable `v', +;; and passes it on to MATCH-NEXT. It's a constant throughout the +;; code below that the binding `v' is a direct variable reference, not +;; an expression. + +(define-syntax match + (syntax-rules () + ((match) + (match-syntax-error "missing match expression")) + ((match atom) + (match-syntax-error "no match clauses")) + ((match (app ...) (pat . body) ...) + (let ((v (app ...))) + (match-next v ((app ...) (set! (app ...))) (pat . body) ...))) + ((match #(vec ...) (pat . body) ...) + (let ((v #(vec ...))) + (match-next v (v (set! v)) (pat . body) ...))) + ((match atom (pat . body) ...) + (match-next atom (atom (set! atom)) (pat . body) ...)) + )) + +;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure +;; thunk, which is expanded by recursing MATCH-NEXT on the remaining +;; clauses. `g+s' is a list of two elements, the get! and set! +;; expressions respectively. + +(define-syntax match-next + (syntax-rules (=>) + ;; no more clauses, the match failed + ((match-next v g+s) + (error 'match "no matching pattern")) + ;; named failure continuation + ((match-next v g+s (pat (=> failure) . body) . rest) + (let ((failure (lambda () (match-next v g+s . rest)))) + ;; match-one analyzes the pattern for us + (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ()))) + ;; anonymous failure continuation, give it a dummy name + ((match-next v g+s (pat . body) . rest) + (match-next v g+s (pat (=> failure) . body) . rest)))) + +;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to +;; MATCH-TWO. + +(define-syntax match-one + (syntax-rules () + ;; If it's a list of two or more values, check to see if the + ;; second one is an ellipse and handle accordingly, otherwise go + ;; to MATCH-TWO. + ((match-one v (p q . r) g+s sk fk i) + (match-check-ellipse + q + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()) + (match-two v (p q . r) g+s sk fk i))) + ;; Go directly to MATCH-TWO. + ((match-one . x) + (match-two . x)))) + +;; This is the guts of the pattern matcher. We are passed a lot of +;; information in the form: +;; +;; (match-two var pattern getter setter success-k fail-k (ids ...)) +;; +;; usually abbreviated +;; +;; (match-two v p g+s sk fk i) +;; +;; where VAR is the symbol name of the current variable we are +;; matching, PATTERN is the current pattern, getter and setter are the +;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding +;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure +;; continuation (which is just a thunk call and is thus safe to expand +;; multiple times) and IDS are the list of identifiers bound in the +;; pattern so far. + +(define-syntax match-two + (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!) + ((match-two v () g+s (sk ...) fk i) + (if (null? v) (sk ... i) fk)) + ((match-two v (quote p) g+s (sk ...) fk i) + (if (equal? v 'p) (sk ... i) fk)) + ((match-two v (quasiquote p) . x) + (match-quasiquote v p . x)) + ((match-two v (and) g+s (sk ...) fk i) (sk ... i)) + ((match-two v (and p q ...) g+s sk fk i) + (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i)) + ((match-two v (or) g+s sk fk i) fk) + ((match-two v (or p) . x) + (match-one v p . x)) + ((match-two v (or p ...) g+s sk fk i) + (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ())) + ((match-two v (not p) g+s (sk ...) fk i) + (match-one v p g+s (match-drop-ids fk) (sk ... i) i)) + ((match-two v (get! getter) (g s) (sk ...) fk i) + (let ((getter (lambda () g))) (sk ... i))) + ((match-two v (set! setter) (g (s ...)) (sk ...) fk i) + (let ((setter (lambda (x) (s ... x)))) (sk ... i))) + ((match-two v (? pred . p) g+s sk fk i) + (if (pred v) (match-one v (and . p) g+s sk fk i) fk)) + ((match-two v (= proc p) . x) + (let ((w (proc v))) (match-one w p . x))) + ((match-two v (p ___ . r) g+s sk fk i) + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())) + ((match-two v (p) g+s sk fk i) + (if (and (pair? v) (null? (cdr v))) + (let ((w (car v))) + (match-one w p ((car v) (set-car! v)) sk fk i)) + fk)) + ((match-two v (p *** q) g+s sk fk i) + (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) + ((match-two v (p *** . q) g+s sk fk i) + (match-syntax-error "invalid use of ***" (p *** . q))) + ((match-two v (p . q) g+s sk fk i) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-one w p ((car v) (set-car! v)) + (match-one x q ((cdr v) (set-cdr! v)) sk fk) + fk + i)) + fk)) + ((match-two v #(p ...) g+s . x) + (match-vector v 0 () (p ...) . x)) + ((match-two v _ g+s (sk ...) fk i) (sk ... i)) + ;; Not a pair or vector or special literal, test to see if it's a + ;; new symbol, in which case we just bind it, or if it's an + ;; already bound symbol or some other literal, in which case we + ;; compare it with EQUAL?. + ((match-two v x g+s (sk ...) fk (id ...)) + (let-syntax + ((new-sym? + (syntax-rules (id ...) + ((new-sym? x sk2 fk2) sk2) + ((new-sym? y sk2 fk2) fk2)))) + (new-sym? random-sym-to-match + (let ((x v)) (sk ... (id ... x))) + (if (equal? v x) (sk ... (id ...)) fk)))) + )) + +;; QUASIQUOTE patterns + +(define-syntax match-quasiquote + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ v (unquote p) g+s sk fk i) + (match-one v p g+s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g+s sk fk i) + (if (pair? v) + (match-one v + (p . tmp) + (match-quasiquote tmp rest g+s sk fk) + fk + i) + fk)) + ((_ v (quasiquote p) g+s sk fk i . depth) + (match-quasiquote v p g+s sk fk i #f . depth)) + ((_ v (unquote p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (unquote-splicing p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (p . q) g+s sk fk i . depth) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-quasiquote + w p g+s + (match-quasiquote-step x q g+s sk fk depth) + fk i . depth)) + fk)) + ((_ v #(elt ...) g+s sk fk i . depth) + (if (vector? v) + (let ((ls (vector->list v))) + (match-quasiquote ls (elt ...) g+s sk fk i . depth)) + fk)) + ((_ v x g+s sk fk i . depth) + (match-one v 'x g+s sk fk i)))) + +(define-syntax match-quasiquote-step + (syntax-rules () + ((match-quasiquote-step x q g+s sk fk depth i) + (match-quasiquote x q g+s sk fk i . depth)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities + +;; Takes two values and just expands into the first. +(define-syntax match-drop-ids + (syntax-rules () + ((_ expr ids ...) expr))) + +(define-syntax match-drop-first-arg + (syntax-rules () + ((_ arg expr) expr))) + +;; To expand an OR group we try each clause in succession, passing the +;; first that succeeds to the success continuation. On failure for +;; any clause, we just try the next clause, finally resorting to the +;; failure continuation fk if all clauses fail. The only trick is +;; that we want to unify the identifiers, so that the success +;; continuation can refer to a variable from any of the OR clauses. + +(define-syntax match-gen-or + (syntax-rules () + ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...)) + (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) + (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...)))))) + +(define-syntax match-gen-or-step + (syntax-rules () + ((_ v () g+s sk fk . x) + ;; no OR clauses, call the failure continuation + fk) + ((_ v (p) . x) + ;; last (or only) OR clause, just expand normally + (match-one v p . x)) + ((_ v (p . q) g+s sk fk i) + ;; match one and try the remaining on failure + (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) + )) + +;; We match a pattern (p ...) by matching the pattern p in a loop on +;; each element of the variable, accumulating the bound ids into lists. + +;; Look at the body of the simple case - it's just a named let loop, +;; matching each element in turn to the same pattern. The only trick +;; is that we want to keep track of the lists of each extracted id, so +;; when the loop recurses we cons the ids onto their respective list +;; variables, and on success we bind the ids (what the user input and +;; expects to see in the success body) to the reversed accumulated +;; list IDs. + +(define-syntax match-gen-ellipses + (syntax-rules () + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to (p ...), just bind the list + (let ((p v)) + (if (list? p) + (sk ... i) + fk)) + ;; simple case, match all elements of the list + (let loop ((ls v) (id-ls '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) + fk i))) + (else + fk))))) + ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking + (match-verify-no-ellipses + r + (let* ((tail-len (length 'r)) + (ls v) + (len (length ls))) + (if (< len tail-len) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond + ((= n tail-len) + (let ((id (reverse id-ls)) ...) + (match-one ls r (#f #f) (sk ... i) fk i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids + (loop (cdr ls) (- n 1) (cons id id-ls) ...)) + fk + i))) + (else + fk))))))))) + +;; This is just a safety check. Although unlike syntax-rules we allow +;; trailing patterns after an ellipses, we explicitly disable multiple +;; ellipses at the same level. This is because in the general case +;; such patterns are exponential in the number of ellipses, and we +;; don't want to make it easy to construct very expensive operations +;; with simple looking patterns. For example, it would be O(n^2) for +;; patterns like (a ... b ...) because we must consider every trailing +;; element for every possible break for the leading "a ...". + +(define-syntax match-verify-no-ellipses + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipse + x + (match-syntax-error + "multiple ellipse patterns not allowed at same level") + (match-verify-no-ellipses y sk))) + ((_ () sk) + sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipse" x)))) + +;; Matching a tree search pattern is only slightly more complicated. +;; Here we allow patterns of the form +;; +;; (x *** y) +;; +;; to represent the pattern y located somewhere in a tree where the +;; path from the current object to y can be seen as a list of the form +;; (X ...). Y can immediately match the current object in which case +;; the path is the empty list. In a sense it's a 2-dimensional +;; version of the ... pattern. +;; +;; As a common case the pattern (_ *** y) can be used to search for Y +;; anywhere in a tree, regardless of the path used. +;; +;; To implement the search, we use two recursive procedures. TRY +;; attempts to match Y once, and on success it calls the normal SK on +;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we +;; call NEXT which first checks if the current value is a list +;; beginning with X, then calls TRY on each remaining element of the +;; list. Since TRY will recursively call NEXT again on failure, this +;; effects a full depth-first search. +;; +;; The failure continuation throughout is a jump to the next step in +;; the tree search, initialized with the original failure continuation +;; FK. + +(define-syntax match-gen-search + (syntax-rules () + ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) + (letrec ((try (lambda (w fail id-ls ...) + (match-one w q g+s + (match-drop-ids + (let ((id (reverse id-ls)) ...) + sk)) + (next w fail id-ls ...) i))) + (next (lambda (w fail id-ls ...) + (if (not (pair? w)) + (fail) + (let ((u (car w))) + (match-one + u p ((car w) (set-car! w)) + (match-drop-ids + ;; accumulate the head variables from + ;; the p pattern, and loop over the tail + (let ((id-ls (cons id id-ls)) ...) + (let lp ((ls (cdr w))) + (if (pair? ls) + (try (car ls) + (lambda () (lp (cdr ls))) + id-ls ...) + (fail))))) + (fail) i)))))) + ;; the initial id-ls binding here is a dummy to get the right + ;; number of '()s + (let ((id-ls '()) ...) + (try v (lambda () fk) id-ls ...)))))) + +;; Vector patterns are just more of the same, with the slight +;; exception that we pass around the current vector index being +;; matched. + +(define-syntax match-vector + (syntax-rules (___) + ((_ v n pats (p q) . x) + (match-check-ellipse q + (match-gen-vector-ellipses v n pats p . x) + (match-vector-two v n pats (p q) . x))) + ((_ v n pats (p ___) sk fk i) + (match-gen-vector-ellipses v n pats p sk fk i)) + ((_ . x) + (match-vector-two . x)))) + +;; Check the exact vector length, then check each element in turn. + +(define-syntax match-vector-two + (syntax-rules () + ((_ v n ((pat index) ...) () sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (= len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) . x) + (match-vector v (+ n 1) (pats ... (p n)) q . x)))) + +(define-syntax match-vector-step + (syntax-rules () + ((_ v () (sk ...) fk i) (sk ... i)) + ((_ v ((pat index) . rest) sk fk i) + (let ((w (vector-ref v index))) + (match-one w pat ((vector-ref v index) (vector-set! v index)) + (match-vector-step v rest sk fk) + fk i))))) + +;; With a vector ellipse pattern we first check to see if the vector +;; length is at least the required length. + +(define-syntax match-gen-vector-ellipses + (syntax-rules () + ((_ v n ((pat index) ...) p sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (>= len n) + (match-vector-step v ((pat index) ...) + (match-vector-tail v p n len sk fk) + fk i) + fk)) + fk)))) + +(define-syntax match-vector-tail + (syntax-rules () + ((_ v p n len sk fk i) + (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())))) + +(define-syntax match-vector-tail-two + (syntax-rules () + ((_ v p n len (sk ...) fk i ((id id-ls) ...)) + (let loop ((j n) (id-ls '()) ...) + (if (>= j len) + (let ((id (reverse id-ls)) ...) (sk ... i)) + (let ((w (vector-ref v j))) + (match-one w p ((vector-ref v j) (vetor-set! v j)) + (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) + fk i))))))) + +;; Extract all identifiers in a pattern. A little more complicated +;; than just looking for symbols, we need to ignore special keywords +;; and non-pattern forms (such as the predicate expression in ? +;; patterns), and also ignore previously bound identifiers. +;; +;; Calls the continuation with all new vars as a list of the form +;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely +;; pair with the original variable (e.g. it's used in the ellipse +;; generation for list variables). +;; +;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) + +(define-syntax match-extract-vars + (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!) + ((match-extract-vars (? pred . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars ($ rec . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (= proc p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (quote x) (k ...) i v) + (k ... v)) + ((match-extract-vars (quasiquote x) k i v) + (match-extract-quasiquote-vars x k i v (#t))) + ((match-extract-vars (and . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (or . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (not . p) . x) + (match-extract-vars p . x)) + ;; A non-keyword pair, expand the CAR with a continuation to + ;; expand the CDR. + ((match-extract-vars (p q . r) k i v) + (match-check-ellipse + q + (match-extract-vars (p . r) k i v) + (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) + ((match-extract-vars (p . q) k i v) + (match-extract-vars p (match-extract-vars-step q k i v) i ())) + ((match-extract-vars #(p ...) . x) + (match-extract-vars (p ...) . x)) + ((match-extract-vars _ (k ...) i v) (k ... v)) + ((match-extract-vars ___ (k ...) i v) (k ... v)) + ((match-extract-vars *** (k ...) i v) (k ... v)) + ;; This is the main part, the only place where we might add a new + ;; var if it's an unbound symbol. + ((match-extract-vars p (k ...) (i ...) v) + (let-syntax + ((new-sym? + (syntax-rules (i ...) + ((new-sym? p sk fk) sk) + ((new-sym? x sk fk) fk)))) + (new-sym? random-sym-to-match + (k ... ((p p-ls) . v)) + (k ... v)))) + )) + +;; Stepper used in the above so it can expand the CAR and CDR +;; separately. + +(define-syntax match-extract-vars-step + (syntax-rules () + ((_ p k i v ((v2 v2-ls) ...)) + (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) + )) + +(define-syntax match-extract-quasiquote-vars + (syntax-rules (quasiquote unquote unquote-splicing) + ((match-extract-quasiquote-vars (quasiquote x) k i v d) + (match-extract-quasiquote-vars x k i v (#t . d))) + ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) + (match-extract-quasiquote-vars (unquote x) k i v d)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t)) + (match-extract-vars x k i v)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) + (match-extract-quasiquote-vars x k i v d)) + ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) + (match-extract-quasiquote-vars + x + (match-extract-quasiquote-vars-step y k i v d) i ())) + ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) + (match-extract-quasiquote-vars (x ...) k i v d)) + ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) + (k ... v)) + )) + +(define-syntax match-extract-quasiquote-vars-step + (syntax-rules () + ((_ x k i v d ((v2 v2-ls) ...)) + (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d)) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gimme some sugar baby. + +(define-syntax match-lambda + (syntax-rules () + ((_ clause ...) (lambda (expr) (match expr clause ...))))) + +(define-syntax match-lambda* + (syntax-rules () + ((_ clause ...) (lambda expr (match expr clause ...))))) + +(define-syntax match-let + (syntax-rules () + ((_ (vars ...) . body) + (match-let/helper let () () (vars ...) . body)) + ((_ loop . rest) + (match-named-let loop () . rest)))) + +(define-syntax match-letrec + (syntax-rules () + ((_ vars . body) (match-let/helper letrec () () vars . body)))) + +(define-syntax match-let/helper + (syntax-rules () + ((_ let ((var expr) ...) () () . body) + (let ((var expr) ...) . body)) + ((_ let ((var expr) ...) ((pat tmp) ...) () . body) + (let ((var expr) ...) + (match-let* ((pat tmp) ...) + . body))) + ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((a expr) . rest) . body) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)))) + +(define-syntax match-named-let + (syntax-rules () + ((_ loop ((pat expr var) ...) () . body) + (let loop ((var expr) ...) + (match-let ((pat var) ...) + . body))) + ((_ loop (v ...) ((pat expr) . rest) . body) + (match-named-let loop (v ... (pat expr tmp)) rest . body)))) + +(define-syntax match-let* + (syntax-rules () + ((_ () . body) + (begin . body)) + ((_ ((pat expr) . rest) . body) + (match expr (pat (match-let* rest . body)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Otherwise COND-EXPANDed bits. + +;; This *should* work, but doesn't :( +;; (define-syntax match-check-ellipse +;; (syntax-rules (...) +;; ((_ ... sk fk) sk) +;; ((_ x sk fk) fk))) + +;; This is a little more complicated, and introduces a new let-syntax, +;; but should work portably in any R[56]RS Scheme. Taylor Campbell +;; originally came up with the idea. +(define-syntax match-check-ellipse + (syntax-rules () + ;; these two aren't necessary but provide fast-case failures + ((match-check-ellipse (a . b) success-k failure-k) failure-k) + ((match-check-ellipse #(a ...) success-k failure-k) failure-k) + ;; matching an atom + ((match-check-ellipse id success-k failure-k) + (let-syntax ((ellipse? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipse? (foo id) sk fk) sk) + ((ellipse? other sk fk) fk)))) + ;; this list of three elements will only many the (foo id) list + ;; above if `id' is `...' + (ellipse? (a b c) success-k failure-k))))) + + +;; This is portable but can be more efficient with non-portable +;; extensions. This trick was originally discovered by Oleg Kiselyov. + +(define-syntax match-check-identifier + (syntax-rules () + ;; fast-case failures, lists and vectors are not identifiers + ((_ (x . y) success-k failure-k) failure-k) + ((_ #(x ...) success-k failure-k) failure-k) + ;; x is an atom + ((_ x success-k failure-k) + (let-syntax + ((sym? + (syntax-rules () + ;; if the symbol `abracadabra' matches x, then x is a + ;; symbol + ((sym? x sk fk) sk) + ;; otherwise x is a non-symbol datum + ((sym? y sk fk) fk)))) + (sym? abracadabra success-k failure-k))))) diff --git a/lib/chibi/mime.module b/lib/chibi/mime.module new file mode 100644 index 00000000..2c10dbd1 --- /dev/null +++ b/lib/chibi/mime.module @@ -0,0 +1,7 @@ + +(define-module (chibi mime) + (export mime-ref assoc-ref mime-header-fold mime-headers->list + mime-parse-content-type mime-decode-header + mime-message-fold mime-message->sxml) + (import-immutable (scheme) (chibi base64) (chibi quoted-printable) (chibi io)) + (include "mime.scm")) diff --git a/lib/chibi/mime.scm b/lib/chibi/mime.scm new file mode 100644 index 00000000..e712d7fa --- /dev/null +++ b/lib/chibi/mime.scm @@ -0,0 +1,410 @@ +;; mime.scm -- RFC2045 MIME library +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2822 headers + +;; Procedure: mime-header-fold kons knil [source [limit [kons-from]]] +;; +;; Performs a fold operation on the MIME headers of source which can be +;; either a string or port, and defaults to current-input-port. kons +;; is called on the three values: +;; kons header value accumulator +;; where accumulator begins with knil. Neither the header nor the +;; value are modified, except wrapped lines are handled for the value. +;; +;; The optional procedure KONS-FROM is a procedure to be called when +;; the first line of the headers is an "From
" line, to +;; enable this procedure to be used as-is on mbox files and the like. +;; It defaults to KONS, and if such a line is found the fold will begin +;; with (KONS-FROM "%from"
(KONS-FROM "%date" KNIL)). +;; +;; The optional LIMIT gives a limit on the number of headers to read. + +;; Procedure: mime-headers->list [source] +;; Return an alist of the MIME headers from source with headers all +;; downcased. + +;; Procedure: mime-parse-content-type str +;; Parses STR as a Content-Type style-value returning the list +;; (type (attr . val) ...) +;; For example: +;; (mime-parse-content-type +;; "text/html; CHARSET=US-ASCII; filename=index.html") +;; => ("text/html" ("charset" . "US-ASCII") ("filename" . "index.html")) + +;; Procedure: mime-decode-header str +;; Replace all occurrences of RFC1522 =?ENC?...?= escapes in STR with +;; the appropriate decoded and charset converted value. + +;; Procedure: mime-ref headers str [default] +;; A case-insensitive assoc-ref. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2045 MIME encoding + +;; Procedure: mime-message-fold src headers kons knil +;; Performs a fold operation on the given string or port SRC as a MIME +;; body corresponding to the headers give in HEADERS. KONS is called +;; on the successive values: +;; +;; KONS part-headers part-body accumulator +;; +;; where part-headers are the headers for the given MIME part (the +;; original headers for single-part MIME), part-body is the +;; appropriately decoded and charset-converted body of the message, +;; and the accumulator begins with KNIL. +;; +;; TODO: Extend mime-message-fold to (optionally?) pass KONS an +;; input-port instead of string for the body to handle very large bodies +;; (this is not much of an issue for SMTP since the messages are in +;; practice limited, but it could be problematic for large HTTP bodies). +;; +;; This does a depth-first search, folding in sequence. It should +;; probably be doing a tree-fold as in html-parser. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define mime-line-length-limit 4096) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; association lists + +(define (assoc* key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (cond + ((null? ls) #f) + ((eq key (caar ls)) (car ls)) + (else (lp (cdr ls))))))) + +(define (assoc-ref ls key . o) + (let ((default (and (pair? o) (car o))) + (eq (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) equal?))) + (cond ((assoc* key ls eq) => cdr) + (else default)))) + +(define (mime-ref ls key . o) + (assoc-ref ls key (and (pair? o) (car o)) string-ci=?)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; simple matching instead of regexps + +(define (match-mbox-from-line line) + (let ((len (string-length line))) + (and (> len 5) + (string=? (substring line 0 5) "From ") + (let lp ((i 6)) + (cond + ((= i len) (list (substring line 5 len) "")) + ((memq (string-ref line i) '(#\space #\tab)) + (list (substring line 5 i) (substring line (+ i 1) len))) + (else (lp (+ i 1)))))))) + +(define (string-scan-colon-or-maybe-equal str) + (let ((len (string-length str))) + (let lp ((i 0) (best #f)) + (if (= i len) + best + (let ((c (string-ref str i))) + (cond ((or (char-alphabetic? c) + (char-numeric? c) + (memv c '(#\- #\_))) + (lp (+ i 1) best)) + ((eq? c #\:) + (if (= i 0) #f i)) + ((eqv? c #\=) + (lp (+ i 1) (or best i))) + (else + best))))))) + +(define (string-skip-white-space str i) + (let ((lim (string-length str))) + (let lp ((i i)) + (cond ((>= i lim) lim) + ((char-whitespace? (string-ref str i)) (lp (+ i 1))) + (else i))))) + +(define (match-mime-header-line line) + (let ((i (string-scan-colon-or-maybe-equal line))) + (and i + (let ((j (string-skip-white-space line (+ i 1)))) + (list (substring line 0 i) + (substring line j (string-length line))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dummy encoder + +(define (ces-convert str . x) + str) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; some srfi-13 & string utils + +(define (string-copy! to tstart from . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length from)))) + (let lp ((i start) (j tstart)) + (cond + ((< i end) + (string-set! to j (string-ref from i)) + (lp (+ i 1) (+ j 1))))))) + +(define (string-concatenate-reverse ls) + (let lp ((ls ls) (rev '()) (len 0)) + (if (null? ls) + (let ((res (make-string len))) + (let lp ((ls rev) (i 0)) + (cond + ((null? ls) + res) + (else + (string-copy! res i (car ls)) + (lp (cdr ls) (+ i (string-length (car ls)))))))) + (lp (cdr ls) (cons (car ls) rev) (+ len (string-length (car ls))))))) + +(define (string-downcase s . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length s)))) + (let* ((len (- end start)) (s2 (make-string len))) + (let lp ((i start) (j 0)) + (cond + ((>= i end) + s2) + (else + (string-set! s2 j (char-downcase (string-ref s i))) + (lp (+ i 1) (+ j 1)))))))) + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-trim-white-space s) + (let ((len (string-length s))) + (let lp ((i 0)) + (cond ((= i len) "") + ((char-whitespace? (string-ref s i)) (lp (+ i 1))) + (else + (let lp ((j (- len 1))) + (cond ((<= j i) "") + ((char-whitespace? (string-ref s j)) (lp (- j 1))) + (else (substring s i (+ j 1)))))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; header parsing + +(define (mime-header-fold kons knil . o) + (let ((src (and (pair? o) (car o))) + (limit (and (pair? o) (pair? (cdr o)) (car (cdr o)))) + (kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (caddr o) kons))) + ((if (string? src) mime-header-fold-string mime-header-fold-port) + kons knil (or src (current-input-port)) limit kons-from))) + +(define (mime-header-fold-string kons knil str limit kons-from) + (call-with-input-string str + (lambda (in) (mime-header-fold-port kons knil in limit kons-from)))) + +(define (mime-header-fold-port kons knil port limit kons-from) + (define (out line acc count) + (cond + ((or (and limit (> count limit)) (eof-object? line) (string=? line "")) + acc) + ((match-mime-header-line line) + => (lambda (m) (in (car m) (list (cadr m)) acc (+ count 1)))) + (else + ;;(warn "invalid header line: ~S\n" line) + (out (read-line port mime-line-length-limit) acc (+ count 1))))) + (define (in header value acc count) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((and limit (> count limit)) + acc) + ((or (eof-object? line) (string=? line "")) + (kons header (string-concatenate-reverse value) acc)) + ((char-whitespace? (string-ref line 0)) + (in header (cons line value) acc (+ count 1))) + (else + (out line + (kons header (string-concatenate-reverse value) acc) + (+ count 1)))))) + (let ((first-line (read-line port mime-line-length-limit))) + (cond + ((eof-object? first-line) + knil) + ((and kons-from (match-mbox-from-line first-line)) + => (lambda (m) ; special case check on first line for mbox files + (out (read-line port mime-line-length-limit) + (kons-from "%from" (car m) + (kons-from "%date" (cadr m) knil)) + 0))) + (else + (out first-line knil 0))))) + +(define (mime-headers->list . o) + (reverse + (apply + mime-header-fold + (lambda (h v acc) (cons (cons (string-downcase h) v) acc)) + '() + o))) + +(define (mime-split-name+value s) + (let ((i (string-char-index s #\=))) + (if i + (cons (string-downcase (string-trim-white-space (substring s 0 i))) + (if (= i (string-length s)) + "" + (if (eqv? #\" (string-ref s (+ i 1))) + (substring s (+ i 2) (- (string-length s) 1)) + (substring s (+ i 1) (string-length s))))) + (cons (string-downcase (string-trim-white-space s)) "")))) + +(define (mime-parse-content-type str) + (map mime-split-name+value (string-split str #\;))) + +(define (mime-decode-header str) + (let* ((len (string-length str)) + (limit (- len 8))) ; need at least 8 chars: "=?Q?X??=" + (let lp ((i 0) (from 0) (res '())) + (if (>= i limit) + (string-concatenate (reverse (cons (substring str from len) res))) + (if (and (eqv? #\= (string-ref str i)) + (eqv? #\? (string-ref str (+ i 1)))) + (let* ((j (string-char-index str #\? (+ i 3))) + (k (string-char-index str #\? (+ j 3)))) + (if (and j k (< (+ k 1) len) + (eqv? #\? (string-ref str (+ j 2))) + (memq (string-ref str (+ j 1)) '(#\Q #\B #\q #\b)) + (eqv? #\= (string-ref str (+ k 1)))) + (let ((decode (if (memq (string-ref str (+ j 1)) '(#\Q #\q)) + quoted-printable-decode-string + base64-decode-string)) + (cset (substring str (+ i 2) j)) + (content (substring str (+ j 3) k)) + (k2 (+ k 2))) + (lp k2 k2 (cons (ces-convert (decode content) cset) + (cons (substring str from i) res)))) + (lp (+ i 2) from res))) + (lp (+ i 1) from res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; message parsing + +(define (mime-read-to-boundary port boundary next final) + (let ((final-boundary (and boundary (string-append boundary "--")))) + (let lp ((res '())) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((or (eof-object? line) (equal? line final-boundary)) + (final (string-concatenate (reverse res) + (call-with-output-string newline)))) + ((equal? line boundary) + (next (string-concatenate (reverse res) + (call-with-output-string newline)))) + (else + (lp (cons line res)))))))) + +(define (mime-convert-part str cte enc) + (let ((str (cond + ((and (string? cte) (string-ci=? cte "quoted-printable")) + (quoted-printable-decode-string str)) + ((and (string? cte) (string-ci=? cte "base64")) + (base64-decode-string str)) + (else + str)))) + (if (string? enc) (ces-convert str enc) str))) + +(define (mime-read-part port cte enc boundary next final) + (mime-read-to-boundary + port boundary + (lambda (x) (next (mime-convert-part x cte enc))) + (lambda (x) (final (mime-convert-part x cte enc))))) + +;; (kons parent-headers part-headers part-body seed) +;; (start headers seed) +;; (end headers parent-seed seed) +(define (mime-message-fold src kons init-seed . o) + (let ((port (if (string? src) (open-input-string src) src))) + (let ((kons-start + (if (pair? o) (car o) (lambda (headers seed) '()))) + (kons-end + (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)))) + (headers + (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + (mime-headers->list port)))) + (let tfold ((parent-headers '()) + (headers headers) + (seed init-seed) + (boundary #f) + (next (lambda (x) x)) + (final (lambda (x) x))) + (let* ((ctype (mime-parse-content-type + (mime-ref headers "Content-Type" "text/plain"))) + (type (string-trim-white-space (caar ctype))) + (enc (string-trim-white-space + (or (mime-ref ctype "charset") + (mime-ref headers "charset" "ASCII")))) + (cte (string-trim-white-space + (or (mime-ref headers "Content-Transfer-Encoding") + (mime-ref headers "Encoding" "7-bit"))))) + (cond + ((and (string-ci=? type "multipart/") + (mime-ref ctype "boundary")) + => (lambda (boundary2) + (let ((boundary2 (string-append "--" boundary2))) + ;; skip preamble + (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x)) + (let lp ((part-seed (kons-start headers seed))) + (let ((part-headers (mime-headers->list port))) + (tfold parent-headers part-headers + part-seed boundary2 + lp + (lambda (x) + ;; skip epilogue + (if boundary + (mime-read-to-boundary port boundary + (lambda (x) x) (lambda (x) x))) + (next (kons-end headers seed x))) + )))))) + (else + (mime-read-part + port cte enc boundary + (lambda (x) (next (kons parent-headers headers x seed))) + (lambda (x) (final (kons parent-headers headers x seed))))))))))) + +;; (mime (^ (header . value) ...) parts ...) +(define (mime-message->sxml . o) + (car + (apply + mime-message-fold + (if (pair? o) (car o) (current-input-port)) + (lambda (parent-headers headers body seed) + `((mime (^ ,@headers) ,body) ,@seed)) + '() + (lambda (headers seed) '()) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)) + (if (pair? o) (cdr o) '())))) + diff --git a/lib/chibi/net.module b/lib/chibi/net.module new file mode 100644 index 00000000..845a7aa8 --- /dev/null +++ b/lib/chibi/net.module @@ -0,0 +1,11 @@ + +(define-module (chibi net) + (export sockaddr? address-info? get-address-info socket connect + with-net-io open-net-io + address-info-family address-info-socket-type address-info-protocol + address-info-address address-info-address-length address-info-next) + (import-immutable (scheme)) + (import (chibi filesystem)) + (include-shared "net") + (include "net.scm")) + diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm new file mode 100644 index 00000000..5f912cb5 --- /dev/null +++ b/lib/chibi/net.scm @@ -0,0 +1,32 @@ +;; net.scm -- the high-level network interface +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (open-net-io host service) + (let lp ((addr (get-address-info host + (if (integer? service) + (number->string service) + service) + #f))) + (if (not addr) + (error "couldn't find address" host service) + (let ((sock (socket (address-info-family addr) + (address-info-socket-type addr) + (address-info-protocol addr)))) + (if (negative? sock) + (lp (address-info-next addr)) + (if (negative? + (connect sock + (address-info-address addr) + (address-info-address-length addr))) + (lp (address-info-next addr)) + (list (open-input-file-descriptor sock) + (open-output-file-descriptor sock)))))))) + +(define (with-net-io host service proc) + (let ((io (open-net-io host service))) + (if (not (pair? io)) + (error "couldn't find address" host service) + (let ((res (proc (car io) (car (cdr io))))) + (close-input-port (car io)) + res)))) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub new file mode 100644 index 00000000..0d72bc90 --- /dev/null +++ b/lib/chibi/net.stub @@ -0,0 +1,25 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/socket.h") +(c-system-include "netdb.h") + +(define-c-struct sockaddr + predicate: sockaddr?) + +(define-c-struct addrinfo + finalizer: freeaddrinfo + predicate: address-info? + (int ai_family address-info-family) + (int ai_socktype address-info-socket-type) + (int ai_protocol address-info-protocol) + ((link sockaddr) ai_addr address-info-address) + (size_t ai_addrlen address-info-address-length) + ((link addrinfo) ai_next address-info-next)) + +(define-c errno (get-address-info getaddrinfo) + (string string (maybe-null addrinfo) (result free addrinfo))) + +(define-c int bind (int sockaddr int)) +(define-c int listen (int int)) +(define-c int socket (int int int)) +(define-c int connect (int sockaddr int)) diff --git a/lib/chibi/net/http.module b/lib/chibi/net/http.module new file mode 100644 index 00000000..352bf7b4 --- /dev/null +++ b/lib/chibi/net/http.module @@ -0,0 +1,7 @@ + +(define-module (chibi net http) + (export http-get call-with-input-url with-input-from-url + http-parse-request http-parse-form) + (import-immutable (scheme) (srfi 39) (chibi net) (chibi io) + (chibi uri) (chibi mime)) + (include "http.scm")) diff --git a/lib/chibi/net/http.scm b/lib/chibi/net/http.scm new file mode 100644 index 00000000..37cac5e6 --- /dev/null +++ b/lib/chibi/net/http.scm @@ -0,0 +1,180 @@ +;; http.scm -- http client +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; client utils + +(define http-user-agent "chibi") + +(define http-redirect-limit 10) +(define http-chunked-buffer-size 4096) +(define http-chunked-size-limit 409600) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (http-parse-response line) + (let* ((len (string-length line)) + (i (or (string-scan line #\space 0 len) len)) + (j (or (string-scan line #\space (+ i 1) len) len)) + (n (and (< i j) (string->number (substring line (+ i 1) j))))) + (if (not (integer? n)) + (error "bad response" line i j) + (list (substring line 0 i) + n + (if (>= j len) "" (substring line (+ j 1) len)))))) + +(define (http-wrap-chunked-input-port in) + (define (read-chunk in) + (let* ((line (read-line in)) + (n (and (string? line) (string->number line 16)))) + (display "read-chunk ") (write line) (newline) + (cond + ((not (and (integer? n) (<= 0 n http-chunked-size-limit))) + (error "invalid chunked size line" line)) + ((zero? n) "") + (else (read-string n in))))) + (make-generated-input-port + (lambda () (read-chunk in)))) + +(define (http-get/raw url in-headers limit) + (if (<= limit 0) + (error "http-get: redirect limit reached" url) + (let* ((uri (if (uri? url) url (string->uri url))) + (host (and uri (uri-host uri)))) + (if (not host) + (error "invalid url" url) + (let* ((io (open-net-io + host + (or (uri-port uri) + (if (eq? 'https (uri-scheme uri)) 443 80)))) + (in (car io)) + (out (car (cdr io)))) + (display "GET " out) + (display (or (uri-path uri) "/") out) + (display " HTTP/1.0\r\n" out) + (display "Host: " out) (display host out) (display "\r\n" out) + (cond + ((not (mime-ref in-headers "user-agent")) + (display "User-Agent: " out) + (display http-user-agent out) + (display "\r\n" out))) + (for-each + (lambda (x) + (display (car x) out) (display ": " out) + (display (cdr x) out) (display "\r\n" out)) + in-headers) + (display "Connection: close\r\n\r\n" out) + (flush-output out) + (let* ((resp (http-parse-response (read-line in))) + (headers (mime-headers->list in)) + (status (quotient (cadr resp) 100))) + (case status + ((2) + (let ((enc (mime-ref headers "transfer-encoding"))) + (cond + ((equal? enc "chunked") + (http-wrap-chunked-input-port in)) + (else + in)))) + ((3) + (close-input-port in) + (close-output-port out) + (let ((url2 (mime-ref headers "location"))) + (if url2 + (http-get/raw url2 in-headers (- limit 1)) + (error "redirect with no location header")))) + (else + (close-input-port in) + (close-output-port out) + (error "couldn't retrieve url" url resp))))))))) + +(define (http-get url . headers) + (http-get/raw url + (if (pair? headers) (car headers) '()) + http-redirect-limit)) + +(define (call-with-input-url url proc) + (let* ((p (http-get url)) + (res (proc p))) + (close-input-port p) + res)) + +(define (with-input-from-url url thunk) + (let ((p (http-get url))) + (let ((res (parameterize ((current-input-port p)) (thunk)))) + (close-input-port p) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; server utils + +;; read and parse a request line +(define (http-parse-request . o) + (let ((line (string-split + (read-line (if (pair? o) (car o) (current-input-port)) 4096)))) + (cons (string->symbol (car line)) (cdr line)))) + +;; Parse a form body with a given URI and MIME headers (as parsed with +;; mime-headers->list). Returns an alist of (name . value) for every +;; query or form parameter. +(define (http-parse-form uri headers . o) + (let* ((in (if (pair? o) (car o) (current-input-port))) + (type (mime-ref headers + "content-type" + "application/x-www-form-urlencoded")) + (query0 (or (uri-query (if (string? uri) (string->uri uri) uri)) '())) + (query (if (string? query0) (uri-query->alist query0) query0))) + (cond + ((string-ci=? "multipart/" type) + (let ((mime (mime-message->sxml in headers))) + (append + (let lp ((ls (cddr mime)) + (res '())) + (cond + ((null? ls) + res) + ((and (pair? (car ls)) + (eq? 'mime (caar ls)) + (pair? (cdar ls)) + (pair? (cadar ls)) + (memq (caadar ls) '(^ @))) + (let* ((disp0 (mime-ref (cdadar ls) "content-disposition" "")) + (disp (mime-parse-content-type disp0)) + (name (mime-ref disp "name"))) + (if name + (lp (cdr ls) (cons (cons name (caddar ls)) res)) + (lp (cdr ls) res)))) + (else + (lp (cdr ls) res)))) + query))) + (else + query)))) + diff --git a/lib/chibi/pathname.module b/lib/chibi/pathname.module new file mode 100644 index 00000000..765ee189 --- /dev/null +++ b/lib/chibi/pathname.module @@ -0,0 +1,7 @@ + +(define-module (chibi pathname) + (export path-strip-directory path-directory path-extension-pos + path-extension path-strip-extension path-replace-extension + path-absolute? path-relative? path-normalize make-path) + (import-immutable (scheme)) + (include "pathname.scm")) diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm new file mode 100644 index 00000000..de27ad61 --- /dev/null +++ b/lib/chibi/pathname.scm @@ -0,0 +1,180 @@ +;; pathname.scm -- a general, non-host-specific path lib +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-scan-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (- i 1)))))) + +(define (string-skip c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (+ i 1))))))) + +(define (string-skip-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (- i 1)))))) + +;; POSIX basename +;; (define (path-strip-directory path) +;; (if (string=? path "") +;; path +;; (let ((end (string-skip-right #\/ path))) +;; (if (not end) +;; "/" +;; (let ((start (string-scan-right #\/ path (- end 1)))) +;; (substring path (if start (+ start 1) 0) (+ end 1))))))) + +;; GNU basename +(define (path-strip-directory path) + (if (string=? path "") + path + (let ((len (string-length path))) + (if (eqv? #\/ (string-ref path (- len 1))) + "" + (let ((slash (string-scan-right #\/ path))) + (if (not slash) + path + (substring path (+ slash 1) len))))))) + +(define (path-directory path) + (if (string=? path "") + "." + (let ((end (string-skip-right #\/ path))) + (if (not end) + "/" + (let ((start (string-scan-right #\/ path (- end 1)))) + (if (not start) + "." + (let ((start (string-skip-right #\/ path start))) + (if (not start) "/" (substring path 0 (+ start 1)))))))))) + +(define (path-extension-pos path) (string-scan-right #\. path)) + +(define (path-extension path) + (let ((i (path-extension-pos path))) + (and i + (let ((start (+ i 1)) (end (string-length path))) + (and (< start end) (substring path start end)))))) + +(define (path-strip-extension path) + (let ((i (path-extension-pos path))) + (if (and i (< (+ i 1) (string-length path))) + (substring path 0 i) + path))) + +(define (path-replace-extension path ext) + (string-append (path-strip-extension path) "." ext)) + +(define (path-absolute? path) + (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0)))) + +(define (path-relative? path) (not (path-absolute? path))) + +;; This looks big and hairy, but it's mutation-free and guarantees: +;; (string=? s (path-normalize s)) <=> (eq? s (path-normalize s)) +;; i.e. fast and simple for already normalized paths. + +(define (path-normalize path) + (let* ((len (string-length path)) (len-1 (- len 1))) + (define (collect i j res) + (if (>= i j) res (cons (substring path i j) res))) + (define (finish i res) + (if (zero? i) + path + (apply string-append (reverse (collect i len res))))) + ;; loop invariants: + ;; - res is a list such that (string-concatenate-reverse res) + ;; is always the normalized string up to j + ;; - the tail of the string from j onward can be concatenated to + ;; the above value to get a partially normalized path referring + ;; to the same location as the original path + (define (inside i j res) + (if (>= j len) + (finish i res) + (if (eqv? #\/ (string-ref path j)) + (boundary i (+ j 1) res) + (inside i (+ j 1) res)))) + (define (boundary i j res) + (if (>= j len-1) + (finish i res) + (case (string-ref path j) + ((#\.) + (case (string-ref path (+ j 1)) + ((#\.) + (if (or (>= j (- len 2)) (eqv? #\/ (string-ref path (+ j 2)))) + (if (>= i (- j 1)) + (if (null? res) + (backup j "" '()) + (backup j (car res) (cdr res))) + (backup j (substring path i j) res)) + (inside i (+ j 2) res))) + ((#\/) + (if (= i j) + (boundary (+ j 2) (+ j 2) res) + (let ((s (substring path i j))) + (boundary (+ j 2) (+ j 2) (cons s res))))) + (else (inside i (+ j 1) res)))) + ((#\/) (boundary (+ j 1) (+ j 1) (collect i j res))) + (else (inside i (+ j 1) res))))) + (define (backup j s res) + (let ((pos (+ j 3))) + (cond + ;; case 1: we're reduced to accumulating parents of the cwd + ((or (string=? s "/..") (string=? s "..")) + (boundary pos pos (cons "/.." (cons s res)))) + ;; case 2: the string isn't a component itself, skip it + ((or (string=? s "") (string=? s ".") (string=? s "/")) + (if (pair? res) + (backup j (car res) (cdr res)) + (boundary pos pos (if (string=? s "/") '("/") '(".."))))) + ;; case3: just take the directory of the string + (else + (let ((d (path-directory s))) + (cond + ((string=? d "/") + (boundary pos pos (if (null? res) '("/") res))) + ((string=? d ".") + (boundary pos pos res)) + (else (boundary pos pos (cons "/" (cons d res)))))))))) + ;; start with boundary if abs path, otherwise inside + (if (zero? len) + path + ((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '())))) + +(define (make-path . args) + (define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "not a valid path component" x)))) + (define (trim-trailing-slash s) + (let ((i (string-skip-right #\/ s))) + (if i (substring s 0 (+ i 1)) ""))) + (if (null? args) + "" + (let ((start (trim-trailing-slash (x->string (car args))))) + (let lp ((ls (cdr args)) + (res (if (string=? "" start) '() (list start)))) + (cond + ((null? ls) + (apply string-append (reverse res))) + ((pair? (car ls)) + (lp (append (car ls) (cdr ls)) res)) + (else + (let ((x (trim-trailing-slash (x->string (car ls))))) + (lp (cdr ls) + (if (string=? x "") res (cons x (cons "/" res))))))))))) diff --git a/lib/chibi/process.module b/lib/chibi/process.module new file mode 100644 index 00000000..fe03c2e5 --- /dev/null +++ b/lib/chibi/process.module @@ -0,0 +1,17 @@ + +(define-module (chibi process) + (export exit sleep alarm fork kill execute waitpid + set-signal-action! make-signal-set signal-set-contains? + signal-set-fill! signal-set-add! signal-set-delete! + current-signal-mask + signal-mask-block! signal-mask-unblock! signal-mask-set! + signal/hang-up signal/interrupt signal/quit + signal/illegal signal/abort signal/fpe + signal/kill signal/segv signal/pipe + signal/alarm signal/term signal/user1 + signal/user2 signal/child signal/continue + signal/stop signal/tty-stop signal/tty-input + signal/tty-output) + (import-immutable (scheme)) + (include-shared "process")) + diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub new file mode 100644 index 00000000..17287d30 --- /dev/null +++ b/lib/chibi/process.stub @@ -0,0 +1,72 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/wait.h") +(c-system-include "signal.h") +(c-system-include "unistd.h") + +(define-c-type siginfo_t + predicate: signal-info? + (int si_signo signal-number) + (int si_errno signal-error-number) + (int si_code signal-code) + (pid_t si_pid signal-pid) + (uid_t si_uid signal-uid) + (int si_status signal-status) + ;;(clock_t si_utime signal-user-time) + ;;(clock_t si_stime signal-system-time) + ) + +(define-c-type sigset_t + predicate: signal-set?) + +(define-c-const int (signal/hang-up "SIGHUP")) +(define-c-const int (signal/interrupt "SIGINT")) +(define-c-const int (signal/quit "SIGQUIT")) +(define-c-const int (signal/illegal "SIGILL")) +(define-c-const int (signal/abort "SIGABRT")) +(define-c-const int (signal/fpe "SIGFPE")) +(define-c-const int (signal/kill "SIGKILL")) +(define-c-const int (signal/segv "SIGSEGV")) +(define-c-const int (signal/pipe "SIGPIPE")) +(define-c-const int (signal/alarm "SIGALRM")) +(define-c-const int (signal/term "SIGTERM")) +(define-c-const int (signal/user1"SIGUSR1")) +(define-c-const int (signal/user2 "SIGUSR2")) +(define-c-const int (signal/child "SIGCHLD")) +(define-c-const int (signal/continue "SIGCONT")) +(define-c-const int (signal/stop "SIGSTOP")) +(define-c-const int (signal/tty-stop "SIGTSTP")) +(define-c-const int (signal/tty-input "SIGTTIN")) +(define-c-const int (signal/tty-output "SIGTTOU")) + +(c-include "signal.c") + +(define-c sexp (set-signal-action! "sexp_set_signal_action") + ((value ctx sexp) (value self sexp) sexp sexp)) + +(define-c errno (make-signal-set "sigemptyset") ((result sigset_t))) +(define-c errno (signal-set-fill! "sigfillset") (sigset_t)) +(define-c errno (signal-set-add! "sigaddset") (sigset_t int)) +(define-c errno (signal-set-delete! "sigaddset") (sigset_t int)) +(define-c boolean (signal-set-contains? "sigismember") (sigset_t int)) + +(define-c errno (signal-mask-block! "sigprocmask") + ((value SIG_BLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-unblock! "sigprocmask") + ((value SIG_UNBLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-set! "sigprocmask") + ((value SIG_SETMASK int) sigset_t (value NULL sigset_t))) +(define-c errno (current-signal-mask "sigprocmask") + ((value SIG_BLOCK int) (value NULL sigset_t) (result sigset_t))) + +(define-c unsigned-int alarm (unsigned-int)) +(define-c unsigned-int sleep (unsigned-int)) + +(define-c pid_t fork ()) +;;(define-c pid_t wait ((result int))) +(define-c pid_t waitpid (int (result int) int)) +(define-c errno kill (int int)) +;;(define-c errno raise (int)) +(define-c void exit (int)) +(define-c int (execute execvp) (string (array string))) + diff --git a/lib/chibi/quoted-printable.module b/lib/chibi/quoted-printable.module new file mode 100644 index 00000000..9cbec430 --- /dev/null +++ b/lib/chibi/quoted-printable.module @@ -0,0 +1,7 @@ + +(define-module (chibi quoted-printable) + (export quoted-printable-encode quoted-printable-encode-string + quoted-printable-encode-header + quoted-printable-decode quoted-printable-decode-string) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "quoted-printable.scm")) diff --git a/lib/chibi/quoted-printable.scm b/lib/chibi/quoted-printable.scm new file mode 100644 index 00000000..80709026 --- /dev/null +++ b/lib/chibi/quoted-printable.scm @@ -0,0 +1,157 @@ +;; quoted-printable.scm -- RFC2045 implementation +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: quoted-printable-encode-string str [start-col max-col] +;; Return a quoted-printable encoded representation of string +;; according to the official standard as described in RFC2045. +;; +;; ? and _ are always encoded for compatibility with RFC1522 encoding, +;; and soft newlines are inserted as necessary to keep each lines +;; length less than MAX-COL (default 76). The starting column may be +;; overridden with START-COL (default 0). + +;; Procedure: quoted-printable-decode-string str [mime?] +;; Return a quoted-printable decoded representation of string. If +;; MIME? is specified and true, _ will be decoded as as space in +;; accordance with RFC1522. No errors will be raised on invalid +;; input. + +;; Procedure: quoted-printable-encode [port start-col max-col] +;; Procedure: quoted-printable-decode [port start-col max-col] +;; Variations of the above which read and write to ports. + +;; Procedure: quoted-printable-encode-header enc str [start-col max-col] +;; Return a quoted-printable encoded representation of string as +;; above, wrapped in =?ENC?Q?...?= as per RFC1522, split across +;; multiple MIME-header lines as needed to keep each lines length less +;; than MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring STR +;; is already encoded according to ENC. + +;; Example: + +;; (define (mime-encode-header header value charset) +;; (let ((prefix (string-append header ": ")) +;; (str (ces-convert value "UTF8" charset))) +;; (string-append +;; prefix +;; (quoted-printable-encode-header charset str (string-length prefix))))) + +;; This API is backwards compatible with the Gauche library +;; rfc.quoted-printable. + +(define *default-max-col* 76) + +;; Allow for RFC1522 quoting for headers by always escaping ? and _ +(define (qp-encode str start-col max-col separator) + (define (hex i) (integer->char (+ i (if (<= i 9) 48 55)))) + (let ((end (string-length str)) + (buf (make-string max-col))) + (let lp ((i 0) (col start-col) (res '())) + (cond + ((= i end) + (if (pair? res) + (string-concatenate (reverse (cons (substring buf 0 col) res)) + separator) + (substring buf start-col col))) + ((>= col (- max-col 3)) + (lp i 0 (cons (substring buf (if (pair? res) 0 start-col) col) res))) + (else + (let ((c (char->integer (string-ref str i)))) + (cond + ((and (<= 33 c 126) (not (memq c '(61 63 95)))) + (string-set! buf col (integer->char c)) + (lp (+ i 1) (+ col 1) res)) + (else + (string-set! buf col #\=) + (string-set! buf (+ col 1) (hex (arithmetic-shift c -4))) + (string-set! buf (+ col 2) (hex (bitwise-and c #b1111))) + (lp (+ i 1) (+ col 3) res))))))))) + +(define (quoted-printable-encode-string . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*))) + (qp-encode (if (string? src) src (read-string #f src)) + start-col max-col "=\r\n"))) + +(define (quoted-printable-encode . o) + (display (apply (quoted-printable-encode-string o)))) + +(define (quoted-printable-encode-header encoding . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdddr o))) + (cadddr o) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?Q?")) + (prefix-length (+ 2 (string-length prefix))) + (separator (string-append "?=" nl "\t" prefix)) + (effective-max-col (- max-col prefix-length))) + (string-append prefix + (qp-encode (if (string? src) src (read-string #f src)) + start-col effective-max-col separator) + "?=")))) + +(define (quoted-printable-decode-string . o) + (define (hex? c) (or (char-numeric? c) (<= 65 (char->integer c) 70))) + (define (unhex1 c) + (let ((i (char->integer c))) (if (>= i 65) (- i 55) (- i 48)))) + (define (unhex c1 c2) + (integer->char (+ (arithmetic-shift (unhex1 c1) 4) (unhex1 c2)))) + (let ((src (if (pair? o) (car o) (current-input-port))) + (mime-header? (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (let* ((str (if (string? src) src (read-string #f src))) + (end (string-length str))) + (call-with-output-string + (lambda (out) + (let lp ((i 0)) + (cond + ((< i end) + (let ((c (string-ref str i))) + (case c + ((#\=) ; = escapes + (cond + ((< (+ i 2) end) + (let ((c2 (string-ref str (+ i 1)))) + (cond + ((eq? c2 #\newline) (lp (+ i 2))) + ((eq? c2 #\return) + (lp (if (eq? (string-ref str (+ i 2)) #\newline) + (+ i 3) + (+ i 2)))) + ((hex? c2) + (let ((c3 (string-ref str (+ i 2)))) + (if (hex? c3) (write-char (unhex c2 c3) out)) + (lp (+ i 3)))) + (else (lp (+ i 3)))))))) + ((#\_) ; maybe translate _ to space + (write-char (if mime-header? #\space c) out) + (lp (+ i 1))) + ((#\space #\tab) ; strip trailing whitespace + (let lp2 ((j (+ i 1))) + (cond + ((not (= j end)) + (case (string-ref str j) + ((#\space #\tab) (lp2 (+ j 1))) + ((#\newline) + (lp (+ j 1))) + ((#\return) + (let ((k (+ j 1))) + (lp (if (and (< k end) + (eqv? #\newline (string-ref str k))) + (+ k 1) k)))) + (else (display (substring str i j) out) (lp j))))))) + (else ; a literal char + (write-char c out) + (lp (+ i 1))))))))))))) + +(define (quoted-printable-decode . o) + (display (apply quoted-printable-decode-string o))) + diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c new file mode 100644 index 00000000..ea23929f --- /dev/null +++ b/lib/chibi/signal.c @@ -0,0 +1,62 @@ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_MAX_SIGNUM 32 + +static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM]; + +static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { + sexp ctx, sigctx, handler; + sexp_gc_var1(args); + ctx = sexp_signal_contexts[signum]; + if (ctx) { + handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), + sexp_make_fixnum(signum)); + if (sexp_truep(handler)) { + sigctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve1(sigctx, args); + args = sexp_cons(sigctx, SEXP_FALSE, SEXP_NULL); + sexp_car(args) + = sexp_make_cpointer(sigctx, sexp_siginfo_t_type_id, info, SEXP_FALSE, 0); + args = sexp_cons(sigctx, SEXP_FALSE, args); + sexp_car(args) = sexp_make_fixnum(signum); + sexp_apply(sigctx, handler, args); + sexp_gc_release1(sigctx); + } + } +} + +static struct sigaction call_sigaction = { + .sa_sigaction = sexp_call_sigaction, + .sa_flags = SA_SIGINFO | SA_NODEFER +}; + +static struct sigaction call_sigdefault = {.sa_handler = SIG_DFL}; +static struct sigaction call_sigignore = {.sa_handler = SIG_IGN}; + +static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newaction) { + int res; + sexp oldaction; + if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0 + && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) + return sexp_xtype_exception(ctx, self, "not a valid signal number", signum); + if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) + || sexp_booleanp(newaction))) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, newaction); + if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS))) + sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS) + = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE); + oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); + res = sigaction(sexp_unbox_fixnum(signum), + (sexp_booleanp(newaction) ? + (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore) + : &call_sigaction), + NULL); + if (res) + return sexp_user_exception(ctx, self, "couldn't set signal", signum); + sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction); + sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx; + return oldaction; +} + diff --git a/lib/chibi/stty.module b/lib/chibi/stty.module new file mode 100644 index 00000000..4540cb18 --- /dev/null +++ b/lib/chibi/stty.module @@ -0,0 +1,11 @@ + +(define-module (chibi stty) + (export stty with-stty with-raw-io + get-terminal-width get-terminal-dimensions + TCSANOW TCSADRAIN TCSAFLUSH) + (import-immutable (scheme) + (srfi 33) + (srfi 69)) + (include-shared "stty") + (include "stty.scm")) + diff --git a/lib/chibi/stty.scm b/lib/chibi/stty.scm new file mode 100644 index 00000000..b4aee004 --- /dev/null +++ b/lib/chibi/stty.scm @@ -0,0 +1,235 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; symbolic representation of attributes + +(define stty-lookup (make-hash-table eq?)) + +(for-each + (lambda (c) + (let ((type (cadr c)) + (value (caddr c))) + (hash-table-set! stty-lookup (car c) (cdr c)))) + + ;; ripped from the stty man page, then trimmed down to what seemed + ;; available on most systems + + `(;; characters + ;;(dsusp char ,VDSUSP) ; CHAR will send a terminal stop signal + (eof char ,VEOF) ; CHAR will send an EOF (terminate input) + (eol char ,VEOL) ; CHAR will end the line + (eol2 char ,VEOL2) ; alternate CHAR for ending the line + (erase char ,VERASE) ; CHAR will erase the last character typed + (intr char ,VINTR) ; CHAR will send an interrupt signal + (kill char ,VKILL) ; CHAR will erase the current line + (lnext char ,VLNEXT) ; CHAR will enter the next character quoted + (quit char ,VQUIT) ; CHAR will send a quit signal + (rprnt char ,VREPRINT) ; CHAR will redraw the current line + (start char ,VSTART) ; CHAR will restart output after stopping it + (stop char ,VSTOP) ; CHAR will stop the output + (susp char ,VSUSP) ; CHAR will send a terminal stop signal + (werase char ,VWERASE) ; CHAR will erase the last word typed + + ;; special settings + (cols special #f) ; tell the kernel that the terminal has N columns + (columns special #f) ; same as cols N + (ispeed special #f) ; set the input speed to N + (line special #f) ; use line discipline N + (min special #f) ; with -icanon, set N characters minimum for a completed read + (ospeed special #f) ; set the output speed to N + (rows special #f) ; tell the kernel that the terminal has N rows + (size special #f) ; print the number of rows and columns according to the kernel + (speed special #f) ; print the terminal speed + (time special #f) ; with -icanon, set read timeout of N tenths of a second + + ;; control settings + (clocal control ,CLOCAL) ; disable modem control signals + (cread control ,CREAD) ; allow input to be received + (crtscts control ,CRTSCTS) ; enable RTS/CTS handshaking + (cs5 control ,CS5) ; set character size to 5 bits + (cs6 control ,CS6) ; set character size to 6 bits + (cs7 control ,CS7) ; set character size to 7 bits + (cs8 control ,CS8) ; set character size to 8 bits + (cstopb control ,CSTOPB) ; use two stop bits per character (one with `-') + (hup control ,HUPCL) ; send a hangup signal when the last process closes the tty + (hupcl control ,HUPCL) ; same as [-]hup + (parenb control ,PARENB) ; generate parity bit in output and expect parity bit in input + (parodd control ,PARODD) ; set odd parity (even with `-') + + ;; input settings + (brkint input ,BRKINT) ; breaks cause an interrupt signal + (icrnl input ,ICRNL) ; translate carriage return to newline + (ignbrk input ,IGNBRK) ; ignore break characters + (igncr input ,IGNCR) ; ignore carriage return + (ignpar input ,IGNPAR) ; ignore characters with parity errors + (imaxbel input ,IMAXBEL) ; * beep and do not flush a full input buffer on a character + (inlcr input ,INLCR) ; translate newline to carriage return + (inpck input ,INPCK) ; enable input parity checking + (istrip input ,ISTRIP) ; clear high (8th) bit of input characters + ;;(iuclc input ,IUCLC) ; * translate uppercase characters to lowercase + (ixany input ,IXANY) ; * let any character restart output, not only start character + (ixoff input ,IXOFF) ; enable sending of start/stop characters + (ixon input ,IXON) ; enable XON/XOFF flow control + (parmrk input ,PARMRK) ; mark parity errors (with a 255-0-character sequence) + (tandem input ,IXOFF) ; same as [-]ixoff + + ;; output settings + ;;(bs0 output ,BS0) ; backspace delay style, N in [0..1] + ;;(bs1 output ,BS1) ; backspace delay style, N in [0..1] + ;;(cr0 output ,CR0) ; carriage return delay style, N in [0..3] + ;;(cr1 output ,CR1) ; carriage return delay style, N in [0..3] + ;;(cr2 output ,CR2) ; carriage return delay style, N in [0..3] + ;;(cr3 output ,CR3) ; carriage return delay style, N in [0..3] + ;;(ff0 output ,FF0) ; form feed delay style, N in [0..1] + ;;(ff1 output ,FF1) ; form feed delay style, N in [0..1] + ;;(nl0 output ,NL0) ; newline delay style, N in [0..1] + ;;(nl1 output ,NL1) ; newline delay style, N in [0..1] + (ocrnl output ,OCRNL) ; translate carriage return to newline + ;;(ofdel output ,OFDEL) ; use delete characters for fill instead of null characters + ;;(ofill output ,OFILL) ; use fill (padding) characters instead of timing for delays + ;;(olcuc output ,OLCUC) ; translate lowercase characters to uppercase + (onlcr output ,ONLCR) ; translate newline to carriage return-newline + (onlret output ,ONLRET) ; newline performs a carriage return + (onocr output ,ONOCR) ; do not print carriage returns in the first column + (opost output ,OPOST) ; postprocess output + (tab0 output #f) ; horizontal tab delay style, N in [0..3] + (tab1 output #f) ; horizontal tab delay style, N in [0..3] + (tab2 output #f) ; horizontal tab delay style, N in [0..3] + (tab3 output #f) ; horizontal tab delay style, N in [0..3] + (tabs output #f) ; same as tab0 + ;;(-tabs output #f) ; same as tab3 + ;;(vt0 output ,VT0) ; vertical tab delay style, N in [0..1] + ;;(vt1 output ,VT1) ; vertical tab delay style, N in [0..1] + + ;; local settings + (crterase local ,ECHOE) ; echo erase characters as backspace-space-backspace + (crtkill local ,ECHOKE) ; kill all line by obeying the echoprt and echoe settings + ;;(-crtkill local #f) ; kill all line by obeying the echoctl and echok settings + (ctlecho local ,ECHOCTL) ; echo control characters in hat notation (`^c') + (echo local ,ECHO) ; echo input characters + (echoctl local ,ECHOCTL) ; same as [-]ctlecho + (echoe local ,ECHOE) ; same as [-]crterase + ;;(echok local ,ECHOK) ; echo a newline after a kill character + (echoke local ,ECHOKE) ; same as [-]crtkill + (echonl local ,ECHONL) ; echo newline even if not echoing other characters + (echoprt local ,ECHOPRT) ; echo erased characters backward, between `\' and '/' + (icanon local ,ICANON) ; enable erase, kill, werase, and rprnt special characters + ;;(iexten local ,IEXTEN) ; enable non-POSIX special characters + (isig local ,ISIG) ; enable interrupt, quit, and suspend special characters + (noflsh local ,NOFLSH) ; disable flushing after interrupt and quit special characters + (prterase local ,ECHOPRT) ; same as [-]echoprt + (tostop local ,TOSTOP) ; stop background jobs that try to write to the terminal + ;;(xcase local ,XCASE) ; with icanon, escape with `\' for uppercase characters + + ;; combination settings + (LCASE combine (lcase)) + (cbreak combine (not icanon)) + (cooked combine (brkint ignpar istrip icrnl ixon opost isig icanon)) + ; also eof and eol characters + ; to their default values + (crt combine (echoe echoctl echoke)) + (dec combine (echoe echoctl echoke (not ixany))) + ; also intr ^c erase 0177 kill ^u + (decctlq combine (ixany)) + (ek combine ()) ; erase and kill characters to their default values + (evenp combine (parenb (not parodd) cs7)) + ;;(-evenp combine #f) ; same as -parenb cs8 + (lcase combine (xcase iuclc olcuc)) + (litout combine (cs8 (not parenb istrip opost))) + ;;(-litout combine #f) ; same as parenb istrip opost cs7 + (nl combine (not icrnl onlcr)) + ;;(-nl combine #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret + (oddp combine (parenb parodd cs7)) + (parity combine (evenp)) ; same as [-]evenp + (pass8 combine (cs8 (not parenb istrip))) + ;;(-pass8 combine #f) ; same as parenb istrip cs7 + (raw combine (not ignbrk brkint ignpar parmrk + inpck istrip inlcr igncr icrnl)) + (ixon combine (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc + ;;(time combine #f) ; 0 + ;;(-raw combine #f) ; same as cooked + (sane combine (cread brkint icrnl imaxbel opost onlcr + isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0 + echo echoe echoctl echoke ;; iexten echok + (not ignbrk igncr ixoff ixany inlcr ;; iuclc + ocrnl onocr onlret ;; olcuc ofill ofdel + echonl noflsh tostop echoprt))) ;; xcase + ; plus all special characters to + ; their default values + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; high-level interface + +(define (port? x) (or (input-port? x) (output-port? x))) + +(define (stty . args) + (let* ((port (if (and (pair? args) (port? (car args))) + (car args) + (current-output-port))) + (attr (get-terminal-attributes port))) + ;; parse change requests + (let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args)) + (iflag (term-attrs-iflag attr)) + (oflag (term-attrs-oflag attr)) + (cflag (term-attrs-cflag attr)) + (lflag (term-attrs-lflag attr)) + (invert? #f) + (return (lambda (iflag oflag cflag lflag) + (term-attrs-iflag-set! attr iflag) + (term-attrs-oflag-set! attr oflag) + (term-attrs-cflag-set! attr cflag) + (term-attrs-lflag-set! attr lflag) + (set-terminal-attributes! port TCSANOW attr)))) + (define (join old new) + (if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new))) + (cond + ((pair? lst) + (let ((command (car lst))) + (cond + ((pair? command) ;; recurse on sub-expr + (lp command iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((eq? command 'not) ;; toggle current setting + (lp (cdr lst) iflag oflag cflag lflag (not invert?) return)) + (else + (let ((x (hash-table-ref/default stty-lookup command #f))) + (case (and x (car x)) + ((input) + (lp (cdr lst) (join iflag (cadr x)) oflag cflag lflag invert? return)) + ((output) + (lp (cdr lst) iflag (join oflag (cadr x)) cflag lflag invert? return)) + ((control) + (lp (cdr lst) iflag oflag (join cflag (cadr x)) lflag invert? return)) + ((local) + (lp (cdr lst) iflag oflag cflag (join lflag (cadr x)) invert? return)) + ((char) + ;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0)) + (lp (cddr lst) iflag oflag cflag lflag invert? return)) + ((combine) + (lp (cadr x) iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((special) + (error "special settings not yet supported" command)) + (else + (error "unknown stty command" command)))))))) + (else + (return iflag oflag cflag lflag)))))) + +(define (with-stty setting thunk . o) + (let* ((port (if (pair? o) (car o) (current-input-port))) + (orig-attrs (get-terminal-attributes port))) + (dynamic-wind + (lambda () (stty setting)) + thunk + (lambda () (set-terminal-attributes! port TCSANOW orig-attrs))))) + +(define (with-raw-io port thunk) + (with-stty '(not icanon echo) thunk port)) + +(define (get-terminal-width x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (winsize-col ws)))) + +(define (get-terminal-dimensions x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (list (winsize-col ws) (winsize-row ws))))) diff --git a/lib/chibi/stty.stub b/lib/chibi/stty.stub new file mode 100644 index 00000000..3c5939c5 --- /dev/null +++ b/lib/chibi/stty.stub @@ -0,0 +1,106 @@ + +(c-system-include "termios.h") +(c-system-include "sys/ioctl.h") + +(define-c-struct termios + predicate: term-attrs? + constructor: (make-term-attrs) + (unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!) + (unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!) + (unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!) + (unsigned-long c_lflag term-attrs-lflag term-attrs-lflag-set!) + ;;(unsigned-char (c_cc 22) term-attrs-cc term-attrs-cc-set!) + (unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!) + (unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!)) + +(define-c-struct winsize + predicate: winsize? + (unsigned-short ws_row winsize-row) + (unsigned-short ws_col winsize-col)) + +(define-c errno ioctl (port-or-fd unsigned-long (result winsize))) + +(define-c-const int TIOCGWINSZ) + +(define-c-const int TCSANOW) +(define-c-const int TCSADRAIN) +(define-c-const int TCSAFLUSH) + +(define-c-const unsigned-long IGNBRK) +(define-c-const unsigned-long BRKINT) +(define-c-const unsigned-long IGNPAR) +(define-c-const unsigned-long PARMRK) +(define-c-const unsigned-long INPCK) +(define-c-const unsigned-long ISTRIP) +(define-c-const unsigned-long INLCR) +(define-c-const unsigned-long IGNCR) +(define-c-const unsigned-long ICRNL) +(define-c-const unsigned-long IXON) +(define-c-const unsigned-long IXOFF) +(define-c-const unsigned-long IXANY) +(define-c-const unsigned-long IMAXBEL) +;; (define-c-const unsigned-long IUCLC) + +(define-c-const unsigned-long OPOST) +(define-c-const unsigned-long ONLCR) +;; (define-c-const unsigned-long OXTABS) +;; (define-c-const unsigned-long ONOEOT) +(define-c-const unsigned-long OCRNL) +;; (define-c-const unsigned-long OLCUC) +(define-c-const unsigned-long ONOCR) +(define-c-const unsigned-long ONLRET) + +(define-c-const unsigned-long CSIZE) +(define-c-const unsigned-long CS5) +(define-c-const unsigned-long CS6) +(define-c-const unsigned-long CS7) +(define-c-const unsigned-long CS8) +(define-c-const unsigned-long CSTOPB) +(define-c-const unsigned-long CREAD) +(define-c-const unsigned-long PARENB) +(define-c-const unsigned-long PARODD) +(define-c-const unsigned-long HUPCL) +(define-c-const unsigned-long CLOCAL) +;; (define-c-const unsigned-long CCTS_OFLOW) +(define-c-const unsigned-long CRTSCTS) +;; (define-c-const unsigned-long CRTS_IFLOW) +;; (define-c-const unsigned-long MDMBUF) + +(define-c-const unsigned-long ECHOKE) +(define-c-const unsigned-long ECHOE) +(define-c-const unsigned-long ECHO) +(define-c-const unsigned-long ECHONL) +(define-c-const unsigned-long ECHOPRT) +(define-c-const unsigned-long ECHOCTL) +(define-c-const unsigned-long ISIG) +(define-c-const unsigned-long ICANON) +;; (define-c-const unsigned-long ALTWERASE) +(define-c-const unsigned-long IEXTEN) +;; (define-c-const unsigned-long EXTPROC) +(define-c-const unsigned-long TOSTOP) +(define-c-const unsigned-long FLUSHO) +;; (define-c-const unsigned-long NOKERNINFO) +(define-c-const unsigned-long PENDIN) +(define-c-const unsigned-long NOFLSH) + +(define-c-const unsigned-long VEOF) +(define-c-const unsigned-long VEOL) +(define-c-const unsigned-long VEOL2) +(define-c-const unsigned-long VERASE) +;; (define-c-const unsigned-long VERASE2) +(define-c-const unsigned-long VWERASE) +(define-c-const unsigned-long VINTR) +(define-c-const unsigned-long VKILL) +(define-c-const unsigned-long VQUIT) +(define-c-const unsigned-long VSUSP) +(define-c-const unsigned-long VSTART) +(define-c-const unsigned-long VSTOP) +;; (define-c-const unsigned-long VDSUSP) +(define-c-const unsigned-long VLNEXT) +(define-c-const unsigned-long VREPRINT) +;; (define-c-const unsigned-long VSTATUS) + +(define-c errno (get-terminal-attributes "tcgetattr") + (port-or-fd (result termios))) +(define-c errno (set-terminal-attributes! "tcsetattr") + (port-or-fd int termios)) diff --git a/lib/chibi/system.module b/lib/chibi/system.module new file mode 100644 index 00000000..adc26ddc --- /dev/null +++ b/lib/chibi/system.module @@ -0,0 +1,15 @@ + +(define-module (chibi system) + (export user-information user-name user-password + user-id user-group-id user-gecos user-home user-shell + current-user-id current-group-id + current-effective-user-id current-effective-group-id + set-current-user-id! set-current-effective-user-id! + set-current-group-id! set-current-effective-group-id! + current-session-id create-session + set-root-directory!) + (import-immutable (scheme)) + (include-shared "system") + ;;(include "system.scm") + ) + diff --git a/lib/chibi/system.stub b/lib/chibi/system.stub new file mode 100644 index 00000000..7d4a836f --- /dev/null +++ b/lib/chibi/system.stub @@ -0,0 +1,34 @@ + +(c-system-include "unistd.h") +(c-system-include "pwd.h") +(c-system-include "sys/types.h") + +(define-c-struct passwd + predicate: user? + (string pw_name user-name) + (string pw_passwd user-password) + (uid_t pw_uid user-id) + (gid_t pw_gid user-group-id) + (string pw_gecos user-gecos) + (string pw_dir user-home) + (string pw_shell user-shell)) + +(define-c uid_t (current-user-id "getuid") ()) +(define-c gid_t (current-group-id "getgid") ()) +(define-c uid_t (current-effective-user-id "geteuid") ()) +(define-c gid_t (current-effective-group-id "getegid") ()) + +(define-c errno (set-current-user-id! "setuid") (uid_t)) +(define-c errno (set-current-effective-user-id! "seteuid") (uid_t)) +(define-c errno (set-current-group-id! "setgid") (gid_t)) +(define-c errno (set-current-effective-group-id! "setegid") (gid_t)) + +(define-c pid_t (current-session-id "getsid") ((default 0 pid_t))) +(define-c pid_t (create-session "setsid") ()) + +(define-c errno (set-root-directory! "chroot") (string)) + +;; (define-c errno getpwuid_r +;; (uid_t (result passwd) (result (array char arg3)) +;; (value 256 int) (result pointer passwd))) + diff --git a/lib/chibi/term/edit-line.module b/lib/chibi/term/edit-line.module new file mode 100644 index 00000000..d8116473 --- /dev/null +++ b/lib/chibi/term/edit-line.module @@ -0,0 +1,5 @@ + +(define-module (chibi term edit-line) + (export edit-line edit-line-repl) + (import-immutable (scheme) (chibi stty) (srfi 9)) + (include "edit-line.scm")) diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm new file mode 100644 index 00000000..6c63f5d9 --- /dev/null +++ b/lib/chibi/term/edit-line.scm @@ -0,0 +1,492 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; vt100 terminal utilities + +(define (terminal-escape out ch arg) + (write-char (integer->char 27) out) + (write-char #\[ out) + (if arg (display arg out)) + (write-char ch out)) + +;; we use zero-based columns +(define (terminal-goto-col out n) (terminal-escape out #\G (+ n 1))) +(define (terminal-up out n) (terminal-escape out #\A n)) +(define (terminal-down out n) (terminal-escape out #\B n)) +(define (terminal-clear-below out) (terminal-escape out #\J #f)) +(define (terminal-clear-right out) (terminal-escape out #\K #f)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; history + +(define maximum-history-size 128) + +(define-record-type history + (%make-history remaining past future) + history? + (remaining history-remaining history-remaining-set!) + (past history-past history-past-set!) + (future history-future history-future-set!)) + +(define (make-history . o) + (%make-history (if (pair? o) (car o) maximum-history-size) '() '())) + +(define (history-current h) + (let ((p (history-past h))) + (and (pair? p) (car p)))) + +(define (history->list h) + (let ((past (history-past h)) (future (history-future h))) + (if (pair? past) (cons (car past) (append future (cdr past))) future))) + +(define (history-flatten! h) + (history-past-set! h (history->list h)) + (history-future-set! h '())) + +(define (drop-last ls) (reverse (cdr (reverse ls)))) + +(define (history-past-push! h x) + (if (positive? (history-remaining h)) + (history-remaining-set! h (- (history-remaining h) 1)) + (if (pair? (history-past h)) + (history-past-set! h (drop-last (history-past h))) + (history-future-set! h (drop-last (history-future h))))) + (history-past-set! h (cons x (history-past h)))) + +(define (history-insert! h x) + (history-flatten! h) + (history-past-push! h x)) + +(define (history-commit! h x) + (cond + ((pair? (history-future h)) + (history-past-set! + h (cons x (append (drop-last (history-future h)) (history-past h)))) + (history-future-set! h '())) + (else + (history-insert! h x)))) + +(define (history-prev! h) + (let ((past (history-past h))) + (and (pair? past) + (pair? (cdr past)) + (begin + (history-future-set! h (cons (car past) (history-future h))) + (history-past-set! h (cdr past)) + (cadr past))))) + +(define (history-next! h) + (let ((future (history-future h))) + (and (pair? future) + (begin + (history-past-set! h (cons (car future) (history-past h))) + (history-future-set! h (cdr future)) + (car future))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; char and string utils + +(define (char-word-constituent? ch) + (or (char-alphabetic? ch) (char-numeric? ch) + (memv ch '(#\_ #\- #\+ #\:)))) + +(define (char-non-word-constituent? ch) (not (char-word-constituent? ch))) + +(define (string-copy! dst dstart src start end) + (if (>= start dstart) + (do ((i start (+ i 1)) (j dstart (+ j 1))) + ((= i end)) + (string-set! dst j (string-ref src i))) + (do ((i (- end 1) (- i 1)) (j (+ dstart (- end start 1)) (- j 1))) + ((< i start)) + (string-set! dst j (string-ref src i))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; buffers + +(define-record-type buffer + (%make-buffer refresh? min pos row max-row col gap width string history) + buffer? + (refresh? buffer-refresh? buffer-refresh?-set!) + (min buffer-min buffer-min-set!) + (pos buffer-pos buffer-pos-set!) + (row buffer-row buffer-row-set!) + (max-row buffer-max-row buffer-max-row-set!) + (col buffer-col buffer-col-set!) + (gap buffer-gap buffer-gap-set!) + (width buffer-width buffer-width-set!) + (string buffer-string buffer-string-set!) + (history buffer-history buffer-history-set!)) + +(define default-buffer-size 256) +(define default-buffer-width 80) + +(define (make-buffer) + (%make-buffer #f 0 0 0 0 0 default-buffer-size default-buffer-width + (make-string default-buffer-size) '())) + +(define (buffer->string buf) + (let ((str (buffer-string buf))) + (string-append (substring str (buffer-min buf) (buffer-pos buf)) + (substring str (buffer-gap buf) (string-length str))))) + +(define (buffer-right-length buf) + (- (string-length (buffer-string buf)) (buffer-gap buf))) +(define (buffer-length buf) + (+ (buffer-pos buf) (buffer-right-length buf))) +(define (buffer-free-space buf) + (- (buffer-gap buf) (buffer-pos buf))) + +(define (buffer-clamp buf n) + (max (buffer-min buf) (min n (buffer-length buf)))) + +(define (buffer-resize buf n) + (cond ((<= (buffer-free-space buf) n) + (let* ((right-len (buffer-right-length buf)) + (new-len (* 2 (max n (buffer-length buf)))) + (new-gap (- new-len right-len)) + (new (make-string new-len)) + (old (buffer-string buf))) + (string-copy! new 0 old 0 (buffer-pos buf)) + (string-copy! new new-gap old (buffer-gap buf) (string-length old)) + (buffer-string-set! buf new) + (buffer-gap-set! buf new-gap))))) + +(define (buffer-update-position! buf) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (end (string-length (buffer-string buf))) + (width (buffer-width buf))) + (let lp ((i 0) (row 0) (col 0)) ;; update row/col + (cond ((= i pos) + (buffer-row-set! buf row) + (buffer-col-set! buf col) + (lp gap row col)) + ((>= i end) + (buffer-max-row-set! + buf (if (and (zero? col) (> row 0)) (- row 1) row))) + ((= (+ col 1) width) + (lp (+ i 1) (+ row 1) 0)) + (else + (lp (+ i 1) row (+ col 1))))))) + +(define (buffer-draw buf out) + (let* ((gap (buffer-gap buf)) + (str (buffer-string buf)) + (end (string-length str)) + (old-row (buffer-row buf)) + (old-col (buffer-col buf))) + (buffer-update-position! buf) + ;; goto start of input + (terminal-goto-col out 0) + (if (positive? old-row) + (terminal-up out old-row)) + ;; clear and display new buffer + (terminal-clear-below out) + (display (substring str 0 (buffer-pos buf)) out) + (display (substring str (buffer-gap buf) end) out) + ;; move to next line if point at eol + (if (and (zero? (buffer-col buf)) (positive? (buffer-row buf))) + (write-char #\space out)) + ;; move to correct row then col + (if (< (buffer-row buf) (buffer-max-row buf)) + (terminal-up out (- (buffer-max-row buf) (buffer-row buf)))) + (terminal-goto-col out (buffer-col buf)))) + +(define (buffer-refresh buf out) + (cond ((buffer-refresh? buf) + (buffer-draw buf out) + (buffer-refresh?-set! buf #f)))) + +(define (buffer-goto! buf out n) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (n (buffer-clamp buf n))) + (cond ((not (= n pos)) + (buffer-update-position! buf) ;; XXXX shouldn't be needed + (if (< n pos) + (string-copy! str (- gap (- pos n)) str n pos) + (string-copy! str pos str gap (+ gap (- n pos)))) + (buffer-pos-set! buf n) + (buffer-gap-set! buf (+ gap (- n pos))) + (cond + ((not (buffer-refresh? buf)) + (let ((old-row (buffer-row buf))) + (buffer-update-position! buf) + (let ((row-diff (- old-row (buffer-row buf)))) + (cond ((> row-diff 0) (terminal-up out row-diff)) + ((< row-diff 0) (terminal-down out (- row-diff))))) + (terminal-goto-col out (buffer-col buf))))))))) + +(define (buffer-insert! buf out x) + (let ((len (if (char? x) 1 (string-length x))) + (pos (buffer-pos buf))) + (buffer-resize buf len) + (if (char? x) + (string-set! (buffer-string buf) pos x) + (string-copy! (buffer-string buf) pos x 0 len)) + (buffer-pos-set! buf (+ (buffer-pos buf) len)) + (cond + ((buffer-refresh? buf)) + ((and (= (buffer-gap buf) (string-length (buffer-string buf))) + (< (+ (buffer-col buf) len) (buffer-width buf))) + ;; fast path - append to end of buffer w/o wrapping to next line + (display x out) + (buffer-col-set! buf (+ (buffer-col buf) len))) + (else + (buffer-refresh?-set! buf #t))))) + +(define (buffer-delete! buf out start end) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (start (buffer-clamp buf start)) + (end (buffer-clamp buf end))) + (if (not (buffer-refresh? buf)) + (if (and (= start pos) (>= end (buffer-length buf))) + (terminal-clear-below out) + (buffer-refresh?-set! buf #t))) + (cond ((< end pos) + (string-copy! str start str end pos) + (buffer-pos-set! buf (+ start (- pos end)))) + ((> start gap) + (string-copy! str start str gap (+ gap (- end start))) + (buffer-gap-set! buf (+ gap (- end start)))) + (else + (buffer-pos-set! buf (min pos start)) + (buffer-gap-set! buf (max gap (+ pos (- gap pos) (- end pos)))))))) + +(define (buffer-skip buf pred) + (let* ((str (buffer-string buf)) (end (string-length str))) + (let lp ((i (buffer-gap buf))) + (if (or (>= i end) (not (pred (string-ref str i)))) + (+ (- i (buffer-gap buf)) (buffer-pos buf)) + (lp (+ i 1)))))) + +(define (buffer-skip-reverse buf pred) + (let ((str (buffer-string buf))) + (let lp ((i (- (buffer-pos buf) 1))) + (if (or (< i 0) (not (pred (string-ref str i)))) i (lp (- i 1)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; keymaps + +(define keymap? pair?) + +(define (make-keymap . o) + (cons (make-vector 256 #f) (and (pair? o) (car o)))) + +(define (make-sparse-keymap . o) + (cons '() (and (pair? o) (car o)))) + +(define (make-printable-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (do ((i #x20 (+ i 1))) ((= i #x7F) keymap) + (vector-set! v i command/self-insert)))) + +(define (make-standard-escape-bracket-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 65 command/backward-history) + (vector-set! v 66 command/forward-history) + (vector-set! v 67 command/forward-char) + (vector-set! v 68 command/backward-char) + keymap)) + +(define (make-standard-escape-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 8 command/backward-delete-word) + (vector-set! v 91 (make-standard-escape-bracket-keymap)) + (vector-set! v 98 command/backward-word) + (vector-set! v 100 command/forward-delete-word) + (vector-set! v 102 command/forward-word) + (vector-set! v 127 command/backward-delete-word) + keymap)) + +(define (make-standard-keymap) + (let* ((keymap (make-printable-keymap)) + (v (car keymap))) + (vector-set! v 1 command/beggining-of-line) + (vector-set! v 2 command/backward-char) + (vector-set! v 4 command/forward-delete-char) + (vector-set! v 5 command/end-of-line) + (vector-set! v 6 command/forward-char) + (vector-set! v 8 command/backward-delete-char) + (vector-set! v 10 command/enter) + (vector-set! v 11 command/forward-delete-line) + (vector-set! v 12 command/refresh) + (vector-set! v 13 command/enter) + (vector-set! v 21 command/backward-delete-line) + (vector-set! v 27 (make-standard-escape-keymap)) + (vector-set! v 127 command/backward-delete-char) + keymap)) + +(define (keymap-lookup keymap n) + (let ((table (car keymap))) + (or (if (vector? table) + (and (< n (vector-length table)) (vector-ref table n)) + (cond ((assv n table) => cdr) (else #f))) + (if (keymap? (cdr keymap)) + (keymap-lookup (cdr keymap) n) + (cdr keymap))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; commands + +(define (command/self-insert ch buf out return) + (buffer-insert! buf out ch)) + +(define (command/enter ch buf out return) + (command/end-of-line ch buf out return) + (newline out) + (return)) + +(define (command/beep ch buf out return) + (write-char (integer->char 7) out)) + +(define (command/refresh ch buf out return) + (buffer-draw buf out)) + +(define (command/beggining-of-line ch buf out return) + (buffer-goto! buf out 0)) + +(define (command/end-of-line ch buf out return) + (buffer-goto! buf out (buffer-length buf))) + +(define (command/forward-char ch buf out return) + (buffer-goto! buf out (+ (buffer-pos buf) 1))) + +(define (command/backward-char ch buf out return) + (buffer-goto! buf out (- (buffer-pos buf) 1))) + +(define (command/forward-delete-char ch buf out return) + (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1))) + +(define (command/backward-delete-char ch buf out return) + (buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf))) + +(define (command/forward-delete-line ch buf out return) + (buffer-delete! buf out (buffer-pos buf) (buffer-length buf))) + +(define (command/backward-delete-line ch buf out return) + (buffer-delete! buf out 0 (buffer-pos buf))) + +(define (command/backward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-past history))) + (if (null? (history-future history)) + (history-insert! history (buffer->string buf))) + (cond + ((pair? (cdr (history-past history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (buffer-insert! buf out (history-prev! history)))))))) + +(define (command/forward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-future history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (let ((res (buffer-insert! buf out (history-next! history)))) + (if (null? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + res))))) + +(define (command/forward-word ch buf out return) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-goto! buf out (buffer-skip buf char-word-constituent?))) + +(define (command/backward-word ch buf out return) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (buffer-goto! buf out (+ (buffer-skip-reverse buf char-word-constituent?) 1))) + +(define (command/forward-delete-word ch buf out return) + (let ((start (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-delete! buf out start (buffer-skip buf char-word-constituent?)))) + +(define (command/backward-delete-word ch buf out return) + (let ((end (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (let ((start (buffer-skip-reverse buf char-word-constituent?))) + (buffer-delete! buf out (+ start 1) end)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; line-editing + +(define standard-keymap (make-standard-keymap)) + +(define (get-key ls key . o) + (let ((x (memq key ls))) + (if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o))))) + +(define (with-leading-ports ls proc) + (if (and (pair? ls) (input-port? (car ls))) + (if (and (pair? (cdr ls)) (output-port? (cadr ls))) + (proc (car ls) (cadr ls) (cddr ls)) + (proc (car ls) (current-output-port) (cdr ls))) + (proc (current-input-port) (current-output-port) ls))) + +(define (make-line-editor . args) + (let* ((prompt (get-key args 'prompt: "> ")) + (history (get-key args 'history:)) + (terminal-width (get-key args 'terminal-width:)) + (keymap (get-key args 'keymap: standard-keymap))) + (lambda (in out) + (let* ((width (or terminal-width (get-terminal-width out))) + (buf (make-buffer)) + (done? #f) + (return (lambda o (set! done? #t)))) + (buffer-refresh?-set! buf #t) + (buffer-width-set! buf width) + (buffer-insert! buf out prompt) + (buffer-min-set! buf (string-length prompt)) + (buffer-history-set! buf history) + (buffer-refresh buf out) + (flush-output out) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp ((kmap keymap)) + (let ((ch (read-char in))) + (if (eof-object? ch) + (buffer->string buf) + (let ((x (keymap-lookup kmap (char->integer ch)))) + (cond + ((keymap? x) + (lp x)) + ((procedure? x) + (x ch buf out return) + (buffer-refresh buf out) + (if done? (buffer->string buf) (lp keymap))) + (else + ;;(command/beep ch buf out return) + (lp keymap))))))))))))) + +(define (edit-line . args) + (with-leading-ports + args + (lambda (in out rest) ((apply make-line-editor rest) in out)))) + +(define (edit-line-repl . args) + (with-leading-ports + args + (lambda (in out rest) + (let ((eval (get-key rest 'eval: (lambda (x) x))) + (print (get-key rest 'write: write)) + (history (or (get-key rest 'history:) (make-history)))) + (let ((edit-line + (apply make-line-editor 'no-stty?: #t 'history: history rest))) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp () + (let ((line (edit-line in out))) + (if (pair? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + (history-commit! history line) + (print (eval line) out) + (newline out) + (lp)))))))))) diff --git a/lib/chibi/time.module b/lib/chibi/time.module new file mode 100644 index 00000000..8d591100 --- /dev/null +++ b/lib/chibi/time.module @@ -0,0 +1,12 @@ + +(define-module (chibi time) + (export current-seconds get-time-of-day set-time-of-day! + seconds->time seconds->string time->seconds time->string + timeval-seconds timeval-microseconds + timezone-offset timezone-dst-time + time-second time-minute time-hour time-day time-month time-year + time-day-of-week time-day-of-year time-dst? + tm? timeval? timezone?) + (import-immutable (scheme)) + (include-shared "time")) + diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub new file mode 100644 index 00000000..adde486e --- /dev/null +++ b/lib/chibi/time.stub @@ -0,0 +1,46 @@ + +(c-system-include "time.h") +(c-system-include "sys/time.h") + +(define-c-struct tm + predicate: tm? + (int tm_sec time-second) + (int tm_min time-minute) + (int tm_hour time-hour) + (int tm_mday time-day) + (int tm_mon time-month) + (int tm_year time-year) + (int tm_wday time-day-of-week) + (int tm_yday time-day-of-year) + (int tm_isdst time-dst?)) + +(define-c-struct timeval + predicate: timeval? + (time_t tv_sec timeval-seconds) + (int tv_usec timeval-microseconds)) + +(define-c-struct timezone + predicate: timezone? + (int tz_minuteswest timezone-offset) + (int tz_dsttime timezone-dst-time)) + +(define-c time_t (current-seconds "time") ((value NULL))) + +(define-c errno (get-time-of-day "gettimeofday") + ((result timeval) (result timezone))) + +(define-c errno (set-time-of-day! "settimeofday") + (timeval (maybe-null default NULL timezone))) + +(define-c non-null-pointer (seconds->time "localtime_r") + ((pointer time_t) (result tm))) + +(define-c time_t (time->seconds "mktime") + (tm)) + +(define-c non-null-string (seconds->string "ctime_r") + ((pointer time_t) (result (array char 64)))) + +(define-c non-null-string (time->string "asctime_r") + (tm (result (array char 64)))) + diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module new file mode 100644 index 00000000..46f9e6a6 --- /dev/null +++ b/lib/chibi/uri.module @@ -0,0 +1,10 @@ + +(define-module (chibi uri) + (export uri? uri->string make-uri string->uri + uri-scheme uri-user uri-host uri-port uri-path uri-query uri-fragment + uri-with-scheme uri-with-user uri-with-host uri-with-path + uri-with-query uri-with-fragment + uri-encode uri-decode uri-query->alist uri-alist->query) + (import-immutable (scheme) + (srfi 9)) + (include "uri.scm")) diff --git a/lib/chibi/uri.scm b/lib/chibi/uri.scm new file mode 100644 index 00000000..41507961 --- /dev/null +++ b/lib/chibi/uri.scm @@ -0,0 +1,306 @@ +;; uri.scm -- URI parsing library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URI representation + +(define-record-type uri + (%make-uri scheme user host port path query fragment) + uri? + (scheme uri-scheme) + (user uri-user) + (host uri-host) + (port uri-port) + (path uri-path) + (query uri-query) + (fragment uri-fragment)) + +;; (make-uri scheme [user host port path query fragment]) +(define (make-uri scheme . o) + (let* ((user (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (host (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (port (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (path (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (query (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f))) + (%make-uri scheme user host port path query fragment))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils (don't feel like using SRFI-13 and these are more +;; specialised) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (string-scan-right str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i (- end 1))) + (and (>= i start) + (if (eqv? ch (string-ref str i)) + i + (lp (- i 1))))))) + +(define (string-index-of str pred . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond ((>= i end) #f) + ((pred (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase->symbol str) + (let ((len (string-length str))) + (let lp ((i 0)) + (cond + ((= i len) + (string->symbol str)) + ((char-upper-case? (string-ref str i)) + (let ((res (make-string len))) + (do ((j 0 (+ j 1))) + ((= j i)) + (string-set! res j (string-ref str j))) + (string-set! res i (char-downcase (string-ref str i))) + (do ((j (+ i 1) (+ j 1))) + ((= j len)) + (string-set! res j (char-downcase (string-ref str j)))) + (string->symbol res))) + (else + (lp (+ i 1))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; functional updaters (uses as much shared state as possible) + +(define (uri-with-scheme u scheme) + (%make-uri scheme (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-user u user) + (%make-uri (uri-scheme u) user (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-host u host) + (%make-uri (uri-scheme u) (uri-user u) host (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-port u port) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) port + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-path u path) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + path (uri-query u) (uri-fragment u))) + +(define (uri-with-query u query) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) query (uri-fragment u))) + +(define (uri-with-fragment u fragment) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) fragment)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parsing - without :// we just split into scheme & path + +(define (char-uri-scheme-unsafe? ch) + (not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\_ #\-))))) + +(define (string->path-uri scheme str . o) + (define decode? (and (pair? o) (car o))) + (define decode (if decode? uri-decode (lambda (x) x))) + (define decode-query + (if (and (pair? o) (pair? (cdr o)) (cadr o)) + uri-query->alist + decode)) + (if (pair? str) + str + (let* ((len (string-length str)) + (colon0 (string-scan str #\:)) + (colon + (and (not (string-index-of str char-uri-scheme-unsafe? + 0 (or colon0 len))) + colon0))) + (if (or (not colon) (zero? colon)) + (and scheme + (let* ((quest (string-scan str #\? 0)) + (pound (string-scan str #\# (or quest 0)))) + (make-uri scheme #f #f #f + (decode (substring str 0 (or quest pound len))) + (and quest + (decode-query + (substring str (+ quest 1) (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len)))))) + (let ((sc1 (+ colon 1)) + (scheme (string-downcase->symbol (substring str 0 colon)))) + (if (= sc1 len) + (make-uri scheme) + (if (or (>= (+ sc1 1) len) + (not (and (eqv? #\/ (string-ref str sc1)) + (eqv? #\/ (string-ref str (+ sc1 1)))))) + (make-uri scheme #f #f #f (substring str sc1 len)) + (if (>= (+ sc1 2) len) + (make-uri scheme #f "") + (let* ((sc2 (+ sc1 2)) + (slash (string-scan str #\/ sc2)) + (sc3 (or slash len)) + (at (string-scan-right str #\@ sc2 sc3)) + (colon3 (string-scan str #\: (or at sc2) sc3)) + (quest (string-scan str #\? sc3)) + (pound (string-scan str #\# (or quest sc3)))) + (%make-uri + scheme + (and at (decode (substring str sc2 at))) + (decode + (substring str + (if at (+ at 1) sc2) + (or colon3 sc3))) + (and colon3 + (string->number + (substring str (+ colon3 1) sc3))) + (and slash + (decode + (substring str slash (or quest pound len)))) + (and quest + (decode-query + (substring str (+ quest 1) + (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len))) + )))))))))) + +(define (string->uri str . o) + (apply string->path-uri #f str o)) + +(define (uri->string uri . o) + (define encode? (and (pair? o) (car o))) + (define encode (if encode? uri-encode (lambda (x) x))) + (if (string? uri) + uri + (let ((fragment (uri-fragment uri)) + (query (uri-query uri)) + (path (uri-path uri)) + (port (uri-port uri)) + (host (uri-host uri)) + (user (uri-user uri))) + (string-append + (symbol->string (uri-scheme uri)) ":" + (if (or user host port) "//" "") + (if user (encode user) "") (if user "@" "") + (or host "") ; host shouldn't need encoding + (if port ":" "") (if port (number->string port) "") + (if path (encode path) "") + (if query "?" "") + (if (pair? query) (uri-alist->query query) (or query "")) + (if fragment "#" "") (if fragment (encode fragment) ""))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; query encoding and decoding + +(define (uri-safe-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (case ch + ((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t) + (else #f)))) + +(define (collect str from to res) + (if (>= from to) + res + (cons (substring str from to) res))) + +(define (uri-encode str . o) + (define (encode-1-space ch) + (if (eqv? ch #\space) + "+" + (encode-1-normal ch))) + (define (encode-1-normal ch) + (let* ((i (char->integer ch)) + (hex (number->string i 16))) + (if (< i 16) + (string-append "%0" hex) + (string-append "%" hex)))) + (let ((start 0) + (end (string-length str)) + (encode-1 (if (and (pair? o) (car o)) + encode-1-space + encode-1-normal))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (if (uri-safe-char? ch) + (lp from next res) + (lp next next (cons (encode-1 ch) + (collect str from to res))))))))) + +(define (uri-decode str . o) + (let ((space-as-plus? (and (pair? o) (car o))) + (start 0) + (end (string-length str))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (cond + ((eqv? ch #\%) + (if (>= next end) + (lp next next (collect str from to res)) + (let ((next2 (+ next 1))) + (if (>= next2 end) + (lp next2 next2 (collect str from to res)) + (let* ((next3 (+ next2 1)) + (hex (substring str next next3)) + (i (string->number hex 16))) + (lp next3 next3 (cons (string (integer->char i)) + (collect str from to res)))))))) + ((and space-as-plus? (eqv? ch #\+)) + (lp next next (cons " " (collect str from to res)))) + (else + (lp from next res)))))))) + +(define (uri-query->alist str . o) + (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;))) + (let ((len (string-length str)) + (plus? (and (pair? o) (car o)))) + (let lp ((i 0) (res '())) + (if (>= i len) + (reverse res) + (let* ((j (or (string-index-of str split-char? i) len)) + (k (string-scan str #\= i j)) + (cell (if k + (cons (uri-decode (substring str i k) plus?) + (uri-decode (substring str (+ k 1) j) plus?)) + (cons (uri-decode (substring str i j) plus?) #f)))) + (lp (+ j 1) (cons cell res))))))) + +(define (uri-alist->query ls . o) + (define plus? (and (pair? o) (car o))) + (define (encode key val res) + (let ((res (cons (uri-encode key plus?) res))) + (if val (cons (uri-encode val plus?) (cons "=" res)) res))) + (if (null? ls) + "" + (let lp ((x (car ls)) (ls (cdr ls)) (res '())) + (let ((res (encode (car x) (cdr x) res))) + (if (null? ls) + (string-concatenate (reverse res)) + (lp (car ls) (cdr ls) (cons "&" res))))))) diff --git a/lib/config.scm b/lib/config.scm new file mode 100644 index 00000000..be6fb36a --- /dev/null +++ b/lib/config.scm @@ -0,0 +1,177 @@ +;; config.scm -- configuration module +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *this-module* '()) + +(define (make-module exports env meta) (vector exports env meta)) +(define (%module-exports mod) (vector-ref mod 0)) +(define (module-env mod) (vector-ref mod 1)) +(define (module-meta-data mod) (vector-ref mod 2)) +(define (module-env-set! mod env) (vector-set! mod 1 env)) + +(define (module-exports mod) + (or (%module-exports mod) (env-exports (module-env mod)))) + +(define (module-name->strings ls res) + (if (null? ls) + res + (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls))) + ((number? (car ls)) (number->string (car ls))) + ((string? (car ls)) (car ls)) + (else (error "invalid module name" (car ls)))))) + (module-name->strings (cdr ls) (cons "/" (cons str res)))))) + +(define (module-name->file name) + (string-concatenate + (reverse (cons ".module" (cdr (module-name->strings name '())))))) + +(define (module-name-prefix name) + (string-concatenate (reverse (cdr (cdr (module-name->strings name '())))))) + +(define (load-module-definition name) + (let* ((file (module-name->file name)) + (path (find-module-file file))) + (if path (load path *config-env*)))) + +(define (find-module name) + (cond + ((assoc name *modules*) => cdr) + (else + (load-module-definition name) + (cond ((assoc name *modules*) => cdr) + (else #f))))) + +(define (symbol-append a b) + (string->symbol (string-append (symbol->string a) (symbol->string b)))) + +(define (to-id id) (if (pair? id) (car id) id)) +(define (from-id id) (if (pair? id) (cdr id) id)) +(define (id-filter pred ls) + (cond ((null? ls) '()) + ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls)))) + (else (id-filter pred (cdr ls))))) + +(define (resolve-import x) + (cond + ((not (and (pair? x) (list? x))) + (error "invalid module syntax" x)) + ((and (pair? (cdr x)) (pair? (cadr x))) + (if (memq (car x) '(only except rename)) + (let* ((mod-name+imports (resolve-import (cadr x))) + (imp-ids (cdr mod-name+imports)) + (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x)))) + (begin + (set-cdr! mod-name+imports + (module-exports + (find-module (car mod-name+imports)))) + (cdr mod-name+imports)) + imp-ids))) + (cons (car mod-name+imports) + (case (car x) + ((only) + (if (not imp-ids) + (cddr x) + (id-filter (lambda (i) (memq i (cddr x))) imp-ids))) + ((except) + (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids)) + ((rename) + (map (lambda (i) + (let ((rename (assq (to-id i) (cddr x)))) + (if rename (cons (cdr rename) (from-id i)) i))) + imp-ids))))) + (error "invalid import modifier" x))) + ((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x))) + (let ((mod-name+imports (resolve-import (caddr x)))) + (cons (car mod-name+imports) + (map (lambda (i) + (cons (symbol-append (cadr x) (if (pair? i) (car i) i)) + (if (pair? i) (cdr i) i))) + (cdr mod-name+imports))))) + ((find-module x) + => (lambda (mod) (cons x (%module-exports mod)))) + (else + (error "couldn't find import" x)))) + +(define (eval-module name mod) + (let ((env (make-environment)) + (dir (module-name-prefix name))) + (define (load-modules files extension) + (for-each + (lambda (f) + (let ((f (string-append dir f extension))) + (cond ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + files)) + (for-each + (lambda (x) + (case (and (pair? x) (car x)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2 (load-module (car mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports) + (eq? (car x) 'import-immutable)))) + (cdr x))) + ((include) + (load-modules (cdr x) "")) + ((include-shared) + (cond-expand + (dynamic-loading (load-modules (cdr x) *shared-object-extension*)) + (else #f))) + ((body) + (for-each (lambda (expr) (eval expr env)) (cdr x))))) + (module-meta-data mod)) + env)) + +(define (load-module name) + (let ((mod (find-module name))) + (if (and mod (not (module-env mod))) + (module-env-set! mod (eval-module name mod))) + mod)) + +(define-syntax define-module + (er-macro-transformer + (lambda (expr rename compare) + (let ((name (cadr expr)) + (body (cddr expr))) + `(let ((tmp *this-module*)) + (set! *this-module* '()) + ,@body + (set! *this-module* (reverse *this-module*)) + (let ((exports + (cond ((assq 'export *this-module*) => cdr) + (else '())))) + (set! *modules* + (cons (cons ',name (make-module exports #f *this-module*)) + *modules*))) + (set! *this-module* tmp)))))) + +(define-syntax define-config-primitive + (er-macro-transformer + (lambda (expr rename compare) + `(define-syntax ,(cadr expr) + (er-macro-transformer + (lambda (expr rename compare) + `(set! *this-module* (cons ',expr *this-module*)))))))) + +(define-config-primitive import) +(define-config-primitive import-immutable) +(define-config-primitive export) +(define-config-primitive include) +(define-config-primitive include-shared) +(define-config-primitive body) + +(define *modules* + (list (cons '(scheme) (make-module #f (interaction-environment) '())) + (cons '(srfi 0) (make-module (list 'cond-expand) + (interaction-environment) + (list (list 'export 'cond-expand)))) + (cons '(srfi 46) (make-module (list 'syntax-rules) + (interaction-environment) + (list (list 'export 'syntax-rules)))))) + diff --git a/lib/init.scm b/lib/init.scm new file mode 100644 index 00000000..d5191caf --- /dev/null +++ b/lib/init.scm @@ -0,0 +1,875 @@ +;; init.scm -- R5RS library procedures +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; 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 f ls . lol) + (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls))))) + (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f)))) + +(define (any pred ls) + (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f)) + +(define (every pred ls) + (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t)) + +(define (delq x ls) + (if (pair? ls) + (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls)))) + '())) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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) + (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 (rename 'else) (car cl)) + (if (pair? (cddr expr)) + (error "non-final else in cond" expr) + (cons (rename 'begin) (cdr cl))) + (if (if (null? (cdr cl)) #t (compare (rename '=>) (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 + ((compare (rename 'unquote) (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((compare (rename '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))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (compare (rename '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 (null? (cdr expr)) (error "empty let" expr)) + (if (null? (cddr expr)) (error "no let body" expr)) + ((lambda (bindings) + (if (list? bindings) #f (error "bad let bindings")) + (if (every (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + bindings) + ((lambda (vars vals) + (if (identifier? (cadr expr)) + `((,(rename 'lambda) ,vars + (,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,vars + ,@(cdddr expr)))) + (,(cadr expr) ,@vars))) + ,@vals) + `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals))) + (map car bindings) + (map cadr bindings)) + (error "bad let syntax" expr))) + (if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let*" expr)) + (if (null? (cddr expr)) (error "no let* body" expr)) + (if (null? (cadr expr)) + `(,(rename 'let) () ,@(cddr expr)) + (if (if (list? (cadr expr)) + (every + (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + (cadr expr)) + #f) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))) + (error "bad let* syntax")))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare (rename '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)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; promises + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exceptions + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f))) + +(define (with-exception-handler handler thunk) + (letrec ((orig-handler (current-exception-handler)) + (self (lambda (exn) + (current-exception-handler orig-handler) + (let ((res (handler exn))) + (current-exception-handler self) + res)))) + (current-exception-handler self) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; library functions + +;; 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 . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (and (pair? ls) (if (eq obj (car ls)) ls (lp (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 (if (bignum? x) #t (flonum? x)))) +(define complex? number?) +(define rational? number?) +(define real? number?) +(define (exact? x) (if (fixnum? x) #t (bignum? x))) +(define inexact? flonum?) +(define (integer? x) + (if (fixnum? x) #t (if (bignum? 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 (numerator x) + (if (integer? x) x (numerator (* x 10)))) +(define (denominator x) + (if (exact? x) + 1 + (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10)))))) + +(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) + (if (<= n 9) + (integer->char (+ n (char->integer #\0))) + (integer->char (+ (- n 10) (char->integer #\A))))) +(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)) 55)))) + +(define (number->string num . o) + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-output-string (lambda (out) (write num out))) + (let lp ((n (abs num)) (d (car o)) (res '())) + (if (> n 0) + (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) + (if (null? res) + "0" + (list->string (if (negative? num) (cons #\- 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 (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-output-port)) + (tmp-out (open-output-file file))) + (current-output-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)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dynamic-wind + +(define *dk* (list #f)) + +(define (dynamic-wind before thunk after) + (let ((dk *dk*)) + (set-dk! (cons (cons before after) dk)) + (let ((res (thunk))) (set-dk! dk) res))) + +(define (set-dk! dk) + (if (not (eq? dk *dk*)) + (begin + (set-dk! (cdr dk)) + (let ((before (car (car dk))) (dk dk)) + (set-car! *dk* (cons (cdr (car dk)) before)) + (set-cdr! *dk* dk) + (set-car! dk #f) + (set-cdr! dk '()) + (set! *dk* dk) + (before))))) + +(define (call-with-current-continuation proc) + (let ((dk *dk*)) + (%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((ellipse-specified? (identifier? (cadr 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 'syntax-quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_len (rename'len)) (_length (rename 'length)) + (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error)) + (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define ellipse (rename (if ellipse-specified? (cadr expr) '...))) + (define lits (if ellipse-specified? (caddr expr) (cadr expr))) + (define forms (if ellipse-specified? (cdddr expr) (cddr expr))) + (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))) + (cond + ((not (list? (cddr p))) + (error "dotted ellipse" p)) + ((any (lambda (x) (and (identifier? x) (compare x ellipse))) + (cddr p)) + (error "multiple ellipses" p)) + (else + (let ((len (length (cdr (cdr p))))) + `(,_let ((,_len (,_length ,v))) + (,_and (,_>= ,_len ,len) + (,_let ,_lp ((,_ls ,v) + (,_i (,_- ,_len ,len)) + (,_res (,_quote ()))) + (,_if (,_>= 0 ,_i) + ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p))) + `(,_append ,_ls (,_reverse ,_res)) + dim + vars + k) + (,_lp (,_cdr ,_ls) + (,_- ,_i 1) + (,_cons (,_car ,_ls) ,_res)))))))))) + ((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-escape? x) (and (pair? x) (compare ellipse (car x)))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare ellipse (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 (any (lambda (lit) (compare x lit)) 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 + ((any (lambda (v) (compare t (car v))) vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (cond + ((ellipse-escape? t) + (if (pair? (cdr t)) + (if (pair? (cddr t)) (cddr t) (cadr t)) + (cdr t))) + ((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))))))) + (else (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 for" + (list (rename 'strip-syntactic-closures) _expr))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *config-env* #f) + +(define-syntax import + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (res '())) + (cond + ((null? ls) + (cons 'begin (reverse res))) + (else + (let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*))) + (if (pair? mod+imps) + (lp (cdr ls) + (cons `(%env-copy! + #f + (vector-ref + (eval '(load-module ',(car mod+imps)) *config-env*) + 1) + ',(cdr mod+imps) + #f) + res)) + (error "couldn't find module" (car ls)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SRFI-0 + +(define-syntax cond-expand + (er-macro-transformer + (lambda (expr rename compare) + (define (check x) + (if (pair? x) + (case (car x) + ((and) (every check (cdr x))) + ((or) (any check (cdr x))) + ((not) (not (check (cadr x)))) + (else (error "cond-expand: bad feature" x))) + (memq (identifier->symbol x) *features*))) + (let expand ((ls (cdr expr))) + (cond ((null? ls) (error "cond-expand: no expansions" expr)) + ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) + ((eq? 'else (identifier->symbol (caar ls))) + (if (pair? (cdr ls)) + (error "cond-expand: else in non-final position") + `(,(rename 'begin) ,@(cdar ls)))) + ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) + (else (expand (cdr ls)))))))) + diff --git a/lib/srfi/1.module b/lib/srfi/1.module new file mode 100644 index 00000000..3d3da044 --- /dev/null +++ b/lib/srfi/1.module @@ -0,0 +1,31 @@ + +(define-module (srfi 1) + (export + xcons cons* make-list list-tabulate list-copy circular-list iota + proper-list? circular-list? dotted-list? not-pair? null-list? list= + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr take drop take-right drop-right take! drop-right! split-at split-at! + last last-pair length+ concatenate append! concatenate! reverse! + append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 count + fold unfold pair-fold reduce fold-right unfold-right + pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter partition remove filter! partition! remove! find find-tail any every + list-index take-while drop-while take-while! span break span! break! + delete delete-duplicates delete! delete-duplicates! + alist-cons alist-copy alist-delete alist-delete! + lset<= lset= lset-adjoin lset-union lset-union! lset-intersection + lset-intersection! lset-difference lset-difference! lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection!) + (import (scheme)) + (include "1/predicates.scm" + "1/selectors.scm" + "1/search.scm" + "1/misc.scm" + "1/constructors.scm" + "1/fold.scm" + "1/deletion.scm" + "1/alists.scm" + "1/lset.scm")) + diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm new file mode 100644 index 00000000..a35db42c --- /dev/null +++ b/lib/srfi/1/alists.scm @@ -0,0 +1,14 @@ +;; alist.scm -- association list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (alist-cons key value ls) (cons (cons key value) ls)) + +(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls)) + +(define (alist-delete key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (remove (lambda (x) (eq (car x) key)) ls))) + +(define alist-delete! alist-delete) + diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm new file mode 100644 index 00000000..1f8a8d5e --- /dev/null +++ b/lib/srfi/1/constructors.scm @@ -0,0 +1,36 @@ +;; constructors.scm -- list construction utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (xcons a b) (cons b a)) + +(define (cons* x . args) + (let lp ((rev '()) (x x) (ls args)) + (if (null? ls) + (append-reverse rev x) + (lp (cons x rev) (car ls) (cdr ls))))) + +(define (make-list n . o) + (let ((default (if (pair? o) (car o)))) + (let lp ((n n) (res '())) + (if (<= n 0) res (lp (- n 1) (cons default res)))))) + +(define (list-tabulate n proc) + (let lp ((n n) (res '())) + (if (< n 0) res (lp (- n 1) (cons (proc n) res))))) + +(define (list-copy ls) (reverse! (reverse ls))) + +(define (circular-list x . args) + (let ((res (cons x args))) + (set-cdr! (last-pair res) res) + res)) + +(define (iota count . o) + (let ((start (if (pair? o) (car o) 0)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) + (let lp ((i count) (n (+ start (* (- count 1) step))) (res '())) + (if (<= i 0) + res + (lp (- i 1) (- n step) (cons n res)))))) + diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm new file mode 100644 index 00000000..70ee5cc5 --- /dev/null +++ b/lib/srfi/1/deletion.scm @@ -0,0 +1,25 @@ +;; deletion.scm -- list deletion utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (delete x ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (if (eq? eq eq?) + (let lp ((ls ls) (rev '())) ;; fast path for delq + (let ((tail (memq x ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls)))) + (filter (lambda (y) (eq x y)) ls)))) + +(define delete! delete) + +(define (delete-duplicates ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res))) + (reverse! res))))) + +(define delete-duplicates! delete-duplicates) + diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm new file mode 100644 index 00000000..892b075c --- /dev/null +++ b/lib/srfi/1/fold.scm @@ -0,0 +1,115 @@ +;; fold.scm -- list fold/reduce utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (map-onto car lists (list acc)))) + acc)))) + +(define (fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (map-onto car lists (lp (map cdr lists)))) + knil)))) + +(define (pair-fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (append lists (list acc)))) + acc)))) + +(define (pair-fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (append lists (lp (map cdr lists)))) + knil)))) + +(define (reduce f identity ls) + (if (null? ls) identity (fold f (car ls) (cdr ls)))) + +(define (reduce-right f identity ls) + (if (null? ls) identity (fold-right f (car ls) (cdr ls)))) + +(define (unfold p f g seed . o) + (let lp ((seed seed)) + (if (p seed) + (if (pair? o) ((car o) seed) '()) + (cons (f seed) (lp (g seed)))))) + +(define (unfold-right p f g seed . o) + (let lp ((seed seed) (res (if (pair? o) (car o) '()))) + (if (p seed) res (lp (g seed) (cons (f seed) res))))) + +(define (append-map-helper append f ls lists) + (if (null? lists) + (if (null? ls) + '() + (let ((rev-ls (reverse ls))) + (let lp ((ls (cdr rev-ls)) (res (car rev-ls))) + (if (null? ls) res (lp (cdr ls) (append (f (car ls) res)))) + ))) + (if (and (pair? ls) (every pair? lists)) + (let lp ((lists (cons ls lists))) + (let ((vals (apply f (map car lists))) + (cdrs (map cdr lists))) + (if (every pair? cdrs) (append vals (lp cdrs)) vals))) + '()))) + +(define (append-map f ls . lists) + (append-map-helper append f ls lists)) + +(define (append-map! f ls . lists) + (append-map-helper append! f ls lists)) + +(define map! map) +(define map-in-order map) + +(define (pair-for-each f ls . lists) + (apply pair-fold (lambda (x _) (f x)) ls lists)) + +(define (filter-map f ls . lists) + (if (null? lists) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res))) + (reverse! res))) + (filter (lambda (x) x) (apply map f ls lists)))) + +(define (take-up-to-reverse from to init) + (if (eq? from to) + init + (take-up-to-reverse (cdr from) to (cons (car from) init)))) + +(define (remove pred ls) + (let lp ((ls ls) (rev '())) + (let ((tail (find-tail pred ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls))))) + +(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls)) + +(define (partition pred ls) + (let lp ((ls ls) (good '()) (bad '())) + (cond ((null? ls) (values (reverse! good) (reverse! bad))) + ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad)) + (else (lp (cdr ls) good (cons (car ls) bad)))))) + +(define filter! filter) +(define remove! remove) +(define partition! partition) + diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm new file mode 100644 index 00000000..8565fac3 --- /dev/null +++ b/lib/srfi/1/lset.scm @@ -0,0 +1,51 @@ +;; lset.scm -- list set library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (lset<= eq . sets) + (if (null? sets) + #t + (let lp1 ((set1 (car sets)) (sets (cdr sets))) + (if (null? sets) + #t + (let ((set2 (car sets))) + (let lp2 ((ls set1)) + (if (pair? ls) + (and (member (car set1) set2 eq) (lp2 (cdr ls))) + (lp1 set2 (cdr sets))))))))) + +(define (lset= eq . sets) + (and (apply lset<= eq sets) (apply lset<= eq (reverse sets)))) + +(define (lset-adjoin eq set . elts) + (lset-union2 eq elts set)) + +(define (lset-union2 eq a b) + (if (null? b) + a + (lset-union2 eq (if (member (car b) a eq) a (cons (car b) a)) (cdr b)))) + +(define (lset-union eq . sets) + (reduce (lambda (a b) (lset-union2 eq a b)) '() sets)) + +(define (lset-intersection eq . sets) + (reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-difference eq . sets) + (reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-xor eq . sets) + (reduce (lambda (a b) + (append (filter (lambda (x) (member x b eq)) a) + (filter (lambda (x) (member x a eq)) b))) + '() + sets)) + +(define (lset-diff+intersection eq . sets) + (values (apply lset-difference eq sets) (apply lset-intersection eq sets))) + +(define lset-diff+intersection! lset-diff+intersection) +(define lset-xor! lset-xor) +(define lset-difference! lset-difference) +(define lset-intersection! lset-intersection) +(define lset-union! lset-union) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm new file mode 100644 index 00000000..1e7568df --- /dev/null +++ b/lib/srfi/1/misc.scm @@ -0,0 +1,54 @@ +;; misc.scm -- miscellaneous list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (map-onto proc ls init) + (let lp ((ls ls) (res init)) + (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res))))) + +(define (append! . lists) (concatenate! lists)) + +(define (concatenate lists) + (let lp ((ls (reverse lists)) (res '())) + (if (null? ls) res (lp (cdr ls) (append (car ls) res))))) + +(define (concatenate! lists) + (if (null? lists) + '() + (let lp ((ls lists)) + (cond ((not (pair? (cdr ls))) + lists) + (else + (set-cdr! (last-pair (car ls)) (cadr ls)) + (lp (cdr ls))))))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define (append-reverse! rev tail) + (if (null? rev) + tail + (let ((head (reverse! rev))) + (set-cdr! rev tail) + head))) + +(define (zip . lists) (apply map list lists)) + +(define (unzip1 ls) (map car ls)) +(define (unzip2 ls) (values (map car ls) (map cadr ls))) +(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls))) +(define (unzip4 ls) + (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) +(define (unzip5 ls) + (values (map car ls) (map cadr ls) (map caddr ls) + (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls))) + +(define (count pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (res 0)) + (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res)) + (let lp ((lists (cons ls lists)) (res 0)) + (if (every pair? lists) + (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res)) + res)))) + diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm new file mode 100644 index 00000000..be84e085 --- /dev/null +++ b/lib/srfi/1/predicates.scm @@ -0,0 +1,42 @@ +;; predicates.scm -- list prediates +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (proper-list? x) + (cond ((null? x) #t) + ((pair? x) (proper-list? (cdr x))) + (else #f))) + +(define (circular-list? x) + (and (pair? x) (pair? (cdr x)) + (let race ((hare (cdr x)) (tortoise x)) + (or (eq? hare tortoise) + (and (pair? hare) (pair? (cdr hare)) + (race (cddr hare) (cdr tortoise))))))) + +(define (dotted-list? x) + (not (proper-list? x))) + +(define (not-pair? x) (not (pair? x))) + +(define (null-list? x) (null? x)) ; no error + +(define (list= eq . lists) + (let lp1 ((lists lists)) + (or (null? lists) + (null? (cdr lists)) + (let lp2 ((ls1 (car lists)) (ls2 (cadr lists))) + (if (null? ls1) + (and (null? ls2) + (lp1 (cdr lists))) + (and (eq (car ls1) (car ls2)) + (lp2 (cdr ls1) (cdr ls2)))))))) + +(define (length+ x) + (if (not (pair? x)) + 0 + (let lp ((hare (cdr x)) (tortoise x) (res 0)) + (and (not (eq? hare tortoise)) + (if (pair? hare) + (lp (cddr hare) (cdr tortoise) (+ res 1)) + res))))) diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm new file mode 100644 index 00000000..ea31d931 --- /dev/null +++ b/lib/srfi/1/search.scm @@ -0,0 +1,54 @@ +;; search.scm -- list searching and splitting +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (find pred ls) + (cond ((find-tail pred ls) => car) (else #f))) + +(define (find-tail pred ls) + (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls))))) + +(define (take-while pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (reverse! res)))) + +(define take-while! take-while) + +(define (drop-while pred ls) + (or (find-tail (lambda (x) (not (pred x))) ls) '())) + +(define (span pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (values (reverse! res) ls)))) + +(define span! span) + +(define (break pred ls) (span (lambda (x) (not (pred x))) ls)) + +(define break! break) + +(define (any pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls))))) + (let lp ((lists (cons ls lists))) + (and (every pair? lists) + (let ((args (map car lists))) + (if (apply pred args) args (lp (map cdr lists)))))))) + +(define (every pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t)) + (not (apply any (lambda (x) (not (pred x))) ls lists)))) + +(define (list-index pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (n 0)) + (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1))))) + (let lp ((lists (cons ls lists)) (n 0)) + (and (every pair? lists) + (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1))) + )))) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm new file mode 100644 index 00000000..74ef7119 --- /dev/null +++ b/lib/srfi/1/selectors.scm @@ -0,0 +1,59 @@ +;; selectors.scm -- extended list selectors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth ls) (car (cdr (cdr (cdr (cdr ls)))))) +(define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls))))))) +(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (eighth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (ninth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))) +(define (tenth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))) + +(define (car+cdr x) (values (car x) (cdr x))) + +(define (take ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (reverse! res) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (take! ls i) + (if (<= i 0) + '() + (let ((tail (list-tail ls (- i 1)))) + (set-cdr! tail '()) + ls))) + +(define (drop ls i) + (if (<= i 0) ls (drop (cdr ls) (- i 1)))) + +(define (take-right ls i) + (drop ls (- (length+ ls) i))) + +(define (drop-right ls i) + (take ls (- (length+ ls) i))) + +(define (drop-right! ls i) + (take! ls (- (length+ ls) i))) + +(define (split-at ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (values (reverse! res) ls) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (split-at! ls i) + (if (<= i 0) + (values '() ls) + (let* ((tail (list-tail ls (- i 1))) + (right (cdr tail))) + (set-cdr! tail '()) + (values ls right)))) + +(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls)))) +(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls)))) + diff --git a/lib/srfi/11.module b/lib/srfi/11.module new file mode 100644 index 00000000..f3c91df8 --- /dev/null +++ b/lib/srfi/11.module @@ -0,0 +1,28 @@ + +(define-module (srfi 11) + (export let-values let*-values) + (import-immutable (scheme)) + (body + (define-syntax let*-values + (syntax-rules () + ((let*-values () . body) + (begin . body)) + ((let*-values (((a) expr) . rest) . body) + (let ((a expr)) (let*-values rest . body))) + ((let*-values ((params expr) . rest) . body) + (call-with-values (lambda () expr) + (lambda params (let*-values rest . body)))))) + (define-syntax let-values + (syntax-rules () + ((let-values ("step") (binds ...) bind expr maps () () . body) + (let*-values (binds ... (bind expr)) (let maps . body))) + ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body) + (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body) + (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body) + (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body)) + ((let-values ((params expr) . rest) . body) + (let-values ("step") () () expr () params rest . body)) + )))) + diff --git a/lib/srfi/16.module b/lib/srfi/16.module new file mode 100644 index 00000000..f931a376 --- /dev/null +++ b/lib/srfi/16.module @@ -0,0 +1,24 @@ + +(define-module (srfi 16) + (export case-lambda) + (import-immutable (scheme)) + (body + (define-syntax %case + (syntax-rules () + ((%case args len n p ((params ...) . body) . rest) + (if (= len (length '(params ...))) + (apply (lambda (params ...) . body) args) + (%case args len 0 () . rest))) + ((%case args len n (p ...) ((x . y) . body) . rest) + (%case args len (+ n 1) (p ... x) (y . body) . rest)) + ((%case args len n (p ...) (y . body) . rest) + (if (>= len n) + (apply (lambda (p ... y) . body) args) + (%case args len 0 () . rest))) + ((%case args len n p) + (error "case-lambda: no cases matched")))) + (define-syntax case-lambda + (syntax-rules () + ((case-lambda . clauses) + (lambda args (let ((len (length args))) (%case args len 0 () . clauses)))))))) + diff --git a/lib/srfi/2.module b/lib/srfi/2.module new file mode 100644 index 00000000..4ceb8b6b --- /dev/null +++ b/lib/srfi/2.module @@ -0,0 +1,16 @@ + +(define-module (srfi 2) + (export and-let*) + (import-immutable (scheme)) + (body + (define-syntax and-let* + (syntax-rules () + ((and-let* () . body) + (begin . body)) + ((and-let* ((var expr) . rest) . body) + (let ((var expr)) + (and var (and-let* rest . body)))) + ((and-let* ((expr) . rest) . body) + (let ((tmp expr)) + (and tmp (and-let* rest . body)))))))) + diff --git a/lib/srfi/26.module b/lib/srfi/26.module new file mode 100644 index 00000000..f97ab783 --- /dev/null +++ b/lib/srfi/26.module @@ -0,0 +1,24 @@ + +(define-module (srfi 26) + (export cut cute) + (import-immutable (scheme)) + (body + (define-syntax %cut + (syntax-rules (<> <...>) + ((%cut e? params args) + (lambda params args)) + ((%cut e? (params ...) (args ...) <> . rest) + (%cut e? (params ... tmp) (args ... tmp) . rest)) + ((%cut e? (params ...) (args ...) <...>) + (%cut e? (params ... . tmp) (apply args ... tmp))) + ((%cut e? (params ...) (args ...) <...> . rest) + (error "cut: non-terminal <...>")) + ((%cut #t (params ...) (args ...) x . rest) + (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest))) + ((%cut #f (params ...) (args ...) x . rest) + (%cut #t (params ...) (args ... x) . rest)))) + (define-syntax cut + (syntax-rules () ((cut args ...) (%cut #f () () args ...)))) + (define-syntax cute + (syntax-rules () ((cute args ...) (%cut #t () () args ...)))))) + diff --git a/lib/srfi/27.module b/lib/srfi/27.module new file mode 100644 index 00000000..5c451629 --- /dev/null +++ b/lib/srfi/27.module @@ -0,0 +1,11 @@ + +(define-module (srfi 27) + (export random-integer random-real default-random-source + make-random-source random-source? + random-source-state-ref random-source-state-set! + random-source-randomize! random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals) + (import-immutable (scheme)) + (include-shared "27/rand") + (include "27/constructors.scm")) + diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm new file mode 100644 index 00000000..dbd0a8c6 --- /dev/null +++ b/lib/srfi/27/constructors.scm @@ -0,0 +1,10 @@ +;; constructors.scm -- random function constructors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (random-source-make-integers rs) + (lambda (n) (%random-integer rs n))) + +(define (random-source-make-reals rs . o) + (lambda () (%random-real rs))) + diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c new file mode 100644 index 00000000..d70f8726 --- /dev/null +++ b/lib/srfi/27/rand.c @@ -0,0 +1,204 @@ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include + +#define SEXP_RANDOM_STATE_SIZE 128 + +#define ZERO sexp_make_fixnum(0) +#define ONE sexp_make_fixnum(1) +#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE) + +#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id) + +#define sexp_random_init(x, seed) \ + initstate_r(seed, \ + sexp_string_data(sexp_random_state(x)), \ + SEXP_RANDOM_STATE_SIZE, \ + sexp_random_data(x)) + +#if SEXP_BSD +typedef unsigned int sexp_random_t; +#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs))) +#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n) +#else +typedef struct random_data sexp_random_t; +#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst) +#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs)) +#endif + +#define sexp_random_state(x) (sexp_slot_ref((x), 0)) +#define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1))) + +#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp)) + +static sexp_uint_t rs_type_id; +static sexp default_random_source; + +static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, sexp bound) { + sexp res; + int32_t m; +#if SEXP_USE_BIGNUMS + int32_t hi, mod, len, i, *data; +#endif + if (! sexp_random_source_p(rs)) + res = sexp_type_exception(ctx, self, rs_type_id, rs); + if (sexp_fixnump(bound)) { + sexp_call_random(rs, m); + res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(bound)) { + hi = sexp_bignum_hi(bound); + len = hi * sizeof(sexp_uint_t) / sizeof(int32_t); + res = sexp_make_bignum(ctx, hi); + data = (int32_t*) sexp_bignum_data(res); + for (i=0; i +#include + +#if SEXP_USE_BIGNUMS +#include +#else +#define sexp_bignum_normalize(x) x +#endif + +static sexp sexp_bit_and (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { + sexp res; +#if SEXP_USE_BIGNUMS + sexp_sint_t len, i; +#endif + if (sexp_fixnump(x)) { + if (sexp_fixnump(y)) + res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(y)) + res = sexp_bit_and(ctx sexp_api_pass(self, n), y, x); +#endif + else + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + if (sexp_fixnump(y)) { + res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); + } else if (sexp_bignump(y)) { + if (sexp_bignum_length(x) < sexp_bignum_length(y)) + res = sexp_copy_bignum(ctx, NULL, x, 0); + else + res = sexp_copy_bignum(ctx, NULL, y, 0); + for (i=0, len=sexp_bignum_length(res); i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i> -c); + } else { + tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c; +#if SEXP_USE_BIGNUMS + if (((tmp >> c) == sexp_unbox_fixnum(i)) + && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) { +#endif + res = sexp_make_fixnum(tmp); +#if SEXP_USE_BIGNUMS + } else { + sexp_gc_preserve1(ctx, res); + res = sexp_fixnum_to_bignum(ctx, i); + res = sexp_arithmetic_shift(ctx sexp_api_pass(self, n), res, count); + sexp_gc_release1(ctx); + } +#endif + } +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(i)) { + len = sexp_bignum_hi(i); + if (c < 0) { + c = -c; + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + if (len < offset) { + res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1); + } else { + res = sexp_make_bignum(ctx, len - offset + 1); + for (j=len-offset, tmp=0; j>=0; j--) { + sexp_bignum_data(res)[j] + = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp; + tmp = sexp_bignum_data(i)[j+offset] + << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + } + } else { + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + res = sexp_make_bignum(ctx, len + offset + 1); + for (j=tmp=0; j> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + sexp_bignum_data(res)[len+offset] = tmp; + } +#endif + } else { + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + } + return sexp_bignum_normalize(res); +} + +/* bit-count and integer-length were adapted from: */ +/* http://graphics.stanford.edu/~seander/bithacks.html */ +static sexp_uint_t bit_count (sexp_uint_t i) { + i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3); + i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3) + + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3)); + i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15; + return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255)) + >> (sizeof(i) - 1) * CHAR_BIT); +} + +static sexp sexp_bit_count (sexp ctx sexp_api_params(self, n), sexp x) { + sexp res; + sexp_sint_t i; +#if SEXP_USE_BIGNUMS + sexp_uint_t count; +#endif + if (sexp_fixnump(x)) { + i = sexp_unbox_fixnum(x); + res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + for (i=count=0; i> 32)) + return integer_log2(tt) + 32; + else +#endif + if ((tt = x >> 16)) + return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt]; + else + return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; +} + +static sexp sexp_integer_length (sexp ctx sexp_api_params(self, n), sexp x) { + sexp_sint_t tmp; +#if SEXP_USE_BIGNUMS + sexp_sint_t hi; +#endif + if (sexp_fixnump(x)) { + tmp = sexp_unbox_fixnum(x); + return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + hi = sexp_bignum_hi(x); + return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi]) + + hi*sizeof(sexp_uint_t)); +#endif + } else { + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + } +} + +static sexp sexp_bit_set_p (sexp ctx sexp_api_params(self, n), sexp i, sexp x) { +#if SEXP_USE_BIGNUMS + sexp_uint_t pos; +#endif + if (! sexp_fixnump(i)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + if (sexp_fixnump(x)) { + return sexp_make_boolean(sexp_unbox_fixnum(x) & (1<hash-table + hash-table-equivalence-function hash-table-hash-function + hash-table-ref hash-table-ref/default hash-table-set! + hash-table-delete! hash-table-exists? + hash-table-update! hash-table-update!/default + hash-table-size hash-table-keys hash-table-values + hash-table-walk hash-table-fold hash-table->alist + hash-table-copy hash-table-merge! + hash string-hash string-ci-hash hash-by-identity) + (import-immutable (scheme) + (srfi 9)) + (include-shared "69/hash") + (include "69/type.scm" "69/interface.scm")) + diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c new file mode 100644 index 00000000..e739ff1c --- /dev/null +++ b/lib/srfi/69/hash.c @@ -0,0 +1,242 @@ +/* hash.c -- type-general hashing */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define HASH_DEPTH 5 +#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM) + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0) +#define sexp_hash_table_size(x) sexp_slot_ref(x, 1) +#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2) +#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3) + +#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2)) + +static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc % bound; +} + +static sexp sexp_string_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); + return sexp_make_fixnum(string_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= tolower(*str++);} + return acc % bound; +} + +static sexp sexp_string_ci_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); + return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) { + sexp_uint_t acc = FNV_OFFSET_BASIS, size; + sexp_sint_t i, len; + sexp t, *p; + char *p0; + loop: +#if SEXP_USE_FLONUMS + if (sexp_flonump(obj)) + acc ^= (sexp_sint_t) sexp_flonum_value(obj); + else +#endif + if (sexp_pointerp(obj)) { + if (depth) { + t = sexp_object_type(ctx, obj); + p = (sexp*) (((char*)obj) + sexp_type_field_base(t)); + p0 = ((char*)obj) + offsetof(struct sexp_struct, value); + if ((sexp)p == obj) p=(sexp*)p0; + /* hash trailing non-object data */ + size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp)); + if (((char*)obj + size) > p0) + for (i=0; i 0) { + depth--; + for (i=0; ialist table) + (hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '())) + +(define (hash-table-keys table) + (hash-table-fold table (lambda (k v a) (cons k a)) '())) + +(define (hash-table-values table) + (hash-table-fold table (lambda (k v a) (cons v a)) '())) + +(define (alist->hash-table ls . o) + (let ((res (apply make-hash-table o))) + (for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls) + res)) + +(define (hash-table-merge! a b) + (hash-table-walk b (lambda (k v) (hash-table-set! a k v))) + a) + +(define (hash-table-copy table) + (assert-hash-table "hash-table-copy" table) + (let ((res (make-hash-table (hash-table-equivalence-function table)))) + (hash-table-merge! res table) + res)) + diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm new file mode 100644 index 00000000..1fca9953 --- /dev/null +++ b/lib/srfi/69/type.scm @@ -0,0 +1,12 @@ +;; types.scm -- the hash-table record type +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type hash-table + (%make-hash-table buckets size hash-fn eq-fn) + hash-table? + (buckets hash-table-buckets hash-table-buckets-set!) + (size hash-table-size hash-table-size-set!) + (hash-fn %hash-table-hash-function) + (eq-fn %hash-table-equivalence-function)) + diff --git a/lib/srfi/8.module b/lib/srfi/8.module new file mode 100644 index 00000000..64a3e6e2 --- /dev/null +++ b/lib/srfi/8.module @@ -0,0 +1,10 @@ + +(define-module (srfi 8) + (export receive) + (import-immutable (scheme)) + (body + (define-syntax receive + (syntax-rules () + ((receive params expr . body) + (call-with-values (lambda () expr) (lambda params . body))))))) + diff --git a/lib/srfi/9.module b/lib/srfi/9.module new file mode 100644 index 00000000..1c9aad91 --- /dev/null +++ b/lib/srfi/9.module @@ -0,0 +1,85 @@ + +(define-module (srfi 9) + (export define-record-type) + (import-immutable (scheme)) + (body + (define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((name (cadr expr)) + (name-str (symbol->string (identifier->symbol name))) + (make (caaddr expr)) + (make-fields (cdaddr expr)) + (pred (cadddr expr)) + (fields (cddddr expr)) + (num-fields (length fields)) + (index (register-simple-type name-str num-fields)) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let))) + (define (index-of field ls) + (let lp ((ls ls) (i 0)) + (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) + `(,(rename 'begin) + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string (identifier->symbol pred)) + ,index)) + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string + (identifier->symbol (cadar ls))) + ,index + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string + (identifier->symbol (caddar ls))) + ,index + ,i)) + res) + res))))) + (,_define ,make + ,(let lp ((ls make-fields) (sets '()) (set-defs '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string (identifier->symbol make)) + ,index)) + ,@set-defs) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets) + set-defs)) + (else + (let* ((setter-name + (string-append "%" name-str "-" + (symbol->string (car ls)) "-set!")) + (setter (rename (string->symbol setter-name))) + (i (index-of (car ls) fields))) + (lp (cdr ls) + (cons (list setter 'res (car ls)) sets) + (cons (list setter + (list (rename 'make-setter) + setter-name + index + (index-of (car ls) fields))) + set-defs))))))))))))))))) + diff --git a/lib/srfi/95.module b/lib/srfi/95.module new file mode 100644 index 00000000..43bab9dd --- /dev/null +++ b/lib/srfi/95.module @@ -0,0 +1,7 @@ + +(define-module (srfi 95) + (export sorted? merge merge! sort sort! object-cmp) + (import-immutable (scheme)) + (include-shared "95/qsort") + (include "95/sort.scm")) + diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c new file mode 100644 index 00000000..4b5d36aa --- /dev/null +++ b/lib/srfi/95/qsort.c @@ -0,0 +1,228 @@ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#if SEXP_USE_HUFF_SYMS +#include "../../../opt/sexp-hufftabs.c" +#endif + +#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var) + +static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) { + sexp_sint_t i; + sexp ls, *data=sexp_vector_data(vec); + for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls)) + sexp_car(ls) = data[i]; + return seq; +} + +static sexp sexp_vector_nreverse (sexp ctx, sexp vec) { + int i, j; + sexp tmp, *data=sexp_vector_data(vec); + for (i=0, j=sexp_vector_length(vec)-1; i>3, d = ((sexp_uint_t)b)>>3; + while (c && d) { +#include "../../../opt/sexp-unhuff.c" +#define c d +#define res res2 +#include "../../../opt/sexp-unhuff.c" +#undef c +#undef res + if ((tmp=res-res2) != 0) + return tmp; + } + return c ? 1 : d ? -1 : 0; +} +#endif + +static int sexp_object_compare (sexp ctx, sexp a, sexp b) { + int res; + if (a == b) + return 0; + if (sexp_pointerp(a)) { + if (sexp_pointerp(b)) { + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) { + res = sexp_pointer_tag(a) - sexp_pointer_tag(b); + } else { + switch (sexp_pointer_tag(a)) { + case SEXP_FLONUM: + res = sexp_flonum_value(a) - sexp_flonum_value(b); + break; + case SEXP_BIGNUM: + res = sexp_bignum_compare(a, b); + break; + case SEXP_STRING: + res = strcmp(sexp_string_data(a), sexp_string_data(b)); + break; + case SEXP_SYMBOL: + res = strcmp(sexp_string_data(sexp_symbol_string(a)), + sexp_string_data(sexp_symbol_string(b))); + break; + default: + res = 0; + break; + } + } +#if SEXP_USE_HUFF_SYMS + } else if (sexp_lsymbolp(a) && sexp_isymbolp(b)) { + res = sexp_object_compare(ctx, sexp_symbol_string(a), + sexp_write_to_string(ctx, b)); +#endif + } else { + res = 1; + } + } else if (sexp_pointerp(b)) { +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_lsymbolp(b)) + res = sexp_object_compare(ctx, sexp_symbol_string(b), + sexp_write_to_string(ctx, a)); + else +#endif + res = -1; + } else { +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_isymbolp(b)) + return sexp_isymbol_compare(ctx, a, b); + else +#endif + res = (sexp_sint_t)a - (sexp_sint_t)b; + } + return res; +} + +static sexp sexp_object_compare_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + return sexp_make_fixnum(sexp_object_compare(ctx, a, b)); +} + +static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) { + sexp_sint_t mid, i, j; + sexp tmp, tmp2; + loop: + if (lo < hi) { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + for (i=j=lo; i < hi; i++) + if (sexp_object_compare(ctx, vec[i], tmp) < 0) + swap(tmp2, vec[i], vec[j]), j++; + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + sexp_qsort(ctx, vec, lo, j-1); + lo = j+1; + goto loop; + } + } +} + +static sexp sexp_qsort_less (sexp ctx, sexp *vec, + sexp_sint_t lo, sexp_sint_t hi, + sexp less, sexp key) { + sexp_sint_t mid, i, j; + sexp tmp, res, args1; + sexp_gc_var3(a, b, args2); + sexp_gc_preserve3(ctx, a, b, args2); + args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID); + args1 = sexp_cdr(args2); + loop: + if (lo >= hi) { + res = SEXP_VOID; + } else { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + if (sexp_truep(key)) { + sexp_car(args1) = tmp; + b = sexp_apply(ctx, key, args1); + } else { + b = tmp; + } + for (i=j=lo; i < hi; i++) { + if (sexp_truep(key)) { + sexp_car(args1) = vec[i]; + a = sexp_apply(ctx, key, args1); + } else { + a = vec[i]; + } + sexp_car(args2) = a; + sexp_car(args1) = b; + res = sexp_apply(ctx, less, args2); + if (sexp_exceptionp(res)) + goto done; + else if (sexp_truep(res)) + swap(res, vec[i], vec[j]), j++; + } + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + res = sexp_qsort_less(ctx, vec, lo, j-1, less, key); + if (sexp_exceptionp(res)) + goto done; + lo = j+1; + goto loop; + } + } + done: + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, + sexp less, sexp key) { + sexp_sint_t len; + sexp res, *data; + sexp_gc_var1(vec); + + if (sexp_nullp(seq)) return seq; + + sexp_gc_preserve1(ctx, vec); + + vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); + + if (! sexp_vectorp(vec)) { + res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec); + } else { + data = sexp_vector_data(vec); + len = sexp_vector_length(vec); + if (sexp_not(key) && sexp_basic_comparator(less)) { + sexp_qsort(ctx, data, 0, len-1); + if (sexp_opcodep(less) && sexp_opcode_inverse(less)) + sexp_vector_nreverse(ctx, vec); + } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less); + } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key); + } else { + res = sexp_qsort_less(ctx, data, 0, len-1, less, key); + } + } + + if (sexp_pairp(seq)) + res = sexp_vector_copy_to_list(ctx, vec, seq); + else if (! sexp_exceptionp(res)) + res = vec; + + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "object-cmp", 2, sexp_object_compare_op); + sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE); + return SEXP_VOID; +} diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm new file mode 100644 index 00000000..14e24517 --- /dev/null +++ b/lib/srfi/95/sort.scm @@ -0,0 +1,70 @@ +;; sort.scm -- SRFI-95 sorting utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (copy seq) + (if (vector? seq) + (let* ((len (vector-length seq)) + (res (make-vector len))) + (do ((i (- len 1) (- i 1))) + ((< i 0) res) + (vector-set! res i (vector-ref seq i)))) + (map (lambda (x) x) seq))) + +(define (sort seq . o) + (let ((less (and (pair? o) (car o))) + (key (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (sort! (copy seq) less key))) + +(define (sorted? seq less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (cond + ((vector? seq) + (let ((len (- (vector-length seq) 1))) + (let lp ((i 0)) + (cond + ((>= i len) #t) + ((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f) + (else (lp (+ i 1))))))) + ((null? seq) + #t) + (else + (let lp ((ls1 seq) (ls2 (cdr seq))) + (cond ((null? ls2) #t) + ((less (key (car ls2)) (key (car ls1))) #f) + (else (lp ls2 (cdr ls2))))))))) + +(define (merge! ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (define (lp prev ls1 ls2 a b less key) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))) + (else + (set-cdr! prev ls2) + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))))) + (cond + ((null? ls1) ls2) + ((null? ls2) ls1) + (else + (let ((a (key (car ls1))) + (b (key (car ls2)))) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)) + ls1) + (else + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)) + ls2))))))) + +(define (merge ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (merge! (copy ls1) (copy ls2) less key))) diff --git a/lib/srfi/98.module b/lib/srfi/98.module new file mode 100644 index 00000000..9d124d66 --- /dev/null +++ b/lib/srfi/98.module @@ -0,0 +1,5 @@ + +(define-module (srfi 98) + (export get-environment-variable get-environment-variables) + (include-shared "98/env")) + diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c new file mode 100644 index 00000000..f8e519f3 --- /dev/null +++ b/lib/srfi/98/env.c @@ -0,0 +1,48 @@ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifdef __APPLE__ +#include +#define environ (*_NSGetEnviron()) +#else +extern char **environ; +#endif + +#include + +sexp sexp_get_environment_variable (sexp ctx sexp_api_params(self, n), sexp str) { + char *cstr; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + cstr = getenv(sexp_string_data(str)); + return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE; +} + +sexp sexp_get_environment_variables (sexp ctx sexp_api_params(self, n)) { + int i; + char **env, *cname, *cval; + sexp_gc_var3(res, name, val); + sexp_gc_preserve3(ctx, res, name, val); + res = SEXP_NULL; + env = environ; + for (i=0; env[i]; i++) { + cname = env[i]; + cval = strchr(cname, '='); + if (cval) { + name = sexp_c_string(ctx, cname, cval-cname); + val = sexp_c_string(ctx, cval+1, -1); + val = sexp_cons(ctx, name, val); + res = sexp_cons(ctx, val, res); + } + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable); + sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables); + return SEXP_VOID; +} + diff --git a/main.c b/main.c new file mode 100644 index 00000000..7ecc913f --- /dev/null +++ b/main.c @@ -0,0 +1,217 @@ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define sexp_argv_symbol "*command-line-arguments*" +#define sexp_argv_proc "(define (command-line-arguments) "sexp_argv_symbol")" + +#define sexp_import_prefix "(import (" +#define sexp_import_suffix "))" + +#define sexp_version_string "chibi-scheme "sexp_version" \""sexp_release_name"\" " + +#ifdef PLAN9 +#define exit_failure() exits("ERROR") +#else +#define exit_failure() exit(70) +#endif + +static void repl (sexp ctx) { + sexp in, out, err; + sexp_gc_var4(obj, tmp, res, env); + sexp_gc_preserve4(ctx, obj, tmp, res, env); + env = sexp_make_env(ctx); + sexp_env_parent(env) = sexp_context_env(ctx); + sexp_env_define(ctx, sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); + sexp_context_tracep(ctx) = 1; + in = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE); + out = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE); + err = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE); + 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, env); + if (sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, err); + } else { +#if SEXP_USE_WARN_UNDEFS + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + if (res != SEXP_VOID) { + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + } + } + } + sexp_gc_release4(ctx); +} + +static void check_nonull_arg (int c, char *arg) { + if (! arg) { + fprintf(stderr, "chibi-scheme: option '%c' requires an argument\n", c); + exit_failure(); + } +} + +static sexp check_exception (sexp ctx, sexp res) { + sexp err; + if (res && sexp_exceptionp(res)) { + err = sexp_current_error_port(ctx); + if (! sexp_oportp(err)) + err = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_print_exception(ctx, res, err); + exit_failure(); + } + return res; +} + +#define init_context() if (! ctx) do { \ + ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \ + env = sexp_context_env(ctx); \ + sexp_gc_preserve2(ctx, tmp, args); \ + } while (0) + +#define load_init() if (! init_loaded++) do { \ + init_context(); \ + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \ + } while (0) + +void run_main (int argc, char **argv) { + char *arg, *impmod, *p; + sexp env, out=SEXP_FALSE, res=SEXP_VOID, ctx=NULL; + sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0; + sexp_uint_t heap_size=0; + sexp_gc_var2(tmp, args); + args = SEXP_NULL; + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + case 'p': + load_init(); + print = (argv[i][1] == 'p'); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('e', arg); + res = check_exception(ctx, sexp_read_from_string(ctx, arg, -1)); + res = check_exception(ctx, sexp_eval(ctx, res, env)); + if (print) { + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + quit = 1; + break; + case 'l': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('l', arg); + check_exception(ctx, sexp_load_module_file(ctx, arg, env)); + break; + case 'm': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('m', arg); + len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); + impmod = (char*) malloc(len+1); + strcpy(impmod, sexp_import_prefix); + strcpy(impmod+strlen(sexp_import_prefix), arg); + strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix); + impmod[len] = '\0'; + for (p=impmod; *p; p++) + if (*p == '.') *p=' '; + check_exception(ctx, sexp_eval_string(ctx, impmod, -1, env)); + free(impmod); + break; + case 'q': + init_context(); + if (! init_loaded++) sexp_load_standard_parameters(ctx, env); + break; + case 'A': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('A', arg); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); + break; + case 'I': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('I', arg); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); + break; + case '-': + i++; + goto done_options; + case 'h': + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('h', arg); + heap_size = atol(arg); + len = strlen(arg); + if (heap_size && isalpha(arg[len-1])) { + switch (tolower(arg[len-1])) { + case 'k': heap_size *= 1024; break; + case 'm': heap_size *= (1024*1024); break; + } + } + break; + case 'V': + load_init(); + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + sexp_write_string(ctx, sexp_version_string, out); + tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*", -1), SEXP_NULL); + sexp_write(ctx, tmp, out); + sexp_newline(ctx, out); + return; + default: + fprintf(stderr, "unknown option: %s\n", argv[i]); + exit_failure(); + } + } + + done_options: + if (! quit) { + load_init(); + if (i < argc) + for (j=argc-1; j>i; j--) + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); + else + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); + sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args); + sexp_eval_string(ctx, sexp_argv_proc, -1, env); + if (i < argc) { /* script usage */ + check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); + tmp = sexp_intern(ctx, "main", -1); + tmp = sexp_env_ref(env, tmp, SEXP_FALSE); + if (sexp_procedurep(tmp)) { + args = sexp_list1(ctx, args); + check_exception(ctx, sexp_apply(ctx, tmp, args)); + } + } else { + repl(ctx); + } + } + + sexp_gc_release2(ctx); + sexp_destroy_context(ctx); +} + +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..a193e9b6 --- /dev/null +++ b/mkfile @@ -0,0 +1,28 @@ + include/chibi/install.h + echo '#define sexp_platform "plan9"' >> include/chibi/install.h + echo '#define sexp_version "'`{cat VERSION}'"' >> include/chibi/install.h + echo '#define sexp_release_name "'`{cat RELEASE}'"' >> include/chibi/install.h + +install:V: $BIN/$TARG + test -d $MODDIR || mkdir -p $MODDIR + cp -r lib/* $MODDIR/ + +test:V: + ./$O.out tests/r5rs-tests.scm + +sexp.c:N: gc.c opt/bignum.c diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..4f11e7e0 --- /dev/null +++ b/opcodes.c @@ -0,0 +1,154 @@ + +#define _OP(c,o,n,m,t,u,i,s,d,f) \ + {.tag=SEXP_OPCODE, \ + .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}} +#define _FN(o,n,m,t,u,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f) +#define _FN0(s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, 0, 0, s, d, f) +#define _FN1(t, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, t, 0, s, d, f) +#define _FN1OPT(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, t, u, s, d, f) +#define _FN1OPTP(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, t, 0, s, d, f) +#define _FN2(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, t, u, s, d, f) +#define _FN2OPT(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, t, u, s, d, f) +#define _FN2OPTP(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, t, u, s, d, f) +#define _FN3(t, u, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, t, u, s, d, f) +#define _FN4(t, u, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, t, u, s, d, f) +#define _FN5(t, u, s, d, f) _FN(SEXP_OP_FCALL5, 5, 0, t, u, s, d, f) +#define _FN6(t, u, s, d, f) _FN(SEXP_OP_FCALL6, 6, 0, t, u, s, d, f) +#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, 0, 0, n, a, 0) + +static struct sexp_struct opcodes[] = { +_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, SEXP_FIXNUM, 0, 1, "-", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 1, 1, SEXP_FIXNUM, 0, 1, "/", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), +#if SEXP_USE_IMMEDIATE_FLONUMS +_FN1(0, "flonum?", 0, sexp_flonump_op), +#else +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), +#endif +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read_op), +_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write_op), +_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display_op), +_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op), +_FN2(0, 0, "equal?", 0, sexp_equalp_op), +_FN1(0, "list?", 0, sexp_listp_op), +_FN1(0, "identifier?", 0, sexp_identifierp_op), +_FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr_op), +_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq_op), +_FN1(SEXP_PAIR, "length", 0, sexp_length_op), +_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse_op), +_FN1(SEXP_PAIR, "reverse!", 0, sexp_nreverse_op), +_FN2(SEXP_PAIR, SEXP_PAIR, "append2", 0, sexp_append2_op), +_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector_op), +_FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file_op), +_FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file_op), +_FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port_op), +_FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port_op), +_FN0("make-environment", 0, sexp_make_env_op), +_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env_op), +_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env_op), +_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval_op), +_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load_op), +_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy_op), +_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception_op), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_op), +_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string_op), +_FN2OPT(SEXP_FIXNUM, SEXP_FIXNUM, "string->number", SEXP_TEN, sexp_string_to_number_op), +_FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp_op), +_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring_op), +_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol_op), +_FN2OPT(SEXP_PAIR, SEXP_STRING, "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op), +_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq_op), +_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq_op), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo_op), +_FN1(0, "strip-syntactic-closures", 0, sexp_strip_synclos), +_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), +_FN0("open-output-string", 0, sexp_make_output_string_port_op), +_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port_op), +_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string_op), +#if SEXP_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), +#endif +_FN2(0, 0, "expt", 0, sexp_expt_op), +#if SEXP_USE_TYPE_DEFS +_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type_op), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate_op), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor_op), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter_op), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter_op), +#endif +#if PLAN9 +#include "opt/plan9-opcodes.c" +#endif +#if SEXP_USE_MODULES +_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports_op), +_FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), +_FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), +_FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory_op), +#endif +}; + diff --git a/opt/bignum.c b/opt/bignum.c new file mode 100644 index 00000000..09c82ded --- /dev/null +++ b/opt/bignum.c @@ -0,0 +1,775 @@ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_INIT_BIGNUM_SIZE 2 + +#define sexp_negate(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_fixnump(x)) \ + x = sexp_fx_neg(x); + +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { + sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + sexp_bignum_length(res) = len; + sexp_bignum_sign(res) = 1; + return res; +} + +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { + sexp res = sexp_make_bignum(ctx, 1); + sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a)); + sexp_bignum_sign(res) = sexp_fx_sign(a); + return res; +} + +sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { + sexp res; + if ((SEXP_MIN_FIXNUM <= x) && (x <= SEXP_MAX_FIXNUM)) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + if (x < 0) { + sexp_bignum_sign(res) = -1; + sexp_bignum_data(res)[0] = -x; + } else { + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + } + return res; +} + +sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { + sexp res; + if (x <= SEXP_MAX_FIXNUM) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + return res; +} + +#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) +#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) + +sexp sexp_double_to_bignum (sexp ctx, double f) { + int sign; + sexp_gc_var3(res, scale, tmp); + sexp_gc_preserve3(ctx, res, scale, tmp); + res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + sign = (f < 0 ? -1 : 1); + for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { + tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); + res = sexp_bignum_add(ctx, res, res, tmp); + scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); + } + sexp_bignum_sign(res) = sign; + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { + sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size; + size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + if (! dst || sexp_bignum_length(dst) < len) { + dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + memmove(dst, a, size); + sexp_bignum_length(dst) = len; + } else { + memset(dst->value.bignum.data, 0, + sexp_bignum_length(dst)*sizeof(sexp_uint_t)); + memmove(dst->value.bignum.data, a->value.bignum.data, + sexp_bignum_length(a)*sizeof(sexp_uint_t)); + } + return dst; +} + +int sexp_bignum_zerop (sexp a) { + int i; + sexp_uint_t *data = sexp_bignum_data(a); + for (i=sexp_bignum_length(a)-1; i>=0; i--) + if (data[i]) + return 0; + return 1; +} + +sexp_uint_t sexp_bignum_hi (sexp a) { + sexp_uint_t i=sexp_bignum_length(a)-1; + while ((i>0) && ! sexp_bignum_data(a)[i]) + i--; + return i+1; +} + +sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) { + int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b); + sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b); + if (ai != bi) + return ai - bi; + for (--ai; ai >= 0; ai--) { + if (adata[ai] > bdata[ai]) + return 1; + else if (adata[ai] < bdata[ai]) + return -1; + } + return 0; +} + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { + if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) + return sexp_bignum_sign(a); + return sexp_bignum_compare_abs(a, b); +} + +sexp sexp_bignum_normalize (sexp a) { + sexp_uint_t *data; + if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) + return a; + data = sexp_bignum_data(a); + if ((data[0] > SEXP_MAX_FIXNUM) + && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1))) + return a; + return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a)); +} + +double sexp_bignum_to_double (sexp a) { + double res = 0; + sexp_sint_t i; + sexp_uint_t *data=sexp_bignum_data(a); + for (i=sexp_bignum_hi(a)-1; i>=0; i--) + res = res * ((double)SEXP_UINT_T_MAX+1) + data[i]; + return res * sexp_bignum_sign(a); +} + +sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), + carry=b, i=0, n; + do { n = data[i]; + data[i] += carry; + carry = (n > (SEXP_UINT_T_MAX - carry)); + } while (++i> (sizeof(sexp_uint_t)*8); + } + if (carry) { + if (sexp_bignum_length(d)+offset <= len) + d = sexp_copy_bignum(ctx, NULL, d, len+offset+1); + sexp_bignum_data(d)[len+offset] = carry; + } + sexp_gc_release1(ctx); + return d; +} + +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0; + int i; + sexp_luint_t n = 0; + for (i=len-1; i>=offset; i--) { + n = (n << sizeof(sexp_uint_t)*8) + data[i]; + q = n / b; + r = n - (sexp_luint_t)q * b; + data[i] = q; + n = r; + } + return r; +} + +sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, + char sign, sexp_uint_t base) { + int c, digit; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE); + sexp_bignum_sign(res) = sign; + sexp_bignum_data(res)[0] = init; + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + res = sexp_bignum_fxmul(ctx, res, res, base, 0); + res = sexp_bignum_fxadd(ctx, res, digit); + } + if (c=='.' || c=='e' || c=='E') { + if (base != 10) { + res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + } else { + if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */ + res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); + } + } else if ((c!=EOF) && ! is_separator(c)) { + res = sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + } else { + sexp_push_char(ctx, c, in); + } + sexp_gc_release1(ctx); + return sexp_bignum_normalize(res); +} + +static int log2i(int v) { + int i; + for (i = 0; i < sizeof(v)*8; i++) + if ((1<<(i+1)) > v) + break; + return i; +} + +sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { + int i, str_len, lg_base = log2i(base); + char *data; + sexp_gc_var2(b, str); + sexp_gc_preserve2(ctx, b, str); + b = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(b) = 1; + i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) + / lg_base + 1; + str = sexp_make_string(ctx, sexp_make_fixnum(str_len), + sexp_make_character(' ')); + data = sexp_string_data(str); + while (! sexp_bignum_zerop(b)) + data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0)); + if (i == str_len) + data[--i] = '0'; + else if (sexp_bignum_sign(a) == -1) + data[--i] = '-'; + sexp_write_string(ctx, data + i, out); + sexp_gc_release2(ctx); + return SEXP_VOID; +} + +/****************** bignum arithmetic *************************/ + +sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(c); + sexp_gc_preserve1(ctx, c); + c = sexp_copy_bignum(ctx, NULL, a, 0); + if (sexp_bignum_sign(c) == sexp_fx_sign(b)) + c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + else + c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + sexp_gc_release1(ctx); + return c; +} + +sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), + borrow=0, i, *adata, *bdata, *cdata; + sexp_gc_var1(c); + if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) + return sexp_bignum_sub_digits(ctx, dst, b, a); + sexp_gc_preserve1(ctx, c); + c = ((dst && sexp_bignum_hi(dst) >= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0); + } + for ( ; carry && (i= 0 ? a : b); + } + return res; +} + +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { + sexp res; + if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { + res = sexp_bignum_sub_digits(ctx, dst, a, b); + sexp_bignum_sign(res) + = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a) + : -sexp_bignum_sign(a)); + } else { + res = sexp_bignum_add_digits(ctx, dst, a, b); + sexp_bignum_sign(res) = sexp_bignum_sign(a); + } + return res; +} + +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, + *bdata=sexp_bignum_data(b); + sexp_gc_var2(c, d); + if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); + sexp_gc_preserve2(ctx, c, d); + c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); + d = sexp_make_bignum(ctx, alen+blen+1); + for (i=0; i 0) { + *rem = a; + return sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + } + sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); + k2 = sexp_bignum_double(ctx, k); + i2 = sexp_bignum_double(ctx, i); + x = quot_step(ctx, rem, a, b, k2, i2); + prod = sexp_bignum_mul(ctx, NULL, x, b); + diff = sexp_bignum_sub_digits(ctx, NULL, a, prod); + if (sexp_bignum_compare(diff, k) >= 0) { + *rem = sexp_bignum_sub_digits(ctx, NULL, diff, k); + res = sexp_bignum_add_digits(ctx, NULL, x, i); + } else { + *rem = diff; + res = x; + } + sexp_gc_release5(ctx); + return res; +} + +sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { + sexp res; + sexp_gc_var4(k, i, a1, b1); + sexp_gc_preserve4(ctx, k, i, a1, b1); + a1 = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(a1) = 1; + b1 = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_bignum_sign(b1) = 1; + k = sexp_copy_bignum(ctx, NULL, b1, 0); + i = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + res = quot_step(ctx, rem, a1, b1, k, i); + sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); + if (sexp_bignum_sign(a) < 0) { + sexp_negate(*rem); + } + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { + sexp res; + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + res = sexp_bignum_quot_rem(ctx, &rem, a, b); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */ + sexp_gc_release1(ctx); + return rem; +} + +sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { + sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b)); + sexp_gc_var2(res, acc); + sexp_gc_preserve2(ctx, res, acc); + res = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + acc = sexp_copy_bignum(ctx, NULL, a, 0); + for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) + if (e & 1) + res = sexp_bignum_mul(ctx, NULL, res, acc); + sexp_gc_release2(ctx); + return res; +} + +/****************** generic arithmetic ************************/ + +enum sexp_number_types { + SEXP_NUM_NOT = 0, + SEXP_NUM_FIX, + SEXP_NUM_FLO, + SEXP_NUM_BIG +}; + +enum sexp_number_combs { + SEXP_NUM_NOT_NOT = 0, + SEXP_NUM_NOT_FIX, + SEXP_NUM_NOT_FLO, + SEXP_NUM_NOT_BIG, + SEXP_NUM_FIX_NOT, + SEXP_NUM_FIX_FIX, + SEXP_NUM_FIX_FLO, + SEXP_NUM_FIX_BIG, + SEXP_NUM_FLO_NOT, + SEXP_NUM_FLO_FIX, + SEXP_NUM_FLO_FLO, + SEXP_NUM_FLO_BIG, + SEXP_NUM_BIG_NOT, + SEXP_NUM_BIG_FIX, + SEXP_NUM_BIG_FLO, + SEXP_NUM_BIG_BIG +}; + +static int sexp_number_types[] = + {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0}; + +static int sexp_number_type (sexp a) { + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] +#if SEXP_USE_IMMEDIATE_FLONUMS + : sexp_flonump(a) ? 2 +#endif + : sexp_fixnump(a); +} + +sexp sexp_add (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_add(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_add(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_add(ctx, NULL, b, a)); + break; + } + return r; +} + +sexp sexp_sub (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_sub(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + tmp = sexp_fixnum_to_bignum(ctx, a); + r = sexp_bignum_sub(ctx, NULL, b, tmp); + sexp_negate(r); + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)+sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_sub(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + tmp = sexp_fixnum_to_bignum(ctx, b); + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, tmp)); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) - sexp_flonum_value(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_mul (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_mul(a, b); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0); + sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_mul(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_mul(ctx, NULL, a, b); + break; + } + return r; +} + +sexp sexp_div (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + double f; + sexp r=SEXP_VOID; + sexp_gc_var2(tmp, rem); + sexp_gc_preserve2(ctx, tmp, rem); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: + f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b); + r = ((f == trunc(f)) ? sexp_make_fixnum((sexp_sint_t)f) + : sexp_make_flonum(ctx, f)); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_flonum_value(a)/sexp_fixnum_to_double(b)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_div(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_quot_rem(ctx, &rem, a, b); + if (sexp_bignum_normalize(rem) != SEXP_ZERO) + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) + / sexp_bignum_to_double(b)); + else + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b)); + break; + } + sexp_gc_release2(ctx); + return r; +} + +sexp sexp_quotient (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_div(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = SEXP_ZERO; + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_remainder (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_rem(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = a; + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_compare (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + double f; + if (at > bt) { + r = sexp_compare(ctx, b, a); + sexp_negate(r); + } else { + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); + break; + case SEXP_NUM_FIX_FLO: + f = sexp_fixnum_to_double(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(-1); + break; + case SEXP_NUM_FLO_FLO: + f = sexp_flonum_value(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FLO_BIG: + f = sexp_flonum_value(a) - sexp_bignum_to_double(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_make_fixnum(sexp_bignum_compare(a, b)); + break; + } + } + return r; +} + diff --git a/opt/plan9-opcodes.c b/opt/plan9-opcodes.c new file mode 100644 index 00000000..9f7cac33 --- /dev/null +++ b/opt/plan9-opcodes.c @@ -0,0 +1,19 @@ +_FN0("random-integer", 0, sexp_rand), +_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), +_FN0("current-directory", 0, sexp_getwd), +_FN0("current-user", 0, sexp_getuser), +_FN0("system-name", 0, sexp_sysname), +_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), +_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), +_FN0("fork", 0, sexp_fork), +_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), +_FN1(SEXP_STRING, "exits", 0, sexp_exits), +_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), +_FN0("pipe", 0, sexp_pipe), +_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), +_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), +_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), +_FN0("wait", 0, sexp_wait), +_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), +_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), +_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), diff --git a/opt/plan9.c b/opt/plan9.c new file mode 100644 index 00000000..ca25afba --- /dev/null +++ b/opt/plan9.c @@ -0,0 +1,351 @@ +/* plan9.c -- extended Plan 9 system utils */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +sexp sexp_rand (sexp ctx sexp_api_params(self, n)) { + return sexp_make_fixnum(rand()); +} + +sexp sexp_srand (sexp ctx sexp_api_params(self, n), sexp seed) { + srand(sexp_unbox_fixnum(seed)); + return SEXP_VOID; +} + +sexp sexp_file_exists_p (sexp ctx sexp_api_params(self, n), sexp path) { + int res; + uchar statbuf[STATMAX]; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "file-exists?: not a string", path); + res = stat(sexp_string_data(path), statbuf, sizeof(statbuf)); + return (res < 0) ? SEXP_FALSE : SEXP_TRUE; +} + +sexp sexp_fdopen (sexp ctx sexp_api_params(self, n), sexp fd, sexp mode) { + FILE *f; + if (! sexp_integerp(fd)) + return sexp_type_exception(ctx, "fdopen: not an integer", fd); + if (! sexp_stringp(mode)) + return sexp_type_exception(ctx, "fdopen: not a mode string", mode); + f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode)); + if (! f) + return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd); + /* maybe use fd2path to get the name of the fd */ + if (sexp_string_data(mode)[0] == 'w') + return sexp_make_output_port(ctx, f, SEXP_FALSE); + else + return sexp_make_input_port(ctx, f, SEXP_FALSE); +} + +sexp sexp_fileno (sexp ctx sexp_api_params(self, n), sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "fileno: not a port", port); + return sexp_make_fixnum(fileno(sexp_port_stream(port))); +} + +sexp sexp_fork (sexp ctx sexp_api_params(self, n)) { + return sexp_make_fixnum(fork()); +} + +sexp sexp_exec (sexp ctx sexp_api_params(self, n), sexp name, sexp args) { + int i, len = sexp_unbox_fixnum(sexp_length(ctx, args)); + char **argv = malloc((len+1)*sizeof(char*)); + for (i=0; imsg, -1); + res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg); + sexp_gc_release(ctx, msg, s_msg); + return res; +} + +sexp sexp_postnote (sexp ctx sexp_api_params(self, n), sexp pid, sexp note) { + if (! sexp_integerp(pid)) + return sexp_type_exception(ctx, "postnote: not an integer", pid); + if (! sexp_stringp(note)) + return sexp_type_exception(ctx, "postnote: not a string", note); + postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note)); + return SEXP_VOID; +} + +/**********************************************************************/ +/* 9p interface */ + +typedef struct sexp_plan9_srv { + sexp context, auth, attach, walk, walk1, clone, open, create, remove, + read, write, stat, wstat, flush, destroyfid, destroyreq, end; +} *sexp_plan9_srv; + +void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) { + s->context = ctx; + s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open + = s->create = s->remove = s->read = s->write = s->stat = s->wstat + = s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE; + for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) { + if (sexp_car(ls) == sexp_intern(ctx, "auth:", -1)) { + s->auth = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "attach:", -1)) { + s->attach = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk:", -1)) { + s->walk = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:", -1)) { + s->walk1 = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "clone:", -1)) { + s->clone = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "open:", -1)) { + s->open = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "create:", -1)) { + s->create = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "remove:", -1)) { + s->remove = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "read:", -1)) { + s->read = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "write:", -1)) { + s->write = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "stat:", -1)) { + s->stat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:", -1)) { + s->wstat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "flush:", -1)) { + s->flush = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:", -1)) { + s->destroyfid = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:", -1)) { + s->destroyreq = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "end:", -1)) { + s->end = sexp_cadr(ls); + } + } +} + +void sexp_run_9p_handler (Req *r, sexp handler) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, handler, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +#define sexp_def_9p_handler(name, field) \ + void name (Req *r) { \ + sexp_run_9p_handler(r, ((sexp_plan9_srv)r->srv->aux)->field); \ + } + +sexp_def_9p_handler(sexp_9p_auth, auth) +sexp_def_9p_handler(sexp_9p_attach, attach) +sexp_def_9p_handler(sexp_9p_walk, walk) +sexp_def_9p_handler(sexp_9p_open, open) +sexp_def_9p_handler(sexp_9p_create, create) +sexp_def_9p_handler(sexp_9p_remove, remove) +sexp_def_9p_handler(sexp_9p_read, read) +sexp_def_9p_handler(sexp_9p_write, write) +sexp_def_9p_handler(sexp_9p_stat, stat) +sexp_def_9p_handler(sexp_9p_wstat, wstat) +sexp_def_9p_handler(sexp_9p_flush, flush) + +char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_c_string(ctx, name, -1); + args = sexp_cons(ctx, ptr, args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->walk1, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +char* sexp_9p_clone (Fid *oldfid, Fid *newfid) { + sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->clone, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +void sexp_9p_destroyfid (Fid *fid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyfid, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_destroyreq (Req *r) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyreq, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_end (Srv *srv) { + sexp_plan9_srv s = (sexp_plan9_srv)srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->end, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +sexp sexp_postmountsrv (sexp ctx sexp_api_params(self, n), sexp ls, sexp name, sexp mtpt, sexp flags) { + Srv s; + struct sexp_plan9_srv p9s; + if (! sexp_listp(ctx, ls)) + return sexp_type_exception(ctx, "postmountsrv: not a list", ls); + if (! sexp_stringp(name)) + return sexp_type_exception(ctx, "postmountsrv: not a string", name); + if (! sexp_stringp(mtpt)) + return sexp_type_exception(ctx, "postmountsrv: not a string", mtpt); + if (! sexp_integerp(flags)) + return sexp_type_exception(ctx, "postmountsrv: not an integer", flags); + sexp_build_srv(ctx, &p9s, ls); + s.aux = &p9s; + s.auth = &sexp_9p_auth; + s.attach = &sexp_9p_attach; + s.walk = &sexp_9p_walk; + s.walk1 = &sexp_9p_walk1; + s.clone = &sexp_9p_clone; + s.open = &sexp_9p_open; + s.create = &sexp_9p_create; + s.remove = &sexp_9p_remove; + s.read = &sexp_9p_read; + s.write = &sexp_9p_write; + s.stat = &sexp_9p_stat; + s.wstat = &sexp_9p_wstat; + s.flush = &sexp_9p_flush; + s.destroyfid = &sexp_9p_destroyfid; + s.destroyreq = &sexp_9p_destroyreq; + s.end = &sexp_9p_end; + postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt), + sexp_unbox_fixnum(flags)); + return SEXP_UNDEF; +} + +sexp sexp_9p_req_offset (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset); +} + +sexp sexp_9p_req_count (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count); +} + +#if 0 +sexp sexp_9p_req_path (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1); +} +#endif + +sexp sexp_9p_req_fid (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0); +} + +sexp sexp_9p_req_newfid (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0); +} + +sexp sexp_9p_respond (sexp ctx sexp_api_params(self, n), sexp req, sexp err) { + char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil; + respond(sexp_cpointer_value(req), cerr); + return SEXP_VOID; +} + +sexp sexp_9p_responderror (sexp ctx sexp_api_params(self, n), sexp req) { + responderror(sexp_cpointer_value(req)); + return SEXP_VOID; +} + 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/opt/simplify.c b/opt/simplify.c new file mode 100644 index 00000000..4217a1bb --- /dev/null +++ b/opt/simplify.c @@ -0,0 +1,143 @@ +/* simplify.c -- basic simplification pass */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda)) + +static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { + int check; + sexp ls1, ls2, p1, p2, sv, ctx2; + sexp_gc_var4(res, substs, tmp, app); + sexp_gc_preserve4(ctx, res, substs, tmp, app); + res = ast; /* return the ast as-is by default */ + substs = init_substs; + + loop: + switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) { + + case SEXP_PAIR: + /* don't simplify the operator if it's a lambda because we + simplify that as a special case below, with the appropriate + substs list */ + app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res) + : (tmp=simplify(ctx, sexp_car(res), substs, lambda))); + for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); + app = sexp_nreverse(ctx, app); + /* app now holds a copy of the list, and is the default result + (res = app below) if we don't replace it with a simplification */ + if (sexp_opcodep(sexp_car(app))) { + /* opcode app - right now we just constant fold arithmetic */ + if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) { + for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { + if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { + check = 0; + break; + } + } + if (check) { + ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0); + generate(ctx2, app); + res = finalize_bytecode(ctx2); + if (! sexp_exceptionp(res)) { + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp); + if (! sexp_exceptionp(tmp)) { + tmp = sexp_apply(ctx2, tmp, SEXP_NULL); + if (! sexp_exceptionp(tmp)) + app = sexp_make_lit(ctx2, tmp); + } + } + } + } + } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */ + p1 = NULL; + p2 = sexp_lambda_params(sexp_car(app)); + ls1 = app; + ls2 = sexp_cdr(app); + sv = sexp_lambda_sv(sexp_car(app)); + for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) { + if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv)) + && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2)) + || (sexp_refp(sexp_car(ls2)) + && sexp_lambdap(sexp_ref_loc(sexp_car(ls2))) + && sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)), + sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) { + tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2)); + tmp = sexp_cons(ctx, sexp_car(p2), tmp); + sexp_push(ctx, substs, tmp); + sexp_cdr(ls1) = sexp_cdr(ls2); + if (p1) + sexp_cdr(p1) = sexp_cdr(p2); + else + sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2); + } else { + p1 = p2; + ls1 = ls2; + } + } + sexp_lambda_body(sexp_car(app)) + = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app)); + if (sexp_nullp(sexp_cdr(app)) + && sexp_nullp(sexp_lambda_params(sexp_car(app))) + && sexp_nullp(sexp_lambda_defs(sexp_car(app)))) + app = sexp_lambda_body(sexp_car(app)); + } + res = app; + break; + + case SEXP_LAMBDA: + sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res); + break; + + case SEXP_CND: + tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda); + if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) { + res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp)) + ? sexp_cnd_fail(res) : sexp_cnd_pass(res); + goto loop; + } else { + sexp_cnd_test(res) = tmp; + simplify_it(sexp_cnd_pass(res)); + simplify_it(sexp_cnd_fail(res)); + } + break; + + case SEXP_REF: + tmp = sexp_ref_name(res); + for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) { + res = sexp_cddar(ls1); + break; + } + break; + + case SEXP_SET: + simplify_it(sexp_set_value(res)); + break; + + case SEXP_SEQ: + app = SEXP_NULL; + for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { + tmp = simplify(ctx, sexp_car(ls2), substs, lambda); + if (! (sexp_pairp(sexp_cdr(ls2)) + && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) + || sexp_lambdap(tmp)))) + sexp_push(ctx, app, tmp); + } + if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app))) + res = sexp_car(app); + else + sexp_seq_ls(res) = sexp_nreverse(ctx, app); + break; + + } + + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_simplify (sexp ctx sexp_api_params(self, n), sexp ast) { + return simplify(ctx, ast, SEXP_NULL, NULL); +} + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..75333dab --- /dev/null +++ b/sexp.c @@ -0,0 +1,1776 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* optional huffman-compressed immediate symbols */ +struct sexp_huff_entry { + unsigned char len; + unsigned short bits; +}; + +#if SEXP_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; + +sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp); + +static const 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 (int c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int hex_digit (int n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + +static int is_separator(int c) { + return 0= SEXP_MAXIMUM_TYPES) { + res = sexp_user_exception(ctx, self, "register-type: exceeded maximum type limit", name); + } else if (! sexp_stringp(name)) { + res = sexp_type_exception(ctx, self, SEXP_STRING, name); + } else { + if (num_types >= type_array_size) { + len = type_array_size*2; + if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES; +#if SEXP_USE_GLOBAL_TYPES + new = malloc(len * sizeof(_sexp_type_specs[0])); + for (i=0; i num_types) free(tmp); + sexp_type_array_size = len; +#else + res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID); + v1 = sexp_vector_data(res); + v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)); + for (i=0; inext; +#if SEXP_USE_MMAP_GC + munmap(heap, heap->size); +#else + free(heap); +#endif + } + } +} +#endif + +/***************************** exceptions *****************************/ + +sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, + 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_source(exn) = source; + return exn; +} + +sexp sexp_string_cat3 (sexp ctx, char *pre, char *mid, char* suf) { + int plen=strlen(pre), mlen=strlen(mid), slen=strlen(suf); + char *s; + sexp str; + str = sexp_make_string(ctx, sexp_make_fixnum(plen+mlen+slen), SEXP_VOID); + memcpy(s=sexp_string_data(str), pre, plen); + memcpy(s+plen, mid, mlen); + memcpy(s+plen+mlen, suf, slen); + return str; +} + +sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { + sexp res; + sexp_gc_var3(sym, str, irr); + sexp_gc_preserve3(ctx, sym, str, irr); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user", -1), + str = sexp_c_string(ctx, ms, -1), + ((sexp_pairp(ir) || sexp_nullp(ir)) + ? ir : (irr = sexp_list1(ctx, ir))), + self, SEXP_FALSE); + sexp_gc_release3(ctx); + return res; +} + +static sexp type_exception (sexp ctx, sexp self, sexp str, sexp obj, sexp src) { + sexp_gc_var2(res, sym); + sexp_gc_preserve2(ctx, res, sym); + sym = sexp_intern(ctx, "type", -1); + res = sexp_make_exception(ctx, sym, str, obj, self, src); + sexp_exception_irritants(res)=sexp_list1(ctx, sexp_exception_irritants(res)); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_c_string(ctx, msg, -1); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_string_cat3(ctx, "invalid type, expected ", + sexp_type_name_by_index(ctx, type_id), ""); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { + sexp_gc_var2(res, msg); + sexp_gc_preserve2(ctx, res, 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", -1), msg, res, + SEXP_FALSE, SEXP_FALSE); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out) { + sexp ls; + if (! sexp_oportp(out)) + out = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_write_string(ctx, "ERROR", out); + if (sexp_exceptionp(exn)) { + if (sexp_exception_procedure(exn)) { + if (sexp_procedurep(sexp_exception_procedure(exn))) { + ls = sexp_bytecode_name( + sexp_procedure_code(sexp_exception_procedure(exn))); + if (sexp_symbolp(ls)) { + sexp_write_string(ctx, " in ", out); + sexp_write(ctx, ls, out); + } + } else if (sexp_opcodep(sexp_exception_procedure(exn))) { + sexp_write_string(ctx, " in ", out); + sexp_write_string(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out); + } + } + if (sexp_pairp(sexp_exception_source(exn))) { + ls = sexp_exception_source(exn); + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(sexp_exception_message(exn))) + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); + else + sexp_write(ctx, 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, const char *msg, sexp ir, sexp port) { + sexp res; + sexp_gc_var4(sym, name, str, irr); + sexp_gc_preserve4(ctx, sym, name, str, irr); + name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); + name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port))); + str = sexp_c_string(ctx, msg, -1); + irr = ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir)); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read", -1), + str, irr, SEXP_FALSE, name); + sexp_gc_release4(ctx); + return res; +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons_op (sexp ctx sexp_api_params(self, n), sexp head, sexp tail) { + sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); + if (sexp_exceptionp(pair)) return 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_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_listp_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(ctx, sexp_car(ls), res); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp a, b, tmp; + if (ls == SEXP_NULL) return ls; + sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, ls); + 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_copy_list_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp tmp; + sexp_gc_var1(res); + if (! sexp_pairp(ls)) return ls; + sexp_gc_preserve1(ctx, res); + tmp = res = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + for (ls=sexp_cdr(ls); sexp_pairp(ls); ls=sexp_cdr(ls), tmp=sexp_cdr(tmp)) + sexp_cdr(tmp) = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_append2_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + sexp_gc_var2(a1, b1); + sexp_gc_preserve2(ctx, a1, 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_release2(ctx); + return b1; +} + +sexp sexp_length_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp_uint_t res=0; + for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) + ; + return sexp_make_fixnum(res); +} + +sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + sexp_uint_t size; + sexp_sint_t i, len; + sexp t, *p, *q; + char *p0, *q0; + + loop: + if (a == b) + return SEXP_TRUE; + else if ((! sexp_pointerp(a)) || (! sexp_pointerp(b)) + || (sexp_pointer_tag(a) != sexp_pointer_tag(b))) + return SEXP_FALSE; + + /* a and b are both pointers of the same type */ +#if SEXP_USE_BIGNUMS + if (sexp_pointer_tag(a) == SEXP_BIGNUM) + return sexp_make_boolean(!sexp_bignum_compare(a, b)); +#endif +#if SEXP_USE_FLONUMS && ! SEXP_USE_IMMEDIATE_FLONUMS + if (sexp_pointer_tag(a) == SEXP_FLONUM) + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); +#endif + t = sexp_object_type(ctx, a); + p0 = ((char*)a) + offsetof(struct sexp_struct, value); + p = (sexp*) (((char*)a) + sexp_type_field_base(t)); + q0 = ((char*)b) + offsetof(struct sexp_struct, value); + q = (sexp*) (((char*)b) + sexp_type_field_base(t)); + if ((sexp)p == a) {p=(sexp*)p0; q=(sexp*)q0;} + /* check preliminary non-object data */ + if ((p0 < (char*)p) && memcmp(p0, q0, ((char*)p - p0))) + return SEXP_FALSE; + /* check trailing non-object data */ + size = sexp_type_size_of_object(t, a) - offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,a)*sizeof(sexp)); + if (((char*)a + size) > p0) { + q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp)); + if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value)) + return SEXP_FALSE; + if (memcmp(p0, q0, size)) + return SEXP_FALSE; + } + /* check eq-object slots */ + len = sexp_type_num_eq_slots_of_object(t, a); + if (len > 0) { + for (i=0; i> 32; + return r.flonum; +} +sexp sexp_make_flonum (sexp ctx, float f) { + union sexp_flonum_conv x; + x.flonum = f; + return (sexp)(((sexp_uint_t)(x.bits) << 32) + SEXP_IFLONUM_TAG); +} +#endif +#endif + +sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) { + sexp_sint_t clen = sexp_unbox_fixnum(len); + sexp s; + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len); + if (clen < 0) return sexp_xtype_exception(ctx, self, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); + if (sexp_exceptionp(s)) return s; + sexp_pointer_tag(s) = SEXP_STRING; +#if SEXP_USE_HEADER_MAGIC + sexp_pointer_magic(s) = SEXP_POINTER_MAGIC; +#endif + 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, const char *str, sexp_sint_t slen) { + sexp_sint_t len = ((slen >= 0) ? slen : strlen(str)); + sexp s = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID); + memcpy(sexp_string_data(s), str, len); + sexp_string_data(s)[len] = '\0'; + return s; +} + +sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start); + if (sexp_not(end)) + end = sexp_make_fixnum(sexp_string_length(str)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end); + if ((sexp_unbox_fixnum(start) < 0) + || (sexp_unbox_fixnum(start) > sexp_string_length(str)) + || (sexp_unbox_fixnum(end) < 0) + || (sexp_unbox_fixnum(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_fixnum(start), + sexp_string_length(res)); + sexp_string_data(res)[sexp_string_length(res)] = '\0'; + return res; +} + +sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep) { + sexp res, ls; + sexp_uint_t len=0, i=0, sep_len=0; + char *p, *csep; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception(ctx, self, SEXP_STRING, sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + if (sexp_stringp(sep) && ((sep_len=sexp_string_length(sep)) > 0)) { + csep = sexp_string_data(sep); + len += sep_len*(i-1); + } + res = sexp_make_string(ctx, sexp_make_fixnum(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; + if (sep_len && sexp_pairp(sexp_cdr(ls))) { + memcpy(p, csep, sep_len); + p += sep_len; + } + } + *p = '\0'; + return res; +} + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#if SEXP_USE_HASH_SYMS + +static sexp_uint_t sexp_string_hash(const char *str, sexp_sint_t len, + sexp_uint_t acc) { + for ( ; len; len--) {acc *= FNV_PRIME; acc ^= *str++;} + return acc; +} + +#endif + +sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { +#if SEXP_USE_HUFF_SYMS + struct sexp_huff_entry he; + sexp_uint_t space=3, newbits; + char c; +#endif + sexp_uint_t res=FNV_OFFSET_BASIS, bucket, i=0; + const char *p=str; + sexp ls, tmp; + sexp_gc_var1(sym); + + if (len < 0) len = strlen(str); + +#if SEXP_USE_HUFF_SYMS + res = 0; + for ( ; i 127) + goto normal_intern; + 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); + + normal_intern: +#endif +#if SEXP_USE_HASH_SYMS + bucket = (sexp_string_hash(p, len-i, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if ((sexp_string_length(tmp=sexp_symbol_string(sexp_car(ls))) == len) + && ! strncmp(str, sexp_string_data(tmp), len)) + return sexp_car(ls); + + /* not found, make a new symbol */ + sexp_gc_preserve1(ctx, sym); + sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); + if (sexp_exceptionp(sym)) return sym; + sexp_symbol_string(sym) = sexp_c_string(ctx, str, len); + sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); + sexp_gc_release1(ctx); + return sym; +} + +sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); +} + +sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt) { + sexp vec, *x; + int i, clen = sexp_unbox_fixnum(len); + if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR); + vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); + if (sexp_exceptionp(vec)) return vec; + x = sexp_vector_data(vec); + 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_fixnum(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_fixnum(sexp_stream_size(vec)); + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_stream_ctx(vec), + sexp_make_fixnum(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_fixnum(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_fixnum(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_fixnum(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_fixnum(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_fixnum(pos); + return pos; +} + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + FILE *in; + sexp res; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = str; + sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str)); + sexp_stream_pos(cookie) = SEXP_ZERO; + 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_release1(ctx); + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + FILE *out; + sexp res, size; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + size = sexp_make_fixnum(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(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_ZERO; + 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_release1(ctx); + return res; +} + +sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(ctx, + sexp_stream_buf(cookie), + SEXP_ZERO, + sexp_stream_pos(cookie)); +} + +#else + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + FILE *in; + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + if (sexp_string_length(str) == 0) + in = fopen("/dev/null", "r"); + else + in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + if (in) { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + if (sexp_string_length(str) == 0) + sexp_port_name(res) = sexp_c_string(ctx, "/dev/null", -1); + sexp_port_cookie(res) = str; /* for gc preservation */ + } else { + res = sexp_user_exception(ctx, SEXP_FALSE, "couldn't open string", str); + } + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + 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_op (sexp ctx sexp_api_params(self, n), 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, const 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, const 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_var1(tmp); + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, p); + 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_preserve1(ctx, tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_gc_release1(ctx); + } + sexp_port_offset(p) = 0; + return SEXP_VOID; + } +} + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + 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_op (sexp ctx sexp_api_params(self, n)) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + 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_op (sexp ctx sexp_api_params(self, n), sexp out) { + sexp res; + sexp_gc_var2(ls, tmp); + sexp_gc_preserve2(ctx, ls, 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_FALSE); + sexp_gc_release2(ctx); + return res; +} + +#endif + +sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { + sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); + if (sexp_exceptionp(p)) return p; + 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_no_closep(p) = 0; + 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); + if (sexp_exceptionp(p)) return p; + sexp_pointer_tag(p) = SEXP_OPORT; + return p; +} + +#define NUMBUF_LEN 32 + +sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { +#if SEXP_USE_HUFF_SYMS + unsigned long res, c; +#endif + unsigned long len; + long i=0; + double f; + sexp x, *elts; + char *str=NULL, numbuf[NUMBUF_LEN]; + + 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_one(ctx, sexp_car(obj), out); + for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { + sexp_write_char(ctx, ' ', out); + sexp_write_one(ctx, sexp_car(x), out); + } + if (! sexp_nullp(x)) { + sexp_write_string(ctx, " . ", out); + sexp_write_one(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_one(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; +#if SEXP_USE_BIGNUMS + case SEXP_BIGNUM: + sexp_write_bignum(ctx, obj, out, 10); + break; +#endif + case SEXP_OPCODE: + sexp_write_string(ctx, "#', out); + break; + default: + i = sexp_pointer_tag(obj); + sexp_write_string(ctx, "#<", out); + sexp_write_string(ctx, + (i < sexp_context_num_types(ctx)) + ? sexp_type_name_by_index(ctx, i) : "invalid", + out); + sexp_write_char(ctx, '>', out); + break; + } + } else if (sexp_fixnump(obj)) { + snprintf(numbuf, NUMBUF_LEN, "%ld", (long)sexp_unbox_fixnum(obj)); + sexp_write_string(ctx, numbuf, out); +#if SEXP_USE_IMMEDIATE_FLONUMS + } else if (sexp_flonump(obj)) { + f = sexp_flonum_value(obj); +#if SEXP_USE_INFINITIES + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else +#endif + { + i = snprintf(numbuf, NUMBUF_LEN, "%.8g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + 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 SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(obj)) { + 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); + } + } + return SEXP_VOID; +} + +sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + return sexp_write_one(ctx, obj, out); +} + +sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { + sexp res=SEXP_VOID; + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + if (sexp_stringp(obj)) + sexp_write_string(ctx, sexp_string_data(obj), out); + else if (sexp_charp(obj)) + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else + res = sexp_write_one(ctx, obj, out); + return res; +} + +sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), sexp out) { + sexp_flush(ctx, out); + return SEXP_VOID; +} + +#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 'r': c = '\r'; 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, i) : 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, double whole, int negp) { + sexp exponent=SEXP_VOID; + 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; + if (c=='e' || c=='E') { + exponent = sexp_read_number(ctx, in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(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); + } else { + sexp_push_char(ctx, c, in); + } + res = (whole + res) * pow(10, e); + if (negp) res *= -1; + return sexp_make_flonum(ctx, res); +} + +sexp sexp_read_number (sexp ctx, sexp in, int base) { + sexp den; + sexp_uint_t res = 0, tmp; + int c, digit, negativep = 0; + + c = sexp_read_char(ctx, in); + if (c == '-') { + negativep = 1; + c = sexp_read_char(ctx, in); + } + + for ( ; isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + tmp = res * base + digit; +#if SEXP_USE_BIGNUMS + if ((tmp < res) || (tmp > SEXP_MAX_FIXNUM)) { + sexp_push_char(ctx, c, in); + return sexp_read_bignum(ctx, in, res, (negativep ? -1 : 1), base); + } +#endif + res = tmp; + } + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + return sexp_read_float_tail(ctx, in, res, negativep); + } else if (c=='/') { + den = sexp_read_number(ctx, in, base); + if (! sexp_fixnump(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_fixnum(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_fixnum(negativep ? -res : res); +} + +sexp sexp_read_raw (sexp ctx, sexp in) { + char *str; + int c1, c2, line; + sexp tmp2; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, 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); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res); + break; + case '`': + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res); + break; + case ',': + if ((c1 = sexp_read_char(ctx, in)) == '@') { + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_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)) { + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } + res = sexp_cons(ctx, tmp, res); + tmp = sexp_read_raw(ctx, in); + } + 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_fixnum(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_fixnum((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(ctx, in); + if (sexp_fixnump(res)) + res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res)); + break; + case 'f': case 'F': + case 't': case 'T': + c2 = sexp_read_char(ctx, in); + if (c2 == EOF || is_separator(c2)) { + res = (tolower(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; + break; + case '!': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + sexp_port_line(in)++; + 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); + sexp_push_char(ctx, c1, in); + if (c1 == EOF || is_separator(c1)) { + res = SEXP_RAWDOT; + } else if (isdigit(c1)) { + res = sexp_read_float_tail(ctx, in, 0, 0); + } else { + 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 SEXP_USE_FLONUMS + if (sexp_flonump(res)) +#if SEXP_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 +#if SEXP_USE_BIGNUMS + if (sexp_bignump(res)) { + if ((sexp_bignum_hi(res) == 1) + && (sexp_bignum_data(res)[0] == (SEXP_MAX_FIXNUM+1))) + res = sexp_make_fixnum(-sexp_bignum_data(res)[0]); + else + sexp_bignum_sign(res) = -sexp_bignum_sign(res); + } else +#endif + res = sexp_fx_mul(res, SEXP_NEG_ONE); + } + } else { + sexp_push_char(ctx, c2, in); + res = sexp_read_symbol(ctx, in, c1, 1); +#if SEXP_USE_INFINITIES + if (res == sexp_intern(ctx, "+inf.0", -1)) + res = sexp_make_flonum(ctx, 1.0/0.0); + else if (res == sexp_intern(ctx, "-inf.0", -1)) + res = sexp_make_flonum(ctx, -1.0/0.0); + else if (res == sexp_intern(ctx, "+nan.0", -1)) + res = sexp_make_flonum(ctx, 0.0/0.0); +#endif + } + 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_release2(ctx); + return res; +} + +sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in) { + sexp res; + sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in); + res = sexp_read_raw(ctx, in); + if (res == SEXP_CLOSE) + res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); + if (res == SEXP_RAWDOT) + res = sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); + return res; +} + +sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) { + sexp res; + sexp_gc_var2(s, in); + sexp_gc_preserve2(ctx, s, in); + s = sexp_c_string(ctx, str, len); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b) { + int base; + sexp_gc_var1(in); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b); + if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36)) + return sexp_user_exception(ctx, self, "invalid numeric base", b); + sexp_gc_preserve1(ctx, in); + in = sexp_make_input_string_port(ctx, str); + in = ((sexp_string_data(str)[0] == '#') ? + sexp_read(ctx, in) : sexp_read_number(ctx, in, base)); + sexp_gc_release1(ctx); + return sexp_numberp(in) ? in : SEXP_FALSE; +} + +sexp sexp_write_to_string (sexp ctx, sexp obj) { + sexp str; + sexp_gc_var1(out); + sexp_gc_preserve1(ctx, out); + out = sexp_make_output_string_port(ctx); + str = sexp_write(ctx, obj, out); + if (! sexp_exceptionp(str)) + str = sexp_get_output_string(ctx, out); + sexp_gc_release1(ctx); + return str; +} + +void sexp_init (void) { +#if SEXP_USE_GLOBAL_SYMBOLS + int i; +#endif + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if SEXP_USE_BOEHM + GC_init(); +#if SEXP_USE_GLOBAL_SYMBOLS + GC_add_roots((char*)&sexp_symbol_table, + ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); +#endif +#elif ! SEXP_USE_MALLOC + sexp_gc_init(); +#endif +#if SEXP_USE_GLOBAL_SYMBOLS + 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..820020c1 --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,48 @@ + +(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)))) 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/build/build-opts.txt b/tests/build/build-opts.txt new file mode 100644 index 00000000..e6bcd056 --- /dev/null +++ b/tests/build/build-opts.txt @@ -0,0 +1,21 @@ +CPPFLAGS=-DSEXP_USE_MODULES=0 +CPPFLAGS=-DSEXP_USE_DL=0 +CPPFLAGS=-DSEXP_USE_SIMPLIFY=0 +CPPFLAGS=-DSEXP_USE_TYPE_DEFS=0 +SEXP_USE_BOEHM=1 +CPPFLAGS=-DSEXP_USE_DEBUG_GC=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_HEAP=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_TYPES=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_SYMBOLS=1 +CPPFLAGS=-DSEXP_USE_FLONUMS=0 +CPPFLAGS=-DSEXP_USE_IMMEDIATE_FLONUMS=1 +CPPFLAGS=-DSEXP_USE_BIGNUMS=0 +CPPFLAGS=-DSEXP_USE_MATH=0 +CPPFLAGS=-DSEXP_WARN_UNDEFS=0 +CPPFLAGS=-DSEXP_USE_HUFF_SYMS=0 +CPPFLAGS=-DSEXP_USE_HASH_SYMS=0 +CPPFLAGS=-DSEXP_USE_STRING_STREAMS=0 +CPPFLAGS=-DSEXP_USE_AUTOCLOSE_PORTS=0 +CPPFLAGS=-DSEXP_USE_2010_EPOCH=0 +CPPFLAGS=-DSEXP_USE_CHECK_STACK=0 +CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 diff --git a/tests/build/build-tests.sh b/tests/build/build-tests.sh new file mode 100755 index 00000000..1d239629 --- /dev/null +++ b/tests/build/build-tests.sh @@ -0,0 +1,37 @@ +#! /bin/bash + +# test basic build options + +# for bootstrapping reasons this is a shell script, instead of a +# scheme script using (chibi process) + +# we just check each build against r5rs-tests.scm - +# some of the libraries will fail to build (notably +# if modules or user-defined types are disabled). + +BUILDDIR=tests/build +FAILURES=0 +i=0 + +for opts in `cat ${BUILDDIR}/build-opts.txt`; do + make cleaner 2>&1 >/dev/null + if make $opts chibi-scheme 2>&1 >${BUILDDIR}/build${i}-make.out; then + if make test 2>&1 | tee ${BUILDDIR}/build${i}-test.out | grep -q -E 'FAIL|ERROR'; then + echo "[FAIL] ${i}: tests failed with $opts" + FAILURES=$((FAILURES + 1)) + else + echo "[PASS] ${i}: tests passed with $opts" + fi + else + echo "[FAIL] ${i}: couldn't build with $opts" + FAILURES=$((FAILURES + 1)) + fi + i=$((i+1)) +done + +if (( FAILURES == 0 )); then + echo "build-tests: all tests passed" +else + echo "build-tests: ${FAILURES} tests failed" +fi + diff --git a/tests/hash-tests.scm b/tests/hash-tests.scm new file mode 100644 index 00000000..6dec5734 --- /dev/null +++ b/tests/hash-tests.scm @@ -0,0 +1,74 @@ + +(import (srfi 69)) + +(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) + (write *tests-run*) + (display ". ") + (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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test + 'white + (let ((ht (make-hash-table eq?))) + (hash-table-set! ht 'cat 'black) + (hash-table-set! ht 'dog 'white) + (hash-table-set! ht 'elephant 'pink) + (hash-table-ref/default ht 'dog #f))) + +(test + 'white + (let ((ht (make-hash-table equal?))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "dog" #f))) + +(test + 'white + (let ((ht (make-hash-table string-ci=? string-ci-hash))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "DOG" #f))) + +(test 625 + (let ((ht (make-hash-table))) + (do ((i 0 (+ i 1))) ((= i 1000)) + (hash-table-set! ht i (* i i))) + (hash-table-ref/default ht 25 #f))) + +(test-report) + diff --git a/tests/install/install-tests.pl b/tests/install/install-tests.pl new file mode 100755 index 00000000..63681324 --- /dev/null +++ b/tests/install/install-tests.pl @@ -0,0 +1,57 @@ +#! /usr/bin/env perl + +use strict; +use warnings; + +my $ROOT="tests/install/root"; +my $USER=$ENV{USER}; + +my $ignore = qr!/lib\d*/modules|/X11|alsa-lib|aspell|dosemu|emacs|erlang|/perl|python|ruby|lisp|sbcl|/ghc-|ocaml|evolution|office|gimp|gtk|mysql|postgres|wordnet|xulrunner!; + +sub linkdir ($$$) { + my ($FROM, $TO, $DEPTH) = @_; + mkdir $TO; + for my $f (`ls $FROM`) { + chomp $f; + if (-d "$FROM/$f") { + if (($DEPTH > 0) && ($FROM !~ $ignore)) { + linkdir("$FROM/$f", "$TO/$f", $DEPTH-1); + } + } else { + link "$FROM/$f", "$TO/$f"; + } + } +} + +mkdir "$ROOT"; +mkdir "$ROOT/bin"; +mkdir "$ROOT/sbin"; +mkdir "$ROOT/dev"; +mkdir "$ROOT/etc"; +mkdir "$ROOT/etc/alternatives"; +mkdir "$ROOT/lib"; +mkdir "$ROOT/lib64"; +mkdir "$ROOT/usr"; +mkdir "$ROOT/usr/bin"; +mkdir "$ROOT/usr/include"; +mkdir "$ROOT/usr/lib"; +mkdir "$ROOT/usr/lib/gcc"; + +linkdir "/bin", "$ROOT/bin", 1; +linkdir "/sbin", "$ROOT/sbin", 1; +link "/etc/passwd", "$ROOT/etc/passwd"; +linkdir "/etc/alternatives", "$ROOT/etc/alternatives", 1; +linkdir "/lib", "$ROOT/lib", 3; +linkdir "/lib64", "$ROOT/lib64", 3; +linkdir "/usr/bin", "$ROOT/usr/bin", 3; +linkdir "/usr/include", "$ROOT/usr/include", 2; +linkdir "/usr/lib", "$ROOT/usr/lib", 3; +linkdir "/usr/lib/gcc", "$ROOT/usr/lib/gcc", 3; + +`make dist`; +my $VERSION=`cat VERSION`; +chomp $VERSION; +`cp chibi-scheme-$VERSION.tgz $ROOT/`; +`sed -e 's/\@VERSION\@/$VERSION/g' $ROOT/bin/run-install-test.sh`; +`chmod 755 $ROOT/bin/run-install-test.sh`; +exec "sudo chroot $ROOT run-install-test.sh"; diff --git a/tests/install/run-install-test.sh b/tests/install/run-install-test.sh new file mode 100755 index 00000000..c558e7cd --- /dev/null +++ b/tests/install/run-install-test.sh @@ -0,0 +1,12 @@ +#! /bin/bash + +export PATH=/usr/local/bin:$PATH +export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH + +tar xzvf chibi-scheme-@VERSION@.tgz +cd chibi-scheme-@VERSION@ +make +make install +cp tests/r5rs-tests.scm .. +cd .. +chibi-scheme r5rs-tests.scm | tee r5rs-tests.out diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm new file mode 100644 index 00000000..1c49d48f --- /dev/null +++ b/tests/loop-tests.scm @@ -0,0 +1,202 @@ + +(import (chibi loop)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test + "stepping" + '(0 1 2) + (loop lp ((with i 0 (+ i 1)) + (with res '() (cons i res))) + (if (= i 3) + (reverse res) + (lp)))) + +(test + "basic in-list" + '(c b a) + (let ((res '())) + (loop ((for x (in-list '(a b c)))) + (set! res (cons x res))) + res)) + +(test + "in-list with result" + '(c b a) + (loop ((for x (in-list '(a b c))) + (with res '() (cons x res))) + => res)) + +(test + "in-list with listing" + '(a b c) + (loop ((for x (in-list '(a b c))) (for res (listing x))) => res)) + +(test + "in-list with listing-reverse" + '(c b a) + (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res)) + +(test + "uneven length in-list's" + '((a . 1) (b . 2) (c . 3)) + (loop ((for x (in-list '(a b c))) + (for y (in-list '(1 2 3 4))) + (for res (listing (cons x y)))) + => res)) + +(test + "in-lists" + '((a 1) (b 2) (c 3)) + (loop ((for ls (in-lists '((a b c) (1 2 3)))) + (for res (listing ls))) + => res)) + +(define (flatten ls) + (reverse + (loop lp ((for x ls (in-list ls)) (with res '())) + => res + (if (pair? x) + (lp (=> res (lp (=> ls x)))) + (lp (=> res (cons x res))))))) + +(test + "flatten (recursion test)" + '(1 2 3 4 5 6 7) + (flatten '(1 (2) (3 (4 (5)) 6) 7))) + +(test + "in-string" + '(#\h #\e #\l #\l #\o) + (loop ((for c (in-string "hello")) (for res (listing c))) => res)) + +(test + "in-string with start" + '(#\l #\o) + (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res)) + +(test + "in-string with start and end" + '(#\h #\e #\l #\l) + (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res)) + +(test + "in-string with start, end and step" + '(#\e #\l) + (loop ((for c (in-string "hello" 1 4 2)) (for res (listing c))) => res)) + +(test + "in-string-reverse" + '(#\o #\l #\l #\e #\h) + (loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res)) + +(test + "in-vector" + '(1 2 3) + (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res)) + +(test "up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 8))) + (for res (listing i))) + => res)) + +(test "up-from by" '(5 10 15) + (loop ((for i (up-from 5 (to 20) (by 5))) + (for res (listing i))) + => res)) + +(test "up-from listing if" '(10 12 14 16 18) + (loop ((for i (up-from 10 (to 20))) + (for res (listing i (if (even? i))))) + => res)) + +(test "down-from" '(7 6 5) + (loop ((for i (down-from 8 (to 5))) + (for res (listing i))) + => res)) + +(test "down-from by" '(15 10 5) + (loop ((for i (down-from 20 (to 5) (by 5))) + (for res (listing i))) + => res)) + +(test "down-from listing if" '(18 16 14 12 10) + (loop ((for i (down-from 20 (to 10))) + (for res (listing i (if (even? i))))) + => res)) + +(test "appending" '(1 2 3 4 5 6 7 8 9) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending ls))) + => res)) + +(test "appending-reverse" '(9 8 7 6 5 4 3 2 1) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending-reverse ls))) + => res)) + +(test "while + up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 10))) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "up-from by, open-ended" '(5 7 9) + (loop ((for i (up-from 5 (by 2))) + (while (< i 10)) + (for res (listing i))) + => res)) + +(test "up-from open-ended" '(5 6 7) + (loop ((for i (up-from 5)) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "down-from by, open-ended" '(5 3 1) + (loop ((for i (down-from 7 (by 2))) + (until (< i 1)) + (for res (listing i))) + => res)) + +(test "down-from open-ended" '(4 3 2) + (loop ((for i (down-from 5)) + (until (< i 2)) + (for res (listing i))) + => res)) + +(test-report) + diff --git a/tests/match-tests.scm b/tests/match-tests.scm new file mode 100644 index 00000000..a223e729 --- /dev/null +++ b/tests/match-tests.scm @@ -0,0 +1,196 @@ + +(import (chibi match)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test "any" (match 'any (_ 'ok)) 'ok) +(test "symbol" (match 'ok (x x)) 'ok) +(test "number" (match 28 (28 'ok)) 'ok) +(test "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok) +(test "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok) +(test "null" (match '() (() 'ok)) 'ok) +(test "pair" (match '(ok) ((x) x)) 'ok) +(test "vector" (match '#(ok) (#(x) x)) 'ok) +(test "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok) +(test "and empty" (match '(o k) ((and) 'ok)) 'ok) +(test "and single" (match 'ok ((and x) x)) 'ok) +(test "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok) +(test "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok) +(test "or single" (match 'ok ((or x) 'ok)) 'ok) +(test "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok) +(test "not" (match 28 ((not (a . b)) 'ok)) 'ok) +(test "pred" (match 28 ((? number?) 'ok)) 'ok) +(test "named pred" (match 28 ((? number? x) (+ x 1))) 29) + +(test "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok) +(test "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok) +(test "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok) + +(test "ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ___) (list x y))) + '((a b c) (1 2 3))) + +(test "real ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ...) (list x y))) + '((a b c) (1 2 3))) + +(test "vector ellipses" + (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) + (#(a b c (hd . tl) ...) (list a b c hd tl))) + '(1 2 3 (a b c) (1 2 3))) + +(test "pred ellipses" + (match '(1 2 3) + (((? odd? n) ___) n) + (((? number? n) ___) n)) + '(1 2 3)) + +(test "failure continuation" + (match '(1 2) + ((a . b) (=> next) (if (even? a) 'fail (next))) + ((a . b) 'ok)) + 'ok) + +(test "let" + (match-let ((x 'ok) (y '(o k))) + y) + '(o k)) + +(test "let*" + (match-let* ((x 'f) (y 'o) ((z w) (list y x))) + (list x y z w)) + '(f o o f)) + +(test "getter car" + (match '(1 . 2) (((get! a) . b) (list (a) b))) + '(1 2)) + +(test "getter cdr" + (match '(1 . 2) ((a . (get! b)) (list a (b)))) + '(1 2)) + +(test "getter vector" + (match '#(1 2 3) (#((get! a) b c) (list (a) b c))) + '(1 2 3)) + +(test "setter car" + (let ((x (cons 1 2))) + (match x (((set! a) . b) (a 3))) + x) + '(3 . 2)) + +(test "setter cdr" + (let ((x (cons 1 2))) + (match x ((a . (set! b)) (b 3))) + x) + '(1 . 3)) + +(test "setter vector" + (let ((x (vector 1 2 3))) + (match x (#(a (set! b) c) (b 0))) + x) + '#(1 0 3)) + +(test "single tail" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) (c . 3))) + +(test "single tail 2" + (match '((a . 1) (b . 2) 3) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) 3)) + +(test "multiple tail" + (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) + (((x . y) ... u v w) (list x y u v w))) + '((a b) (1 2) (c . 3) (d . 4) (e . 5))) + +(test "Riastradh quasiquote" + (match '(1 2 3) (`(1 ,b ,c) (list b c))) + '(2 3)) + +(test "trivial tree search" + (match '(1 2 3) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "simple tree search" + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "deep tree search" + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "non-tail tree search" + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "restricted tree search" + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "fail restricted tree search" + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f)) + #f) + +(test "sxml tree search" + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f)) + '(((href . "http://synthcode.com/")) ("synthcode"))) + +(test "failed sxml tree search" + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f)) + #f) + +(test "collect tree search" + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f)) + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))) + +(test-report) + diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm new file mode 100644 index 00000000..76a783f0 --- /dev/null +++ b/tests/numeric-tests.scm @@ -0,0 +1,150 @@ + +;; these tests are only valid if chibi-scheme is compiled with full +;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-neighborhoods x) + (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) + +(test '(536870912 536870913 536870911 -536870912 -536870911 -536870913) + (integer-neighborhoods (expt 2 29))) + +(test '(1073741824 1073741825 1073741823 -1073741824 -1073741823 -1073741825) + (integer-neighborhoods (expt 2 30))) + +(test '(2147483648 2147483649 2147483647 -2147483648 -2147483647 -2147483649) + (integer-neighborhoods (expt 2 31))) + +(test '(4294967296 4294967297 4294967295 -4294967296 -4294967295 -4294967297) + (integer-neighborhoods (expt 2 32))) + +(test '(4611686018427387904 4611686018427387905 4611686018427387903 + -4611686018427387904 -4611686018427387903 -4611686018427387905) + (integer-neighborhoods (expt 2 62))) + +(test '(9223372036854775808 9223372036854775809 9223372036854775807 + -9223372036854775808 -9223372036854775807 -9223372036854775809) + (integer-neighborhoods (expt 2 63))) + +(test '(18446744073709551616 18446744073709551617 18446744073709551615 + -18446744073709551616 -18446744073709551615 -18446744073709551617) + (integer-neighborhoods (expt 2 64))) + +(test '(85070591730234615865843651857942052864 + 85070591730234615865843651857942052865 + 85070591730234615865843651857942052863 + -85070591730234615865843651857942052864 + -85070591730234615865843651857942052863 + -85070591730234615865843651857942052865) + (integer-neighborhoods (expt 2 126))) + +(test '(170141183460469231731687303715884105728 + 170141183460469231731687303715884105729 + 170141183460469231731687303715884105727 + -170141183460469231731687303715884105728 + -170141183460469231731687303715884105727 + -170141183460469231731687303715884105729) + (integer-neighborhoods (expt 2 127))) + +(test '(340282366920938463463374607431768211456 + 340282366920938463463374607431768211457 + 340282366920938463463374607431768211455 + -340282366920938463463374607431768211456 + -340282366920938463463374607431768211455 + -340282366920938463463374607431768211457) + (integer-neighborhoods (expt 2 128))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-arithmetic-combinations a b) + (list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b))) + +(define (sign-combinations a b) + (list (integer-arithmetic-combinations a b) + (integer-arithmetic-combinations (- a) b) + (integer-arithmetic-combinations a (- b)) + (integer-arithmetic-combinations (- a) (- b)))) + +;; fix x fix +(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0)) + (sign-combinations 0 1)) +(test '((2 0 1 1 0) (0 -2 -1 -1 0) (0 2 -1 -1 0) (-2 0 1 1 0)) + (sign-combinations 1 1)) +(test '((59 25 714 2 8) (-25 -59 -714 -2 -8) + (25 59 -714 -2 8) (-59 -25 714 2 -8)) + (sign-combinations 42 17)) + +;; fix x big +(test '((4294967338 -4294967254 180388626432 0 42) + (4294967254 -4294967338 -180388626432 0 -42) + (-4294967254 4294967338 -180388626432 0 42) + (-4294967338 4294967254 180388626432 0 -42)) + (sign-combinations 42 (expt 2 32))) + +;; big x fix +(test '((4294967338 4294967254 180388626432 102261126 4) + (-4294967254 -4294967338 -180388626432 -102261126 -4) + (4294967254 4294967338 -180388626432 -102261126 4) + (-4294967338 -4294967254 180388626432 102261126 -4)) + (sign-combinations (expt 2 32) 42)) + +;; big x bigger +(test '((12884901889 -4294967297 36893488151714070528 0 4294967296) + (4294967297 -12884901889 -36893488151714070528 0 -4294967296) + (-4294967297 12884901889 -36893488151714070528 0 4294967296) + (-12884901889 4294967297 36893488151714070528 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) + +(test '((18446744078004518913 -18446744069414584321 79228162514264337597838917632 0 4294967296) + (18446744069414584321 -18446744078004518913 -79228162514264337597838917632 0 -4294967296) + (-18446744069414584321 18446744078004518913 -79228162514264337597838917632 0 4294967296) + (-18446744078004518913 18446744069414584321 79228162514264337597838917632 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 64)))) + +;; bigger x big +(test '((12884901889 4294967297 36893488151714070528 2 1) + (-4294967297 -12884901889 -36893488151714070528 -2 -1) + (4294967297 12884901889 -36893488151714070528 -2 1) + (-12884901889 -4294967297 36893488151714070528 2 -1)) + (sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) + +(test '((18446744078004518913 18446744069414584321 79228162514264337597838917632 4294967296 1) + (-18446744069414584321 -18446744078004518913 -79228162514264337597838917632 -4294967296 -1) + (18446744069414584321 18446744078004518913 -79228162514264337597838917632 -4294967296 1) + (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1)) + (sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) + +(test-report) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..80db4e00 --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,483 @@ + +(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) + (write *tests-run*) + (display ". ") + (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 -2 (let () + (define x 2) + (define f (lambda () (- x))) + (f))) + +(define let*-def 1) +(let* () (define let*-def 2) #f) +(test 1 let*-def) + +(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 4 16 9 8) + `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 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 #f (eqv? 2 2.0)) + +;;(test #f (equal? 2.0 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)) + +;;;; these will fail when compiled either without flonums or trig funcs + +;; (test #t (= -5 (floor -4.3))) + +;; (test #t (= -4 (ceiling -4.3))) + +;; (test #t (= -4 (truncate -4.3))) + +;; (test #t (= -4 (round -4.3))) + +;; (test #t (= 3 (floor 3.5))) + +;; (test #t (= 4 (ceiling 3.5))) + +;; (test #t (= 3 (truncate 3.5))) + +;; (test #t (= 4 (round 3.5))) + +(test 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 127 (string->number "177" 8)) + +(test 5 (string->number "101" 2)) + +(test 100.0 (string->number "1e2")) + +(test "100" (number->string 100)) + +(test "100" (number->string 256 16)) + +(test "FF" (number->string 255 16)) + +(test "177" (number->string 127 8)) + +(test "101" (number->string 5 2)) + +(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 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + +(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 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad)))) + +(test 'ok (let ((=> 1)) (cond (#t => 'ok)))) + +(test '(,foo) (let ((unquote 1)) `(,foo))) + +(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) + +(test 'ok + (let ((... 2)) + (let-syntax ((s (syntax-rules () + ((_ x ...) 'bad) + ((_ . r) 'ok)))) + (s a b c)))) + +(test 'ok (let () + (let-syntax () + (define internal-def 'ok)) + internal-def)) + +(test 'ok (let () + (letrec-syntax () + (define internal-def 'ok)) + internal-def)) + +(test '(2 1) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y)))))) + +(test '(2 2) + ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y)))))) + +(test '(1 2) + ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y)))))) + +(test '(2 3) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) + +(test '(a b c) + (let* ((path '()) + (add (lambda (s) (set! path (cons s path))))) + (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) + (reverse path))) + +(test '(connect talk1 disconnect connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + +(test 2 (let-syntax + ((foo (syntax-rules ::: () + ((foo ... args :::) + (args ::: ...))))) + (foo 3 - 5))) + +(test '(5 4 1 2 3) + (let-syntax + ((foo (syntax-rules () + ((foo args ... penultimate ultimate) + (list ultimate penultimate args ...))))) + (foo 1 2 3 4 5))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm new file mode 100644 index 00000000..5471e648 --- /dev/null +++ b/tests/sort-tests.scm @@ -0,0 +1,57 @@ + +(import (srfi 95)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test "sort null" (sort '()) '()) +(test "sort null <" (sort '() <) '()) +(test "sort null < car" (sort '() < car) '()) +(test "sort list" (sort '(7 5 2 8 1 6 4 9 3)) '(1 2 3 4 5 6 7 8 9)) +(test "sort list <" (sort '(7 5 2 8 1 6 4 9 3) <) '(1 2 3 4 5 6 7 8 9)) +(test "sort list < car" (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car) + '((1) (2) (3) (4) (5) (6) (7) (8) (9))) +(test "sort list (lambda (a b) (< (car a) (car b)))" + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) + (lambda (a b) (< (car a) (car b)))) + '((1) (2) (3) (4) (5) (6) (7) (8) (9))) +(test "sort 1-char symbols" (sort '(h b k d a c j i e g f)) + '(a b c d e f g h i j k)) +(test "sort short symbols" (sort '(h b aa k d a ee c j i e g f)) + '(a aa b c d e ee f g h i j k)) +(test "sort long symbols" (sort '(h b aa k d a ee c j i bzzzzzzzzzzzzzzzzzzzzzzz e g f)) + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz c d e ee f g h i j k)) + +(test-report) diff --git a/tools/genstatic.scm b/tools/genstatic.scm new file mode 100755 index 00000000..3382698e --- /dev/null +++ b/tools/genstatic.scm @@ -0,0 +1,135 @@ +#! /usr/bin/env chibi-scheme + +(import (chibi filesystem) + (chibi pathname)) + +(define c-libs '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (path-relative path dir) + (let ((p-len (string-length path)) + (d-len (string-length dir))) + (and (> p-len d-len) + (string=? dir (substring path 0 d-len)) + (cond + ((eqv? #\/ (string-ref path d-len)) + (substring path (+ d-len 1) p-len)) + ((eqv? #\/ (string-ref path (- d-len 1))) + (substring path d-len p-len)) + (else #f))))) + +(define (path-split file) + (let ((len (string-length file))) + (let lp ((i 0) (res '())) + (let ((j (string-scan #\/ file i))) + (cond + (j (lp (+ j 1) (cons (substring file i j) res))) + (else (reverse (if (= i len) + res + (cons (substring file i len) res))))))))) + +(define (init-name mod) + (string-append "sexp_init_lib_" + (string-concatenate (map mangle mod) "_"))) + +(define (find-c-libs basedir) + (define (process-dir dir) + (directory-fold + dir + (lambda (f x) + (if (and (not (equal? "" f)) (not (eqv? #\. (string-ref f 0)))) + (process (string-append dir "/" f)))) + #f)) + (define (process file) + (cond + ((file-directory? file) + (process-dir file)) + ((equal? "module" (path-extension file)) + (let* ((mod-path (path-strip-extension (path-relative file basedir))) + (mod-name (map (lambda (x) (or (string->number x) (string->symbol x))) + (path-split mod-path)))) + (cond + ((eval `(find-module ',mod-name) *config-env*) + => (lambda (mod) + (cond + ((assq 'include-shared (vector-ref mod 2)) + => (lambda (x) + (set! c-libs + (cons (cons (string-append + (path-directory file) + "/" + (cadr x) + ".c") + (init-name mod-name)) + c-libs)))))))))))) + (process-dir basedir)) + +(define (include-c-lib lib) + (display "#define sexp_init_library ") + (display (cdr lib)) + (newline) + (display "#include \"") + (display (car lib)) + (display "\"") + (newline) + (display "#undef sexp_init_library") + (newline) + (newline)) + +(define (init-c-lib lib) + (display " ") + (display (cdr lib)) + (display "(ctx, env);\n")) + +(define (main args) + (find-c-libs (if (pair? (cdr args)) (cadr args) "lib")) + (newline) + (for-each include-c-lib c-libs) + (newline) + (display "static sexp sexp_init_all_libraries (sexp ctx, sexp env) {\n") + (for-each init-c-lib c-libs) + (display " return SEXP_VOID;\n") + (display "}\n\n")) + diff --git a/tools/genstubs.scm b/tools/genstubs.scm new file mode 100755 index 00000000..77acbe26 --- /dev/null +++ b/tools/genstubs.scm @@ -0,0 +1,1237 @@ +#! /usr/bin/env chibi-scheme + +;; Note: this evolved as a throw-away script to provide certain core +;; modules, and so is a mess. Tread carefully. + +;; Simple C FFI. "genstubs.scm file.stub" will read in the C function +;; FFI definitions from file.stub and output the appropriate C +;; wrappers into file.c. You can then compile that file with: +;; +;; cc -fPIC -shared file.c -lchibi-scheme +;; +;; (or using whatever flags are appropriate to generate shared libs on +;; your platform) and then the generated .so file can be loaded +;; directly with load, or portably using (include-shared "file") in a +;; module definition (note that include-shared uses no suffix). + +;; The goal of this interface is to make access to C types and +;; functions easy, without requiring the user to write any C code. +;; That means the stubber needs to be intelligent about various C +;; calling conventions and idioms, such as return values passed in +;; actual parameters. Writing C by hand is still possible, and +;; several of the core modules provide C interfaces directly without +;; using the stubber. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Struct Interface +;; +;; (define-c-struct struct-name +;; [predicate: predicate-name] +;; [constructor: constructor-name] +;; [finalizer: c_finalizer_name] +;; (type c_field_name getter-name setter-name) ...) +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Function Interface +;; +;; (define-c return-type name-spec (arg-type ...)) +;; +;; where name-space is either a symbol name, or a list of +;; (scheme-name c_name). If just a symbol, the C name is taken +;; to be the same with -'s replaced by _'s. +;; +;; arg-type is a type suitable for input validation and conversion. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Types +;; +;; Types +;; +;; Basic Types +;; void +;; boolean +;; char +;; sexp (no conversions) +;; +;; Integer Types: +;; signed-char short int long +;; unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t +;; time_t (in seconds, but using the chibi epoch of 2010/01/01) +;; errno (as a return type returns #f on error) +;; +;; Float Types: +;; float double long-double +;; +;; String Types: +;; string - a null-terminated char* +;; env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme +;; in addition you can use (array char) as a string +;; +;; Port Types: +;; input-port output-port +;; +;; Struct Types: +;; +;; Struct types are by default just referred to by the bare +;; struct-name from define-c-struct, and it is assumed you want a +;; pointer to that type. To refer to the full struct, use the struct +;; modifier, as in (struct struct-name). + +;; Type modifiers +;; +;; Any type may also be written as a list of modifiers followed by the +;; type itself. The supported modifiers are: +;; +;; const: prepends the "const" C type modifier +;; * as a return or result parameter, makes non-immediates immutable +;; +;; free: it's Scheme's responsibility to "free" this resource +;; * as a return or result parameter, registers the freep flag +;; this causes the type finalizer to be run when GCed +;; +;; maybe-null: this pointer type may be NULL +;; * as a result parameter, NULL is translated to #f +;; normally this would just return a wrapped NULL pointer +;; * as an input parameter, #f is translated to NULL +;; normally this would be a type error +;; +;; pointer: create a pointer to this type +;; * as a return parameter, wraps the result in a vanilla cpointer +;; * as a result parameter, boxes then unboxes the value +;; +;; struct: treat this struct type as a struct, not a pointer +;; * as an input parameter, dereferences the pointer +;; * as a type field, indicates a nested struct +;; +;; link: add a gc link +;; * as a field getter, link to the parent object, so the +;; parent won't be GCed so long as we have a reference +;; to the child. this behavior is automatic for nested +;; structs. +;; +;; result: return a result in this parameter +;; * if there are multiple results (including the return type), +;; they are all returned in a list +;; * if there are any result parameters, a return type +;; of errno returns #f on failure, and as eliminated +;; from the list of results otherwise +;; +;; (value ): specify a fixed value +;; * as an input parameter, this parameter is not provided +;; in the Scheme API but always passed as +;; +;; (default ): specify a default value +;; * as the final input parameter, makes the Scheme parameter +;; optional, defaulting to +;; +;; (array []) an array type +;; * length must be specified for return and result parameters +;; * if specified, length can be any of +;; ** an integer, for a fixed size +;; ** the symbol null, indicating a NULL-terminated array + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; globals + +(define *types* '()) +(define *funcs* '()) +(define *consts* '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type objects + +(define (parse-type type . o) + (cond + ((vector? type) + type) + (else + (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) + (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f) + (value #f) (default? #f)) + (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) + (case (and (pair? type) (car type)) + ((free) + (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) + ((const) + (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) + ((maybe-null) + (lp (next) free? const? #t ptr? struct? link? result? array value default?)) + ((pointer) + (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) + ((struct) + (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) + ((link) + (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) + ((result) + (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) + ((array) + (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) + ((value) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) + ((default) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) + (else + (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) + +(define (type-base type) (vector-ref type 0)) +(define (type-free? type) (vector-ref type 1)) +(define (type-const? type) (vector-ref type 2)) +(define (type-null? type) (vector-ref type 3)) +(define (type-pointer? type) (vector-ref type 4)) +(define (type-struct? type) (vector-ref type 5)) +(define (type-link? type) (vector-ref type 6)) +(define (type-result? type) (vector-ref type 7)) +(define (type-array type) (vector-ref type 8)) +(define (type-value type) (vector-ref type 9)) +(define (type-default? type) (vector-ref type 10)) +(define (type-index type) (vector-ref type 11)) + +(define (type-auto-expand? type) + (and (pair? (type-array type)) + (memq 'auto-expand (type-array type)))) + +(define (type-index-string type) + (if (integer? (type-index type)) + (number->string (type-index type)) + "")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type predicates + +(define (signed-int-type? type) + (memq type '(signed-char short int long boolean))) + +(define (unsigned-int-type? type) + (memq type '(unsigned-char unsigned-short unsigned-int unsigned-long + size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t + uid_t gid_t pid_t blksize_t blkcnt_t sigval_t))) + +(define (int-type? type) + (or (signed-int-type? type) (unsigned-int-type? type))) + +(define (float-type? type) + (memq type '(float double long-double long-long-double))) + +(define (string-type? type) + (or (memq type '(char* string env-string non-null-string)) + (and (vector? type) + (type-array type) + (not (type-pointer? type)) + (eq? 'char (type-base type))))) + +(define (port-type? type) + (memq type '(port input-port output-port))) + +(define (error-type? type) + (memq type '(errno non-null-string non-null-pointer))) + +(define (array-type? type) + (and (type-array type) (not (eq? 'char (type-base type))))) + +(define (basic-type? type) + (let ((type (parse-type type))) + (and (not (type-array type)) + (not (void-pointer-type? type)) + (not (assq (type-base type) *types*))))) + +(define (void-pointer-type? type) + (or (and (eq? 'void (type-base type)) (type-pointer? type)) + (eq? 'void* (type-base type)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; function objects + +(define (parse-func func) + (if (not (and (= 3 (length func)) + (or (identifier? (cadr func)) (list (cadr func))) + (list (caddr func)))) + (error "bad function definition" func)) + (let* ((ret-type (parse-type (car func))) + (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) + (c-name (if (pair? (cadr func)) + (cadadr func) + (mangle scheme-name))) + (stub-name (if (and (pair? (cadr func)) (pair? (cddadr func))) + (car (cddadr func)) + (generate-stub-name scheme-name)))) + (let lp ((ls (caddr func)) + (i 0) + (results '()) + (c-args '()) + (s-args '())) + (cond + ((null? ls) + (if (> i 6) + (error "FFI currently only supports up to 6 scheme args" func)) + (vector scheme-name c-name stub-name ret-type + (reverse results) (reverse c-args) (reverse s-args))) + (else + (let ((type (parse-type (car ls) i))) + (cond + ((type-result? type) + (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) + ((and (type-value type) (not (type-default? type))) + (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) + (else + (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) + ))))))) + +(define (func-scheme-name func) (vector-ref func 0)) +(define (func-c-name func) (vector-ref func 1)) +(define (func-stub-name func) (vector-ref func 2)) +(define (func-ret-type func) (vector-ref func 3)) +(define (func-results func) (vector-ref func 4)) +(define (func-c-args func) (vector-ref func 5)) +(define (func-scheme-args func) (vector-ref func 6)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (cat . args) + (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (filter pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (cons (car ls) (filter pred (cdr ls)))) + (else (filter pred (cdr ls))))) + +(define (remove pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (filter pred (cdr ls))) + (else (cons (car ls) (filter pred (cdr ls)))))) + +(define (strip-extension path) + (let lp ((i (- (string-length path) 1))) + (cond ((<= i 0) path) + ((eq? #\. (string-ref path i)) (substring path 0 i)) + (else (lp (- i 1)))))) + +(define (string-concatenate-reverse ls) + (cond ((null? ls) "") + ((null? (cdr ls)) (car ls)) + (else (string-concatenate (reverse ls))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase str) + (list->string (map char-downcase (string->list str)))) + +(define (with-output-to-string thunk) + (call-with-output-string + (lambda (out) + (let ((old-out (current-output-port))) + (current-output-port out) + (thunk) + (current-output-port old-out))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; naming + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +(define (generate-stub-name sym) + (string-append "sexp_" (mangle sym) "_stub")) + +(define (type-id-name sym) + (string-append "sexp_" (mangle sym) "_type_id")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; .stub file interface + +(define (c-declare . args) + (apply cat args) + (newline)) + +(define (c-include header) + (cat "\n#include \"" header "\"\n")) + +(define (c-system-include header) + (cat "\n#include <" header ">\n")) + +(define (parse-struct-like ls) + (let lp ((ls ls) (res '())) + (cond + ((null? ls) + (reverse res)) + ((symbol? (car ls)) + (lp (cddr ls) (cons (cadr ls) (cons (car ls) res)))) + ((pair? (car ls)) + (lp (cdr ls) (cons (cons (parse-type (caar ls)) (cdar ls)) res))) + (else + (lp (cdr ls) (cons (car ls) res)))))) + +(define-syntax define-struct-like + (er-macro-transformer + (lambda (expr rename compare) + (set! *types* + `((,(cadr expr) + ,@(parse-struct-like (cddr expr))) + ,@*types*)) + `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) + +(define-syntax define-c-struct + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr))))) + +(define-syntax define-c-class + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) + +(define-syntax define-c-type + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) ,@(cddr expr))))) + +(define-syntax define-c + (er-macro-transformer + (lambda (expr rename compare) + (set! *funcs* (cons (parse-func (cdr expr)) *funcs*)) + #f))) + +(define-syntax define-c-const + (er-macro-transformer + (lambda (expr rename compare) + (set! *consts* + (cons (cons (parse-type (cadr expr)) (cddr expr)) *consts*))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; C code generation + +(define (c->scheme-converter type val . o) + (let ((base (type-base type))) + (cond + ((and (eq? base 'void) (not (type-pointer? type))) + (cat "((" val "), SEXP_VOID)")) + ((or (eq? base 'sexp) (error-type? base)) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_make_boolean(" val ")")) + ((eq? base 'time_t) + (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) + ((unsigned-int-type? base) + (cat "sexp_make_unsigned_integer(ctx, " val ")")) + ((signed-int-type? base) + (cat "sexp_make_integer(ctx, " val ")")) + ((eq? base 'char) + (if (type-array type) + (cat "sexp_c_string(ctx, " val ", -1)") + (cat "sexp_make_character(ctx, " val ")"))) + ((eq? 'env-string base) + (cat "(p=strchr(" val ", '=') ? " + "sexp_cons(ctx, str=sexp_c_string(ctx, " val ", p - " val "), str=sexp_c_string(ctx, p, -1))" + " : sexp_cons(ctx, str=" val ", SEXP_FALSE)")) + ((string-type? base) + (cat "sexp_c_string(ctx, " val ", -1)")) + ((eq? 'input-port base) + (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)")) + ((eq? 'output-port base) + (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) + (else + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) + (cond + ((or ctype void*?) + (cat "sexp_make_cpointer(ctx, " + (if void*? "SEXP_CPOINTER" (type-id-name base)) ", " + val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " + (if (or (type-free? type) + (and (type-result? type) (not (basic-type? type)))) + 1 + 0) + ")")) + (else + (error "unknown type" base)))))))) + +(define (scheme->c-converter type val) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'sexp) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_truep(" val ")")) + ((eq? base 'time_t) + (cat "sexp_unshift_epoch(sexp_uint_value(" val "))")) + ((signed-int-type? base) + (cat "sexp_sint_value(" val ")")) + ((unsigned-int-type? base) + (cat "sexp_uint_value(" val ")")) + ((eq? base 'char) + (cat "sexp_unbox_character(" val ")")) + ((eq? base 'env-string) + (cat "sexp_concat_env_string(" val ")")) + ((string-type? base) + (cat "sexp_string_data(" val ")")) + ((eq? base 'port-or-fd) + (cat "(sexp_portp(" val ") ? fileno(sexp_port_stream(" val "))" + " : sexp_unbox_fixnum(" val "))")) + ((port-type? base) + (cat "sexp_port_stream(" val ")")) + (else + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) + (cond + ((or ctype void*?) + (cat "(" (type-c-name type) ")" + (if (type-null? type) + "sexp_cpointer_maybe_null_value" + "sexp_cpointer_value") + "(" val ")")) + (else + (error "unknown type" base)))))))) + +(define (type-predicate type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "sexp_exact_integerp") + ((float-type? base) "sexp_flonump") + ((string-type? base) "sexp_stringp") + ((eq? base 'char) "sexp_charp") + ((eq? base 'boolean) "sexp_booleanp") + ((eq? base 'port) "sexp_portp") + ((eq? base 'input-port) "sexp_iportp") + ((eq? base 'output-port) "sexp_oportp") + (else #f)))) + +(define (type-name type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "integer") + ((float-type? base) "flonum") + ((eq? 'boolean base) "int") + (else base)))) + +(define (base-type-c-name base) + (case base + ((string env-string non-null-string) "char*") + (else (symbol->string base)))) + +(define (type-struct-type type) + (let ((type-spec (assq (if (vector? type) (type-base type) type) *types*))) + (cond ((and type-spec (memq 'type: type-spec)) => cadr) + (else #f)))) + +(define (type-c-name type) + (let* ((type (parse-type type)) + (base (type-base type)) + (type-spec (assq base *types*)) + (struct-type (type-struct-type type))) + (string-append + (if (type-const? type) "const " "") + (if struct-type (string-append (symbol->string struct-type) " ") "") + (string-replace (base-type-c-name base) #\- " ") + (if type-spec "*" "") + (if (type-pointer? type) "*" "")))) + +(define (check-type arg type) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'env-string) + (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg + ")) && sexp_stringp(sexp_cdr(" arg ")))")) + ((or (int-type? base) (float-type? base) + (string-type? base) (port-type? base)) + (cat (type-predicate type) "(" arg ")")) + ((or (assq base *types*) (void-pointer-type? type)) + (cat + (if (type-null? type) "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " + (if (void-pointer-type? type) "SEXP_CPOINTER" (type-id-name base)) "))" + (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) + (else + (display "WARNING: don't know how to check: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (cat "1"))))) + +(define (type-id-number type) + (let ((base (type-base type))) + (cond + ((int-type? base) "SEXP_FIXNUM") + ((float-type? base) "SEXP_FLONUM") + ((string-type? base) "SEXP_STRING") + ((eq? base 'char) "SEXP_CHAR") + ((eq? base 'boolean) "SEXP_BOOLEAN") + ((eq? base 'port) "SEXP_IPORT") + ((eq? base 'input-port) "SEXP_IPORT") + ((eq? base 'output-port) "SEXP_OPORT") + (else (type-id-name base))))) + +(define (write-validator arg type) + (let* ((type (parse-type type)) + (array (type-array type)) + (base-type (type-base type))) + (cond + ((and array (not (string-type? type))) + (cond + ((number? array) + (cat " if (!sexp_listp(ctx, " arg ")" + " || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n" + " return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n"))) + (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" + " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" + " return sexp_xtype_exception(ctx, self, \"not a list of " + (type-name type) "s\", " arg ");\n") + (if (not (number? array)) + (cat " if (! sexp_nullp(res))\n" + " return sexp_xtype_exception(ctx, self, \"not a list of " + (type-name type) "s\", " arg ");\n"))) + ((eq? base-type 'port-or-fd) + (cat "if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" + " return sexp_xtype_exception(ctx, self, \"not a port of file descriptor\"," arg ");\n")) + ((or (int-type? base-type) + (float-type? base-type) + (string-type? base-type) + (port-type? base-type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) + ((or (assq base-type *types*) (void-pointer-type? type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) + ((eq? 'sexp base-type)) + ((string-type? type) + (write-validator arg 'string)) + (else + (display "WARNING: don't know how to validate: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)))))) + +(define (write-parameters args) + (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) + +(define (get-array-length func x) + (let ((len (if (pair? (type-array x)) + (car (reverse (type-array x))) + (type-array x)))) + (if (number? len) + len + (and (symbol? len) + (let* ((str (symbol->string len)) + (len2 (string-length str))) + (and (> len2 3) + (string=? "arg" (substring str 0 3)) + (let ((i (string->number (substring str 3 len2)))) + (if i + (let ((y (list-ref (func-c-args func) i))) + (or (type-value y) len)))))))))) + +(define (write-locals func) + (define (arg-res x) + (string-append "res" (type-index-string x))) + (let* ((ret-type (func-ret-type func)) + (results (func-results func)) + (scheme-args (func-scheme-args func)) + (return-res? (not (error-type? (type-base ret-type)))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons ret-type results))) + (gc-vars (map arg-res results)) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (sexps (if preserve-res? '() '("res"))) + (num-gc-vars (length gc-vars)) + (ints (if (or return-res? + (memq (type-base ret-type) + '(non-null-string non-null-pointer))) + '() + '("err"))) + (ints (if (or (array-type? ret-type) + (any array-type? results) + (any array-type? scheme-args)) + (cons "i" ints) + ints))) + (case (type-base ret-type) + ((non-null-string) (cat " char *err;\n")) + ((non-null-pointer) (cat " void *err;\n"))) + (cond + ((pair? ints) + (cat " int " (car ints)) + (for-each (lambda (x) (display ", ") (display x)) (cdr ints)) + (cat ";\n"))) + (if (any (lambda (a) (eq? 'env-string (type-base a))) + (cons ret-type results)) + (cat " char *p;\n")) + (for-each + (lambda (x) + (let ((len (get-array-length func x))) + (cat " " (type-c-name (type-base x)) " ") + (if (and (type-array x) (not (number? len))) + (cat "*")) + (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) + (if (number? len) + (cat "[" len "]")) + (cat ";\n") + (if (or (vector? len) (type-auto-expand? x)) + (cat " int len" (type-index x) ";\n")) + (if (type-auto-expand? x) + (cat " " (type-c-name (type-base x)) + " *tmp" (type-index-string x) ";\n")))) + (append (if (type-array ret-type) (list ret-type) '()) + results + (remove type-result? (filter type-array scheme-args)))) + (for-each + (lambda (arg) + (cond + ((and (type-pointer? arg) (basic-type? arg)) + (cat " " (type-c-name (type-base arg)) + " tmp" (type-index arg) ";\n")))) + scheme-args) + (cond + ((pair? sexps) + (cat " sexp " (car sexps)) + (for-each (lambda (x) (display ", ") (display x)) (cdr sexps)) + (cat ";\n"))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_var" num-gc-vars "(") + (display (car gc-vars)) + (for-each (lambda (x) (display ", ") (display x)) (cdr gc-vars)) + (cat ");\n") + (cat " sexp_gc_preserve" num-gc-vars "(ctx") + (for-each (lambda (x) (display ", ") (display x)) gc-vars) + (cat ");\n"))))) + +(define (write-validators args) + (for-each + (lambda (a) + (write-validator (string-append "arg" (type-index-string a)) a)) + args)) + +(define (write-temporaries func) + (for-each + (lambda (a) + (let ((len (and (type-array a) (get-array-length func a)))) + (cond + ((and (type-array a) (or (vector? len) (type-auto-expand? a))) + (cat " len" (type-index a) " = " + (lambda () + (if (number? len) (cat len) (scheme->c-converter 'int len))) + ";\n" + " tmp" (type-index a) " = buf" (type-index a) ";\n"))) + (cond + ((and (not (type-result? a)) (type-array a) (not (string-type? a))) + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) + " = (" (type-c-name (type-base a)) "*) malloc(" + "(sexp_unbox_fixnum(sexp_length(ctx, arg" (type-index a) + "))+1) * sizeof(tmp" (type-index a) "[0]));\n")) + (cat " for (i=0, res=arg" (type-index a) + "; sexp_pairp(res); res=sexp_cdr(res), i++) {\n" + " tmp" (type-index a) "[i] = " + (lambda () (scheme->c-converter (type-base a) "sexp_car(res)")) + ";\n" + " }\n") + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) "[i] = NULL;\n"))) + ((and (type-result? a) (not (basic-type? a)) + (not (type-free? a)) (not (type-pointer? a)) + (not (type-auto-expand? a)) + (or (not (type-array a)) + (not (integer? len)))) + (cat " tmp" (type-index a) " = malloc(" + (if (and (symbol? len) (not (eq? len 'null))) + (lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len)) + "*sizeof(tmp" (type-index a) "[0])")) + (lambda () (cat "sizeof(tmp" (type-index a) "[0])"))) + ");\n")) + ((and (type-pointer? a) (basic-type? a)) + (cat " tmp" (type-index a) " = " + (lambda () + (scheme->c-converter + a + (string-append "arg" (type-index-string a)))) + ";\n"))))) + (func-c-args func))) + +(define (write-actual-parameter func arg) + (cond + ((and (not (type-default? arg)) (type-value arg)) + => (lambda (x) + (cond + ((any (lambda (y) + (and (type-array y) + (type-auto-expand? y) + (eq? x (get-array-length func y)))) + (func-c-args func)) + => (lambda (y) (cat "len" (type-index y)))) + (else (write x))))) + ((or (type-result? arg) (type-array arg)) + (cat (if (or (type-pointer? arg) (type-free? arg) (basic-type? arg)) + "&" + "") + "tmp" (type-index arg))) + ((and (type-pointer? arg) (basic-type? arg)) + (cat "&tmp" (type-index arg))) + (else + (scheme->c-converter + arg + (string-append "arg" (type-index-string arg)))))) + +(define (write-call func) + (let ((ret-type (func-ret-type func)) + (c-name (func-c-name func)) + (c-args (func-c-args func))) + (if (any type-auto-expand? (func-c-args func)) + (cat " loop:\n")) + (cat (cond ((error-type? (type-base ret-type)) " err = ") + ((type-array ret-type) " tmp = ") + (else " res = "))) + ((if (type-array ret-type) + (lambda (t f x) (f)) + c->scheme-converter) + ret-type + (lambda () + (cat c-name "(") + (for-each + (lambda (arg) + (if (> (type-index arg) 0) (cat ", ")) + (write-actual-parameter func arg)) + c-args) + (cat ")")) + (cond + ((any type-link? (func-c-args func)) + => (lambda (a) (string-append "arg" (type-index-string a)))) + (else #f))) + (cat ";\n") + (if (type-array ret-type) + (write-result ret-type)))) + +(define (write-result result) + (let ((res (string-append "res" (type-index-string result))) + (tmp (string-append "tmp" (type-index-string result)))) + (cond + ((and (type-array result) (eq? 'char (type-base result))) + (cat " " res " = " (lambda () (c->scheme-converter result tmp)) ";\n")) + ((type-array result) + (cat " " res " = SEXP_NULL;\n") + (let ((auto-expand? + (and (pair? (type-array result)) + (memq 'auto-expand (type-array result)))) + (len (if (pair? (type-array result)) + (car (reverse (type-array result))) + (type-array result)))) + (cond + ((eq? 'null len) + (cat " for (i=0; " tmp "[i]; i++) {\n" + " sexp_push(ctx, " res ", " + (if (eq? 'string (type-base result)) + "str=" + (lambda () (cat "SEXP_VOID);\n sexp_car(" res ") = "))) + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ");\n" + " }\n" + " " res " = sexp_nreverse(ctx, " res ");\n")) + (else + (cat " for (i=" len "-1; i>=0; i--) {\n" + " sexp_push(ctx, " res ", SEXP_VOID);\n" + " sexp_car(" res ") = " + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ";\n" + " }\n"))))) + (else + (cat " " res " = ") + (c->scheme-converter + result + (string-append "tmp" (type-index-string result))) + (cat ";\n"))))) + +(define (write-results func) + (let ((error-res? (error-type? (type-base (func-ret-type func)))) + (results (func-results func))) + (if error-res? + (cat " if (" + (if (memq (type-base (func-ret-type func)) + '(non-null-string non-null-pointer)) + "!" + "") + "err) {\n" + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (lambda () + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")) + (cat " len" i " *= 2;\n" + " tmp" i + " = malloc(len" i "*sizeof(tmp" i "[0]));\n" + " goto loop;\n"))))) + (else + " res = SEXP_FALSE;\n")) + " } else {\n")) + (if (null? results) + (if error-res? + (cat " res = SEXP_TRUE;\n")) + (for-each write-result results)) + (cond + ((> (length results) (if error-res? 1 0)) + (if error-res? + (cat " res = SEXP_NULL;\n") + (cat " res = sexp_cons(ctx, res, SEXP_NULL);\n")) + (for-each + (lambda (x) + (if error-res? + (cat " sexp_push(ctx, res, res" (type-index x) ");\n") + (cat " sexp_push(ctx, res, sexp_car(res));\n" + " sexp_cadr(res) = res" (type-index x) ";\n"))) + (reverse results))) + ((pair? results) + (cat " res = res" (type-index (car results)) ";\n"))) + (if error-res? + (cat " }\n")))) + +(define (write-free type) + (if (type-array type) + (cat " free(tmp" (type-index-string type) ");\n"))) + +(define (write-cleanup func) + (for-each write-free (func-scheme-args func)) + (for-each + (lambda (a) + (cond + ((type-auto-expand? a) + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")))) + ((and (type-result? a) (not (basic-type? a)) + (not (assq (type-base a) *types*)) + (not (type-free? a)) (not (type-pointer? a)) + (or (not (type-array a)) + (not (integer? (get-array-length func a))))) + ;; the above is hairy - basically this frees temporary strings + (cat " free(tmp" (type-index a) ");\n")))) + (func-c-args func)) + (let* ((results (func-results func)) + (return-res? (not (error-type? (type-base (func-ret-type func))))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons (func-ret-type func) + (func-results func)))) + (gc-vars results) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (num-gc-vars (length gc-vars))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_release" num-gc-vars "(ctx);\n"))))) + +(define (write-func func) + (cat "static sexp " (func-stub-name func) + " (sexp ctx sexp_api_params(self, n)" + (write-parameters (func-scheme-args func)) ") {\n") + (write-locals func) + (write-validators (func-scheme-args func)) + (write-temporaries func) + (write-call func) + (write-results func) + (write-cleanup func) + (cat " return res;\n" + "}\n\n")) + +(define (parameter-default? x) + (and (pair? x) + (member x '((current-input-port) + (current-output-port) + (current-error-port))))) + +(define (write-default x) ;; this is a hack but very convenient + (lambda () + (let ((value (type-value x))) + (cond + ((equal? value '(current-input-port)) + (cat "\"*current-input-port*\"")) + ((equal? value '(current-output-port)) + (cat "\"*current-output-port*\"")) + ((equal? value '(current-error-port)) + (cat "\"*current-error-port*\"")) + (else + (c->scheme-converter x value)))))) + +(define (write-func-binding func) + (let ((default (and (pair? (func-scheme-args func)) + (type-default? (car (reverse (func-scheme-args func)))) + (car (reverse (func-scheme-args func)))))) + (cat (if default + (if (parameter-default? (type-value default)) + " sexp_define_foreign_param(ctx, env, " + " sexp_define_foreign_opt(ctx, env, ") + " sexp_define_foreign(ctx, env, ") + (lambda () (write (symbol->string (func-scheme-name func)))) + ", " (length (func-scheme-args func)) ", " + (if default "(sexp_proc1)" "") + (func-stub-name func) + (if default ", " "") + (if default (write-default default) "") + ");\n"))) + +(define (write-type type) + (let ((name (car type)) + (type (cdr type))) + (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" + " " (type-id-name name) + " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, " + (cond ((memq 'finalizer: type) + => (lambda (x) (generate-stub-name (cadr x)))) + (else "sexp_finalize_c_type")) + "));\n") + (cond + ((memq 'predicate: type) + => (lambda (x) + (let ((pred (cadr x))) + (cat " tmp = sexp_make_type_predicate(ctx, name, " + "sexp_make_fixnum(" (type-id-name name) "));\n" + " name = sexp_intern(ctx, \"" pred "\", " + (string-length (x->string pred)) ");\n" + " sexp_env_define(ctx, env, name, tmp);\n"))))))) + +(define (type-getter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_get_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-getter type name field) + (cat "static sexp " (type-getter-name type name field) + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" + (lambda () (write-validator "x" name)) + " return " + (lambda () + (c->scheme-converter + (car field) + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (x->string (cadr field))) + (and (or (type-struct? (car field)) (type-link? (car field))) "x"))) + ";\n" + "}\n\n")) + +(define (type-setter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_set_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-setter type name field) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx sexp_api_params(self, n), sexp x, sexp v) {\n" + (lambda () (write-validator "x" name)) + (lambda () (write-validator "v" (car field))) + " " + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" + (if (type-struct? (car field)) "." "->") + (x->string (cadr field))) + " = " (lambda () (scheme->c-converter (car field) "v")) ";\n" + " return SEXP_VOID;\n" + "}\n\n")) + +(define (write-type-funcs type) + (let ((name (car type)) + (type (cdr type))) + ;; maybe write finalizer + (cond + ((memq 'finalizer: type) + => (lambda (x) + (cat "static sexp " (generate-stub-name (cadr x)) + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" + " if (sexp_cpointer_freep(x))\n" + " " (cadr x) "(sexp_cpointer_value(x));\n" + " return SEXP_VOID;\n" + "}\n\n")))) + ;; maybe write constructor + (cond + ((memq 'constructor: type) + => (lambda (x) + (let ((make (caadr x)) + (args (cdadr x))) + (cat "static sexp " (generate-stub-name make) + " (sexp ctx sexp_api_params(self, n)" + (lambda () + (let lp ((ls args) (i 0)) + (cond ((pair? ls) + (cat ", sexp arg" i) + (lp (cdr ls) (+ i 1)))))) + ") {\n" + " struct " (type-name name) " *r;\n" + " sexp_gc_var1(res);\n" + " sexp_gc_preserve1(ctx, res);\n" + ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + ;; (type-id-name name) + ;; ");\n" + ;; " r = sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), " + (type-id-name name) + ");\n" + " r = sexp_cpointer_value(res) = malloc(sizeof(struct " + (type-name name) "));\n" + " sexp_freep(res) = 1;\n" + (lambda () + (let lp ((ls args) (i 0)) + (cond + ((pair? ls) + (let* ((a (car ls)) + (field + (any (lambda (f) (and (pair? f) (eq? a (cadr f)))) + (cddr x)))) + (if field + (cat " r->" (cadr field) " = " + (lambda () + (scheme->c-converter + (car field) + (string-append "arg" + (number->string i)))) + ";\n")) + (lp (cdr ls) (+ i 1))))))) + " sexp_gc_release1(ctx);\n" + " return res;\n" + "}\n\n") + (set! *funcs* + (cons (parse-func `(void ,make ,args)) *funcs*)))))) + ;; write field accessors + (for-each + (lambda (field) + (cond + ((and (pair? field) (pair? (cdr field))) + (cond + ((and (pair? (cddr field)) (caddr field)) + (write-type-getter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(caddr field) + #f + ,(type-getter-name type name field)) + (,name))) + *funcs*)))) + (cond + ((and (pair? (cddr field)) + (pair? (cdddr field)) + (car (cdddr field))) + (write-type-setter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(car (cdddr field)) + #f + ,(type-setter-name type name field)) + (,name ,(car field)))) + *funcs*))))))) + type))) + +(define (write-const const) + (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) + (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) + (cat " name = sexp_intern(ctx, \"" scheme-name "\", " + (string-length (x->string scheme-name)) ");\n" + " sexp_env_define(ctx, env, name, tmp=" + (lambda () (c->scheme-converter (car const) c-name)) ");\n"))) + +(define (write-utilities) + (define (input-env-string? x) + (and (eq? 'env-string (type-base x)) (not (type-result? x)))) + (cond + ((any (lambda (f) + (or (any input-env-string? (func-results f)) + (any input-env-string? (func-scheme-args f)))) + *funcs*) + (cat "static char* sexp_concat_env_string (sexp x) {\n" + " int klen=sexp_string_length(sexp_car(x)), vlen=sexp_string_length(sexp_cdr(x));\n" + " char *res = (char*) malloc(klen+vlen+2);\n" + " strncpy(res, sexp_string_data(sexp_car(x)), klen);\n" + " res[sexp_string_length(sexp_car(x))] = '=';\n" + " strncpy(res+sexp_string_length(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n" + " res[len-1] = '\\0';\n" + " return res;\n" + "}\n\n")))) + +(define (write-init) + (newline) + (write-utilities) + (for-each write-func *funcs*) + (for-each write-type-funcs *types*) + (cat "sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {\n" + " sexp_gc_var2(name, tmp);\n" + " sexp_gc_preserve2(ctx, name, tmp);\n") + (for-each write-const *consts*) + (for-each write-type *types*) + (for-each write-func-binding *funcs*) + (cat " sexp_gc_release2(ctx);\n" + " return SEXP_VOID;\n" + "}\n\n")) + +(define (generate file) + (display "/* automatically generated by chibi genstubs */\n") + (c-system-include "chibi/eval.h") + (load file) + (write-init)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main + +(define (main args) + (case (length args) + ((1) + (with-output-to-file (string-append (strip-extension (car args)) ".c") + (lambda () (generate (car args))))) + ((2) + (if (equal? "-" (cadr args)) + (generate (car args)) + (with-output-to-file (cadr args) (lambda () (generate (car args)))))) + (else + (error "usage: genstubs []")))) diff --git a/vm.c b/vm.c new file mode 100644 index 00000000..88bf4fcc --- /dev/null +++ b/vm.c @@ -0,0 +1,1226 @@ +/* vm.c -- stack-based virtual machine backend */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +/************************* code generation ****************************/ + +static void emit_word (sexp ctx, sexp_uint_t val) { + unsigned char *data; + expand_bcode(ctx, sizeof(sexp)); + data = sexp_bytecode_data(sexp_context_bc(ctx)); + sexp_context_align_pos(ctx); + *((sexp_uint_t*)(&(data[sexp_context_pos(ctx)]))) = val; + sexp_context_pos(ctx) += sizeof(sexp); +} + +static void emit_push (sexp ctx, sexp obj) { + emit(ctx, SEXP_OP_PUSH); + emit_word(ctx, (sexp_uint_t)obj); + if (sexp_pointerp(obj) && ! sexp_symbolp(obj)) + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); +} + +static void emit_enter (sexp ctx) {return;} +static void bless_bytecode (sexp ctx, sexp bc) {return;} + +static void emit_return (sexp ctx) { + emit(ctx, SEXP_OP_RET); +} + +static sexp_sint_t sexp_context_make_label (sexp ctx) { + sexp_sint_t label; + sexp_context_align_pos(ctx); + 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 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, SEXP_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, SEXP_OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, SEXP_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, SEXP_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, SEXP_OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, SEXP_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) + ? SEXP_OP_GLOBAL_REF : SEXP_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, SEXP_OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, SEXP_OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, SEXP_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, inv_default=0; + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); + + num_args = sexp_unbox_fixnum(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_data(op) + && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { + if (sexp_opcode_inverse(op)) { + inv_default = 1; + } else { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + } + + /* push the arguments onto the stack in reverse order */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC)) + ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the default for inverse opcodes */ + if (inv_default) { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case SEXP_OPC_ARITHMETIC: + /* fold variadic arithmetic operators */ + for (i=num_args-1; i>0; i--) + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + emit(ctx, SEXP_OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_FOREIGN: + emit(ctx, sexp_opcode_code(op)); + emit_word(ctx, (sexp_uint_t)op); + break; + case SEXP_OPC_TYPE_PREDICATE: + case SEXP_OPC_GETTER: + case SEXP_OPC_SETTER: + case SEXP_OPC_CONSTRUCTOR: + emit(ctx, sexp_opcode_code(op)); + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE) { + if (sexp_opcode_data(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); + if (sexp_opcode_data2(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + } + break; + case SEXP_OPC_PARAMETER: + emit_push(ctx, sexp_opcode_data(op)); + emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + sexp_context_depth(ctx) -= (num_args-1); + sexp_gc_release1(ctx); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, 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 ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); + + sexp_context_tailp(ctx) = tailp; + sexp_context_depth(ctx) -= len; + sexp_gc_release1(ctx); +} + +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_var2(tmp, bc); + sexp_gc_preserve2(ctx, tmp, 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_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); + 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, SEXP_OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, SEXP_OP_CONS); + emit(ctx2, SEXP_OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, SEXP_OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_fixnum((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_ZERO, 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, SEXP_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_fixnum(k)); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_VECTOR_SET); + emit(ctx, SEXP_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, SEXP_OP_MAKE_PROCEDURE); + } + sexp_gc_release2(ctx); +} + +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 make_param_list (sexp ctx, sexp_uint_t i) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_fixnum(i), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ls, bc, res, env; + sexp_gc_var5(params, ref, refs, lambda, ctx2); + if (i == sexp_opcode_num_args(op)) { /* return before preserving */ + if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); + } else if (i < sexp_opcode_num_args(op)) { + return sexp_compile_error(ctx, "not enough args for opcode", op); + } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ + return sexp_compile_error(ctx, "too many args for opcode", op); + } + sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = sexp_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), sexp_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_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + sexp_gc_release5(ctx); + 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_fixnum(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= SEXP_INIT_STACK_SIZE) { + _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); + goto end_loop; + } +#endif + _ALIGN_IP(); + i = sexp_unbox_fixnum(_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_fixnum(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_fixnum(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_fixnum(i); + stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + stack[top+1] = self; + stack[top+2] = sexp_make_fixnum(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 SEXP_OP_FCALL0: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 0))); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL1: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 1), _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL2: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 2), _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL3: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 3), _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL4: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 4), _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL5: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 5), _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL6: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 6), _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_JUMP_UNLESS: + _ALIGN_IP(); + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case SEXP_OP_JUMP: + _ALIGN_IP(); + ip += _SWORD0; + break; + case SEXP_OP_PUSH: + _ALIGN_IP(); + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case SEXP_OP_DROP: + top--; + break; + case SEXP_OP_GLOBAL_REF: + _ALIGN_IP(); + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case SEXP_OP_GLOBAL_KNOWN_REF: + _ALIGN_IP(); + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_STACK_REF: /* `pick' in forth */ + _ALIGN_IP(); + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_REF: + _ALIGN_IP(); + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_SET: + _ALIGN_IP(); + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case SEXP_OP_CLOSURE_REF: + _ALIGN_IP(); + _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); + ip += sizeof(sexp); + break; + case SEXP_OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_VECTOR_LENGTH: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); + break; + case SEXP_OP_STRING_REF: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_string_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2)); + else if (! sexp_charp(_ARG3)) + sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_string_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_STRING_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); + break; + case SEXP_OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; + _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case SEXP_OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; + if (! sexp_fixnump(_ARG1)) + sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); + _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_MAKE_EXCEPTION: + _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + break; + case SEXP_OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case SEXP_OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case SEXP_OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case SEXP_OP_FIXNUMP: + _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; + case SEXP_OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case SEXP_OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case SEXP_OP_TYPEP: + _ALIGN_IP(); + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_MAKE: + _ALIGN_IP(); + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_REF: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_SET: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); + sexp_slot_set(_ARG1, _UWORD1, _ARG2); + _ARG2 = SEXP_VOID; + ip += sizeof(sexp)*2; + top--; + break; + case SEXP_OP_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case SEXP_OP_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case SEXP_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 SEXP_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 SEXP_OP_CONS: + sexp_context_top(ctx) = top; + _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_ADD: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(j); + } + else + _ARG2 = sexp_add(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_add(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) + sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_SUB: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(j); + } + else + _ARG2 = sexp_sub(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_sub(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) - sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_MUL: +#if SEXP_USE_BIGNUMS + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); + if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) + _ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG2 = sexp_make_fixnum(prod); + } + else + _ARG2 = sexp_mul(ctx, tmp1, tmp2); +#else + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_fx_mul(_ARG1, _ARG2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) * sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_DIV: + sexp_context_top(ctx) = top; + if (_ARG2 == SEXP_ZERO) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) + _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { +#if SEXP_USE_FLONUMS + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); + _ARG2 = sexp_fixnum_to_flonum(ctx, _ARG2); + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + if (sexp_flonum_value(_ARG2) == trunc(sexp_flonum_value(_ARG2))) + _ARG2 = sexp_make_fixnum(sexp_flonum_value(_ARG2)); +#else + _ARG2 = sexp_fx_div(_ARG1, _ARG2); +#endif + } +#if SEXP_USE_BIGNUMS + else + _ARG2 = sexp_div(ctx, _ARG1, _ARG2); +#else +#if SEXP_USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_fixnum(_ARG2)); + else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) / sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + top--; + break; + case SEXP_OP_QUOTIENT: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG2 = sexp_fx_div(_ARG1, _ARG2); + top--; + } +#if SEXP_USE_BIGNUMS + else { + sexp_context_top(ctx) = top; + _ARG2 = sexp_quotient(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case SEXP_OP_REMAINDER: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + if (_ARG2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + tmp1 = sexp_fx_rem(_ARG1, _ARG2); + top--; + _ARG1 = tmp1; + } +#if SEXP_USE_BIGNUMS + else { + sexp_context_top(ctx) = top; + _ARG2 = sexp_remainder(ctx, _ARG1, _ARG2); + top--; + } +#else + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#endif + break; + case SEXP_OP_LT: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) < 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) < sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_LE: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) <= 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) <= sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_EQN: + if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + i = _ARG1 == _ARG2; +#if SEXP_USE_BIGNUMS + _ARG2 = sexp_make_boolean(i); + } else { + tmp1 = sexp_compare(ctx, _ARG1, _ARG2); + _ARG2 = sexp_fixnump(tmp1) + ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) == 0) : tmp1; + } +#else +#if SEXP_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_fixnump(_ARG2)) { + i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_fixnum(_ARG2); + } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { + i = (double)sexp_unbox_fixnum(_ARG1) == sexp_flonum_value(_ARG2); +#endif + } else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); +#endif + top--; + break; + case SEXP_OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case SEXP_OP_FIX2FLO: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); +#endif + else if (! sexp_flonump(_ARG1)) + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case SEXP_OP_FLO2FIX: + if (sexp_flonump(_ARG1)) { + if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { + sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_BIGNUMS + } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { + _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); +#endif + } else { + _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); + } + } else if (! sexp_fixnump(_ARG1) && ! sexp_bignump(_ARG1)) { + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + } + break; + case SEXP_OP_CHAR2INT: + if (! sexp_charp(_ARG1)) + sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); + break; + case SEXP_OP_INT2CHAR: + if (! sexp_fixnump(_ARG1)) + sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); + break; + case SEXP_OP_CHAR_UPCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_CHAR_DOWNCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_WRITE_CHAR: + if (! sexp_charp(_ARG1)) + sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); + if (! sexp_oportp(_ARG2)) + sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2)); + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_NEWLINE: + if (! sexp_oportp(_ARG1)) + sexp_raise("newline: not an output-port", sexp_list1(ctx, _ARG1)); + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case SEXP_OP_READ_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("read-char: not an intput-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_PEEK_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("peek-char: not an intput-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); + sexp_push_char(ctx, i, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_RET: + i = sexp_unbox_fixnum(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_fixnum(stack[fp+1]); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_fixnum(stack[fp+3]); + break; + case SEXP_OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); + } + goto loop; + + end_loop: + sexp_gc_release3(ctx); + sexp_context_top(ctx) = top; + return _ARG1; +} + +/******************************* apply ********************************/ + +static sexp sexp_apply1 (sexp ctx, sexp f, sexp x) { + sexp res; + sexp_gc_var1(args); + if (sexp_opcodep(f)) { + res = ((sexp_proc2)sexp_opcode_func(f))(ctx sexp_api_pass(f, 1), x); + } else { + sexp_gc_preserve1(ctx, args); + res = sexp_apply(ctx, f, args=sexp_list1(ctx, x)); + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_apply (sexp ctx, sexp proc, sexp args) { + sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx), len, offset; + len = sexp_unbox_fixnum(sexp_length(ctx, args)); + if (sexp_opcodep(proc)) + proc = make_opcode_procedure(ctx, proc, len); + if (! sexp_procedurep(proc)) { + res = sexp_exceptionp(proc) ? proc : + sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); + } else { + offset = top + len; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) + stack[--offset] = sexp_car(ls); + stack[top] = sexp_make_fixnum(len); + top++; + stack[top++] = SEXP_ZERO; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + stack[top++] = SEXP_ZERO; + sexp_context_top(ctx) = top; + res = sexp_vm(ctx, proc); + if (! res) res = SEXP_VOID; /* shouldn't happen */ + } + return res; +} From 8b6b2e5e83b5f7a47dc389ed030af86ebd44aacd Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 22 Jun 2010 13:50:30 +0000 Subject: [PATCH 435/535] compressing environment structures pack the next cell pointer into the source loc info of the env cell instead of requiring a "backbone" list --- eval.c | 53 ++++++++++++++++++++++---------------------- include/chibi/eval.h | 3 +++ 2 files changed, 29 insertions(+), 27 deletions(-) diff --git a/eval.c b/eval.c index 9123cd60..5e8170a1 100644 --- a/eval.c +++ b/eval.c @@ -53,9 +53,9 @@ static void sexp_warn (sexp ctx, char *msg, sexp x) { void sexp_warn_undefs (sexp ctx, sexp from, sexp to) { sexp x; - for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x)) - if (sexp_cdar(x) == SEXP_UNDEF) - sexp_warn(ctx, "reference to undefined variable", sexp_caar(x)); + for (x=from; sexp_pairp(x) && x!=to; x=sexp_env_next_cell(x)) + if (sexp_cdr(x) == SEXP_UNDEF) + sexp_warn(ctx, "reference to undefined variable", sexp_car(x)); } @@ -65,10 +65,10 @@ static sexp sexp_env_cell_loc (sexp env, sexp key, sexp *varenv) { sexp ls; do { - for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_cdr(ls)) - if (sexp_caar(ls) == key) { + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + if (sexp_car(ls) == key) { if (varenv) *varenv = env; - return sexp_car(ls); + return ls; } env = sexp_env_parent(env); } while (env); @@ -86,10 +86,9 @@ static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, cell = sexp_env_cell_loc(env, key, varenv); if (! cell) { sexp_gc_preserve1(ctx, cell); - cell = sexp_cons(ctx, key, value); while (sexp_env_lambda(env) || sexp_env_syntactic_p(env)) env = sexp_env_parent(env); - sexp_env_bindings(env) = sexp_cons(ctx, cell, sexp_env_bindings(env)); + sexp_env_push(ctx, env, cell, key, value); if (varenv) *varenv = env; sexp_gc_release1(ctx); } @@ -108,8 +107,13 @@ sexp sexp_env_global_ref (sexp env, sexp key, sexp dflt) { } sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { - sexp cell = sexp_assq(ctx, key, sexp_env_bindings(env)), res=SEXP_VOID; + sexp cell=SEXP_FALSE, res=SEXP_VOID; sexp_gc_var1(tmp); + for (tmp=sexp_env_bindings(env); sexp_pairp(tmp); tmp=sexp_env_next_cell(tmp)) + if (sexp_car(tmp) == key) { + cell = tmp; + break; + } if (sexp_immutablep(env)) { res = sexp_user_exception(ctx, NULL, "immutable binding", key); } else { @@ -120,8 +124,7 @@ sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { else sexp_cdr(cell) = value; } else { - tmp = sexp_cons(ctx, key, value); - sexp_push(ctx, sexp_env_bindings(env), tmp); + sexp_env_push(ctx, env, tmp, key, value); } sexp_gc_release1(ctx); } @@ -133,8 +136,8 @@ sexp sexp_env_exports_op (sexp ctx sexp_api_params(self, n), sexp env) { sexp_gc_var1(res); sexp_gc_preserve1(ctx, res); res = SEXP_NULL; - for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_cdr(ls)) - sexp_push(ctx, res, sexp_caar(ls)); + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_push(ctx, res, sexp_car(ls)); sexp_gc_release1(ctx); return res; } @@ -145,10 +148,8 @@ sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { 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)) { - tmp = sexp_cons(ctx, sexp_car(vars), value); - sexp_push(ctx, sexp_env_bindings(e), tmp); - } + for ( ; sexp_pairp(vars); vars = sexp_cdr(vars)) + sexp_env_push(ctx, e, tmp, sexp_car(vars), value); sexp_gc_release2(ctx); return e; } @@ -619,8 +620,7 @@ static sexp analyze_define (sexp ctx, sexp x) { 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_env_push(ctx, env, tmp, 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); tmp = sexp_cons(ctx, sexp_cdr(x), ctx); @@ -665,8 +665,7 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) name = sexp_synclo_expr(name); mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(bind_ctx)); - tmp = sexp_cons(eval_ctx, name, mac); - sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp); + sexp_env_push(eval_ctx, sexp_context_env(bind_ctx), tmp, name, mac); } else { res = (sexp_exceptionp(proc) ? proc : sexp_compile_error(eval_ctx, "non-procedure macro:", proc)); @@ -990,13 +989,13 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { res = SEXP_VOID; sexp_close_port(ctx, in); } - sexp_gc_release4(ctx); -#if SEXP_USE_DL - } -#endif #if SEXP_USE_WARN_UNDEFS if (! sexp_exceptionp(res)) sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + sexp_gc_release4(ctx); +#if SEXP_USE_DL + } #endif return res; } @@ -1495,8 +1494,8 @@ sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, se sexp_immutablep(value) = 1; sexp_env_bindings(value) = sexp_env_bindings(from); } else { - for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls)) - sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls)); + for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_env_define(ctx, to, sexp_car(ls), sexp_cdr(ls)); } } else { for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { diff --git a/include/chibi/eval.h b/include/chibi/eval.h index df97eb1e..66ce173e 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -160,6 +160,9 @@ SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, sexp_proc1 f, const char *param); +#define sexp_env_next_cell(x) sexp_pair_source(x) +#define sexp_env_push(ctx, env, tmp, name, value) (tmp=sexp_cons(ctx,name,value), sexp_env_next_cell(tmp)=sexp_env_bindings(env), sexp_env_bindings(env)=tmp) + #if SEXP_USE_TYPE_DEFS SEXP_API sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type); SEXP_API sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type); From 00e30bfcaab982c0f0a4193f13f280d035bfa151 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 22 Jun 2010 22:58:26 +0900 Subject: [PATCH 436/535] packing string data into symbol instead of consing an extra string object --- include/chibi/sexp.h | 5 +++-- sexp.c | 6 +++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 69684c3b..a9c642e5 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -206,7 +206,8 @@ struct sexp_struct { char data[]; } string; struct { - sexp string; + sexp_uint_t length; + char data[]; } symbol; struct { FILE *stream; @@ -569,7 +570,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_string_ref(x, i) (sexp_make_character((unsigned char)sexp_string_data(x)[sexp_unbox_fixnum(i)])) #define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_character(v)) -#define sexp_symbol_string(x) ((x)->value.symbol.string) +#define sexp_symbol_string(x) (x) #define sexp_port_stream(p) ((p)->value.port.stream) #define sexp_port_name(p) ((p)->value.port.name) diff --git a/sexp.c b/sexp.c index 75333dab..075553a1 100644 --- a/sexp.c +++ b/sexp.c @@ -87,7 +87,7 @@ static struct sexp_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, "char", NULL), _DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", NULL), _DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, "pair", NULL), - _DEF_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol", NULL), + _DEF_TYPE(SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, "symbol", NULL), _DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string", NULL), _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector", NULL), _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "real", NULL), @@ -790,9 +790,9 @@ sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { /* not found, make a new symbol */ sexp_gc_preserve1(ctx, sym); - sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); + sym = sexp_c_string(ctx, str, len); if (sexp_exceptionp(sym)) return sym; - sexp_symbol_string(sym) = sexp_c_string(ctx, str, len); + sexp_pointer_tag(sym) = SEXP_SYMBOL; sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); sexp_gc_release1(ctx); return sym; From 9a052ddb7c8d88a531a25387adb1d69f0a695972 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 22 Jun 2010 23:09:18 +0900 Subject: [PATCH 437/535] passing correctly adjusted size to munmap when using mmapped heaps --- .hgignore | 1 + AUTHORS | 2 +- Makefile | 7 +++++++ gc.c | 8 -------- include/chibi/sexp.h | 5 +++++ lib/chibi/term/edit-line.scm | 1 + sexp.c | 2 +- tests/hash-tests.scm | 4 ++-- tests/r5rs-tests.scm | 18 ------------------ tools/genstubs.scm | 5 +++-- 10 files changed, 21 insertions(+), 32 deletions(-) diff --git a/.hgignore b/.hgignore index d1af4846..e26cf91b 100644 --- a/.hgignore +++ b/.hgignore @@ -5,6 +5,7 @@ syntax: glob *.o *.so *.dylib +*.class *.dSYM *.orig .hg diff --git a/AUTHORS b/AUTHORS index df7959c1..1e15e0a5 100644 --- a/AUTHORS +++ b/AUTHORS @@ -16,7 +16,7 @@ Thanks to the following people for patches: * John Samsa * Lars J Aas * Lorenzo Campedelli - * sladegen + * Michal Kowalski (sladegen) If you would prefer not to be listed, or are one of the users listed without a full name, please contact me. If you've made a contribution diff --git a/Makefile b/Makefile index 7949a71b..7c641a4c 100644 --- a/Makefile +++ b/Makefile @@ -213,3 +213,10 @@ dist: cleaner 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` + +mips-dist: cleaner + rm -f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz + mkdir chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + for f in `hg manifest`; do mkdir -p chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/$$f; done + tar cphzvf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + rm -rf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` diff --git a/gc.c b/gc.c index fb15ec13..af7b3986 100644 --- a/gc.c +++ b/gc.c @@ -8,16 +8,8 @@ #include #endif -#if SEXP_64_BIT -#define sexp_heap_align(n) sexp_align(n, 5) -#else -#define sexp_heap_align(n) sexp_align(n, 4) -#endif - #define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(sexp_sizeof(pair))) -#define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1)) - #if SEXP_USE_GLOBAL_HEAP sexp_heap sexp_global_heap; #endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index a9c642e5..ad773145 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -113,13 +113,18 @@ enum sexp_types { typedef unsigned int sexp_tag_t; typedef unsigned long sexp_uint_t; typedef long sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) #else typedef unsigned short sexp_tag_t; typedef unsigned int sexp_uint_t; typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 4) #endif + typedef struct sexp_struct *sexp; +#define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1)) + #define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2)) #define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type)) #define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type)) diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm index 6c63f5d9..cd8fd376 100644 --- a/lib/chibi/term/edit-line.scm +++ b/lib/chibi/term/edit-line.scm @@ -115,6 +115,7 @@ (gap buffer-gap buffer-gap-set!) (width buffer-width buffer-width-set!) (string buffer-string buffer-string-set!) + (kill-ring buffer-kill-ring buffer-kill-ring-set!) (history buffer-history buffer-history-set!)) (define default-buffer-size 256) diff --git a/sexp.c b/sexp.c index 075553a1..07a0d824 100644 --- a/sexp.c +++ b/sexp.c @@ -311,7 +311,7 @@ void sexp_destroy_context (sexp ctx) { for ( ; heap; heap=tmp) { tmp = heap->next; #if SEXP_USE_MMAP_GC - munmap(heap, heap->size); + munmap(heap, sexp_heap_pad_size(heap->size)); #else free(heap); #endif diff --git a/tests/hash-tests.scm b/tests/hash-tests.scm index 6dec5734..54fb4fc7 100644 --- a/tests/hash-tests.scm +++ b/tests/hash-tests.scm @@ -11,8 +11,8 @@ (set! *tests-run* (+ *tests-run* 1)) (let ((str (call-with-output-string (lambda (out) - (write *tests-run*) - (display ". ") + (write *tests-run* out) + (display ". " out) (display 'expr out)))) (res expr)) (display str) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 80db4e00..a9197fb1 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -216,24 +216,6 @@ (test 288 (lcm 32 -36)) -;;;; these will fail when compiled either without flonums or trig funcs - -;; (test #t (= -5 (floor -4.3))) - -;; (test #t (= -4 (ceiling -4.3))) - -;; (test #t (= -4 (truncate -4.3))) - -;; (test #t (= -4 (round -4.3))) - -;; (test #t (= 3 (floor 3.5))) - -;; (test #t (= 4 (ceiling 3.5))) - -;; (test #t (= 3 (truncate 3.5))) - -;; (test #t (= 4 (round 3.5))) - (test 100 (string->number "100")) (test 256 (string->number "100" 16)) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 77acbe26..95443d24 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -73,6 +73,7 @@ ;; ;; Port Types: ;; input-port output-port +;; port-or-fd - an fd-backed port or a fixnum ;; ;; Struct Types: ;; @@ -620,8 +621,8 @@ " return sexp_xtype_exception(ctx, self, \"not a list of " (type-name type) "s\", " arg ");\n"))) ((eq? base-type 'port-or-fd) - (cat "if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" - " return sexp_xtype_exception(ctx, self, \"not a port of file descriptor\"," arg ");\n")) + (cat " if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" + " return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n")) ((or (int-type? base-type) (float-type? base-type) (string-type? base-type) From 565ed858fe87a74862805772b4b7c1665504f441 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 23 Jun 2010 22:04:38 +0900 Subject: [PATCH 438/535] fixing memory leak when redefining macros (was generating a new env cell instead of overwriting the old one) --- eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/eval.c b/eval.c index 5e8170a1..e5cf0c79 100644 --- a/eval.c +++ b/eval.c @@ -665,7 +665,7 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) name = sexp_synclo_expr(name); mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(bind_ctx)); - sexp_env_push(eval_ctx, sexp_context_env(bind_ctx), tmp, name, mac); + sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac); } else { res = (sexp_exceptionp(proc) ? proc : sexp_compile_error(eval_ctx, "non-procedure macro:", proc)); From e7f588c6f2f05c81a63f5d08505b6121f1011480 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 23 Jun 2010 13:08:52 +0000 Subject: [PATCH 439/535] got comparison order wrong in the isymbol vs. lsymbol case --- lib/srfi/95/qsort.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c index 4b5d36aa..0f430874 100644 --- a/lib/srfi/95/qsort.c +++ b/lib/srfi/95/qsort.c @@ -84,8 +84,8 @@ static int sexp_object_compare (sexp ctx, sexp a, sexp b) { } #if SEXP_USE_HUFF_SYMS } else if (sexp_lsymbolp(a) && sexp_isymbolp(b)) { - res = sexp_object_compare(ctx, sexp_symbol_string(a), - sexp_write_to_string(ctx, b)); + res = strcmp(sexp_string_data(sexp_symbol_string(a)), + sexp_string_data(sexp_write_to_string(ctx, b))); #endif } else { res = 1; @@ -93,8 +93,8 @@ static int sexp_object_compare (sexp ctx, sexp a, sexp b) { } else if (sexp_pointerp(b)) { #if SEXP_USE_HUFF_SYMS if (sexp_isymbolp(a) && sexp_lsymbolp(b)) - res = sexp_object_compare(ctx, sexp_symbol_string(b), - sexp_write_to_string(ctx, a)); + res = strcmp(sexp_string_data(sexp_write_to_string(ctx, a)), + sexp_string_data(sexp_symbol_string(b))); else #endif res = -1; From dd0588d7788b0114ff5f74b4f79e690583fa6184 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Jun 2010 11:07:38 +0900 Subject: [PATCH 440/535] signalling exceptions on generalized sexp_* numeric operations --- vm.c | 287 ++++++++++++++++++++++++++++++----------------------------- 1 file changed, 147 insertions(+), 140 deletions(-) diff --git a/vm.c b/vm.c index 88bf4fcc..3ae152da 100644 --- a/vm.c +++ b/vm.c @@ -858,231 +858,238 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case SEXP_OP_ADD: -#if SEXP_USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; - sexp_context_top(ctx) = top; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) - _ARG2 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + _ARG1 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); else - _ARG2 = sexp_make_fixnum(j); + _ARG1 = sexp_make_fixnum(j); + } + else { + _ARG1 = sexp_add(ctx, tmp1, tmp2); + sexp_check_exception(); } - else - _ARG2 = sexp_add(ctx, tmp1, tmp2); #else - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_fx_add(_ARG1, _ARG2); + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_add(tmp1, tmp2); #if SEXP_USE_FLONUMS - else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2); - else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_fixnum(_ARG2)); - else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) + sexp_flonum_value(_ARG2)); + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_add(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) + (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) + sexp_flonum_value(tmp2)); #endif - else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + else sexp_raise("+: not a number", sexp_list2(ctx, tmp1, tmp2)); #endif - top--; break; case SEXP_OP_SUB: -#if SEXP_USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; - sexp_context_top(ctx) = top; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) - _ARG2 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + _ARG1 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); else - _ARG2 = sexp_make_fixnum(j); + _ARG1 = sexp_make_fixnum(j); + } + else { + _ARG1 = sexp_sub(ctx, tmp1, tmp2); + sexp_check_exception(); } - else - _ARG2 = sexp_sub(ctx, tmp1, tmp2); #else - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_fx_sub(_ARG1, _ARG2); + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_sub(tmp1, tmp2); #if SEXP_USE_FLONUMS - else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2); - else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_fixnum(_ARG2)); - else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) - sexp_flonum_value(_ARG2)); + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_sub(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) - (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) - sexp_flonum_value(tmp2)); #endif - else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + else sexp_raise("-: not a number", sexp_list2(ctx, tmp1, tmp2)); #endif - top--; break; case SEXP_OP_MUL: -#if SEXP_USE_BIGNUMS tmp1 = _ARG1, tmp2 = _ARG2; - sexp_context_top(ctx) = top; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) - _ARG2 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + _ARG1 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); else - _ARG2 = sexp_make_fixnum(prod); + _ARG1 = sexp_make_fixnum(prod); + } + else { + _ARG1 = sexp_mul(ctx, tmp1, tmp2); + sexp_check_exception(); } - else - _ARG2 = sexp_mul(ctx, tmp1, tmp2); #else - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_fx_mul(_ARG1, _ARG2); + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_mul(tmp1, tmp2); #if SEXP_USE_FLONUMS - else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2); - else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_fixnum(_ARG2)); - else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) * sexp_flonum_value(_ARG2)); + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_mul(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) * (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) * sexp_flonum_value(tmp2)); #endif - else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + else sexp_raise("*: not a number", sexp_list2(ctx, tmp1, tmp2)); #endif - top--; break; case SEXP_OP_DIV: - sexp_context_top(ctx) = top; - if (_ARG2 == SEXP_ZERO) { + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (tmp2 == SEXP_ZERO) { #if SEXP_USE_FLONUMS - if (sexp_flonump(_ARG1) && sexp_flonum_value(_ARG1) == 0.0) - _ARG2 = sexp_make_flonum(ctx, 0.0/0.0); + if (sexp_flonump(tmp1) && sexp_flonum_value(tmp1) == 0.0) + _ARG1 = sexp_make_flonum(ctx, 0.0/0.0); else #endif sexp_raise("divide by zero", SEXP_NULL); - } else if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { + } else if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { #if SEXP_USE_FLONUMS - _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); - _ARG2 = sexp_fixnum_to_flonum(ctx, _ARG2); - _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); - if (sexp_flonum_value(_ARG2) == trunc(sexp_flonum_value(_ARG2))) - _ARG2 = sexp_make_fixnum(sexp_flonum_value(_ARG2)); + tmp1 = sexp_fixnum_to_flonum(ctx, tmp1); + tmp2 = sexp_fixnum_to_flonum(ctx, tmp2); + _ARG1 = sexp_fp_div(ctx, tmp1, tmp2); + if (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1))) + _ARG1 = sexp_make_fixnum(sexp_flonum_value(_ARG1)); #else - _ARG2 = sexp_fx_div(_ARG1, _ARG2); + _ARG1 = sexp_fx_div(tmp1, tmp2); #endif } -#if SEXP_USE_BIGNUMS - else - _ARG2 = sexp_div(ctx, _ARG1, _ARG2); -#else -#if SEXP_USE_FLONUMS - else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); - else if (sexp_flonump(_ARG1) && sexp_fixnump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_fixnum(_ARG2)); - else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(_ARG1) / sexp_flonum_value(_ARG2)); -#endif - else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2)); -#endif - top--; - break; - case SEXP_OP_QUOTIENT: - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - if (_ARG2 == SEXP_ZERO) - sexp_raise("divide by zero", SEXP_NULL); - _ARG2 = sexp_fx_div(_ARG1, _ARG2); - top--; - } #if SEXP_USE_BIGNUMS else { - sexp_context_top(ctx) = top; - _ARG2 = sexp_quotient(ctx, _ARG1, _ARG2); - top--; + _ARG1 = sexp_div(ctx, tmp1, tmp2); + sexp_check_exception(); } #else - else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_div(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) / (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) / sexp_flonum_value(tmp2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_QUOTIENT: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + if (tmp2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG1 = sexp_fx_div(tmp1, tmp2); + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_quotient(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, tmp2)); #endif break; case SEXP_OP_REMAINDER: - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - if (_ARG2 == SEXP_ZERO) + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + if (tmp2 == SEXP_ZERO) sexp_raise("divide by zero", SEXP_NULL); - tmp1 = sexp_fx_rem(_ARG1, _ARG2); - top--; - _ARG1 = tmp1; + _ARG1 = sexp_fx_rem(tmp1, tmp2); } #if SEXP_USE_BIGNUMS else { - sexp_context_top(ctx) = top; - _ARG2 = sexp_remainder(ctx, _ARG1, _ARG2); - top--; + _ARG1 = sexp_remainder(ctx, tmp1, tmp2); + sexp_check_exception(); } #else - else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, tmp2)); #endif break; case SEXP_OP_LT: - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = (sexp_sint_t)tmp1 < (sexp_sint_t)tmp2; #if SEXP_USE_BIGNUMS - _ARG2 = sexp_make_boolean(i); + _ARG1 = sexp_make_boolean(i); } else { - tmp1 = sexp_compare(ctx, _ARG1, _ARG2); - _ARG2 = sexp_fixnump(tmp1) - ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) < 0) : tmp1; + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) < 0); } #else #if SEXP_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_fixnump(_ARG2)) { - i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_fixnum(_ARG2); - } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { - i = (double)sexp_unbox_fixnum(_ARG1) < sexp_flonum_value(_ARG2); + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) < sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) < sexp_flonum_value(tmp2); #endif - } else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); - _ARG2 = sexp_make_boolean(i); + } else sexp_raise("<: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); #endif - top--; break; case SEXP_OP_LE: - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = (sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2; #if SEXP_USE_BIGNUMS - _ARG2 = sexp_make_boolean(i); + _ARG1 = sexp_make_boolean(i); } else { - tmp1 = sexp_compare(ctx, _ARG1, _ARG2); - _ARG2 = sexp_fixnump(tmp1) - ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) <= 0) : tmp1; + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) <= 0); } #else #if SEXP_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_fixnump(_ARG2)) { - i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_fixnum(_ARG2); - } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { - i = (double)sexp_unbox_fixnum(_ARG1) <= sexp_flonum_value(_ARG2); + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) <= sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) <= (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) <= sexp_flonum_value(tmp2); #endif - } else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); - _ARG2 = sexp_make_boolean(i); + } else sexp_raise("<=: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); #endif - top--; break; case SEXP_OP_EQN: - if (sexp_fixnump(_ARG1) && sexp_fixnump(_ARG2)) { - i = _ARG1 == _ARG2; + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = tmp1 == tmp2; #if SEXP_USE_BIGNUMS - _ARG2 = sexp_make_boolean(i); + _ARG1 = sexp_make_boolean(i); } else { - tmp1 = sexp_compare(ctx, _ARG1, _ARG2); - _ARG2 = sexp_fixnump(tmp1) - ? sexp_make_boolean(sexp_unbox_fixnum(tmp1) == 0) : tmp1; + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) == 0); } #else #if SEXP_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_fixnump(_ARG2)) { - i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_fixnum(_ARG2); - } else if (sexp_fixnump(_ARG1) && sexp_flonump(_ARG2)) { - i = (double)sexp_unbox_fixnum(_ARG1) == sexp_flonum_value(_ARG2); + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) == sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) == (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) == sexp_flonum_value(tmp2); #endif - } else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); - _ARG2 = sexp_make_boolean(i); + } else sexp_raise("=: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); #endif - top--; break; case SEXP_OP_EQ: _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); From 0aa20e30b2ae062f5b90a590cfb31983d6a697e0 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Jun 2010 11:08:41 +0900 Subject: [PATCH 441/535] not all ports record source info --- sexp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sexp.c b/sexp.c index 07a0d824..069edea7 100644 --- a/sexp.c +++ b/sexp.c @@ -1087,7 +1087,7 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { sexp_port_buf(p) = NULL; sexp_port_openp(p) = 1; sexp_port_no_closep(p) = 0; - sexp_port_sourcep(p) = 1; + sexp_port_sourcep(p) = 0; sexp_port_cookie(p) = SEXP_VOID; return p; } From 2c8c2a8c23407bfb85ebe214f086301db04a2615 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Jun 2010 11:28:42 +0900 Subject: [PATCH 442/535] fixing runtime error reporting --- eval.c | 4 +++- include/chibi/sexp.h | 25 ++++++++++++++++--------- sexp.c | 20 +++++++++++--------- vm.c | 10 +++++++--- 4 files changed, 37 insertions(+), 22 deletions(-) diff --git a/eval.c b/eval.c index e5cf0c79..d9a5a0f9 100644 --- a/eval.c +++ b/eval.c @@ -204,7 +204,7 @@ static void expand_bcode (sexp ctx, sexp_uint_t size) { if (sexp_bytecode_length(sexp_context_bc(ctx)) < (sexp_context_pos(ctx))+size) { tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2); - sexp_bytecode_name(tmp) = SEXP_FALSE; + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); sexp_bytecode_length(tmp) = sexp_bytecode_length(sexp_context_bc(ctx))*2; sexp_bytecode_literals(tmp) @@ -551,6 +551,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x)); /* build lambda and analyze body */ res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x))); + sexp_lambda_source(res) = sexp_pair_source(x); ctx2 = sexp_make_child_context(ctx, res); tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); @@ -624,6 +625,7 @@ 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); tmp = sexp_cons(ctx, sexp_cdr(x), ctx); + sexp_pair_source(tmp) = sexp_pair_source(x); sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp); res = SEXP_VOID; } else { diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index ad773145..e2dc3e8c 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -183,6 +183,7 @@ struct sexp_struct { char gc_mark; unsigned int immutablep:1; unsigned int freep:1; + unsigned int syntacticp:1; #if SEXP_USE_HEADER_MAGIC unsigned int magic; #endif @@ -239,12 +240,11 @@ struct sexp_struct { } cpointer; /* runtime types */ struct { - unsigned int syntacticp:1; sexp parent, lambda, bindings; } env; struct { sexp_uint_t length; - sexp name, literals; + sexp name, literals, source; unsigned char data[]; } bytecode; struct { @@ -271,22 +271,22 @@ struct sexp_struct { } core; /* ast types */ struct { - sexp name, params, body, defs, locals, flags, fv, sv; + sexp name, params, body, defs, locals, flags, fv, sv, source; } lambda; struct { - sexp test, pass, fail; + sexp test, pass, fail, source; } cnd; struct { - sexp var, value; + sexp var, value, source; } set; struct { - sexp name, cell; + sexp name, cell, source; } ref; struct { - sexp ls; + sexp ls, source; } seq; struct { - sexp value; + sexp value, source; } lit; /* compiler state */ struct { @@ -604,9 +604,10 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #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_source(x) ((x)->value.bytecode.source) #define sexp_bytecode_data(x) ((x)->value.bytecode.data) -#define sexp_env_syntactic_p(x) ((x)->value.env.syntacticp) +#define sexp_env_syntactic_p(x) ((x)->syntacticp) #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)) @@ -648,21 +649,27 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #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_lambda_source(x) ((x)->value.lambda.source) #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_cnd_source(x) ((x)->value.cnd.source) #define sexp_set_var(x) ((x)->value.set.var) #define sexp_set_value(x) ((x)->value.set.value) +#define sexp_set_source(x) ((x)->value.set.source) #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_ref_source(x) ((x)->value.ref.source) #define sexp_seq_ls(x) ((x)->value.seq.ls) +#define sexp_seq_source(x) ((x)->value.seq.source) #define sexp_lit_value(x) ((x)->value.lit.value) +#define sexp_lit_source(x) ((x)->value.lit.source) #define sexp_stack_length(x) ((x)->value.stack.length) #define sexp_stack_top(x) ((x)->value.stack.top) diff --git a/sexp.c b/sexp.c index 069edea7..a1ff7949 100644 --- a/sexp.c +++ b/sexp.c @@ -100,15 +100,15 @@ static struct sexp_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro", NULL), _DEF_TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure", NULL), _DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, "environment", NULL), - _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode", NULL), + _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode", NULL), _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form", NULL), _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode", NULL), - _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda", NULL), - _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional", NULL), - _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference", NULL), - _DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 2, 0, 0, sexp_sizeof(set), 0, 0, "set!", NULL), - _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence", NULL), - _DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal", NULL), + _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 9, 9, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda", NULL), + _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional", NULL), + _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, "reference", NULL), + _DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, "set!", NULL), + _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, "sequence", NULL), + _DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, "literal", NULL), _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack", NULL), _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 7, 7, 0, 0, sexp_sizeof(context), 0, 0, "context", NULL), }; @@ -417,8 +417,10 @@ sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp sexp_write_string(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out); } } - if (sexp_pairp(sexp_exception_source(exn))) { - ls = sexp_exception_source(exn); + ls = sexp_exception_source(exn); + if ((! (ls && sexp_pairp(ls))) && sexp_exception_procedure(exn)) + ls = sexp_bytecode_source(sexp_procedure_code(sexp_exception_procedure(exn))); + if (ls && sexp_pairp(ls)) { if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { sexp_write_string(ctx, " on line ", out); sexp_write(ctx, sexp_cdr(ls), out); diff --git a/vm.c b/vm.c index 3ae152da..8e96d597 100644 --- a/vm.c +++ b/vm.c @@ -301,6 +301,7 @@ static void generate_lambda (sexp ctx, sexp lambda) { len = sexp_length(ctx2, sexp_lambda_params(lambda)); bc = finalize_bytecode(ctx2); sexp_bytecode_name(bc) = sexp_lambda_name(lambda); + sexp_bytecode_source(bc) = sexp_lambda_source(lambda); if (sexp_nullp(fv)) { /* shortcut, no free vars */ tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID); @@ -441,9 +442,12 @@ static sexp_uint_t sexp_restore_stack (sexp saved, sexp *current) { goto call_error_handler;} \ while (0) -#define sexp_check_exception() do {if (sexp_exceptionp(_ARG1)) \ - goto call_error_handler;} \ - while (0) +#define sexp_check_exception() \ + do {if (sexp_exceptionp(_ARG1)) { \ + if (! sexp_exception_procedure(_ARG1)) \ + sexp_exception_procedure(_ARG1) = self; \ + goto call_error_handler;}} \ + while (0) sexp sexp_vm (sexp ctx, sexp proc) { sexp bc = sexp_procedure_code(proc), cp = sexp_procedure_vars(proc); From 46a07441f17b3fc969073c67eb16f51411caee28 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Jun 2010 11:34:34 +0900 Subject: [PATCH 443/535] fixing line number info for implicit lambda defines --- eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/eval.c b/eval.c index d9a5a0f9..b9c7ad62 100644 --- a/eval.c +++ b/eval.c @@ -625,7 +625,6 @@ 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); tmp = sexp_cons(ctx, sexp_cdr(x), ctx); - sexp_pair_source(tmp) = sexp_pair_source(x); sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp); res = SEXP_VOID; } else { @@ -634,6 +633,7 @@ static sexp analyze_define (sexp ctx, sexp x) { if (sexp_pairp(sexp_cadr(x))) { tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); tmp = sexp_cons(ctx, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(x); value = analyze_lambda(ctx, tmp); } else value = analyze(ctx, sexp_caddr(x)); From c1d5a6f709642fe8724713f11d4757aeba208a9d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 29 Jun 2010 01:41:10 +0900 Subject: [PATCH 444/535] adding simple stack traces --- eval.c | 29 +++++++++++++++++++++++++++++ include/chibi/eval.h | 1 + include/chibi/sexp.h | 3 ++- main.c | 1 + vm.c | 1 + 5 files changed, 34 insertions(+), 1 deletion(-) diff --git a/eval.c b/eval.c index b9c7ad62..862a6062 100644 --- a/eval.c +++ b/eval.c @@ -20,6 +20,34 @@ static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) } #endif +void sexp_stack_trace (sexp ctx, sexp out) { + int i, fp=sexp_context_last_fp(ctx); + sexp self, bc, ls, *stack=sexp_stack_data(sexp_context_stack(ctx)); + if (! sexp_oportp(out)) out = sexp_current_error_port(ctx); + for (i=fp; i>4; i=sexp_unbox_fixnum(stack[i+3])) { + self = stack[i+2]; + if (sexp_procedurep(self)) { + sexp_write_string(ctx, " called from ", out); + bc = sexp_procedure_code(self); + if (sexp_truep(sexp_bytecode_name(bc))) + sexp_write(ctx, sexp_bytecode_name(bc), out); + else + sexp_printf(ctx, out, "anon: %p", bc); + if ((ls=sexp_bytecode_source(bc))) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_char(ctx, '\n', out); + } + } +} + static sexp analyze (sexp ctx, sexp x); static void generate (sexp ctx, sexp x); @@ -1558,6 +1586,7 @@ sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { res = sexp_apply(ctx2, res, SEXP_NULL); sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2); sexp_gc_release2(ctx); return res; } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 66ce173e..54110607 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -128,6 +128,7 @@ SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_u SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj); SEXP_API sexp sexp_analyze (sexp context, sexp x); +SEXP_API void sexp_stack_trace (sexp ctx, sexp out); SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); SEXP_API int sexp_param_index (sexp lambda, sexp name); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index e2dc3e8c..6a0d44d2 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -296,7 +296,7 @@ struct sexp_struct { struct { sexp_heap heap; struct sexp_gc_var_t *saves; - sexp_uint_t pos, depth, tailp, tracep; + sexp_uint_t pos, depth, tailp, tracep, last_fp; sexp bc, lambda, stack, env, fv, parent, globals; } context; } value; @@ -687,6 +687,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_context_tailp(x) ((x)->value.context.tailp) #define sexp_context_tracep(x) ((x)->value.context.tailp) #define sexp_context_globals(x) ((x)->value.context.globals) +#define sexp_context_last_fp(x) ((x)->value.context.last_fp) #if SEXP_USE_ALIGNED_BYTECODE #define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx)) diff --git a/main.c b/main.c index 7ecc913f..08a55662 100644 --- a/main.c +++ b/main.c @@ -45,6 +45,7 @@ static void repl (sexp ctx) { res = sexp_eval(ctx, obj, env); if (sexp_exceptionp(res)) { sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); } else { #if SEXP_USE_WARN_UNDEFS sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); diff --git a/vm.c b/vm.c index 8e96d597..aa60cf3a 100644 --- a/vm.c +++ b/vm.c @@ -476,6 +476,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_RAISE: call_error_handler: tmp1 = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); + sexp_context_last_fp(ctx) = fp; if (! sexp_procedurep(tmp1)) goto end_loop; stack[top] = (sexp) 1; stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc)); From 5b627880cb755404f03acd05c44028d581812264 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 4 Jul 2010 07:43:41 +0000 Subject: [PATCH 445/535] initial threading support (in-progress) --- .hgignore | 1 + Makefile | 10 +- eval.c | 9 +- include/chibi/eval.h | 1 + include/chibi/features.h | 12 ++ include/chibi/sexp.h | 29 ++++- lib/chibi/disasm.c | 17 +-- lib/srfi/18.module | 23 ++++ lib/srfi/18/interface.scm | 16 +++ lib/srfi/18/threads.c | 244 ++++++++++++++++++++++++++++++++++++++ lib/srfi/18/types.scm | 21 ++++ opcodes.c | 3 + opt/opcode_names.h | 16 +++ sexp.c | 18 +-- vm.c | 49 +++++++- 15 files changed, 434 insertions(+), 35 deletions(-) create mode 100644 lib/srfi/18.module create mode 100644 lib/srfi/18/interface.scm create mode 100644 lib/srfi/18/threads.c create mode 100644 lib/srfi/18/types.scm create mode 100644 opt/opcode_names.h diff --git a/.hgignore b/.hgignore index e26cf91b..e8b8b309 100644 --- a/.hgignore +++ b/.hgignore @@ -27,3 +27,4 @@ lib/chibi/net.c lib/chibi/process.c lib/chibi/system.c lib/chibi/time.c +lib/chibi/stty.c diff --git a/Makefile b/Makefile index 7c641a4c..8f47357e 100644 --- a/Makefile +++ b/Makefile @@ -88,11 +88,11 @@ endif all: chibi-scheme$(EXE) libs -COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ - lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \ - lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \ - lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \ - lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \ +COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \ + lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \ + lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/net$(SO) \ + lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \ + lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \ lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) libs: $(COMPILED_LIBS) diff --git a/eval.c b/eval.c index 862a6062..af6b7bde 100644 --- a/eval.c +++ b/eval.c @@ -391,6 +391,10 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); tmp = sexp_c_string(ctx, ".", 1); sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; +#endif sexp_gc_release3(ctx); } @@ -410,7 +414,10 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size) { sexp_context_stack(res) = stack; sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_FIVE)); if (! ctx) sexp_init_eval_context_globals(res); - if (ctx) sexp_gc_release1(ctx); + if (ctx) { + sexp_context_tracep(res) = sexp_context_tracep(ctx); + sexp_gc_release1(ctx); + } return res; } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 54110607..4f98010a 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -116,6 +116,7 @@ enum sexp_opcode_names { SEXP_OP_NEWLINE, SEXP_OP_READ_CHAR, SEXP_OP_PEEK_CHAR, + SEXP_OP_YIELD, SEXP_OP_RET, SEXP_OP_DONE, SEXP_OP_NUM_OPCODES diff --git a/include/chibi/features.h b/include/chibi/features.h index 562d0d49..b8aed237 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -7,6 +7,9 @@ /* option will disable any not explicitly enabled. */ /* #define SEXP_USE_NO_FEATURES 1 */ +/* uncomment this to disable interpreter-based threads */ +/* #define SEXP_USE_GREEN_THREADS 0 */ + /* uncomment this to enable the experimental native x86 backend */ /* #define SEXP_USE_NATIVE_X86 1 */ @@ -193,6 +196,11 @@ #define SEXP_GROW_HEAP_RATIO 0.75 #endif +/* the default number of opcodes to run each thread for */ +#ifndef SEXP_DEFAULT_QUANTUM +#define SEXP_DEFAULT_QUANTUM 1000 +#endif + /************************************************************************/ /* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ /************************************************************************/ @@ -218,6 +226,10 @@ #define SEXP_USE_NO_FEATURES 0 #endif +#ifndef SEXP_USE_GREEN_THREADS +#define SEXP_USE_GREEN_THREADS 1 +#endif + #ifndef SEXP_USE_NATIVE_X86 #define SEXP_USE_NATIVE_X86 0 #endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 6a0d44d2..d21ea569 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -296,8 +296,15 @@ struct sexp_struct { struct { sexp_heap heap; struct sexp_gc_var_t *saves; - sexp_uint_t pos, depth, tailp, tracep, last_fp; - sexp bc, lambda, stack, env, fv, parent, globals; +#if SEXP_USE_GREEN_THREADS + sexp_sint_t refuel; + unsigned char* ip; + struct timeval tval; +#endif + char tailp, tracep, timeoutp, waitp; + sexp_uint_t pos, depth, last_fp; + sexp bc, lambda, stack, env, fv, parent, globals, + proc, name, specific, event; } context; } value; }; @@ -480,6 +487,8 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT)) #define sexp_contextp(x) (sexp_check_tag(x, SEXP_CONTEXT)) +#define sexp_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x)) + #if SEXP_USE_HUFF_SYMS #define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) #else @@ -688,6 +697,15 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_context_tracep(x) ((x)->value.context.tailp) #define sexp_context_globals(x) ((x)->value.context.globals) #define sexp_context_last_fp(x) ((x)->value.context.last_fp) +#define sexp_context_refuel(x) ((x)->value.context.refuel) +#define sexp_context_ip(x) ((x)->value.context.ip) +#define sexp_context_proc(x) ((x)->value.context.proc) +#define sexp_context_timeval(x) ((x)->value.context.tval) +#define sexp_context_name(x) ((x)->value.context.name) +#define sexp_context_specific(x) ((x)->value.context.specific) +#define sexp_context_event(x) ((x)->value.context.event) +#define sexp_context_timeoutp(x) ((x)->value.context.timeoutp) +#define sexp_context_waitp(x) ((x)->value.context.waitp) #if SEXP_USE_ALIGNED_BYTECODE #define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx)) @@ -806,6 +824,13 @@ enum sexp_context_globals { SEXP_G_ERR_HANDLER, SEXP_G_RESUMECC_BYTECODE, SEXP_G_FINAL_RESUMER, +#if SEXP_USE_GREEN_THREADS + SEXP_G_THREADS_SCHEDULER, + SEXP_G_THREADS_FRONT, + SEXP_G_THREADS_BACK, + SEXP_G_THREADS_PAUSED, + SEXP_G_THREADS_LOCAL, +#endif SEXP_G_NUM_GLOBALS }; diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index 38b3a61a..d4a7373c 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -3,26 +3,11 @@ /* BSD-style license: http://synthcode.com/license.txt */ #include "chibi/eval.h" +#include "../../opt/opcode_names.h" #define SEXP_DISASM_MAX_DEPTH 8 #define SEXP_DISASM_PAD_WIDTH 4 -static const char* reverse_opcode_names[] = - {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", - "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", - "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", - "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", - "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", - "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", - "MUL", "DIV", "QUOTIENT", "REMAINDER", - "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", - "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", - "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", - }; - static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { sexp tmp; unsigned char *ip, opcode, i; diff --git a/lib/srfi/18.module b/lib/srfi/18.module new file mode 100644 index 00000000..930e800e --- /dev/null +++ b/lib/srfi/18.module @@ -0,0 +1,23 @@ + +(define-module (srfi 18) + (export + current-thread thread? make-thread thread-name + thread-specific thread-specific-set! thread-start! + thread-yield! thread-sleep! thread-terminate! + thread-join! mutex? make-mutex mutex-name + mutex-specific mutex-specific-set! mutex-state + mutex-lock! mutex-unlock! condition-variable? + make-condition-variable condition-variable-name + condition-variable-specific condition-variable-specific-set! + condition-variable-signal! condition-variable-broadcast! + current-time time? time->seconds seconds->time + current-exception-handler with-exception-handler raise + join-timeout-exception? abandoned-mutex-exception? + terminated-thread-exception? uncaught-exception? + uncaught-exception-reason) + (import-immutable (scheme) + (srfi 9) + (chibi time)) + (include-shared "18/threads") + (include "18/types.scm" "18/interface.scm")) + diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm new file mode 100644 index 00000000..80cf6566 --- /dev/null +++ b/lib/srfi/18/interface.scm @@ -0,0 +1,16 @@ + +(define (thread-join! thread . o) + (let ((timeout (if (pair? o) (car o) #f))) + (cond + ((%thread-join! thread timeout)) + (else + (thread-yield!) + (if (thread-timeout?) + (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (error "timed out waiting for thread" thread))))))) + +(define (thread-terminate! thread) + (if (%thread-terminate! thread) ;; need to yield if terminating ourself + (thread-yield!))) + diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c new file mode 100644 index 00000000..d606784a --- /dev/null +++ b/lib/srfi/18/threads.c @@ -0,0 +1,244 @@ +/* threads.c -- SRFI-18 thread primitives */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include +#include + +#define sexp_mutex_name(x) sexp_slot_ref(x, 0) +#define sexp_mutex_specific(x) sexp_slot_ref(x, 1) +#define sexp_mutex_thread(x) sexp_slot_ref(x, 2) +#define sexp_mutex_lock(x) sexp_slot_ref(x, 3) + +#define sexp_condvar_name(x) sexp_slot_ref(x, 0) +#define sexp_condvar_specific(x) sexp_slot_ref(x, 1) +#define sexp_condvar_threads(x) sexp_slot_ref(x, 2) + +#define timeval_le(a, b) (((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec < (b).tv_usec))) +#define sexp_context_before(c, t) ((sexp_context_timeval(c).tv_sec != 0) && timeval_le(sexp_context_timeval(c), t)) + +/* static int mutex_id, condvar_id; */ + +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); + sexp_gc_release2(ctx); +} + +sexp sexp_thread_timeoutp (sexp ctx sexp_api_params(self, n)) { + return sexp_make_boolean(sexp_context_timeoutp(ctx)); +} + +sexp sexp_thread_name (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + return sexp_context_name(thread); +} + +sexp sexp_thread_specific (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + return sexp_context_specific(thread); +} + +sexp sexp_thread_specific_set (sexp ctx sexp_api_params(self, n), sexp thread, sexp val) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + sexp_context_specific(thread) = val; + return SEXP_VOID; +} + +sexp sexp_current_thread (sexp ctx sexp_api_params(self, n)) { + return ctx; +} + +sexp sexp_make_thread (sexp ctx sexp_api_params(self, n), sexp thunk, sexp name) { + sexp res, *stack; + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk); + res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0); + sexp_context_proc(res) = thunk; + sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk)); + stack = sexp_stack_data(sexp_context_stack(res)); + stack[0] = stack[1] = stack[3] = SEXP_ZERO; + stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + sexp_context_top(res) = 4; + sexp_context_last_fp(res) = 0; + return res; +} + +sexp sexp_thread_start (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp cell; + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + if (sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + cell = sexp_cons(ctx, thread, SEXP_NULL); + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = cell; + sexp_global(ctx, SEXP_G_THREADS_BACK) = cell; + } else { /* init queue */ + sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) + = sexp_cons(ctx, thread, SEXP_NULL); + } + return SEXP_VOID; +} + +sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_context_refuel(thread) = 0; + for ( ; sexp_pairp(ls2) && (sexp_car(ls2) != thread); ls2=sexp_cdr(ls2)) + ls1 = ls2; + if (sexp_pairp(ls2)) { + if (ls1 == SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(ls2); + else /* splice */ + sexp_cdr(ls1) = sexp_cdr(ls2); + if (ls2 == sexp_global(ctx, SEXP_G_THREADS_BACK)) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1; + } else { /* check for paused threads */ + ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + for ( ; sexp_pairp(ls2) && (sexp_car(ls2) != thread); ls2=sexp_cdr(ls2)) + ls1 = ls2; + if (sexp_pairp(ls2)) { + if (ls1 == SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else /* splice */ + sexp_cdr(ls1) = sexp_cdr(ls2); + } + } + /* return true if terminating self */ + return sexp_make_boolean(ctx == thread); +} + +void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { +#if SEXP_USE_FLONUMS + double d; +#endif + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + if (sexp_integerp(timeout)) { + sexp_context_timeval(ctx).tv_sec = sexp_unbox_fixnum(timeout); + sexp_context_timeval(ctx).tv_usec = 0; +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(timeout)) { + d = sexp_flonum_value(timeout); + sexp_context_timeval(ctx).tv_sec = trunc(d); + sexp_context_timeval(ctx).tv_usec = (d-trunc(d))*1000000; +#endif + } else { + sexp_context_timeval(ctx).tv_sec = 0; + sexp_context_timeval(ctx).tv_usec = 0; + } + if (sexp_numberp(timeout)) + while (sexp_pairp(ls2) + && sexp_context_before(sexp_car(ls2), sexp_context_timeval(ctx))) + ls1=ls2, ls2=sexp_cdr(ls2); + else + while (sexp_pairp(ls2) && sexp_context_timeval(sexp_car(ls2)).tv_sec) + ls1=ls2, ls2=sexp_cdr(ls2); + if (ls1 == SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cons(ctx, thread, ls2); + else + sexp_cdr(ls1) = sexp_cons(ctx, thread, ls2); +} + +sexp sexp_thread_join (sexp ctx sexp_api_params(self, n), sexp thread, sexp timeout) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + if (sexp_context_refuel(thread) <= 0) /* return true if already terminated */ + return SEXP_TRUE; + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = thread; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; +} + +sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { + struct timeval tval; + sexp res, ls1, ls2, tmp, paused, front=sexp_global(ctx, SEXP_G_THREADS_FRONT); + + paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); + + /* if we've terminated, check threads joining us */ + if (sexp_context_refuel(ctx) <= 0) { + for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == ctx) { + sexp_context_waitp(ctx) = 0; + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + tmp = sexp_cdr(ls2); + sexp_cdr(ls2) = front; + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; + ls2 = tmp; + } else { + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + } + + /* TODO: check threads blocked on I/O */ + /* ... */ + + /* check timeouts (must be _after_ previous checks) */ + if (sexp_pairp(paused)) { + if (gettimeofday(&tval, NULL) == 0) { + ls1 = SEXP_NULL; + ls2 = paused; + while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), tval)) { + sexp_context_timeoutp(sexp_car(ls2)) = 1; + sexp_context_waitp(ctx) = 0; + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + if (sexp_pairp(ls1)) { + sexp_cdr(ls1) = front; + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused; + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = ls2; + } + } + } + + /* dequeue next thread */ + if (sexp_pairp(front)) { + res = sexp_car(front); + if ((sexp_context_refuel(ctx) <= 0) || sexp_context_waitp(ctx)) { + /* either terminated or paused */ + sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(front); + if (ctx == sexp_car(sexp_global(ctx, SEXP_G_THREADS_BACK))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + } else { + /* swap with front of queue */ + sexp_car(sexp_global(ctx, SEXP_G_THREADS_FRONT)) = ctx; + /* rotate front of queue to back */ + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) + = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) + = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_FRONT)); + sexp_global(ctx, SEXP_G_THREADS_BACK) + = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)); + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = SEXP_NULL; + } + } else { + res = ctx; + } + + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + + sexp_define_type_predicate(ctx, env, "thread?", SEXP_CONTEXT); + sexp_define_foreign(ctx, env, "thread-timeout?", 0, sexp_thread_timeoutp); + sexp_define_foreign(ctx, env, "current-thread", 0, sexp_current_thread); + sexp_define_foreign_opt(ctx, env, "make-thread", 2, sexp_make_thread, SEXP_FALSE); + sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start); + sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate); + sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join); + sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name); + sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific); + sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set); + + sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) + = sexp_make_foreign(ctx, "scheduler", 0, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); + + return SEXP_VOID; +} + diff --git a/lib/srfi/18/types.scm b/lib/srfi/18/types.scm new file mode 100644 index 00000000..611c0670 --- /dev/null +++ b/lib/srfi/18/types.scm @@ -0,0 +1,21 @@ +;; types.scm -- thread types +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type mutex + (%make-mutex name specific thread lock) + mutex? + (name mutex-name) + (specific mutex-specific mutex-specific-set!) + (thread %mutex-thread %mutex-thread-set!) + (lock %mutex-lock %mutex-lock-set!)) + +(define (make-mutex . o) + (%make-mutex (and (pair? o) (car o)) #f #f #f)) + +(define-record-type condition-variable + (%make-condition-variable name specific threads) + condition-variable? + (name condition-variable-name) + (specific condition-variable-specific condition-variable-specific-set!) + (threads %condition-variable-threads %condition-variable-threads-set!)) diff --git a/opcodes.c b/opcodes.c index 4f11e7e0..3e74ce53 100644 --- a/opcodes.c +++ b/opcodes.c @@ -150,5 +150,8 @@ _FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), _FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), _FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory_op), #endif +#if SEXP_USE_GREEN_THREADS +_OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, 0, 0, 0, "thread-yield!", 0, NULL), +#endif }; diff --git a/opt/opcode_names.h b/opt/opcode_names.h new file mode 100644 index 00000000..d4c44632 --- /dev/null +++ b/opt/opcode_names.h @@ -0,0 +1,16 @@ + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", + "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", + "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", + "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", + "MUL", "DIV", "QUOTIENT", "REMAINDER", + "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "YIELD", "RET", "DONE", + }; diff --git a/sexp.c b/sexp.c index a1ff7949..b2390075 100644 --- a/sexp.c +++ b/sexp.c @@ -110,7 +110,7 @@ static struct sexp_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, "sequence", NULL), _DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, "literal", NULL), _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack", NULL), - _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 7, 7, 0, 0, sexp_sizeof(context), 0, 0, "context", NULL), + _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 11, 11, 0, 0, sexp_sizeof(context), 0, 0, "context", NULL), }; #undef _DEF_TYPE @@ -285,12 +285,14 @@ sexp sexp_make_context (sexp ctx, size_t size) { } sexp_context_parent(res) = ctx; sexp_context_lambda(res) = SEXP_FALSE; + sexp_context_name(res) = sexp_context_specific(res) = SEXP_FALSE; sexp_context_fv(res) = SEXP_NULL; - sexp_context_saves(res) = 0; - sexp_context_depth(res) = 0; - sexp_context_pos(res) = 0; + sexp_context_saves(res) = NULL; + sexp_context_depth(res)=sexp_context_tracep(res)=sexp_context_pos(res)=0; sexp_context_tailp(res) = 1; - sexp_context_tracep(res) = 0; +#if SEXP_USE_GREEN_THREADS + sexp_context_refuel(res) = SEXP_DEFAULT_QUANTUM; +#endif if (ctx) { sexp_context_globals(res) = sexp_context_globals(ctx); sexp_gc_release1(ctx); @@ -418,7 +420,8 @@ sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp } } ls = sexp_exception_source(exn); - if ((! (ls && sexp_pairp(ls))) && sexp_exception_procedure(exn)) + if ((! (ls && sexp_pairp(ls))) + && sexp_procedurep(sexp_exception_procedure(exn))) ls = sexp_bytecode_source(sexp_procedure_code(sexp_exception_procedure(exn))); if (ls && sexp_pairp(ls)) { if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { @@ -1165,7 +1168,8 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { #endif case SEXP_PROCEDURE: sexp_write_string(ctx, "#", out); break; case SEXP_STRING: diff --git a/vm.c b/vm.c index aa60cf3a..f7544ddf 100644 --- a/vm.c +++ b/vm.c @@ -2,6 +2,8 @@ /* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ +static sexp sexp_apply1 (sexp ctx, sexp f, sexp x); + /************************* code generation ****************************/ static void emit_word (sexp ctx, sexp_uint_t val) { @@ -449,11 +451,19 @@ static sexp_uint_t sexp_restore_stack (sexp saved, sexp *current) { goto call_error_handler;}} \ while (0) +#if SEXP_USE_DEBUG_VM +#include "opt/opcode_names.h" +#endif + sexp sexp_vm (sexp ctx, sexp proc) { sexp bc = sexp_procedure_code(proc), cp = sexp_procedure_vars(proc); sexp *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)); +#if SEXP_USE_GREEN_THREADS + sexp root_thread = ctx; + sexp_sint_t fuel = sexp_context_refuel(ctx); +#endif #if SEXP_USE_BIGNUMS sexp_lsint_t prod; #endif @@ -463,6 +473,29 @@ sexp sexp_vm (sexp ctx, sexp proc) { self = proc; loop: +#if SEXP_USE_GREEN_THREADS + if (--fuel <= 0) { + tmp1 = sexp_global(ctx, SEXP_G_THREADS_SCHEDULER); + if (sexp_applicablep(tmp1)) { + /* save thread */ + sexp_context_top(ctx) = top; + sexp_context_ip(ctx) = ip; + sexp_context_last_fp(ctx) = fp; + sexp_context_proc(ctx) = self; + /* run scheduler */ + ctx = sexp_apply1(ctx, tmp1, root_thread); + /* restore thread */ + stack = sexp_stack_data(sexp_context_stack(ctx)); + top = sexp_context_top(ctx); + fp = sexp_context_last_fp(ctx); + ip = sexp_context_ip(ctx); + self = sexp_context_proc(ctx); + bc = sexp_procedure_code(self); + cp = sexp_procedure_vars(self); + } + fuel = sexp_context_refuel(ctx); + } +#endif #if SEXP_USE_DEBUG_VM if (sexp_context_tracep(ctx)) { sexp_print_stack(ctx, stack, top, fp, SEXP_FALSE); @@ -1163,17 +1196,20 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case SEXP_OP_READ_CHAR: if (! sexp_iportp(_ARG1)) - sexp_raise("read-char: not an intput-port", sexp_list1(ctx, _ARG1)); + sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1)); i = sexp_read_char(ctx, _ARG1); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case SEXP_OP_PEEK_CHAR: if (! sexp_iportp(_ARG1)) - sexp_raise("peek-char: not an intput-port", sexp_list1(ctx, _ARG1)); + sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1)); i = sexp_read_char(ctx, _ARG1); sexp_push_char(ctx, i, _ARG1); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; + case SEXP_OP_YIELD: + fuel = 0; + break; case SEXP_OP_RET: i = sexp_unbox_fixnum(stack[fp]); stack[fp-i] = _ARG1; @@ -1192,6 +1228,12 @@ sexp sexp_vm (sexp ctx, sexp proc) { goto loop; end_loop: +#if SEXP_USE_GREEN_THREADS + if (ctx != root_thread) { /* don't return from child threads */ + sexp_context_refuel(ctx) = fuel = 0; + goto loop; + } +#endif sexp_gc_release3(ctx); sexp_context_top(ctx) = top; return _ARG1; @@ -1225,8 +1267,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { offset = top + len; for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) stack[--offset] = sexp_car(ls); - stack[top] = sexp_make_fixnum(len); - top++; + stack[top++] = sexp_make_fixnum(len); stack[top++] = SEXP_ZERO; stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); stack[top++] = SEXP_ZERO; From 34710bf44db6d12c5cae2a1bd0049b4c825d13c3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 5 Jul 2010 08:24:36 +0900 Subject: [PATCH 446/535] srfi-18 updates --- lib/srfi/18/interface.scm | 15 ++++++++ lib/srfi/18/threads.c | 76 +++++++++++++++++++++++++++++++++++++-- lib/srfi/18/types.scm | 3 ++ 3 files changed, 92 insertions(+), 2 deletions(-) diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm index 80cf6566..d917cf25 100644 --- a/lib/srfi/18/interface.scm +++ b/lib/srfi/18/interface.scm @@ -14,3 +14,18 @@ (if (%thread-terminate! thread) ;; need to yield if terminating ourself (thread-yield!))) +(define (thread-sleep! timeout) + (%thread-sleep! timeout) + (thread-yield!)) + +(define (mutex-lock! mutex . o) + (let ((timeout (and (pair? o) (car o))) + (thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t))) + (if (not (%mutex-lock! mutex timeout thread)) + (thread-yield!)))) + +(define (mutex-unlock! mutex . o) + #f) + +(define current-time get-time-of-day) +(define time? timeval?) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index d606784a..24c57050 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -9,7 +9,7 @@ #define sexp_mutex_name(x) sexp_slot_ref(x, 0) #define sexp_mutex_specific(x) sexp_slot_ref(x, 1) #define sexp_mutex_thread(x) sexp_slot_ref(x, 2) -#define sexp_mutex_lock(x) sexp_slot_ref(x, 3) +#define sexp_mutex_lockp(x) sexp_slot_ref(x, 3) #define sexp_condvar_name(x) sexp_slot_ref(x, 0) #define sexp_condvar_specific(x) sexp_slot_ref(x, 1) @@ -20,6 +20,8 @@ /* static int mutex_id, condvar_id; */ +/**************************** threads *************************************/ + static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { sexp_gc_var2(name, op); sexp_gc_preserve2(ctx, name, op); @@ -108,7 +110,7 @@ sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) { return sexp_make_boolean(ctx == thread); } -void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { +static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { #if SEXP_USE_FLONUMS double d; #endif @@ -149,6 +151,68 @@ sexp sexp_thread_join (sexp ctx sexp_api_params(self, n), sexp thread, sexp time return SEXP_FALSE; } +sexp sexp_thread_sleep (sexp ctx sexp_api_params(self, n), sexp timeout) { + sexp_assert_type(ctx, sexp_numberp, SEXP_NUMBER, timeout); + sexp_context_waitp(ctx) = 1; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; +} + +/**************************** mutexes *************************************/ + +sexp sexp_mutex_state (sexp ctx sexp_api_params(self, n), sexp mutex) { + /* sexp_assert_type(ctx, sexp_mutexp, mutex_id, timeout); */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + if (sexp_contextp(sexp_mutex_thread(mutex))) + return sexp_mutex_thread(mutex); + else + return sexp_intern(ctx, "not-owned", -1); + } else { + return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1); + } +} + +sexp sexp_mutex_lock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp timeout, sexp thread) { + if (thread == SEXP_TRUE) + thread = ctx; + if (sexp_not(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_TRUE; + sexp_mutex_thread(mutex) = thread; + return SEXP_TRUE; + } else { + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = mutex; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; + } +} + +sexp sexp_mutex_unlock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp condvar, sexp timeout) { + if (sexp_not(condvar)) { + /* normal unlock */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_FALSE; + sexp_mutex_thread(mutex) = ctx; + /* XXXX search for threads blocked on this mutex */ + } + } else { + /* wait on condition var */ + + } +} + +/**************************** condition variables *************************/ + +sexp sexp_condition_variable_signal (sexp ctx sexp_api_params(self, n), sexp condvar) { + return SEXP_VOID; +} + +sexp sexp_condition_variable_broadcast (sexp ctx sexp_api_params(self, n), sexp condvar) { + return SEXP_VOID; +} + +/**************************** the scheduler *******************************/ + sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { struct timeval tval; sexp res, ls1, ls2, tmp, paused, front=sexp_global(ctx, SEXP_G_THREADS_FRONT); @@ -223,6 +287,8 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { return res; } +/**************************************************************************/ + sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_type_predicate(ctx, env, "thread?", SEXP_CONTEXT); @@ -232,9 +298,15 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start); sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate); sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join); + sexp_define_foreign(ctx, env, "%thread-sleep!", 1, sexp_thread_sleep); sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name); sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific); sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set); + sexp_define_foreign(ctx, env, "mutex-state", 1, sexp_mutex_state); + sexp_define_foreign(ctx, env, "%mutex-lock!", 3, sexp_mutex_lock); + sexp_define_foreign(ctx, env, "%mutex-unlock!", 3, sexp_mutex_unlock); + sexp_define_foreign(ctx, env, "condition-variable-signal!", 1, sexp_condition_variable_signal); + sexp_define_foreign(ctx, env, "condition-variable-broadcast!", 1, sexp_condition_variable_broadcast); sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) = sexp_make_foreign(ctx, "scheduler", 0, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); diff --git a/lib/srfi/18/types.scm b/lib/srfi/18/types.scm index 611c0670..093c97a7 100644 --- a/lib/srfi/18/types.scm +++ b/lib/srfi/18/types.scm @@ -19,3 +19,6 @@ (name condition-variable-name) (specific condition-variable-specific condition-variable-specific-set!) (threads %condition-variable-threads %condition-variable-threads-set!)) + +(define (make-condition-variable . o) + (%make-condition-variable (and (pair? o) (car o)) #f #f)) From 3bfc6a2d8eccd8966aeae6f133ef535196725e4e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 7 Jul 2010 21:14:27 +0900 Subject: [PATCH 447/535] adding stack traces for scripts --- eval.c | 2 +- main.c | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/eval.c b/eval.c index af6b7bde..26f1e450 100644 --- a/eval.c +++ b/eval.c @@ -33,7 +33,7 @@ void sexp_stack_trace (sexp ctx, sexp out) { sexp_write(ctx, sexp_bytecode_name(bc), out); else sexp_printf(ctx, out, "anon: %p", bc); - if ((ls=sexp_bytecode_source(bc))) { + if ((ls=sexp_bytecode_source(bc)) && sexp_pairp(ls)) { if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { sexp_write_string(ctx, " on line ", out); sexp_write(ctx, sexp_cdr(ls), out); diff --git a/main.c b/main.c index 08a55662..03caf762 100644 --- a/main.c +++ b/main.c @@ -74,6 +74,7 @@ static sexp check_exception (sexp ctx, sexp res) { if (! sexp_oportp(err)) err = sexp_make_output_port(ctx, stderr, SEXP_FALSE); sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); exit_failure(); } return res; From c031339334eab58b141149f4eb7a2fa2c2da6f92 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 7 Jul 2010 22:41:08 +0900 Subject: [PATCH 448/535] fixing getters/setters on nested structs --- tools/genstubs.scm | 52 ++++++++++++++++++++++++++++++++++++---------- 1 file changed, 41 insertions(+), 11 deletions(-) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 95443d24..70aa0a0d 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -200,6 +200,12 @@ (number->string (type-index type)) "")) +(define (struct-fields ls) + (let lp ((ls ls) (res '())) + (cond ((null? ls) (reverse res)) + ((symbol? (car ls)) (lp (cddr ls) res)) + (else (lp (cdr ls) (cons (car ls) res)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; type predicates @@ -1054,10 +1060,10 @@ (lambda () (c->scheme-converter (car field) - (string-append "((" (x->string (or (type-struct-type name) "")) + (string-append (if (type-struct? (car field)) "&" "") + "((" (x->string (or (type-struct-type name) "")) " " (mangle name) "*)" - "sexp_cpointer_value(x))" - (if (type-struct? (car field)) "." "->") + "sexp_cpointer_value(x))" "->" (x->string (cadr field))) (and (or (type-struct? (car field)) (type-link? (car field))) "x"))) ";\n" @@ -1067,18 +1073,42 @@ (string-append "sexp_" (x->string (type-name (parse-type name))) "_set_" (x->string (type-base (parse-type (cadr field)))))) +(define (write-type-setter-assignment type name field dst val) + (cond + ((type-struct? (car field)) + ;; assign to a nested struct - copy field-by-field + (let ((field-type + (cond ((assq (type-name (car field)) *types*) => cdddr) + (else (cdr field))))) + (lambda () + (for-each + (lambda (subfield) + (let ((subname (x->string (cadr subfield)))) + (cat + " " + (string-append dst "." (x->string (cadr subfield))) + " = " + (string-append + "((" (x->string (or (type-struct-type (type-name (car field))) "")) + " " (mangle (type-name (car field))) "*)" "sexp_cpointer_value(" val "))" + "->" (x->string (cadr subfield))) + ";\n"))) + (struct-fields field-type))))) + (else + (lambda () + (cat " " dst " = " (lambda () (scheme->c-converter (car field) val)) ";\n"))))) + (define (write-type-setter type name field) (cat "static sexp " (type-setter-name type name field) " (sexp ctx sexp_api_params(self, n), sexp x, sexp v) {\n" (lambda () (write-validator "x" name)) (lambda () (write-validator "v" (car field))) - " " - (string-append "((" (x->string (or (type-struct-type name) "")) - " " (mangle name) "*)" - "sexp_cpointer_value(x))" - (if (type-struct? (car field)) "." "->") - (x->string (cadr field))) - " = " (lambda () (scheme->c-converter (car field) "v")) ";\n" + (write-type-setter-assignment + type name field + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" "sexp_cpointer_value(x))" + "->" (x->string (cadr field))) + "v") " return SEXP_VOID;\n" "}\n\n")) @@ -1173,7 +1203,7 @@ ,(type-setter-name type name field)) (,name ,(car field)))) *funcs*))))))) - type))) + (struct-fields type)))) (define (write-const const) (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) From 766a841ca40a99d8ce4a793abe1825f4fc8a356b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 7 Jul 2010 23:53:48 +0900 Subject: [PATCH 449/535] adding support for foreign functions taking up to 16 arguments --- eval.c | 31 ++++++++++++++++++------------- include/chibi/eval.h | 1 + include/chibi/features.h | 7 +++++++ tools/genstubs.scm | 4 ++-- vm.c | 16 ++++++++++++++++ 5 files changed, 44 insertions(+), 15 deletions(-) diff --git a/eval.c b/eval.c index 26f1e450..baa28e8a 100644 --- a/eval.c +++ b/eval.c @@ -1222,20 +1222,25 @@ sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code, sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data) { sexp res; - if (num_args > 6) { - res = sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", - sexp_make_fixnum(num_args)); - } else { - res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); - sexp_opcode_class(res) = SEXP_OPC_FOREIGN; +#if ! SEXP_USE_EXTENDED_FCALL + if (num_args > 6) + return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); +#endif + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; +#if SEXP_USE_EXTENDED_FCALL + if (num_args > 6) + sexp_opcode_code(res) = SEXP_OP_FCALLN; + else +#endif sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1; - if (flags & 1) num_args--; - sexp_opcode_num_args(res) = num_args; - sexp_opcode_flags(res) = flags; - sexp_opcode_name(res) = name; - sexp_opcode_data(res) = data; - sexp_opcode_func(res) = f; - } + if (flags & 1) num_args--; + sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; + sexp_opcode_name(res) = name; + sexp_opcode_data(res) = data; + sexp_opcode_func(res) = f; return res; } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 4f98010a..938bf7c0 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -62,6 +62,7 @@ enum sexp_opcode_names { SEXP_OP_FCALL4, SEXP_OP_FCALL5, SEXP_OP_FCALL6, + SEXP_OP_FCALLN, SEXP_OP_JUMP_UNLESS, SEXP_OP_JUMP, SEXP_OP_PUSH, diff --git a/include/chibi/features.h b/include/chibi/features.h index b8aed237..d1b0c5e8 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -96,6 +96,9 @@ /* heap, of course. */ /* #define SEXP_USE_GLOBAL_SYMBOLS 1 */ +/* uncomment this to disable foreign function bindings with > 6 args */ +/* #define SEXP_USE_EXTENDED_FCALL 0 */ + /* uncomment this if you don't need flonum support */ /* This is only for EVAL - you'll still be able to read */ /* and write flonums directly through the sexp API. */ @@ -310,6 +313,10 @@ #endif #endif +#ifndef SEXP_USE_EXTENDED_FCALL +#define SEXP_USE_EXTENDED_FCALL 1 +#endif + #ifndef SEXP_USE_FLONUMS #define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES #endif diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 70aa0a0d..114320b4 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -272,8 +272,8 @@ (s-args '())) (cond ((null? ls) - (if (> i 6) - (error "FFI currently only supports up to 6 scheme args" func)) + ;;(if (> i 6) + ;; (error "FFI currently only supports up to 6 scheme args" func)) (vector scheme-name c-name stub-name ret-type (reverse results) (reverse c-args) (reverse s-args))) (else diff --git a/vm.c b/vm.c index f7544ddf..1ebad747 100644 --- a/vm.c +++ b/vm.c @@ -455,6 +455,10 @@ static sexp_uint_t sexp_restore_stack (sexp saved, sexp *current) { #include "opt/opcode_names.h" #endif +#if SEXP_USE_EXTENDED_FCALL +#include "opt/fcall.c" +#endif + sexp sexp_vm (sexp ctx, sexp proc) { sexp bc = sexp_procedure_code(proc), cp = sexp_procedure_vars(proc); sexp *stack = sexp_stack_data(sexp_context_stack(ctx)); @@ -692,6 +696,18 @@ sexp sexp_vm (sexp ctx, sexp proc) { ip += sizeof(sexp); sexp_check_exception(); break; +#if SEXP_USE_EXTENDED_FCALL + case SEXP_OP_FCALLN: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + i = sexp_opcode_num_args(_WORD0); + tmp1 = sexp_fcall(ctx, self, i, _WORD0); + top -= (i-1); + _ARG1 = tmp1; + ip += sizeof(sexp); + sexp_check_exception(); + break; +#endif case SEXP_OP_JUMP_UNLESS: _ALIGN_IP(); if (stack[--top] == SEXP_FALSE) From 061458f521e75a717487c2be05ad4172dac354fc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 8 Jul 2010 22:36:41 +0900 Subject: [PATCH 450/535] forgot to add a file --- opt/fcall.c | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 opt/fcall.c diff --git a/opt/fcall.c b/opt/fcall.c new file mode 100644 index 00000000..17e7b82f --- /dev/null +++ b/opt/fcall.c @@ -0,0 +1,31 @@ + +typedef sexp (*sexp_proc8) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc9) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc10) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc11) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc12) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc13) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc14) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc15) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc16) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc17) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); + +#define _A(i) stack[top-i] + +sexp sexp_fcall (sexp ctx, sexp self, sexp_sint_t n, sexp f) { + sexp *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx); + switch (n) { + case 7: return ((sexp_proc8)sexp_opcode_func(f))(ctx, f, 7, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7)); + case 8: return ((sexp_proc9)sexp_opcode_func(f))(ctx, f, 8, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8)); + case 9: return ((sexp_proc10)sexp_opcode_func(f))(ctx, f, 9, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9)); + case 10: return ((sexp_proc11)sexp_opcode_func(f))(ctx, f, 10, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10)); + case 11: return ((sexp_proc12)sexp_opcode_func(f))(ctx, f, 11, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11)); + case 12: return ((sexp_proc13)sexp_opcode_func(f))(ctx, f, 12, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12)); + case 13: return ((sexp_proc14)sexp_opcode_func(f))(ctx, f, 13, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13)); + case 14: return ((sexp_proc15)sexp_opcode_func(f))(ctx, f, 14, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14)); + case 15: return ((sexp_proc16)sexp_opcode_func(f))(ctx, f, 15, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15)); + case 16: return ((sexp_proc17)sexp_opcode_func(f))(ctx, f, 16, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16)); + default: return sexp_user_exception(ctx, self, "too many FFI arguments", f); + } +} From 1ecc2bb55cc04f407cdf720cfeab13cdfe5fd75e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 11 Jul 2010 05:57:07 +0000 Subject: [PATCH 451/535] srfi-18 updates --- Makefile | 3 + eval.c | 40 ------------- include/chibi/sexp.h | 2 +- lib/srfi/18/interface.scm | 16 +++-- lib/srfi/18/threads.c | 119 +++++++++++++++++++++++++++++--------- opt/opcode_names.h | 2 +- sexp.c | 1 + tests/thread-tests.scm | 58 +++++++++++++++++++ vm.c | 51 +++++++++++++++- 9 files changed, 217 insertions(+), 75 deletions(-) create mode 100644 tests/thread-tests.scm diff --git a/Makefile b/Makefile index 8f47357e..ea3bd2f6 100644 --- a/Makefile +++ b/Makefile @@ -161,6 +161,9 @@ test-basic: chibi-scheme$(EXE) test-build: ./tests/build/build-tests.sh +test-threads: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/thread-tests.scm + test-numbers: chibi-scheme$(EXE) LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/numeric-tests.scm diff --git a/eval.c b/eval.c index baa28e8a..eb438301 100644 --- a/eval.c +++ b/eval.c @@ -8,46 +8,6 @@ static int scheme_initialized_p = 0; -#if SEXP_USE_DEBUG_VM -static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { - int i; - if (! sexp_oportp(out)) out = sexp_current_error_port(ctx); - for (i=0; i4; i=sexp_unbox_fixnum(stack[i+3])) { - self = stack[i+2]; - if (sexp_procedurep(self)) { - sexp_write_string(ctx, " called from ", out); - bc = sexp_procedure_code(self); - if (sexp_truep(sexp_bytecode_name(bc))) - sexp_write(ctx, sexp_bytecode_name(bc), out); - else - sexp_printf(ctx, out, "anon: %p", bc); - if ((ls=sexp_bytecode_source(bc)) && sexp_pairp(ls)) { - if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { - sexp_write_string(ctx, " on line ", out); - sexp_write(ctx, sexp_cdr(ls), out); - } - if (sexp_stringp(sexp_car(ls))) { - sexp_write_string(ctx, " of file ", out); - sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); - } - } - sexp_write_char(ctx, '\n', out); - } - } -} - static sexp analyze (sexp ctx, sexp x); static void generate (sexp ctx, sexp x); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index d21ea569..3e66a297 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -694,7 +694,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #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_tracep(x) ((x)->value.context.tracep) #define sexp_context_globals(x) ((x)->value.context.globals) #define sexp_context_last_fp(x) ((x)->value.context.last_fp) #define sexp_context_refuel(x) ((x)->value.context.refuel) diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm index d917cf25..7dde92aa 100644 --- a/lib/srfi/18/interface.scm +++ b/lib/srfi/18/interface.scm @@ -8,7 +8,8 @@ (if (thread-timeout?) (if (and (pair? o) (pair? (cdr o))) (cadr o) - (error "timed out waiting for thread" thread))))))) + (error "timed out waiting for thread" thread)) + #t))))) (define (thread-terminate! thread) (if (%thread-terminate! thread) ;; need to yield if terminating ourself @@ -21,11 +22,18 @@ (define (mutex-lock! mutex . o) (let ((timeout (and (pair? o) (car o))) (thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t))) - (if (not (%mutex-lock! mutex timeout thread)) - (thread-yield!)))) + (cond ((%mutex-lock! mutex timeout thread)) + (else + (thread-yield!) + (not (thread-timeout?)))))) (define (mutex-unlock! mutex . o) - #f) + (let ((condvar (and (pair? o) (car o))) + (timeout (if (and (pair? o) (pair? (cdr o))) (cadr o) #f))) + (cond ((%mutex-unlock! mutex condvar timeout)) + (else + (thread-yield!) + (not (thread-timeout?)))))) (define current-time get-time-of-day) (define time? timeval?) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index 24c57050..046d8bf4 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -5,6 +5,7 @@ #include #include #include +#include #define sexp_mutex_name(x) sexp_slot_ref(x, 0) #define sexp_mutex_specific(x) sexp_slot_ref(x, 1) @@ -16,7 +17,7 @@ #define sexp_condvar_threads(x) sexp_slot_ref(x, 2) #define timeval_le(a, b) (((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec < (b).tv_usec))) -#define sexp_context_before(c, t) ((sexp_context_timeval(c).tv_sec != 0) && timeval_le(sexp_context_timeval(c), t)) +#define sexp_context_before(c, t) (((sexp_context_timeval(c).tv_sec != 0) || (sexp_context_timeval(c).tv_usec != 0)) && timeval_le(sexp_context_timeval(c), t)) /* static int mutex_id, condvar_id; */ @@ -72,13 +73,12 @@ sexp sexp_make_thread (sexp ctx sexp_api_params(self, n), sexp thunk, sexp name) sexp sexp_thread_start (sexp ctx sexp_api_params(self, n), sexp thread) { sexp cell; sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + cell = sexp_cons(ctx, thread, SEXP_NULL); if (sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { - cell = sexp_cons(ctx, thread, SEXP_NULL); sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = cell; sexp_global(ctx, SEXP_G_THREADS_BACK) = cell; } else { /* init queue */ - sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) - = sexp_cons(ctx, thread, SEXP_NULL); + sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) = cell; } return SEXP_VOID; } @@ -115,14 +115,15 @@ static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { double d; #endif sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + if (sexp_integerp(timeout) || sexp_flonump(timeout)) + gettimeofday(&sexp_context_timeval(ctx), NULL); if (sexp_integerp(timeout)) { - sexp_context_timeval(ctx).tv_sec = sexp_unbox_fixnum(timeout); - sexp_context_timeval(ctx).tv_usec = 0; + sexp_context_timeval(ctx).tv_sec += sexp_unbox_fixnum(timeout); #if SEXP_USE_FLONUMS } else if (sexp_flonump(timeout)) { d = sexp_flonum_value(timeout); - sexp_context_timeval(ctx).tv_sec = trunc(d); - sexp_context_timeval(ctx).tv_usec = (d-trunc(d))*1000000; + sexp_context_timeval(ctx).tv_sec += trunc(d); + sexp_context_timeval(ctx).tv_usec += (d-trunc(d))*1000000; #endif } else { sexp_context_timeval(ctx).tv_sec = 0; @@ -143,8 +144,10 @@ static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { sexp sexp_thread_join (sexp ctx sexp_api_params(self, n), sexp thread, sexp timeout) { sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); - if (sexp_context_refuel(thread) <= 0) /* return true if already terminated */ + if (sexp_context_refuel(thread) <= 0) /* return true if already terminated */ { return SEXP_TRUE; + } + sexp_context_timeoutp(ctx) = 0; sexp_context_waitp(ctx) = 1; sexp_context_event(ctx) = thread; sexp_insert_timed(ctx, ctx, timeout); @@ -188,31 +191,79 @@ sexp sexp_mutex_lock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp timeou } sexp sexp_mutex_unlock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp condvar, sexp timeout) { + sexp ls1, ls2; if (sexp_not(condvar)) { - /* normal unlock */ + /* normal unlock - always succeeds, just need to unblock threads */ if (sexp_truep(sexp_mutex_lockp(mutex))) { sexp_mutex_lockp(mutex) = SEXP_FALSE; sexp_mutex_thread(mutex) = ctx; - /* XXXX search for threads blocked on this mutex */ + /* search for threads blocked on this mutex */ + for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == mutex) { + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2; + if (! sexp_pairp(sexp_cdr(ls2))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + sexp_context_waitp(sexp_car(ls2)) + = sexp_context_timeoutp(sexp_car(ls2)) = 0; + break; + } } + return SEXP_TRUE; } else { /* wait on condition var */ - + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = condvar; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; } } /**************************** condition variables *************************/ sexp sexp_condition_variable_signal (sexp ctx sexp_api_params(self, n), sexp condvar) { - return SEXP_VOID; + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + for ( ; sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == condvar) { + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2; + if (! sexp_pairp(sexp_cdr(ls2))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + sexp_context_waitp(sexp_car(ls2)) = sexp_context_timeoutp(sexp_car(ls2)) = 0; + return SEXP_TRUE; + } + return SEXP_FALSE; } sexp sexp_condition_variable_broadcast (sexp ctx sexp_api_params(self, n), sexp condvar) { - return SEXP_VOID; + sexp res = SEXP_FALSE; + while (sexp_truep(sexp_condition_variable_signal(ctx, self, n, condvar))) + res = SEXP_TRUE; + return res; } /**************************** the scheduler *******************************/ +void sexp_wait_on_single_thread (sexp ctx) { + struct timeval tval; + useconds_t usecs = 0; + gettimeofday(&tval, NULL); + if (tval.tv_sec < sexp_context_timeval(ctx).tv_sec) + usecs = (sexp_context_timeval(ctx).tv_sec - tval.tv_sec) * 1000000; + if (tval.tv_usec < sexp_context_timeval(ctx).tv_usec) + usecs += sexp_context_timeval(ctx).tv_usec - tval.tv_usec; + usleep(usecs); +} + sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { struct timeval tval; sexp res, ls1, ls2, tmp, paused, front=sexp_global(ctx, SEXP_G_THREADS_FRONT); @@ -221,27 +272,31 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { /* if we've terminated, check threads joining us */ if (sexp_context_refuel(ctx) <= 0) { - for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ls2=sexp_cdr(ls2)) + for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { if (sexp_context_event(sexp_car(ls2)) == ctx) { - sexp_context_waitp(ctx) = 0; + sexp_context_waitp(sexp_car(ls2)) = 0; + sexp_context_timeoutp(sexp_car(ls2)) = 0; if (ls1==SEXP_NULL) sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); else sexp_cdr(ls1) = sexp_cdr(ls2); tmp = sexp_cdr(ls2); - sexp_cdr(ls2) = front; - sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; + sexp_cdr(ls2) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; ls2 = tmp; } else { ls1 = ls2; ls2 = sexp_cdr(ls2); } + } } - /* TODO: check threads blocked on I/O */ - /* ... */ - - /* check timeouts (must be _after_ previous checks) */ + /* check timeouts */ if (sexp_pairp(paused)) { if (gettimeofday(&tval, NULL) == 0) { ls1 = SEXP_NULL; @@ -253,9 +308,14 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { ls2 = sexp_cdr(ls2); } if (sexp_pairp(ls1)) { - sexp_cdr(ls1) = front; - sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused; - sexp_global(ctx, SEXP_G_THREADS_PAUSED) = ls2; + sexp_cdr(ls1) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = paused; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1; + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = ls2; } } } @@ -266,7 +326,7 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { if ((sexp_context_refuel(ctx) <= 0) || sexp_context_waitp(ctx)) { /* either terminated or paused */ sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(front); - if (ctx == sexp_car(sexp_global(ctx, SEXP_G_THREADS_BACK))) + if (! sexp_pairp(sexp_cdr(front))) sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; } else { /* swap with front of queue */ @@ -284,6 +344,13 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { res = ctx; } + if (sexp_context_waitp(res)) { + /* the only thread available was waiting */ + sexp_wait_on_single_thread(res); + sexp_context_timeoutp(res) = 1; + sexp_context_waitp(res) = 0; + } + return res; } diff --git a/opt/opcode_names.h b/opt/opcode_names.h index d4c44632..a8c06e9a 100644 --- a/opt/opcode_names.h +++ b/opt/opcode_names.h @@ -1,7 +1,7 @@ static const char* reverse_opcode_names[] = {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", - "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALLN", "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/sexp.c b/sexp.c index b2390075..1af3d9a0 100644 --- a/sexp.c +++ b/sexp.c @@ -421,6 +421,7 @@ sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp } ls = sexp_exception_source(exn); if ((! (ls && sexp_pairp(ls))) + && sexp_exception_procedure(exn) && sexp_procedurep(sexp_exception_procedure(exn))) ls = sexp_bytecode_source(sexp_procedure_code(sexp_exception_procedure(exn))); if (ls && sexp_pairp(ls)) { diff --git a/tests/thread-tests.scm b/tests/thread-tests.scm new file mode 100644 index 00000000..df6d8a69 --- /dev/null +++ b/tests/thread-tests.scm @@ -0,0 +1,58 @@ + +(import (srfi 18)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test "no threads" (begin 'ok) 'ok) +(test "unstarted thread" (let ((t (make-thread (lambda () (error "oops"))))) 'ok) 'ok) +(test "ignored thread terminates" (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) 'ok) 'ok) +(test "ignored thread hangs" (let ((t (make-thread (lambda () (let lp () (lp)))))) (thread-start! t) 'ok) 'ok) +(test "joined thread terminates" (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) (thread-join! t) 'ok) 'ok) +(test "joined thread hangs, timeout" (let ((t (make-thread (lambda () (let lp () (lp)))))) (thread-start! t) (thread-join! t 1 'timeout)) 'timeout) + +(test "basic mutex" (let ((m (make-mutex))) (and (mutex? m) 'ok)) 'ok) +(test "mutex unlock" (let ((m (make-mutex))) (and (mutex-unlock! m) 'ok)) 'ok) +(test "mutex lock/unlock" (let ((m (make-mutex))) (and (mutex-lock! m) (mutex-unlock! m) 'ok)) 'ok) +(test "mutex lock timeout" (let* ((m (make-mutex)) (t (make-thread (lambda () (mutex-lock! m))))) (thread-start! t) (thread-yield!) (if (mutex-lock! m 1) 'fail 'timeout)) 'timeout) + +;(test "basic condition-variable" () 'ok) +;(test "condition-variable signal" () 'ok) +;(test "condition-variable broadcast" () 'ok) + +;(test "mailbox") + +(test-report) + diff --git a/vm.c b/vm.c index 1ebad747..88e4e494 100644 --- a/vm.c +++ b/vm.c @@ -4,6 +4,48 @@ static sexp sexp_apply1 (sexp ctx, sexp f, sexp x); +#if SEXP_USE_DEBUG_VM > 1 +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { + int i; + if (! sexp_oportp(out)) out = sexp_current_error_port(ctx); + for (i=0; i4; i=sexp_unbox_fixnum(stack[i+3])) { + self = stack[i+2]; + if (sexp_procedurep(self)) { + sexp_write_string(ctx, " called from ", out); + bc = sexp_procedure_code(self); + if (sexp_truep(sexp_bytecode_name(bc))) + sexp_write(ctx, sexp_bytecode_name(bc), out); + else + sexp_printf(ctx, out, "anon: %p", bc); + if ((ls=sexp_bytecode_source(bc)) && sexp_pairp(ls)) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_char(ctx, '\n', out); + } + } +} + /************************* code generation ****************************/ static void emit_word (sexp ctx, sexp_uint_t val) { @@ -503,8 +545,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { #if SEXP_USE_DEBUG_VM if (sexp_context_tracep(ctx)) { sexp_print_stack(ctx, stack, top, fp, SEXP_FALSE); - fprintf(stderr, "%s\n", (*ip<=SEXP_OP_NUM_OPCODES) ? - reverse_opcode_names[*ip] : "UNKNOWN"); + fprintf(stderr, "%s ip: %p stack: %p top: %d fp: %d\n", (*ip<=SEXP_OP_NUM_OPCODES) ? + reverse_opcode_names[*ip] : "UNKNOWN", ip, stack, top, fp); } #endif switch (*ip++) { @@ -515,7 +557,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { tmp1 = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); sexp_context_last_fp(ctx) = fp; if (! sexp_procedurep(tmp1)) goto end_loop; - stack[top] = (sexp) 1; + stack[top] = SEXP_ONE; stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc)); stack[top+2] = self; stack[top+3] = sexp_make_fixnum(fp); @@ -643,8 +685,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { fp = top-4; break; case SEXP_OP_FCALL0: + tmp1 = _WORD0; _ALIGN_IP(); sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = fp; _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 0))); ip += sizeof(sexp); sexp_check_exception(); @@ -1225,6 +1269,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case SEXP_OP_YIELD: fuel = 0; + _PUSH(SEXP_VOID); break; case SEXP_OP_RET: i = sexp_unbox_fixnum(stack[fp]); From dbb4db17280c0ce6fb74d951b4ac38c8ace79ebb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 12 Jul 2010 00:00:31 +0900 Subject: [PATCH 452/535] initial unicode support --- AUTHORS | 7 +- TODO | 21 +++++- eval.c | 157 ++++++++++++++++++++++++++++++++++++--- include/chibi/eval.h | 4 + include/chibi/features.h | 31 +++++++- include/chibi/sexp.h | 26 +++++++ opcodes.c | 19 +++++ opt/opcode_names.h | 19 +++-- sexp.c | 63 ++++++++++++---- vm.c | 43 +++++++++-- 10 files changed, 349 insertions(+), 41 deletions(-) diff --git a/AUTHORS b/AUTHORS index 1e15e0a5..fc0b8224 100644 --- a/AUTHORS +++ b/AUTHORS @@ -5,18 +5,23 @@ The `dynamic-wind' implementation is adapted from the implementation in the appendix to the Scheme48 reference manual, reportedly first written by Chris Hanson and John Lamping. -Thanks to the following people for patches: +Thanks to the following people for patches and bug reports: + * Alexander Shendi * Andreas Rottman * Bruno Deferrari * Derrick Eddington + * Eduardo Cavazos * Felix Winkelmann * Gregor Klinke + * Jeremy Wolff + * Jeronimo Pellegrini * John Cowan * John Samsa * Lars J Aas * Lorenzo Campedelli * Michal Kowalski (sladegen) + * Taylor Venable If you would prefer not to be listed, or are one of the users listed without a full name, please contact me. If you've made a contribution diff --git a/TODO b/TODO index 3e01c1f5..161ca82c 100644 --- a/TODO +++ b/TODO @@ -8,7 +8,12 @@ ** DONE exceptions - State "DONE" [2009-04-09 Thu 14:45] ** TODO native x86 backend + API redesign in preparation complete, initial + tests on native factorial and closures working. ** TODO fasl/image files + sexp_copy_context() can form the basis for images, + FASL for arbitrary modules will need additional + help with resolving external references. ** DONE shared stack on EVAL - State "DONE" [2009-12-26 Sat 08:22] @@ -58,8 +63,17 @@ * runtime ** DONE bignums - State "DONE" [2009-07-07 Tue 14:42] -** TODO unicode -** TODO threads +** DONE unicode + - State "DONE" from "TODO" [2010-07-11 Sun 23:58] + Supported with UTF-8 strings, string-ref is O(n) and + string-set! may need to reallocate the whole string. + string-cursor-ref can be used for O(1) string access. +** DONE threads + - State "DONE" from "TODO" [2010-07-11 Sun 15:31] + VM now supports an optional hook for green threads, + and a SRFI-18 interface is provided as a separate module. + I/O operations will currently block all threads though, + this needs to be addressed. ** DONE virtual ports - State "DONE" [2010-01-02 Sat 20:12] ** DONE dynamic-wind @@ -107,7 +121,8 @@ ** DONE loop library - State "DONE" [2009-12-08 Tue 14:54] ** TODO network interface -** TODO posix interface +** DONE posix interface + - State "DONE" from "TODO" [2010-07-11 Sun 15:36] Splitting this into several parts. *** DONE filesystem interface - State "DONE" [2009-12-26 Sat 01:50] diff --git a/eval.c b/eval.c index eb438301..50b6726d 100644 --- a/eval.c +++ b/eval.c @@ -43,7 +43,7 @@ void sexp_warn_undefs (sexp ctx, sexp from, sexp to) { sexp x; for (x=from; sexp_pairp(x) && x!=to; x=sexp_env_next_cell(x)) if (sexp_cdr(x) == SEXP_UNDEF) - sexp_warn(ctx, "reference to undefined variable", sexp_car(x)); + sexp_warn(ctx, "reference to undefined variable: ", sexp_car(x)); } @@ -299,14 +299,6 @@ static sexp sexp_make_lit (sexp ctx, sexp value) { return res; } -/************************* backend ***************************/ - -#if SEXP_USE_NATIVE_X86 -#include "opt/x86.c" -#else -#include "vm.c" -#endif - /****************************** contexts ******************************/ #define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) @@ -1123,6 +1115,142 @@ static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, se return sexp_make_fixnum(diff); } +#if SEXP_USE_UTF8_STRINGS + +static int sexp_utf8_initial_byte_count(int c) { + if (c < 0xC0) return 1; + if (c < 0xE0) return 2; + return ((c>>4)&1)+3; +} + +static int sexp_utf8_char_byte_count(int c) { + if (c < 0x80) return 1; + if (c < 0x800) return 2; + if (c < 0x10000) return 3; + return 4; +} + +static int sexp_string_utf8_length (unsigned char *p, int len) { + unsigned char *q = p+len; + int i; + for (i=0; p0 && j0) + return sexp_user_exception(ctx, self, "string-index->offset: index out of range", index); + return sexp_make_fixnum(j); +} + +sexp sexp_string_utf8_ref (sexp ctx, sexp str, sexp i) { + unsigned char *p=(unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(i); + if (*p < 0x80) + return sexp_make_character(*p); + else if ((*p < 0xC0) || (*p > 0xF7)) + return sexp_user_exception(ctx, NULL, "string-ref: invalid utf8 byte", i); + else if (*p < 0xE0) + return sexp_make_character(((p[0]&0x3F)<<6) + (p[1]&0x3F)); + else if (*p < 0xF0) + return sexp_make_character(((p[0]&0x1F)<<12) + ((p[1]&0x3F)<<6) + (p[2]&0x3F)); + else + return sexp_make_character(((p[0]&0x0F)<<16) + ((p[1]&0x3F)<<6) + ((p[2]&0x3F)<<6) + (p[2]&0x3F)); +} + +sexp sexp_string_utf8_index_ref (sexp ctx sexp_api_params(self, n), sexp str, sexp i) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + off = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, i); + if (sexp_exceptionp(off)) return off; + return sexp_string_utf8_ref(ctx, str, off); +} + +void sexp_utf8_encode_char (unsigned char* p, int len, int c) { + switch (len) { + case 4: *p++ = (0xF0 + ((c)>>18)); *p++ = (0x80 + ((c>>12)&0x3F)); + *p++ = (0x80 + ((c>>6)&0x3F)); *p = (0x80 + (c&0x3F)); break; + case 3: *p++ = (0xE0 + ((c)>>12)); *p++ = (0x80 + ((c>>6)&0x3F)); + *p = (0x80 + (c&0x3F)); break; + case 2: *p++ = (0xC0 + ((c)>>6)); *p = (0x80 + (c&0x3F)); break; + default: *p = c; break; + } +} + +void sexp_write_utf8_char (sexp ctx, int c, sexp out) { + unsigned char buf[8]; + int len = sexp_utf8_char_byte_count(c); + sexp_utf8_encode_char(buf, len, c); + buf[len+1] = 0; + sexp_write_string(ctx, (char*)buf, out); +} + +sexp sexp_read_utf8_char (sexp ctx, sexp port, int i) { + if (i >= 0x80) { + if ((i < 0xC0) || (i > 0xF7)) { + return sexp_user_exception(ctx, NULL, "read-char: invalid utf8 byte", sexp_make_fixnum(i)); + } else if (i < 0xE0) { + i = ((i&0x3F)<<6) + (sexp_read_char(ctx, port)&0x3F); + } else if (i < 0xF0) { + i = ((i&0x1F)<<12) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += sexp_read_char(ctx, port)&0x3F; + } else { + i = ((i&0x0F)<<16) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += (sexp_read_char(ctx, port)&0x3F)<<6; + i += sexp_read_char(ctx, port)&0x3F; + } + } + return sexp_make_character(i); +} + +#if SEXP_USE_MUTABLE_STRINGS + +void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) { + sexp b; + unsigned char *p, *q; + int i = sexp_unbox_fixnum(index), c = sexp_unbox_character(ch), + old_len, new_len, len; + p = (unsigned char*)sexp_string_data(str) + i; + old_len = sexp_utf8_initial_byte_count(*p); + new_len = sexp_utf8_char_byte_count(c); + if (old_len != new_len) { /* resize bytes if needed */ + len = sexp_string_length(str)+(new_len-old_len); + b = sexp_make_bytes(ctx, sexp_make_fixnum(len), SEXP_VOID); + if (! sexp_exceptionp(b)) { + q = (unsigned char*)sexp_bytes_data(b); + memcpy(q, sexp_string_data(str), i); + memcpy(q+i+new_len, p+old_len, len-i-new_len+1); + sexp_string_bytes(str) = b; + p = q + i; + } + sexp_string_length(str) += new_len - old_len; + } + sexp_utf8_encode_char(p, new_len, c); +} + +sexp sexp_string_utf8_index_set (sexp ctx sexp_api_params(self, n), sexp str, sexp i, sexp ch) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch); + off = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, i); + if (sexp_exceptionp(off)) return off; + sexp_string_utf8_set(ctx, str, off, ch); + return SEXP_VOID; +} + +#endif +#endif + #ifdef PLAN9 #include "opt/plan9.c" #endif @@ -1438,6 +1566,9 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { #endif #if SEXP_USE_BOEHM sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); +#endif +#if SEXP_USE_UTF8_STRINGS + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); #endif sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); @@ -1519,6 +1650,14 @@ sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, se return SEXP_VOID; } +/************************* backend ***************************/ + +#if SEXP_USE_NATIVE_X86 +#include "opt/x86.c" +#else +#include "vm.c" +#endif + /************************** eval interface ****************************/ sexp sexp_compile (sexp ctx, sexp x) { diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 938bf7c0..b21e3825 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -76,6 +76,9 @@ enum sexp_opcode_names { SEXP_OP_VECTOR_REF, SEXP_OP_VECTOR_SET, SEXP_OP_VECTOR_LENGTH, + SEXP_OP_BYTES_REF, + SEXP_OP_BYTES_SET, + SEXP_OP_BYTES_LENGTH, SEXP_OP_STRING_REF, SEXP_OP_STRING_SET, SEXP_OP_STRING_LENGTH, @@ -132,6 +135,7 @@ SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj); SEXP_API sexp sexp_analyze (sexp context, sexp x); SEXP_API void sexp_stack_trace (sexp ctx, sexp out); SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); +SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x); SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); SEXP_API int sexp_param_index (sexp lambda, sexp name); SEXP_API sexp sexp_eval_op (sexp context sexp_api_params(self, n), sexp obj, sexp env); diff --git a/include/chibi/features.h b/include/chibi/features.h index d1b0c5e8..a1159c47 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -145,6 +145,16 @@ /* non-immediate symbols in a single list. */ /* #define SEXP_USE_HASH_SYMS 0 */ +/* uncomment this to disable UTF-8 string support */ +/* The default settings store strings in memory as UTF-8, */ +/* and assumes strings passed to/from the C FFI are UTF-8. */ +/* #define SEXP_USE_UTF8_STRINGS 0 */ + +/* uncomment this to disable the string-set! opcode */ +/* By default (non-literal) strings are mutable. */ +/* Making them immutable allows for packed UTF-8 strings. */ +/* #define SEXP_USE_MUTABLE_STRINGS 0 */ + /* uncomment this to disable string ports */ /* If disabled some basic functionality such as number->string */ /* will not be available by default. */ @@ -201,7 +211,7 @@ /* the default number of opcodes to run each thread for */ #ifndef SEXP_DEFAULT_QUANTUM -#define SEXP_DEFAULT_QUANTUM 1000 +#define SEXP_DEFAULT_QUANTUM 500 #endif /************************************************************************/ @@ -230,7 +240,7 @@ #endif #ifndef SEXP_USE_GREEN_THREADS -#define SEXP_USE_GREEN_THREADS 1 +#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_NATIVE_X86 @@ -314,7 +324,7 @@ #endif #ifndef SEXP_USE_EXTENDED_FCALL -#define SEXP_USE_EXTENDED_FCALL 1 +#define SEXP_USE_EXTENDED_FCALL ! SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_FLONUMS @@ -361,6 +371,21 @@ #define SEXP_USE_DEBUG_VM 0 #endif +#ifndef SEXP_USE_UTF8_STRINGS +#define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MUTABLE_STRINGS +#define SEXP_USE_MUTABLE_STRINGS 1 +#endif + +#if (SEXP_USE_UTF8_STRINGS && SEXP_USE_MUTABLE_STRINGS) +#define SEXP_USE_PACKED_STRINGS 0 +#endif +#ifndef SEXP_USE_PACKED_STRINGS +#define SEXP_USE_PACKED_STRINGS 1 +#endif + #ifndef SEXP_USE_STRING_STREAMS #define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES #endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 3e66a297..ddcbb098 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -83,6 +83,7 @@ enum sexp_types { SEXP_BOOLEAN, SEXP_PAIR, SEXP_SYMBOL, + SEXP_BYTES, SEXP_STRING, SEXP_VECTOR, SEXP_FLONUM, @@ -210,6 +211,15 @@ struct sexp_struct { struct { sexp_uint_t length; char data[]; + } bytes; + struct { +#if SEXP_USE_PACKED_STRINGS + sexp_uint_t length; + char data[]; +#else + sexp_uint_t offset, length; + sexp bytes; +#endif } string; struct { sexp_uint_t length; @@ -578,12 +588,26 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_procedure_code(x) ((x)->value.procedure.bc) #define sexp_procedure_vars(x) ((x)->value.procedure.vars) +#define sexp_bytes_length(x) ((x)->value.bytes.length) +#define sexp_bytes_data(x) ((x)->value.bytes.data) + #define sexp_string_length(x) ((x)->value.string.length) +#if SEXP_USE_PACKED_STRINGS #define sexp_string_data(x) ((x)->value.string.data) +#else +#define sexp_string_bytes(x) ((x)->value.string.bytes) +#define sexp_string_offset(x) ((x)->value.string.offset) +#define sexp_string_data(x) (sexp_bytes_data(sexp_string_bytes(x))+sexp_string_offset(x)) +#endif + +#define sexp_bytes_ref(x, i) (sexp_make_fixnum((unsigned char)sexp_bytes_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_bytes_set(x, i, v) (sexp_bytes_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_fixnum(v)) #define sexp_string_ref(x, i) (sexp_make_character((unsigned char)sexp_string_data(x)[sexp_unbox_fixnum(i)])) #define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_character(v)) +#define sexp_symbol_data(x) ((x)->value.symbol.data) +#define sexp_symbol_length(x) ((x)->value.symbol.length) #define sexp_symbol_string(x) (x) #define sexp_port_stream(p) ((p)->value.port.stream) @@ -902,6 +926,7 @@ SEXP_API sexp sexp_memq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); SEXP_API sexp sexp_assq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); SEXP_API sexp sexp_length_op(sexp ctx sexp_api_params(self, n), sexp ls); SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen); +SEXP_API sexp sexp_make_bytes_op(sexp ctx sexp_api_params(self, n), sexp len, sexp i); SEXP_API sexp sexp_make_string_op(sexp ctx sexp_api_params(self, n), sexp len, sexp ch); SEXP_API sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end); SEXP_API sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep); @@ -980,6 +1005,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) #define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_string_to_number(ctx, s, b) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), s, b) +#define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx sexp_api_pass(NULL, 2), l, i) #define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), l, c) #define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx sexp_api_pass(NULL, 3), a, b, c) #define sexp_substring(ctx, a, b, c) sexp_substring_op(ctx sexp_api_pass(NULL, 3), a, b, c) diff --git a/opcodes.c b/opcodes.c index 3e74ce53..533052a6 100644 --- a/opcodes.c +++ b/opcodes.c @@ -24,8 +24,21 @@ _OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL _OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), _OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), _OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF,2,0, SEXP_BYTES, SEXP_FIXNUM, 0,"byte-vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET,3,0, SEXP_BYTES, SEXP_FIXNUM, 0,"byte-vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH,1,0, SEXP_BYTES, 0, 0,"byte-vector-length", 0, NULL), +#if SEXP_USE_UTF8_STRINGS +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-cursor-ref", 0, NULL), +#else _OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +#endif +#if SEXP_USE_MUTABLE_STRINGS +#if SEXP_USE_UTF8_STRINGS +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-cursor-set!", 0, NULL), +#else _OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +#endif +#endif _OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), @@ -101,6 +114,7 @@ _FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy_op), _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception_op), _FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_op), _FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string_op), +_FN2OPT(SEXP_FIXNUM, SEXP_FIXNUM, "make-byte-vector", SEXP_ZERO, sexp_make_bytes_op), _FN2OPT(SEXP_FIXNUM, SEXP_FIXNUM, "string->number", SEXP_TEN, sexp_string_to_number_op), _FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp_op), _FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring_op), @@ -134,6 +148,11 @@ _FN1(0, "floor", 0, sexp_floor), _FN1(0, "ceiling", 0, sexp_ceiling), #endif _FN2(0, 0, "expt", 0, sexp_expt_op), +#if SEXP_USE_UTF8_STRINGS +_FN2(SEXP_STRING, SEXP_FIXNUM, "string-index->offset", 0, sexp_string_index_to_offset), +_FN2(SEXP_STRING, SEXP_FIXNUM, "string-ref", 0, sexp_string_utf8_index_ref), +_FN3(SEXP_STRING, SEXP_FIXNUM, "string-set!", 0, sexp_string_utf8_index_set), +#endif #if SEXP_USE_TYPE_DEFS _FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type_op), _FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate_op), diff --git a/opt/opcode_names.h b/opt/opcode_names.h index a8c06e9a..52c639f9 100644 --- a/opt/opcode_names.h +++ b/opt/opcode_names.h @@ -1,16 +1,21 @@ static const char* reverse_opcode_names[] = - {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", - "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALLN", - "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", + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", + "TAIL-CALL", "CALL", "FCALL0", "FCALL1", "FCALL2", + "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALLN", + "JUMP-UNLESS", "JUMP", "PUSH", "DROP", + "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", + "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", + "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", + "BYTES-REF", "BYTES-SET", "BYTES-LENGTH", + "STRING-REF", "STRING-SET", "STRING-LENGTH", + "MAKE-PROCEDURE", "MAKE-VECTOR", "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", - "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "YIELD", "RET", "DONE", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", + "YIELD", "RET", "DONE", }; diff --git a/sexp.c b/sexp.c index 1af3d9a0..01b9e0dd 100644 --- a/sexp.c +++ b/sexp.c @@ -88,7 +88,12 @@ static struct sexp_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", NULL), _DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, "pair", NULL), _DEF_TYPE(SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, "symbol", NULL), + _DEF_TYPE(SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, "byte-vector", NULL), +#if SEXP_USE_PACKED_STRINGS _DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string", NULL), +#else + _DEF_TYPE(SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, "string", NULL), +#endif _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector", NULL), _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "real", NULL), _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), "bignum", NULL), @@ -666,24 +671,44 @@ sexp sexp_make_flonum (sexp ctx, float f) { #endif #endif -sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) { +sexp sexp_make_bytes_op (sexp ctx sexp_api_params(self, n), sexp len, sexp i) { sexp_sint_t clen = sexp_unbox_fixnum(len); sexp s; sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len); if (clen < 0) return sexp_xtype_exception(ctx, self, "negative length", len); - s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); + s = sexp_alloc_atomic(ctx, sexp_sizeof(bytes)+clen+1); if (sexp_exceptionp(s)) return s; - sexp_pointer_tag(s) = SEXP_STRING; + sexp_pointer_tag(s) = SEXP_BYTES; #if SEXP_USE_HEADER_MAGIC sexp_pointer_magic(s) = SEXP_POINTER_MAGIC; #endif - 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'; + sexp_bytes_length(s) = clen; + if (sexp_fixnump(i)) + memset(sexp_bytes_data(s), sexp_unbox_fixnum(i), clen); + sexp_bytes_data(s)[clen] = '\0'; return s; } +sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) +{ + sexp i = (sexp_charp(ch) ? sexp_make_fixnum(sexp_unbox_character(ch)) : ch); + sexp_gc_var2(b, s); + b = sexp_make_bytes_op(ctx sexp_api_pass(self, n), len, i); + if (sexp_exceptionp(b)) return b; +#if SEXP_USE_PACKED_STRINGS + sexp_pointer_tag(b) = SEXP_STRING; + return b; +#else + sexp_gc_preserve2(ctx, b, s); + s = sexp_alloc_type(ctx, string, SEXP_STRING); + sexp_string_bytes(s) = b; + sexp_string_offset(s) = 0; + sexp_string_length(s) = sexp_unbox_fixnum(len); + sexp_gc_release2(ctx); + return s; +#endif +} + sexp sexp_c_string (sexp ctx, const char *str, sexp_sint_t slen) { sexp_sint_t len = ((slen >= 0) ? slen : strlen(str)); sexp s = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID); @@ -790,14 +815,17 @@ sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { bucket = 0; #endif for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) - if ((sexp_string_length(tmp=sexp_symbol_string(sexp_car(ls))) == len) - && ! strncmp(str, sexp_string_data(tmp), len)) + if ((sexp_symbol_length(tmp=sexp_car(ls)) == len) + && ! strncmp(str, sexp_symbol_data(tmp), len)) return sexp_car(ls); /* not found, make a new symbol */ sexp_gc_preserve1(ctx, sym); sym = sexp_c_string(ctx, str, len); if (sexp_exceptionp(sym)) return sym; +#if ! SEXP_USE_PACKED_STRINGS + sym = sexp_string_bytes(sym); +#endif sexp_pointer_tag(sym) = SEXP_SYMBOL; sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); sexp_gc_release1(ctx); @@ -1190,8 +1218,8 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp 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)); + 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(ctx, '\\', out); @@ -1253,8 +1281,17 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp 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); + c = sexp_unbox_character(obj); + if (c >= 0x100) { + if (c >= 0x10000) { + sexp_write_char(ctx, hex_digit((c>>20)&0x0F), out); + sexp_write_char(ctx, hex_digit((c>>16)&0x0F), out); + } + sexp_write_char(ctx, hex_digit((c>>12)&0x0F), out); + sexp_write_char(ctx, hex_digit((c>>8)&0x0F), out); + } + sexp_write_char(ctx, hex_digit((c>>4)&0x0F), out); + sexp_write_char(ctx, hex_digit(c&0x0F), out); } } else if (sexp_symbolp(obj)) { diff --git a/vm.c b/vm.c index 88e4e494..50f8e8b8 100644 --- a/vm.c +++ b/vm.c @@ -2,8 +2,6 @@ /* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ -static sexp sexp_apply1 (sexp ctx, sexp f, sexp x); - #if SEXP_USE_DEBUG_VM > 1 static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { int i; @@ -834,6 +832,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); break; + case SEXP_OP_BYTES_REF: case SEXP_OP_STRING_REF: if (! sexp_stringp(_ARG1)) sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); @@ -842,9 +841,17 @@ sexp sexp_vm (sexp ctx, sexp proc) { i = sexp_unbox_fixnum(_ARG2); if ((i < 0) || (i >= sexp_string_length(_ARG1))) sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); - _ARG2 = sexp_string_ref(_ARG1, _ARG2); + if (ip[-1] == SEXP_OP_BYTES_REF) + _ARG2 = sexp_bytes_ref(_ARG1, _ARG2); + else +#if SEXP_USE_UTF8_STRINGS + _ARG2 = sexp_string_utf8_ref(ctx, _ARG1, _ARG2); +#else + _ARG2 = sexp_string_ref(_ARG1, _ARG2); +#endif top--; break; + case SEXP_OP_BYTES_SET: case SEXP_OP_STRING_SET: if (! sexp_stringp(_ARG1)) sexp_raise("string-set!: not a string", sexp_list1(ctx, _ARG1)); @@ -857,14 +864,30 @@ sexp sexp_vm (sexp ctx, sexp proc) { i = sexp_unbox_fixnum(_ARG2); if ((i < 0) || (i >= sexp_string_length(_ARG1))) sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); - sexp_string_set(_ARG1, _ARG2, _ARG3); + if (ip[-1] == SEXP_OP_BYTES_SET) + sexp_bytes_set(_ARG1, _ARG2, _ARG3); + else +#if SEXP_USE_UTF8_STRINGS + sexp_string_utf8_set(ctx, _ARG1, _ARG2, _ARG3); +#else + sexp_string_set(_ARG1, _ARG2, _ARG3); +#endif _ARG3 = SEXP_VOID; top-=2; break; + case SEXP_OP_BYTES_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("bytes-length: not a byte-vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_bytes_length(_ARG1)); + break; case SEXP_OP_STRING_LENGTH: if (! sexp_stringp(_ARG1)) sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_UTF8_STRINGS + _ARG1 = sexp_make_fixnum(sexp_string_utf8_length((unsigned char*)sexp_string_data(_ARG1), sexp_string_length(_ARG1))); +#else _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); +#endif break; case SEXP_OP_MAKE_PROCEDURE: sexp_context_top(ctx) = top; @@ -1244,6 +1267,11 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); if (! sexp_oportp(_ARG2)) sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2)); +#if SEXP_USE_UTF8_STRINGS + if (sexp_unbox_character(_ARG1) >= 0x80) + sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + else +#endif sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); _ARG2 = SEXP_VOID; top--; @@ -1258,6 +1286,11 @@ sexp sexp_vm (sexp ctx, sexp proc) { if (! sexp_iportp(_ARG1)) sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1)); i = sexp_read_char(ctx, _ARG1); +#if SEXP_USE_UTF8_STRINGS + if (i >= 0x80) + _ARG1 = sexp_read_utf8_char(ctx, _ARG1, i); + else +#endif _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case SEXP_OP_PEEK_CHAR: @@ -1302,7 +1335,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { /******************************* apply ********************************/ -static sexp sexp_apply1 (sexp ctx, sexp f, sexp x) { +sexp sexp_apply1 (sexp ctx, sexp f, sexp x) { sexp res; sexp_gc_var1(args); if (sexp_opcodep(f)) { From b5f29def789a3537492a63f89d56df9117a2fefd Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 12 Jul 2010 23:04:53 +0900 Subject: [PATCH 453/535] adding support for unions --- tools/genstubs.scm | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 114320b4..77f240fb 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -213,7 +213,7 @@ (memq type '(signed-char short int long boolean))) (define (unsigned-int-type? type) - (memq type '(unsigned-char unsigned-short unsigned-int unsigned-long + (memq type '(unsigned-char unsigned-short unsigned unsigned-int unsigned-long size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t uid_t gid_t pid_t blksize_t blkcnt_t sigval_t))) @@ -425,6 +425,11 @@ (lambda (expr rename compare) `(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) +(define-syntax define-c-union + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: union ,@(cddr expr))))) + (define-syntax define-c-type (er-macro-transformer (lambda (expr rename compare) @@ -439,8 +444,9 @@ (define-syntax define-c-const (er-macro-transformer (lambda (expr rename compare) - (set! *consts* - (cons (cons (parse-type (cadr expr)) (cddr expr)) *consts*))))) + (let ((type (parse-type (cadr expr)))) + (for-each (lambda (x) (set! *consts* (cons (list type x) *consts*))) + (cddr expr)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; C code generation @@ -568,7 +574,7 @@ (if (type-const? type) "const " "") (if struct-type (string-append (symbol->string struct-type) " ") "") (string-replace (base-type-c-name base) #\- " ") - (if type-spec "*" "") + (if struct-type "*" "") (if (type-pointer? type) "*" "")))) (define (check-type arg type) @@ -605,6 +611,7 @@ ((eq? base 'port) "SEXP_IPORT") ((eq? base 'input-port) "SEXP_IPORT") ((eq? base 'output-port) "SEXP_OPORT") + ((void-pointer-type? type) "SEXP_CPOINTER") (else (type-id-name base))))) (define (write-validator arg type) @@ -1112,9 +1119,9 @@ " return SEXP_VOID;\n" "}\n\n")) -(define (write-type-funcs type) - (let ((name (car type)) - (type (cdr type))) +(define (write-type-funcs orig-type) + (let ((name (car orig-type)) + (type (cdr orig-type))) ;; maybe write finalizer (cond ((memq 'finalizer: type) @@ -1139,7 +1146,7 @@ (cat ", sexp arg" i) (lp (cdr ls) (+ i 1)))))) ") {\n" - " struct " (type-name name) " *r;\n" + " " (or (type-struct-type name) "") " " (type-name name) " *r;\n" " sexp_gc_var1(res);\n" " sexp_gc_preserve1(ctx, res);\n" ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " @@ -1149,8 +1156,8 @@ " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), " (type-id-name name) ");\n" - " r = sexp_cpointer_value(res) = malloc(sizeof(struct " - (type-name name) "));\n" + " r = sexp_cpointer_value(res) = malloc(sizeof(" + (or (type-struct-type name) "") " " (type-name name) "));\n" " sexp_freep(res) = 1;\n" (lambda () (let lp ((ls args) (i 0)) From 1b14ac40a6c792a23727fd0692e4f6cf97fc3fd7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 13 Jul 2010 07:54:29 +0900 Subject: [PATCH 454/535] adding more featureful repl module --- lib/chibi/repl.module | 5 ++++ lib/chibi/repl.scm | 58 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+) create mode 100644 lib/chibi/repl.module create mode 100644 lib/chibi/repl.scm diff --git a/lib/chibi/repl.module b/lib/chibi/repl.module new file mode 100644 index 00000000..4db9a267 --- /dev/null +++ b/lib/chibi/repl.module @@ -0,0 +1,5 @@ + +(define-module (chibi repl) + (export repl) + (import-immutable (scheme) (chibi process)) + (include "repl.scm")) diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm new file mode 100644 index 00000000..307b0253 --- /dev/null +++ b/lib/chibi/repl.scm @@ -0,0 +1,58 @@ + +(define (run-repl module env) + (if module (display module)) + (display "> ") + (flush-output) + (let lp () + (let ((ch (peek-char))) + (cond ((eof-object? ch) + (exit 0)) + ((and (char? ch) (char-whitespace? ch)) + (read-char) + (lp))))) + (cond + ((eq? #\@ (peek-char)) + (read-char) + (let ((sym (read))) + (if (not (symbol? sym)) + (error "repl: invalid @ syntax: @" sym) + (case sym + ((config) + (let ((res (eval (read) *config-env*))) + (cond + ((not (eq? res (if #f #f))) + (write res) + (newline))) + (run-repl module env))) + ((in) + (let ((mod (read))) + (if (or (not mod) (equal? mod '(scheme))) + (run-repl #f (interaction-environment)) + (let ((env (eval `(module-env (load-module ',mod)) + *config-env*))) + (run-repl mod env))))) + (else + (error "repl: unknown @ escape" sym)))))) + (else + (let ((expr (read))) + (cond + ((eof-object? expr) + (exit 0)) + (else + (let ((res (eval expr env))) + (cond + ((not (eq? res (if #f #f))) + (write res) + (newline))) + (run-repl module env)))))))) + +(define (repl) + (set-signal-action! signal/interrupt + (lambda (n info) + (newline) + (run-repl #f (interaction-environment)))) + (current-exception-handler + (lambda (exn) + (print-exception exn (current-error-port)) + (run-repl #f (interaction-environment)))) + (run-repl #f (interaction-environment))) From cfa12ee2953c5067a2dc6e2f6d8d20752264ff03 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 14 Jul 2010 11:41:03 +0000 Subject: [PATCH 455/535] updates for windows --- .hgignore | 30 + AUTHORS | 29 + COPYING | 24 + Makefile | 225 +++ README | 440 ++++++ RELEASE | 1 + TODO | 165 +++ VERSION | 1 + doc/chibi-scheme.1 | 133 ++ eval.c | 1721 ++++++++++++++++++++++ gc.c | 346 +++++ include/chibi/bignum.h | 43 + include/chibi/eval.h | 202 +++ include/chibi/features.h | 447 ++++++ include/chibi/sexp.h | 1042 ++++++++++++++ lib/chibi/ast.c | 79 + lib/chibi/ast.module | 15 + lib/chibi/base64.module | 7 + lib/chibi/base64.scm | 351 +++++ lib/chibi/disasm.c | 101 ++ lib/chibi/disasm.module | 5 + lib/chibi/filesystem.module | 27 + lib/chibi/filesystem.scm | 43 + lib/chibi/filesystem.stub | 118 ++ lib/chibi/heap-stats.c | 129 ++ lib/chibi/heap-stats.module | 6 + lib/chibi/io.module | 13 + lib/chibi/io/io.scm | 170 +++ lib/chibi/io/io.stub | 27 + lib/chibi/io/port.c | 196 +++ lib/chibi/loop.module | 9 + lib/chibi/loop/loop.scm | 365 +++++ lib/chibi/macroexpand.module | 6 + lib/chibi/macroexpand.scm | 85 ++ lib/chibi/match.module | 6 + lib/chibi/match/match.scm | 670 +++++++++ lib/chibi/mime.module | 7 + lib/chibi/mime.scm | 410 ++++++ lib/chibi/net.module | 11 + lib/chibi/net.scm | 32 + lib/chibi/net.stub | 25 + lib/chibi/net/http.module | 7 + lib/chibi/net/http.scm | 180 +++ lib/chibi/pathname.module | 7 + lib/chibi/pathname.scm | 180 +++ lib/chibi/process.module | 17 + lib/chibi/process.stub | 72 + lib/chibi/quoted-printable.module | 7 + lib/chibi/quoted-printable.scm | 157 ++ lib/chibi/signal.c | 62 + lib/chibi/stty.module | 11 + lib/chibi/stty.scm | 235 +++ lib/chibi/stty.stub | 106 ++ lib/chibi/system.module | 15 + lib/chibi/system.stub | 34 + lib/chibi/term/edit-line.module | 5 + lib/chibi/term/edit-line.scm | 493 +++++++ lib/chibi/time.module | 12 + lib/chibi/time.stub | 46 + lib/chibi/uri.module | 10 + lib/chibi/uri.scm | 306 ++++ lib/config.scm | 177 +++ lib/init.scm | 875 ++++++++++++ lib/srfi/1.module | 31 + lib/srfi/1/alists.scm | 14 + lib/srfi/1/constructors.scm | 36 + lib/srfi/1/deletion.scm | 25 + lib/srfi/1/fold.scm | 115 ++ lib/srfi/1/lset.scm | 51 + lib/srfi/1/misc.scm | 54 + lib/srfi/1/predicates.scm | 42 + lib/srfi/1/search.scm | 54 + lib/srfi/1/selectors.scm | 59 + lib/srfi/11.module | 28 + lib/srfi/16.module | 24 + lib/srfi/18.module | 23 + lib/srfi/18/interface.scm | 39 + lib/srfi/18/threads.c | 383 +++++ lib/srfi/18/types.scm | 24 + lib/srfi/2.module | 16 + lib/srfi/26.module | 24 + lib/srfi/27.module | 11 + lib/srfi/27/constructors.scm | 10 + lib/srfi/27/rand.c | 204 +++ lib/srfi/33.module | 17 + lib/srfi/33/bit.c | 303 ++++ lib/srfi/33/bitwise.scm | 61 + lib/srfi/39.module | 25 + lib/srfi/6.module | 5 + lib/srfi/69.module | 17 + lib/srfi/69/hash.c | 242 ++++ lib/srfi/69/interface.scm | 115 ++ lib/srfi/69/type.scm | 12 + lib/srfi/8.module | 10 + lib/srfi/9.module | 85 ++ lib/srfi/95.module | 7 + lib/srfi/95/qsort.c | 228 +++ lib/srfi/95/sort.scm | 70 + lib/srfi/98.module | 5 + lib/srfi/98/env.c | 48 + main.c | 219 +++ mkfile | 28 + opcodes.c | 174 +++ opt/bignum.c | 775 ++++++++++ opt/fcall.c | 31 + opt/opcode_names.h | 21 + opt/plan9-opcodes.c | 19 + opt/plan9.c | 351 +++++ opt/sexp-huff.c | 128 ++ opt/sexp-hufftabs.c | 92 ++ opt/sexp-unhuff.c | 71 + opt/simplify.c | 143 ++ sexp.c | 1819 ++++++++++++++++++++++++ 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 | 48 + tests/basic/test10-unhygiene.res | 6 + tests/basic/test10-unhygiene.scm | 49 + tests/build/build-opts.txt | 21 + tests/build/build-tests.sh | 37 + tests/hash-tests.scm | 74 + tests/install/install-tests.pl | 57 + tests/install/run-install-test.sh | 12 + tests/loop-tests.scm | 202 +++ tests/match-tests.scm | 196 +++ tests/numeric-tests.scm | 150 ++ tests/r5rs-tests.scm | 465 ++++++ tests/sort-tests.scm | 57 + tests/thread-tests.scm | 58 + tools/genstatic.scm | 135 ++ tools/genstubs.scm | 1268 +++++++++++++++++ vm.c | 1373 ++++++++++++++++++ 149 files changed, 21534 insertions(+) create mode 100644 .hgignore create mode 100644 AUTHORS create mode 100644 COPYING create mode 100644 Makefile create mode 100644 README create mode 100644 RELEASE create mode 100644 TODO create mode 100644 VERSION create mode 100644 doc/chibi-scheme.1 create mode 100644 eval.c create mode 100644 gc.c create mode 100644 include/chibi/bignum.h create mode 100644 include/chibi/eval.h create mode 100644 include/chibi/features.h create mode 100644 include/chibi/sexp.h create mode 100644 lib/chibi/ast.c create mode 100644 lib/chibi/ast.module create mode 100644 lib/chibi/base64.module create mode 100644 lib/chibi/base64.scm create mode 100644 lib/chibi/disasm.c create mode 100644 lib/chibi/disasm.module create mode 100644 lib/chibi/filesystem.module create mode 100644 lib/chibi/filesystem.scm create mode 100644 lib/chibi/filesystem.stub create mode 100644 lib/chibi/heap-stats.c create mode 100644 lib/chibi/heap-stats.module create mode 100644 lib/chibi/io.module create mode 100644 lib/chibi/io/io.scm create mode 100644 lib/chibi/io/io.stub create mode 100644 lib/chibi/io/port.c create mode 100644 lib/chibi/loop.module create mode 100644 lib/chibi/loop/loop.scm create mode 100644 lib/chibi/macroexpand.module create mode 100644 lib/chibi/macroexpand.scm create mode 100644 lib/chibi/match.module create mode 100644 lib/chibi/match/match.scm create mode 100644 lib/chibi/mime.module create mode 100644 lib/chibi/mime.scm create mode 100644 lib/chibi/net.module create mode 100644 lib/chibi/net.scm create mode 100644 lib/chibi/net.stub create mode 100644 lib/chibi/net/http.module create mode 100644 lib/chibi/net/http.scm create mode 100644 lib/chibi/pathname.module create mode 100644 lib/chibi/pathname.scm create mode 100644 lib/chibi/process.module create mode 100644 lib/chibi/process.stub create mode 100644 lib/chibi/quoted-printable.module create mode 100644 lib/chibi/quoted-printable.scm create mode 100644 lib/chibi/signal.c create mode 100644 lib/chibi/stty.module create mode 100644 lib/chibi/stty.scm create mode 100644 lib/chibi/stty.stub create mode 100644 lib/chibi/system.module create mode 100644 lib/chibi/system.stub create mode 100644 lib/chibi/term/edit-line.module create mode 100644 lib/chibi/term/edit-line.scm create mode 100644 lib/chibi/time.module create mode 100644 lib/chibi/time.stub create mode 100644 lib/chibi/uri.module create mode 100644 lib/chibi/uri.scm create mode 100644 lib/config.scm create mode 100644 lib/init.scm create mode 100644 lib/srfi/1.module create mode 100644 lib/srfi/1/alists.scm create mode 100644 lib/srfi/1/constructors.scm create mode 100644 lib/srfi/1/deletion.scm create mode 100644 lib/srfi/1/fold.scm create mode 100644 lib/srfi/1/lset.scm create mode 100644 lib/srfi/1/misc.scm create mode 100644 lib/srfi/1/predicates.scm create mode 100644 lib/srfi/1/search.scm create mode 100644 lib/srfi/1/selectors.scm create mode 100644 lib/srfi/11.module create mode 100644 lib/srfi/16.module create mode 100644 lib/srfi/18.module create mode 100644 lib/srfi/18/interface.scm create mode 100644 lib/srfi/18/threads.c create mode 100644 lib/srfi/18/types.scm create mode 100644 lib/srfi/2.module create mode 100644 lib/srfi/26.module create mode 100644 lib/srfi/27.module create mode 100644 lib/srfi/27/constructors.scm create mode 100644 lib/srfi/27/rand.c create mode 100644 lib/srfi/33.module create mode 100644 lib/srfi/33/bit.c create mode 100644 lib/srfi/33/bitwise.scm create mode 100644 lib/srfi/39.module create mode 100644 lib/srfi/6.module create mode 100644 lib/srfi/69.module create mode 100644 lib/srfi/69/hash.c create mode 100644 lib/srfi/69/interface.scm create mode 100644 lib/srfi/69/type.scm create mode 100644 lib/srfi/8.module create mode 100644 lib/srfi/9.module create mode 100644 lib/srfi/95.module create mode 100644 lib/srfi/95/qsort.c create mode 100644 lib/srfi/95/sort.scm create mode 100644 lib/srfi/98.module create mode 100644 lib/srfi/98/env.c create mode 100644 main.c create mode 100644 mkfile create mode 100644 opcodes.c create mode 100644 opt/bignum.c create mode 100644 opt/fcall.c create mode 100644 opt/opcode_names.h create mode 100644 opt/plan9-opcodes.c create mode 100644 opt/plan9.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 opt/simplify.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/build/build-opts.txt create mode 100755 tests/build/build-tests.sh create mode 100644 tests/hash-tests.scm create mode 100755 tests/install/install-tests.pl create mode 100755 tests/install/run-install-test.sh create mode 100644 tests/loop-tests.scm create mode 100644 tests/match-tests.scm create mode 100644 tests/numeric-tests.scm create mode 100644 tests/r5rs-tests.scm create mode 100644 tests/sort-tests.scm create mode 100644 tests/thread-tests.scm create mode 100755 tools/genstatic.scm create mode 100755 tools/genstubs.scm create mode 100644 vm.c diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..e8b8b309 --- /dev/null +++ b/.hgignore @@ -0,0 +1,30 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dylib +*.class +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +clibs.c +chibi-scheme +chibi-scheme-static +include/chibi/install.h +lib/chibi/filesystem.c +lib/chibi/io/io.c +lib/chibi/net.c +lib/chibi/process.c +lib/chibi/system.c +lib/chibi/time.c +lib/chibi/stty.c diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 00000000..fc0b8224 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,29 @@ +Alex Shinn wrote the initial version of chibi-scheme and all +distributed modules. + +The `dynamic-wind' implementation is adapted from the implementation +in the appendix to the Scheme48 reference manual, reportedly first +written by Chris Hanson and John Lamping. + +Thanks to the following people for patches and bug reports: + + * Alexander Shendi + * Andreas Rottman + * Bruno Deferrari + * Derrick Eddington + * Eduardo Cavazos + * Felix Winkelmann + * Gregor Klinke + * Jeremy Wolff + * Jeronimo Pellegrini + * John Cowan + * John Samsa + * Lars J Aas + * Lorenzo Campedelli + * Michal Kowalski (sladegen) + * Taylor Venable + +If you would prefer not to be listed, or are one of the users listed +without a full name, please contact me. If you've made a contribution +and are not listed, please accept my apologies and contact me +immediately! diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..1fcee28e --- /dev/null +++ b/COPYING @@ -0,0 +1,24 @@ +Copyright (c) 2009 Alex Shinn +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..ea3bd2f6 --- /dev/null +++ b/Makefile @@ -0,0 +1,225 @@ +# -*- makefile-gmake -*- + +.PHONY: all libs doc dist clean cleaner test install uninstall +.PRECIOUS: %.c + +# install configuration + +CC ?= cc +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +SOLIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi +LIBDIR ?= $(PREFIX)/lib/chibi +MANDIR ?= $(PREFIX)/share/man/man1 + +DESTDIR ?= + +GENSTUBS ?= ./tools/genstubs.scm +GENSTATIC ?= ./tools/genstatic.scm + +######################################################################## +# system configuration - if not using GNU make, set PLATFORM and the +# following flags as necessary. + +# +LIBDL = -ldl + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +PLATFORM=unix +endif +endif +endif + +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0 +else +ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL -DSEXP_USE_DEBUG=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +STATICFLAGS = -DSEXP_USE_DL=0 +LIBDL = +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static -DSEXP_USE_DL=0 +endif +endif + +ifeq ($(USE_BOEHM),1) +SEXP_USE_BOEHM = 1 +endif + +ifeq ($(SEXP_USE_BOEHM),1) +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DSEXP_USE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude +endif + +ifeq ($(SEXP_USE_DL),0) +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS) +else +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm +XCFLAGS := -Wall -g3 $(CFLAGS) +endif + +######################################################################## + +all: chibi-scheme$(EXE) libs + +COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \ + lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \ + lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/net$(SO) \ + lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \ + lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \ + lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + +libs: $(COMPILED_LIBS) + +INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h + +include/chibi/install.h: Makefile + echo '#define sexp_so_extension "'$(SO)'"' > $@ + echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@ + echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ + echo '#define sexp_version "'`cat VERSION`'"' >> $@ + echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@ + +sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< + +libchibi-sexp$(SO): sexp.o + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) + +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 $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm + +clibs.c: $(GENSTATIC) lib lib/chibi lib/srfi + make chibi-scheme$(EXE) + make libs + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTATIC) $< > $@ + +%.c: %.stub $(GENSTUBS) + make chibi-scheme$(EXE) + -LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTUBS) $< + +lib/%$(SO): lib/%.c $(INCLUDES) + -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +clean: + rm -f *.o *.i *.s *.8 + find lib -name \*$(SO) -exec rm -f '{}' \; + rm -f tests/basic/*.out tests/basic/*.err + +cleaner: clean + rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h + rm -rf *.dSYM + +test-basic: chibi-scheme$(EXE) + @for f in tests/basic/*.scm; do \ + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + +test-build: + ./tests/build/build-tests.sh + +test-threads: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/thread-tests.scm + +test-numbers: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/numeric-tests.scm + +test-flonums: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/flonum-tests.scm + +test-hash: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/hash-tests.scm + +test-match: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/match-tests.scm + +test-loop: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/loop-tests.scm + +test-sort: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm + +test: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/r5rs-tests.scm + +install: chibi-scheme$(EXE) + mkdir -p $(DESTDIR)$(BINDIR) + cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ + cp tools/genstubs.scm $(DESTDIR)$(BINDIR)/ + mkdir -p $(DESTDIR)$(MODDIR) + cp -r lib/* $(DESTDIR)$(MODDIR)/ + mkdir -p $(DESTDIR)$(INCDIR) + cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ + mkdir -p $(DESTDIR)$(LIBDIR) + mkdir -p $(DESTDIR)$(SOLIBDIR) + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ + mkdir -p $(DESTDIR)$(MANDIR) + cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/ + -if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + +uninstall: + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE) + rm -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO) + rm -f $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a + cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -rf $(DESTDIR)$(MODDIR) + +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` + +mips-dist: cleaner + rm -f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz + mkdir chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + for f in `hg manifest`; do mkdir -p chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/$$f; done + tar cphzvf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + rm -rf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` diff --git a/README b/README new file mode 100644 index 00000000..69965ea7 --- /dev/null +++ b/README @@ -0,0 +1,440 @@ + + 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. + +------------------------------------------------------------------------ +INSTALLING + +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 chibi/features.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 CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 + +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 features.h file, or +directly from make with: + + make SEXP_USE_BOEHM=1 + +To compile a static executable, use + + make chibi-scheme-static SEXP_USE_DL=0 + +To compile a static executable with all C libraries statically +included, first you need to create a clibs.c file, which can be done +with: + + make clibs.c + +or edited manually. Be sure to run this with a non-static +chibi-scheme. Then you can make the static executable with: + + make cleaner + make chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS + +------------------------------------------------------------------------ +CHIBI-SCHEME LANGUAGE + +The default language is mostly compatible with the R5RS, with all +differences made by design, not through difficulty of implementation. +The following procedures are omitted: + + transcript-on and transcript-off (because they're silly) + rationalize (pending the addition of rational numbers) + +Apart from this, chibi-scheme is case-sensitive, unlike the R5RS. +The default configuration includes fixnums, flonums and bignums +but no exact rationals or complex numbers. + +Full continuations are supported, but currently continuations don't +take C code into account. The only higher-order C functions in the +standard environment are LOAD and EVAL. + +LOAD is extended to accept an optional environment argument, like +EVAL. You can also LOAD shared libraries in addition to Scheme source +files - in this case the function sexp_init_library is automatically +called with the following signature: + + sexp_init_library(sexp context, sexp environment) + +SYNTAX-RULES macros are provided by default, with the extensions from +SRFI-46. In addition, low-level hygienic macros are provided with +a syntactic-closures interface, including SC-MACRO-TRANSFORMER, +RSC-MACRO-TRANSFORMER, and ER-MACRO-TRANSFORMER. A good introduction +to syntactic-closures can be found at: + + http://community.schemewiki.org/?syntactic-closures + +IDENTIFIER?, IDENTIFIER->SYMBOL, IDENTIFIER=?, and +MAKE-SYNTACTIC-CLOSURE and STRIP-SYNTACTIC-CLOSURES are provided. + +SRFI-0's COND-EXPAND is provided, with the feature `chibi'. + +STRING-CONCATENATE concatenates a list of strings. + +------------------------------------------------------------------------ +TYPES + +You can define new data types with SRFI-9. This is just syntactic +sugar for the following more primitive type constructors: + +(register-simple-type ) + => ; a fixnum + +(make-type-predicate ) + => ; takes 1 arg, returns #t iff that arg is of the type + +(make-constructor ) + => ; takes 0 args, returns a newly allocated instance of type + +(make-getter ) + => ; takes 1 args, retrieves the field located at the index + +(make-setter ) + => ; takes 2 args, sets the field located at the index + +------------------------------------------------------------------------ +MODULE SYSTEM + +A configurable module system, in the style of the Scheme48 module +system, is provided by default. + +Modules names are hierarchical lists of symbols or numbers. The +definition of the module (foo bar baz) is searched for in the file +foo/bar/baz.module. This file should contain an expression of the +form: + + (define-module (foo bar baz) + ...) + +where can be any of + + (export ...) - specify an export list + (import ...) - specify one or more imports + (import-immutable ...) - specify an immutable import + (body ...) - inline Scheme code + (include ...) - load one or more files + (include-shared ...) - dynamic load a library + + can either be a module name or any of + + (only ...) + (except ...) + (rename ( ) ...) + (prefix ) + +The can be composed and perform basic selection and renaming of +individual identifiers from the given module. + +Files are loaded relative to the .module file, and are written with +their extension (so you can use whatever suffix you prefer - .scm, +.ss, .sls, etc.). + +Shared modules, on the other hand, should be specified _without_ the +extension - the correct suffix will be added portably (e.g. .so for +Unix and .dylib for OS X). + +You may also use COND-EXPAND and arbitrary macro expansions in a +module definition to generate . + +------------------------------------------------------------------------ +MODULES + +The default environment is (scheme) - you almost always want to import +this. + +Currently you can load the following SRFIs with (import (srfi N)): + + (srfi 0) - cond-expand + (srfi 1) - list library + (srfi 2) - and-let* + (srfi 6) - basic string ports + (srfi 8) - receive + (srfi 9) - define-record-type + (srfi 11) - let-values/let*-values + (srfi 16) - case-lambda + (srfi 22) - running scheme scripts on Unix + (srfi 23) - error reporting mechanism + (srfi 26) - cut/cute partial application + (srfi 27) - sources of random bits + (srfi 33) - bitwise operators + (srfi 39) - prameter objects + (srfi 46) - basic syntax-rules extensions + (srfi 62) - s-expression comments + (srfi 69) - basic hash tables + (srfi 95) - sorting and merging + (srfi 98) - environment access + +although 0, 22, 23, 46 and 62 are built into the default environment +so there's no need to import them. + +Included non-standard modules are put in the (chibi) module namespace. +The following additional modules are available: + + (chibi net) - networking interface + (chibi filesystem) - local filesystem and file descriptor interface + (chibi process) - processes and signals + (chibi system) - host system and user information + (chibi time) - time and date library + (chibi match) - pattern-matching library + (chibi loop) - extensible loop syntax + (chibi pathname) - pathname manipulation utilities + (chibi uri) - URI parsing and construction utilities + (chibi macroexpand) - macro expansion utility + (chibi ast) - interface to the internal Abstract Syntax Tree + (chibi disasm) - disassembly utility for the chibi VM + (chibi heap-stats) - debugging tool to analyze or dump the heap + +------------------------------------------------------------------------ +C INTERFACE + +See the file main.c for an example of using chibi-scheme as a library. + +The basic usage involves creating a context for evaluation and loading +or evaluating Scheme source with it. Begin by including the eval.h +header file: + + #include + +then call + + sexp_scheme_init(); + +with no parameters to initialize any globals (this actually does +nothing in the standard configuration but is a good idea to call +anyway). + +Then you can use the following to create and manipulate contexts: + + sexp_make_eval_context(context, stack, environment, heap_size) + Creates a new context with the given stack and environment. + If context is non-NULL, this will be the "parent" context and + the two contexts will share a heap. Otherwise, a new heap + will be allocated with heap_size, or a default size if heap_size + is zero. stack and environment may both also be NULL (and _must_ + be NULL if context is NULL) and will be given standard defaults. + + Thus the to create your first context you generally call: + + sexp_make_eval_context(NULL, NULL, NULL, 0) + + You can create as many contexts as you want, and other than those + sharing a heap they are all independent and thread-safe. + + sexp_load_standard_env(context, env, version) + Loads the init.scm file in the environment env. Version refers + to the RnRS version number and should always be SEXP_FIVE. The + environment created with sexp_make_eval_context only contains + core syntactic forms and C primitives (thus for example it has + CAR but not CADR or LIST), so to get a full featured + environment, plus a module system with which to load additional + modules, you want to use this. + + sexp_destroy_context(context) + Signals that you no longer need context, or any other context + sharing the heap. It will thus free() the context and heap and + all associated memory. Does nothing if using the Boehm GC. + +Environments can be handled with the following: + + sexp_context_env(context) + A macro returning the default environment associated with context. + + sexp_env_define(context, env, symbol, value) + Define a variable in an environment. + + sexp_env_ref(env, symbol, dflt) + Fetch the binding for symbol from the environment env, + returning the default dflt if the symbol is unbound. + +You can evaluate code with the following utility: + + sexp_eval(context, expr, env) + Evaluates an s-expression in an environment. + env can be NULL to use the context's default env. + + sexp_eval_string(context, str, env) + Reads an s-expression from str and evaluates it in env. + + sexp_load(context, file, env) + Read and eval all top-level forms from file in environment env. + As described in LOAD above, file may be a shared library. + +To define new primitive functions from C, use sexp_define_foreign, +which takes a Scheme environment, a name, a number of arguments the C +function takes (not counting the context argument), and a C function. + + /* sexp_define_foreign(context, env, name, num_args, f) */ + + sexp add (sexp context, sexp x, sexp y) { + return sexp_fx_add(x, y); + } + + sexp_define_foreign(context, env, "add", 2, add); + +You can also define functions with a single optional argument: + + sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); + +See the SRFI-69 implementation for more detailed examples of this. + +------------------------------------------------------------------------ +FFI + +Simple C FFI. "genstubs.scm file.stub" will read in the C function +FFI definitions from file.stub and output the appropriate C +wrappers into file.c. You can then compile that file with: + + cc -fPIC -shared file.c -lchibi-scheme + +(or using whatever flags are appropriate to generate shared libs on +your platform) and then the generated .so file can be loaded +directly with LOAD, or portably using (include-shared "file") in a +module definition (note that include-shared uses no suffix). + +The goal of this interface is to make access to C types and +functions easy, without requiring the user to write any C code. +That means the stubber needs to be intelligent about various C +calling conventions and idioms, such as return values passed in +actual parameters. Writing C by hand is still possible, and +several of the core modules provide C interfaces directly without +using the stubber. + +================================ + +Struct Interface + +(define-c-struct struct-name + [predicate: predicate-name] + [constructor: constructor-name] + [finalizer: c_finalizer_name] + (type c_field_name getter-name setter-name) ...) + + +================================ + + +Function Interface + +(define-c return-type name-spec (arg-type ...)) + +where name-space is either a symbol name, or a list of +(scheme-name c_name). If just a symbol, the C name is taken +to be the same with -'s replaced by _'s. + +arg-type is a type suitable for input validation and conversion. + +================================ + + +Types + +Types + +Basic Types + void + boolean + char + sexp (no conversions) + +Integer Types: + signed-char short int long + unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t + time_t (in seconds, but using the chibi epoch of 2010/01/01) + errno (as a return type returns #f on error) + +Float Types: + float double long-double + +String Types: + string - a null-terminated char* + env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme + in addition you can use (array char) as a string + +Port Types: + input-port output-port + +Struct Types: + +Struct types are by default just referred to by the bare +struct-name from define-c-struct, and it is assumed you want a +pointer to that type. To refer to the full struct, use the struct +modifier, as in (struct struct-name). + +Type modifiers + +Any type may also be written as a list of modifiers followed by the +type itself. The supported modifiers are: + +const: prepends the "const" C type modifier + * as a return or result parameter, makes non-immediates immutable + +free: it's Scheme's responsibility to "free" this resource + * as a return or result parameter, registers the freep flag + this causes the type finalizer to be run when GCed + +maybe-null: this pointer type may be NULL + * as a result parameter, NULL is translated to #f + normally this would just return a wrapped NULL pointer + * as an input parameter, #f is translated to NULL + normally this would be a type error + +pointer: create a pointer to this type + * as a return parameter, wraps the result in a vanilla cpointer + * as a result parameter, boxes then unboxes the value + +struct: treat this struct type as a struct, not a pointer + * as an input parameter, dereferences the pointer + * as a type field, indicates a nested struct + +link: add a gc link + * as a field getter, link to the parent object, so the + parent won't be GCed so long as we have a reference + to the child. this behavior is automatic for nested + structs. + +result: return a result in this parameter + * if there are multiple results (including the return type), + they are all returned in a list + * if there are any result parameters, a return type + of errno returns #f on failure, and as eliminated + from the list of results otherwise + +(value ): specify a fixed value + * as an input parameter, this parameter is not provided + in the Scheme API but always passed as + +(default ): specify a default value + * as the final input parameter, makes the Scheme parameter + optional, defaulting to + +(array []) an array type + * length must be specified for return and result parameters + * if specified, length can be any of + ** an integer, for a fixed size + ** the symbol null, indicating a NULL-terminated array diff --git a/RELEASE b/RELEASE new file mode 100644 index 00000000..35f6fb33 --- /dev/null +++ b/RELEASE @@ -0,0 +1 @@ +lithium diff --git a/TODO b/TODO new file mode 100644 index 00000000..161ca82c --- /dev/null +++ b/TODO @@ -0,0 +1,165 @@ +-*- org -*- + +* compiler +** DONE ast rewrite + - State "DONE" [2009-04-09 Thu 14:32] +** DONE call/cc support + - State "DONE" [2009-04-09 Thu 14:36] +** DONE exceptions + - State "DONE" [2009-04-09 Thu 14:45] +** TODO native x86 backend + API redesign in preparation complete, initial + tests on native factorial and closures working. +** TODO fasl/image files + sexp_copy_context() can form the basis for images, + FASL for arbitrary modules will need additional + help with resolving external references. +** DONE shared stack on EVAL + - State "DONE" [2009-12-26 Sat 08:22] + +* compiler optimizations +** DONE constant folding + - State "DONE" [2009-12-16 Wed 23:25] +** DONE simplification pass, dead-code elimination + - State "DONE" [2009-12-18 Fri 14:14] + This is important in particular for the output generated by + syntax-rules. +** TODO lambda lift + The current closure representation is not very efficient, so this + would help a lot. +** TODO inlining (and disabling primitive inlining) + Being able to redefine procedures is important though. +** TODO unsafe operations + Possibly, don't want to make things too complicated or unstable. +** TODO plugin infrastructure +** TODO type inference with warnings + +* macros +** DONE hygiene + - State "DONE" [2009-04-09 Thu 14:41] +** DONE hygienic nested let-syntax + - State "DONE" [2009-12-08 Tue 14:41] +** DONE macroexpand utility + - State "DONE" [2009-12-08 Tue 14:41] +** DONE SRFI-46 basic syntax-rules extensions + - State "DONE" [2009-12-26 Sat 07:59] +** DONE (... ...) support + - State "DONE" [2009-12-26 Sat 02:06] +** TODO compiler macros +** TODO syntax-rules common pattern reduction +** TODO syntax-rules loop optimization + +* garbage collection +** DONE precise gc rewrite + - State "DONE" [2009-06-22 Mon 14:27] +** DONE fix heap growing + - State "DONE" [2009-06-22 Mon 14:29] +** DONE separate gc heaps + - State "DONE" [2009-12-08 Tue 14:29] +** DONE add finalizers + - State "DONE" [2009-12-08 Tue 14:29] +** TODO support weak references + +* runtime +** DONE bignums + - State "DONE" [2009-07-07 Tue 14:42] +** DONE unicode + - State "DONE" from "TODO" [2010-07-11 Sun 23:58] + Supported with UTF-8 strings, string-ref is O(n) and + string-set! may need to reallocate the whole string. + string-cursor-ref can be used for O(1) string access. +** DONE threads + - State "DONE" from "TODO" [2010-07-11 Sun 15:31] + VM now supports an optional hook for green threads, + and a SRFI-18 interface is provided as a separate module. + I/O operations will currently block all threads though, + this needs to be addressed. +** DONE virtual ports + - State "DONE" [2010-01-02 Sat 20:12] +** DONE dynamic-wind + - State "DONE" [2009-12-26 Sat 01:51] + Adapted a version from Scheme48. +** DONE recursive disasm + - State "DONE" [2009-12-18 Fri 14:15] + +* FFI +** DONE libdl support + - State "DONE" [2009-12-08 Tue 14:45] +** DONE opcode generation interface + - State "DONE" [2009-11-15 Sun 14:45] +** DONE stub generator + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE define-c-struct + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE define-c + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE array return types + - State "DONE" [2009-12-26 Sat 01:49] +*** DONE pre-buffered string types (like getcwd) + - State "DONE" [2009-12-26 Sat 01:49] + +* module system +** DONE scheme48-like config language + - State "DONE" [2009-10-13 Tue 14:38] +** DONE shared library includes + - State "DONE" [2009-12-08 Tue 14:39] +** DONE only/except/rename/prefix modifiers + - State "DONE" [2009-12-16 Wed 18:57] +** TODO scheme-complete.el support +** DONE access individual modules from repl + - State "DONE" [2009-12-26 Sat 01:49] + +* core modules +** DONE SRFI-0 cond-expand + - State "DONE" [2009-12-16 Wed 20:12] +** DONE SRFI-9 define-record-type + - State "DONE" [2009-12-08 Tue 14:50] +** DONE SRFI-69 hash-tables + - State "DONE" [2009-11-15 Sun 14:50] +** DONE match library + - State "DONE" [2009-12-08 Tue 14:54] +** DONE loop library + - State "DONE" [2009-12-08 Tue 14:54] +** TODO network interface +** DONE posix interface + - State "DONE" from "TODO" [2010-07-11 Sun 15:36] + Splitting this into several parts. +*** DONE filesystem interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE process interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE time interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE host system interface + - State "DONE" [2010-01-02 Sat 20:12] +** DONE pathname library + - State "DONE" [2009-12-16 Wed 18:58] +** DONE uri library + - State "DONE" [2009-12-16 Wed 18:58] +** TODO http library +** TODO show (formatting) library +** TODO zip library +** TODO tar library +** TODO md5sum library + +* ports +** DONE basic mingw support + - State "DONE" [2009-06-22 Mon 14:36] +** DONE Plan 9 support + - State "DONE" [2009-08-10 Mon 14:37] +** DONE 64-bit support + - State "DONE" [2009-11-01 Sun 14:37] +** TODO iPhone support +** TODO bare-metal support + +* miscellaneous +** TODO overall cleanup +** TODO user documentation +** TODO thorough source documentation +** TODO full test suite for libraries + +* distribution +** TODO packaging format +** TODO code repository with fetch+install tool +** TODO translator to/from other implementations + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..be586341 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.3 diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1 new file mode 100644 index 00000000..b84620d5 --- /dev/null +++ b/doc/chibi-scheme.1 @@ -0,0 +1,133 @@ +.TH "chibi-scheme" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-scheme \- a tiny Scheme interpreter + +.SH SYNOPSIS +.B chibi-scheme +[-qV] +[-I +.I path +] +[-A +.I path +] +[-m +.I module +] +[-l +.I file +] +[-e +.I expr +] +[-p +.I expr +] +[--] +[ +.I script argument ... +] +.br +.sp 0.3 + +.SH DESCRIPTION +.I chibi-scheme +is a sample interactive Scheme interpreter for the +.I chibi-scheme +library. It serves as an example of how to embed +.I chibi-scheme +in applications, and can be useful on its own for writing +scripts and interactive development. + +When +.I script +is given, the script will be loaded with SRFI-22 semantics, +calling the procedure +.I main +(if defined) with a single parameter as a list of the +command-line arguments beginning with the script name. + +Otherwise, if no script is given and no -e or -p options +are given an interactive repl is entered, reading, evaluating, +then printing expressions until EOF is reached. The repl +provided is very minimal - if you want readline +completion you may want to wrap it with the +.I rlwrap(1) +program. Signals aren't caught either - to enable handling keyboard +interrupts you can use the (chibi process) module. + +.SH OPTIONS +.TP 5 +.BI -V +Prints the version information and exits. +.TP +.BI -q +Don't load the initialization file. The resulting +environment will only contain the core syntactic forms +and primitives coded in C. +.TP +.BI -h size +Specifies the initial size of the heap, in bytes. +.I size +can be any integer value, optionally suffixed by +"K" for kilobytes, or "M" for megabytes. +.I -h +must be specified before any options which load or +evaluate Scheme code. +.TP +.BI -I path +Inserts +.I path +on front of the load path list. +.TP +.BI -A path +Appends +.I path +to the load path list. +.TP +.BI -m module +Imports +.I module +as though "(import +.I module +)" were evaluated. However, to reduce the need for shell +escapes, modules are written in a dot notation, so that the module +.I (foo bar) +is written as +.I foo.bar +.TP +.BI -l file +Loads the Scheme source from the file +.I file +searched for in the default load path. +.TP +.BI -e expr +Evaluates the Scheme expression +.I expr. +.TP +.BI -p expr +Evaluates the Scheme expression +.I expr +then prints the result to stdout. + +.SH ENVIRONMENT +.TP +.B CHIBI_MODULE_PATH +.TQ +A colon separated list of directories to search for module +files, inserted before the system default load paths. + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +More detailed information can be found in the README file +included in the distribution. + +The chibi-scheme home-page: +.br +http://code.google.com/p/chibi-scheme/ diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..7cfa3650 --- /dev/null +++ b/eval.c @@ -0,0 +1,1721 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +static sexp analyze (sexp ctx, sexp x); +static void generate (sexp ctx, sexp x); + +#if SEXP_USE_MODULES +static sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env); +static sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file); +#endif + +sexp sexp_compile_error (sexp ctx, const char *message, sexp o) { + sexp exn; + sexp_gc_var3(sym, irritants, msg); + sexp_gc_preserve3(ctx, sym, irritants, msg); + irritants = sexp_list1(ctx, o); + msg = sexp_c_string(ctx, message, -1); + exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile", -1), + msg, irritants, SEXP_FALSE, + (sexp_pairp(o)?sexp_pair_source(o):SEXP_FALSE)); + sexp_gc_release3(ctx); + return exn; +} + +static void sexp_warn (sexp ctx, char *msg, sexp x) { + sexp out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) { + sexp_write_string(ctx, "WARNING: ", out); + sexp_write_string(ctx, msg, out); + sexp_write(ctx, x, out); + sexp_write_char(ctx, '\n', out); + } +} + +void sexp_warn_undefs (sexp ctx, sexp from, sexp to) { + sexp x; + for (x=from; sexp_pairp(x) && x!=to; x=sexp_env_next_cell(x)) + if (sexp_cdr(x) == SEXP_UNDEF) + sexp_warn(ctx, "reference to undefined variable: ", sexp_car(x)); +} + + +/********************** environment utilities ***************************/ + +static sexp sexp_env_cell_loc (sexp env, sexp key, sexp *varenv) { + sexp ls; + + do { + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + if (sexp_car(ls) == key) { + if (varenv) *varenv = env; + return ls; + } + env = sexp_env_parent(env); + } while (env); + + return NULL; +} + +sexp sexp_env_cell (sexp env, sexp key) { + return sexp_env_cell_loc(env, key, NULL); +} + +static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, + sexp value, sexp *varenv) { + sexp_gc_var1(cell); + cell = sexp_env_cell_loc(env, key, varenv); + if (! cell) { + sexp_gc_preserve1(ctx, cell); + while (sexp_env_lambda(env) || sexp_env_syntactic_p(env)) + env = sexp_env_parent(env); + sexp_env_push(ctx, env, cell, key, value); + if (varenv) *varenv = env; + sexp_gc_release1(ctx); + } + return cell; +} + +sexp sexp_env_ref (sexp env, sexp key, sexp dflt) { + sexp cell = sexp_env_cell(env, key); + return (cell ? sexp_cdr(cell) : dflt); +} + +sexp sexp_env_global_ref (sexp env, sexp key, sexp dflt) { + while (sexp_env_lambda(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); + return sexp_env_ref(env, key, dflt); +} + +sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { + sexp cell=SEXP_FALSE, res=SEXP_VOID; + sexp_gc_var1(tmp); + for (tmp=sexp_env_bindings(env); sexp_pairp(tmp); tmp=sexp_env_next_cell(tmp)) + if (sexp_car(tmp) == key) { + cell = tmp; + break; + } + if (sexp_immutablep(env)) { + res = sexp_user_exception(ctx, NULL, "immutable binding", key); + } else { + sexp_gc_preserve1(ctx, tmp); + if (sexp_truep(cell)) { + if (sexp_immutablep(cell)) + res = sexp_user_exception(ctx, NULL, "immutable binding", key); + else + sexp_cdr(cell) = value; + } else { + sexp_env_push(ctx, env, tmp, key, value); + } + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_env_exports_op (sexp ctx sexp_api_params(self, n), sexp env) { + sexp ls; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_push(ctx, res, sexp_car(ls)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { + sexp_gc_var2(e, tmp); + sexp_gc_preserve2(ctx, e, 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_env_push(ctx, e, tmp, sexp_car(vars), value); + sexp_gc_release2(ctx); + return e; +} + +static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(ctx, res, sexp_car(ls)); + sexp_gc_release1(ctx); + return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res)); +} + +static sexp sexp_flatten_dot (sexp ctx, sexp ls) { + return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls)); +} + +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 ctx, sexp_uint_t i) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) { + tmp = sexp_alloc_bytecode(ctx, i); + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); + sexp_bytecode_length(tmp) = i; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(ctx)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(ctx)), + i); + sexp_context_bc(ctx) = tmp; + } +} + +static void expand_bcode (sexp ctx, sexp_uint_t size) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(ctx)) + < (sexp_context_pos(ctx))+size) { + tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2); + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); + sexp_bytecode_length(tmp) + = sexp_bytecode_length(sexp_context_bc(ctx))*2; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(ctx)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(ctx)), + sexp_bytecode_length(sexp_context_bc(ctx))); + sexp_context_bc(ctx) = tmp; + } +} + +static void emit_enter (sexp ctx); +static void emit_return (sexp ctx); +static void bless_bytecode (sexp ctx, sexp bc); + +static sexp finalize_bytecode (sexp ctx) { + sexp bc; + emit_return(ctx); + shrink_bcode(ctx, sexp_context_pos(ctx)); + bc = sexp_context_bc(ctx); + if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */ + if (sexp_nullp(sexp_cdr(sexp_bytecode_literals(bc)))) + sexp_bytecode_literals(bc) = sexp_car(sexp_bytecode_literals(bc)); + else if (sexp_nullp(sexp_cddr(sexp_bytecode_literals(bc)))) + sexp_cdr(sexp_bytecode_literals(bc)) = sexp_cadr(sexp_bytecode_literals(bc)); + else + sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc)); + } + bless_bytecode(ctx, bc); + return bc; +} + +static void emit (sexp ctx, unsigned char c) { + expand_bcode(ctx, 1); + sexp_bytecode_data(sexp_context_bc(ctx))[sexp_context_pos(ctx)++] = c; +} + +sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp flags, + sexp num_args, sexp bc, sexp vars) { + 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; + sexp_procedure_vars(proc) = vars; + return proc; +} + +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_op (sexp ctx sexp_api_params(self, n), sexp env, sexp fv, sexp expr) { + sexp res; + if (! (sexp_symbolp(expr) || sexp_pairp(expr))) + return expr; + res = sexp_alloc_type(ctx, 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 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; + 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 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 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 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 ctx, sexp value) { + sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT); + sexp_lit_value(res) = value; + return res; +} + +/****************************** contexts ******************************/ + +#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) + +static void sexp_add_path (sexp ctx, const char *str) { + const char *colon; + if (str && *str) { + colon = strchr(str, ':'); + if (colon) + sexp_add_path(ctx, colon+1); + else + colon = str + strlen(str); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), SEXP_VOID); + sexp_car(sexp_global(ctx, SEXP_G_MODULE_PATH)) + = sexp_c_string(ctx, str, colon-str); + } +} + +void sexp_init_eval_context_globals (sexp ctx) { + sexp_gc_var3(tmp, vec, ctx2); + ctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve3(ctx, tmp, vec, ctx2); + vec = sexp_intern(ctx, "*current-exception-handler*", -1); + sexp_global(ctx, SEXP_G_ERR_HANDLER) + = sexp_env_cell_create(ctx, sexp_context_env(ctx), vec, SEXP_FALSE, NULL); +#if ! SEXP_USE_NATIVE_X86 + emit(ctx, SEXP_OP_RESUMECC); + sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); + ctx2 = sexp_make_child_context(ctx, NULL); + emit(ctx2, SEXP_OP_DONE); + tmp = finalize_bytecode(ctx2); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + sexp_global(ctx, SEXP_G_FINAL_RESUMER) + = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); + sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) + = sexp_intern(ctx, "final-resumer", -1); +#endif + sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL; + sexp_add_path(ctx, sexp_default_module_dir); + sexp_add_path(ctx, getenv(SEXP_MODULE_PATH_VAR)); + tmp = sexp_c_string(ctx, "./lib", 5); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); + tmp = sexp_c_string(ctx, ".", 1); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; +#endif + sexp_gc_release3(ctx); +} + +sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size) { + sexp_gc_var1(res); + if (ctx) sexp_gc_preserve1(ctx, res); + res = sexp_make_context(ctx, size); + sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE); + sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; + sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE; + sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; + if ((! stack) || (stack == SEXP_FALSE)) { + stack = sexp_alloc_tagged(res, SEXP_STACK_SIZE, SEXP_STACK); + sexp_stack_length(stack) = SEXP_INIT_STACK_SIZE; + sexp_stack_top(stack) = 0; + } + sexp_context_stack(res) = stack; + sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_FIVE)); + if (! ctx) sexp_init_eval_context_globals(res); + if (ctx) { + sexp_context_tracep(res) = sexp_context_tracep(ctx); + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_make_child_context (sexp ctx, sexp lambda) { + sexp res = sexp_make_eval_context(ctx, + sexp_context_stack(ctx), + sexp_context_env(ctx), + 0); + if (! sexp_exceptionp(res)) { + sexp_context_lambda(res) = lambda; + sexp_context_top(res) = sexp_context_top(ctx); + sexp_context_fv(res) = sexp_context_fv(ctx); + sexp_context_tracep(res) = sexp_context_tracep(ctx); + } + return res; +} + +/**************************** identifiers *****************************/ + +static sexp sexp_identifierp_op (sexp ctx sexp_api_params(self, n), sexp x) { + return sexp_make_boolean(sexp_idp(x)); +} + +static sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), sexp x) { + return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); +} + +static sexp sexp_strip_synclos (sexp ctx, sexp x) { + sexp res; + sexp_gc_var2(kar, kdr); + sexp_gc_preserve2(ctx, kar, kdr); + loop: + if (sexp_synclop(x)) { + x = sexp_synclo_expr(x); + goto loop; + } else if (sexp_pairp(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) = 1; + } else { + res = x; + } + sexp_gc_release2(ctx); + return res; +} + +static sexp sexp_identifier_eq_op (sexp ctx sexp_api_params(self, n), 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 = sexp_env_cell(e1, id1); + if (cell && sexp_lambdap(sexp_cdr(cell))) + lam1 = sexp_cdr(cell); + cell = sexp_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 analyze_app (sexp ctx, sexp x) { + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, 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 { + sexp_car(res) = tmp; + } + } + sexp_gc_release2(ctx); + return (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); +} + +static sexp analyze_seq (sexp ctx, sexp ls) { + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + if (sexp_nullp(ls)) + res = SEXP_VOID; + else if (sexp_nullp(sexp_cdr(ls))) + res = analyze(ctx, sexp_car(ls)); + else { + 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_release2(ctx); + return res; +} + +static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) { + sexp env = sexp_context_env(ctx), res; + sexp_gc_var1(cell); + sexp_gc_preserve1(ctx, cell); + cell = sexp_env_cell_loc(env, x, varenv); + if (! cell) { + if (sexp_synclop(x)) { + if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_context_fv(ctx))) + && sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_synclo_free_vars(x)))) + env = sexp_synclo_env(x); + x = sexp_synclo_expr(x); + } + cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF, varenv); + } + if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) + res = sexp_compile_error(ctx, "invalid use of syntax as value", x); + else + res = sexp_make_ref(ctx, x, cell); + sexp_gc_release1(ctx); + return res; +} + +static sexp analyze_set (sexp ctx, sexp x) { + sexp res, varenv; + sexp_gc_var2(ref, value); + sexp_gc_preserve2(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), &varenv); + 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 if (sexp_immutablep(sexp_ref_cell(ref)) + || (varenv && sexp_immutablep(varenv))) + res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x)); + else + res = sexp_make_set(ctx, ref, value); + } + sexp_gc_release2(ctx); + 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, ctx3; + sexp_gc_var6(res, body, tmp, value, defs, ctx2); + sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2); + /* verify syntax */ + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(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))) + sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x)); + 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, tmp=sexp_copy_list(ctx, sexp_cadr(x))); + sexp_lambda_source(res) = sexp_pair_source(x); + ctx2 = sexp_make_child_context(ctx, res); + tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); + sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); + sexp_env_lambda(sexp_context_env(ctx2)) = res; + body = analyze_seq(ctx2, sexp_cddr(x)); + 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)) { + tmp = sexp_car(ls); + ctx3 = sexp_cdr(tmp); + if (sexp_pairp(sexp_caar(tmp))) { + name = sexp_caaar(tmp); + tmp = sexp_cons(ctx3, sexp_cdaar(tmp), sexp_cdar(tmp)); + value = analyze_lambda(ctx3, sexp_cons(ctx3, SEXP_VOID, tmp)); + } else { + name = sexp_caar(tmp); + value = analyze(ctx3, sexp_cadar(tmp)); + } + if (sexp_exceptionp(value)) sexp_return(res, value); + sexp_push(ctx3, defs, + sexp_make_set(ctx3, analyze_var_ref(ctx3, name, NULL), value)); + } + if (sexp_pairp(defs)) { + if (! sexp_seqp(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(ctx2, defs, sexp_seq_ls(body)); + } + sexp_lambda_body(res) = body; + cleanup: + sexp_gc_release6(ctx); + return res; +} + +static sexp analyze_if (sexp ctx, sexp x) { + sexp res, fail_expr; + sexp_gc_var3(test, pass, fail); + sexp_gc_preserve3(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_release3(ctx); + return res; +} + +static sexp analyze_define (sexp ctx, sexp x) { + sexp name, res, varenv; + sexp_gc_var4(ref, value, tmp, env); + sexp_gc_preserve4(ctx, ref, value, tmp, env); + env = sexp_context_env(ctx); + while (sexp_env_syntactic_p(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(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_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))) { + sexp_env_push(ctx, env, tmp, 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); + tmp = sexp_cons(ctx, sexp_cdr(x), ctx); + sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp); + res = SEXP_VOID; + } else { + if (sexp_synclop(name)) name = sexp_synclo_expr(name); + sexp_env_cell_create(ctx, env, name, SEXP_VOID, NULL); + if (sexp_pairp(sexp_cadr(x))) { + tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); + tmp = sexp_cons(ctx, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(x); + value = analyze_lambda(ctx, tmp); + } else + value = analyze(ctx, sexp_caddr(x)); + ref = analyze_var_ref(ctx, name, &varenv); + if (sexp_exceptionp(ref)) + res = ref; + else if (sexp_exceptionp(value)) + res = value; + else if (varenv && sexp_immutablep(varenv)) + res = sexp_compile_error(ctx, "immutable binding", name); + else + res = sexp_make_set(ctx, ref, value); + } + } + sexp_gc_release4(ctx); + return res; +} + +static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { + sexp res = SEXP_VOID, name; + sexp_gc_var3(proc, mac, tmp); + sexp_gc_preserve3(eval_ctx, proc, mac, tmp); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + 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 = sexp_eval(eval_ctx, sexp_cadar(ls), NULL); + if (sexp_procedurep(proc)) { + name = sexp_caar(ls); + if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) + name = sexp_synclo_expr(name); + mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(bind_ctx)); + sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac); + } else { + res = (sexp_exceptionp(proc) ? proc + : sexp_compile_error(eval_ctx, "non-procedure macro:", proc)); + break; + } + } + } + sexp_gc_release3(eval_ctx); + return res; +} + +static sexp analyze_define_syntax (sexp ctx, sexp x) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_list1(ctx, sexp_cdr(x)); + res = analyze_bind_syntax(tmp, ctx, ctx); + sexp_gc_release1(ctx); + return res; +} + +static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp) { + sexp res; + sexp_gc_var3(env, ctx2, tmp); + sexp_gc_preserve3(ctx, env, ctx2, tmp); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad let(rec)-syntax", x); + } else { + env = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_syntactic_p(env) = 1; + 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), (recp ? ctx2 : ctx), ctx2); + res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x))); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp analyze_let_syntax (sexp ctx, sexp x) { + return analyze_let_syntax_aux(ctx, x, 0); +} + +static sexp analyze_letrec_syntax (sexp ctx, sexp x) { + return analyze_let_syntax_aux(ctx, x, 1); +} + +static sexp analyze (sexp ctx, sexp object) { + sexp op; + sexp_gc_var4(res, tmp, x, cell); + sexp_gc_preserve4(ctx, res, tmp, x, cell); + x = object; + loop: + if (sexp_pairp(x)) { + 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 = sexp_env_cell(sexp_context_env(ctx), sexp_car(x)); + if (! cell && sexp_synclop(sexp_car(x))) + cell = sexp_env_cell(sexp_synclo_env(sexp_car(x)), + sexp_synclo_expr(sexp_car(x))); + if (! cell) { + res = analyze_app(ctx, x); + } else { + op = sexp_cdr(cell); + if (sexp_corep(op)) { + switch (sexp_core_code(op)) { + case SEXP_CORE_DEFINE: + res = analyze_define(ctx, x); break; + case SEXP_CORE_SET: + res = analyze_set(ctx, x); break; + case SEXP_CORE_LAMBDA: + res = analyze_lambda(ctx, x); break; + case SEXP_CORE_IF: + res = analyze_if(ctx, x); break; + case SEXP_CORE_BEGIN: + res = analyze_seq(ctx, sexp_cdr(x)); break; + case SEXP_CORE_QUOTE: + case SEXP_CORE_SYNTAX_QUOTE: + if (! (sexp_pairp(sexp_cdr(x)) && sexp_nullp(sexp_cddr(x)))) + res = sexp_compile_error(ctx, "bad quote form", x); + else + res = sexp_make_lit(ctx, + (sexp_core_code(op) == SEXP_CORE_QUOTE) ? + sexp_strip_synclos(ctx, sexp_cadr(x)) : + sexp_cadr(x)); + break; + case SEXP_CORE_DEFINE_SYNTAX: + res = analyze_define_syntax(ctx, x); break; + case SEXP_CORE_LET_SYNTAX: + res = analyze_let_syntax(ctx, x); break; + case SEXP_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)) { + 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_make_child_context(ctx, sexp_context_lambda(ctx)); + x = sexp_apply(x, sexp_macro_proc(op), tmp); + if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x))) + sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp)); + goto loop; + } else if (sexp_opcodep(op)) { + res = sexp_length(ctx, sexp_cdr(x)); + if (sexp_unbox_fixnum(res) < sexp_opcode_num_args(op)) { + res = sexp_compile_error(ctx, "not enough args for opcode", x); + } else if ((sexp_unbox_fixnum(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)); + 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))))))) + sexp_warn(ctx, "invalid operand in application: ", x); + res = analyze_app(ctx, x); + } + } else if (sexp_idp(x)) { + res = analyze_var_ref(ctx, x, NULL); + } else if (sexp_synclop(x)) { + tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(tmp) = sexp_synclo_env(x); + sexp_context_fv(tmp) = sexp_append2(tmp, + sexp_synclo_free_vars(x), + sexp_context_fv(tmp)); + x = sexp_synclo_expr(x); + res = analyze(tmp, x); + } else { + res = x; + } + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res)) + && sexp_pairp(x)) + sexp_exception_source(res) = sexp_pair_source(x); + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} + +/********************** free varable analysis *************************/ + +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_var1(res); + if (sexp_nullp(fv2)) + return fv1; + sexp_gc_preserve1(ctx, res); + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, 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_release1(ctx); + return res; +} + +sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) { + sexp_gc_var2(fv1, fv2); + sexp_gc_preserve2(ctx, fv1, fv2); + fv1 = fv; + if (sexp_lambdap(x)) { + fv1 = sexp_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 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_cndp(x)) { + fv1 = sexp_free_vars(ctx, sexp_cnd_test(x), fv); + fv1 = sexp_free_vars(ctx, sexp_cnd_pass(x), fv1); + fv1 = sexp_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 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_setp(x)) { + fv1 = sexp_free_vars(ctx, sexp_set_value(x), fv); + fv1 = sexp_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 = sexp_free_vars(ctx, sexp_synclo_expr(x), fv); + } + sexp_gc_release2(ctx); + return fv1; +} + +/************************ library procedures **************************/ + +static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) { + sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn); + return sexp_exception_kind(exn); +} + +static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) { + FILE *in; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + in = fopen(sexp_string_data(path), "r"); + if (! in) + return sexp_user_exception(ctx, self, "couldn't open input file", path); + return sexp_make_input_port(ctx, in, path); +} + +static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) { + FILE *out; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + out = fopen(sexp_string_data(path), "w"); + if (! out) + return sexp_user_exception(ctx, self, "couldn't open output file", path); + return sexp_make_output_port(ctx, out, path); +} + +static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) { + sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port); + if (! sexp_port_openp(port)) + return sexp_user_exception(ctx, self, "port already closed", port); + return sexp_finalize_port(ctx sexp_api_pass(self, n), port); +} + +#if SEXP_USE_DL +#ifdef __MINGW32__ +#include +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + HINSTANCE handle = LoadLibraryA(sexp_string_data(file)); + if(!handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = (sexp_proc2) GetProcAddress(handle, "sexp_init_library"); + if(!init) { + FreeLibrary(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx sexp_api_pass(NULL, 1), env); +} +#else +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); + if (! handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = dlsym(handle, "sexp_init_library"); + if (! init) { + dlclose(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx sexp_api_pass(NULL, 1), env); +} +#endif +#endif + +sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { +#if SEXP_USE_DL + char *suffix; +#endif + sexp tmp, out=SEXP_FALSE; + sexp_gc_var4(ctx2, x, in, res); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); +#if SEXP_USE_DL + suffix = sexp_string_data(source) + + sexp_string_length(source) - strlen(sexp_so_extension); + if (strcmp(suffix, sexp_so_extension) == 0) { + res = sexp_load_dl(ctx, source, env); + } else { +#endif + sexp_gc_preserve4(ctx, ctx2, x, in, res); + res = SEXP_VOID; + in = sexp_open_input_file(ctx, source); + out = sexp_current_error_port(ctx); + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0); + sexp_context_parent(ctx2) = ctx; + tmp = sexp_env_bindings(env); + sexp_context_tailp(ctx2) = 0; + if (sexp_exceptionp(in)) { + if (sexp_not(out)) out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) + 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, env); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); + } +#if SEXP_USE_WARN_UNDEFS + if (! sexp_exceptionp(res)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + sexp_gc_release4(ctx); +#if SEXP_USE_DL + } +#endif + return res; +} + +#if SEXP_USE_MATH + +#if SEXP_USE_BIGNUMS +#define maybe_convert_bignum(z) \ + else if (sexp_bignump(z)) d = sexp_bignum_to_double(z); +#else +#define maybe_convert_bignum(z) +#endif + +#define define_math_op(name, cname) \ + static sexp name (sexp ctx sexp_api_params(self, n), sexp z) { \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_fixnump(z)) \ + d = (double)sexp_unbox_fixnum(z); \ + maybe_convert_bignum(z) \ + else \ + return sexp_type_exception(ctx, self, SEXP_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_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) { + double d, r; + if (sexp_flonump(z)) + d = sexp_flonum_value(z); + else if (sexp_fixnump(z)) + d = (double)sexp_unbox_fixnum(z); + maybe_convert_bignum(z) /* XXXX add bignum sqrt */ + else + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); + r = sqrt(d); + if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) + return sexp_make_fixnum(round(r)); + else + return sexp_make_flonum(ctx, r); +} + +#endif + +static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { + long double f, x1, e1; + sexp res; +#if SEXP_USE_BIGNUMS + if (sexp_bignump(e)) { /* bignum exponent needs special handling */ + if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) + res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ + else if (x == SEXP_ONE) + res = SEXP_ONE; /* 1.0 */ + else if (sexp_flonump(x)) + res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); + else + res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */ + } else if (sexp_bignump(x)) { + res = sexp_bignum_expt(ctx, x, e); + } else { +#endif + if (sexp_fixnump(x)) + x1 = sexp_unbox_fixnum(x); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + if (sexp_fixnump(e)) + e1 = sexp_unbox_fixnum(e); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, e); + f = pow(x1, e1); + if ((f > SEXP_MAX_FIXNUM) || (f < SEXP_MIN_FIXNUM) +#if SEXP_USE_FLONUMS + || (! sexp_fixnump(x)) || (! sexp_fixnump(e)) +#endif + ) { +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(x) && sexp_fixnump(e)) + res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); + else +#endif +#if SEXP_USE_FLONUMS + res = sexp_make_flonum(ctx, f); +#else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#endif + } else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#if SEXP_USE_BIGNUMS + } +#endif + return res; +} + +static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, sexp str2, sexp ci) { + sexp_sint_t len1, len2, len, diff; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2); + len1 = sexp_string_length(str1); + len2 = sexp_string_length(str2); + len = ((len1>4)&1)+3; +} + +static int sexp_utf8_char_byte_count(int c) { + if (c < 0x80) return 1; + if (c < 0x800) return 2; + if (c < 0x10000) return 3; + return 4; +} + +static int sexp_string_utf8_length (unsigned char *p, int len) { + unsigned char *q = p+len; + int i; + for (i=0; p0 && j0) + return sexp_user_exception(ctx, self, "string-index->offset: index out of range", index); + return sexp_make_fixnum(j); +} + +sexp sexp_string_utf8_ref (sexp ctx, sexp str, sexp i) { + unsigned char *p=(unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(i); + if (*p < 0x80) + return sexp_make_character(*p); + else if ((*p < 0xC0) || (*p > 0xF7)) + return sexp_user_exception(ctx, NULL, "string-ref: invalid utf8 byte", i); + else if (*p < 0xE0) + return sexp_make_character(((p[0]&0x3F)<<6) + (p[1]&0x3F)); + else if (*p < 0xF0) + return sexp_make_character(((p[0]&0x1F)<<12) + ((p[1]&0x3F)<<6) + (p[2]&0x3F)); + else + return sexp_make_character(((p[0]&0x0F)<<16) + ((p[1]&0x3F)<<6) + ((p[2]&0x3F)<<6) + (p[2]&0x3F)); +} + +sexp sexp_string_utf8_index_ref (sexp ctx sexp_api_params(self, n), sexp str, sexp i) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + off = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, i); + if (sexp_exceptionp(off)) return off; + return sexp_string_utf8_ref(ctx, str, off); +} + +void sexp_utf8_encode_char (unsigned char* p, int len, int c) { + switch (len) { + case 4: *p++ = (0xF0 + ((c)>>18)); *p++ = (0x80 + ((c>>12)&0x3F)); + *p++ = (0x80 + ((c>>6)&0x3F)); *p = (0x80 + (c&0x3F)); break; + case 3: *p++ = (0xE0 + ((c)>>12)); *p++ = (0x80 + ((c>>6)&0x3F)); + *p = (0x80 + (c&0x3F)); break; + case 2: *p++ = (0xC0 + ((c)>>6)); *p = (0x80 + (c&0x3F)); break; + default: *p = c; break; + } +} + +void sexp_write_utf8_char (sexp ctx, int c, sexp out) { + unsigned char buf[8]; + int len = sexp_utf8_char_byte_count(c); + sexp_utf8_encode_char(buf, len, c); + buf[len+1] = 0; + sexp_write_string(ctx, (char*)buf, out); +} + +sexp sexp_read_utf8_char (sexp ctx, sexp port, int i) { + if (i >= 0x80) { + if ((i < 0xC0) || (i > 0xF7)) { + return sexp_user_exception(ctx, NULL, "read-char: invalid utf8 byte", sexp_make_fixnum(i)); + } else if (i < 0xE0) { + i = ((i&0x3F)<<6) + (sexp_read_char(ctx, port)&0x3F); + } else if (i < 0xF0) { + i = ((i&0x1F)<<12) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += sexp_read_char(ctx, port)&0x3F; + } else { + i = ((i&0x0F)<<16) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += (sexp_read_char(ctx, port)&0x3F)<<6; + i += sexp_read_char(ctx, port)&0x3F; + } + } + return sexp_make_character(i); +} + +#if SEXP_USE_MUTABLE_STRINGS + +void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) { + sexp b; + unsigned char *p, *q; + int i = sexp_unbox_fixnum(index), c = sexp_unbox_character(ch), + old_len, new_len, len; + p = (unsigned char*)sexp_string_data(str) + i; + old_len = sexp_utf8_initial_byte_count(*p); + new_len = sexp_utf8_char_byte_count(c); + if (old_len != new_len) { /* resize bytes if needed */ + len = sexp_string_length(str)+(new_len-old_len); + b = sexp_make_bytes(ctx, sexp_make_fixnum(len), SEXP_VOID); + if (! sexp_exceptionp(b)) { + q = (unsigned char*)sexp_bytes_data(b); + memcpy(q, sexp_string_data(str), i); + memcpy(q+i+new_len, p+old_len, len-i-new_len+1); + sexp_string_bytes(str) = b; + p = q + i; + } + sexp_string_length(str) += new_len - old_len; + } + sexp_utf8_encode_char(p, new_len, c); +} + +sexp sexp_string_utf8_index_set (sexp ctx sexp_api_params(self, n), sexp str, sexp i, sexp ch) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch); + off = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, i); + if (sexp_exceptionp(off)) return off; + sexp_string_utf8_set(ctx, str, off, ch); + return SEXP_VOID; +} + +#endif +#endif + +#ifdef PLAN9 +#include "opt/plan9.c" +#endif + +/************************** optimizations *****************************/ + +#if SEXP_USE_SIMPLIFY +#include "opt/simplify.c" +#endif + +/***************************** opcodes ********************************/ + +#include "opcodes.c" + +static sexp sexp_copy_core (sexp ctx, struct sexp_core_form_struct *core) { + sexp res = sexp_alloc_type(ctx, core, SEXP_CORE); + memcpy(&(res->value), core, sizeof(core[0])); + return res; +} + +static sexp sexp_copy_opcode (sexp ctx, struct sexp_opcode_struct *op) { + sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + memcpy(&(res->value), op, sizeof(op[0])); + return res; +} + +sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code, + sexp num_args, sexp flags, sexp arg1t, sexp arg2t, + sexp invp, sexp data, sexp data2, sexp_proc1 func) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, num_args); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, flags); + if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0) + || (sexp_unbox_fixnum(op_class) >= SEXP_OPC_NUM_OP_CLASSES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode class", op_class); + else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) + || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code); + else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_arg1_type(res) = sexp_unbox_fixnum(arg1t); + sexp_opcode_arg2_type(res) = sexp_unbox_fixnum(arg2t); + sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_data(res) = data; + sexp_opcode_data2(res) = data2; + sexp_opcode_func(res) = func; + sexp_opcode_name(res) = strdup(sexp_string_data(name)); + } + return res; +} + +sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res; +#if ! SEXP_USE_EXTENDED_FCALL + if (num_args > 6) + return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); +#endif + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; +#if SEXP_USE_EXTENDED_FCALL + if (num_args > 6) + sexp_opcode_code(res) = SEXP_OP_FCALLN; + else +#endif + sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1; + if (flags & 1) num_args--; + sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; + sexp_opcode_name(res) = name; + sexp_opcode_data(res) = data; + sexp_opcode_func(res) = f; + return res; +} + +sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp_gc_var1(op); + sexp_gc_preserve1(ctx, op); + sexp res = SEXP_VOID; + op = sexp_make_foreign(ctx, name, num_args, flags, f, data); + if (sexp_exceptionp(op)) + res = op; + else + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), op); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, + sexp_proc1 f, const char *param) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_intern(ctx, param, -1); + tmp = sexp_env_cell(env, tmp); + res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_TYPE_DEFS + +sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), + sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); +} + +sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + sexp_uint_t type_size; + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); + type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), + sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, + sexp_make_fixnum(type_size), NULL); +} + +sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); + return + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER), + sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); + return + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER), + sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +#endif + +#if SEXP_USE_STATIC_LIBS +#include "clibs.c" +#endif + +/*********************** standard environment *************************/ + +static struct sexp_core_form_struct core_forms[] = { + {SEXP_CORE_DEFINE, "define"}, + {SEXP_CORE_SET, "set!"}, + {SEXP_CORE_LAMBDA, "lambda"}, + {SEXP_CORE_IF, "if"}, + {SEXP_CORE_BEGIN, "begin"}, + {SEXP_CORE_QUOTE, "quote"}, + {SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}, + {SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}, + {SEXP_CORE_LET_SYNTAX, "let-syntax"}, + {SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}, +}; + +sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) { + 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; + return e; +} + +sexp sexp_make_null_env_op (sexp ctx sexp_api_params(self, n), sexp version) { + sexp_uint_t i; + sexp e = sexp_make_env(ctx), core; + for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) { + core = sexp_copy_core(ctx, &core_forms[i]); + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(core), -1), core); + } + return e; +} + +sexp sexp_make_primitive_env (sexp ctx, sexp version) { + int i; + sexp_gc_var3(e, op, sym); + sexp_gc_preserve3(ctx, e, op, sym); + e = sexp_make_null_env(ctx, version); + for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { + op = sexp_copy_opcode(ctx, &opcodes[i]); + if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1); + sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); + } + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op), -1), op); + } + sexp_gc_release3(ctx); + return e; +} + +sexp sexp_find_module_file (sexp ctx, const char *file) { + sexp res=SEXP_FALSE, ls; + char *dir, *path; + sexp_uint_t slash, dirlen, filelen, len; +#ifdef PLAN9 +#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0) + unsigned char buf[128]; +#else +#define file_exists_p(path, buf) (! stat(path, buf)) + struct stat buf_str; + struct stat *buf = &buf_str; +#endif + + filelen = strlen(file); + + ls = sexp_global(ctx, SEXP_G_MODULE_PATH); + for ( ; sexp_pairp(ls) && sexp_not(res); ls=sexp_cdr(ls)) { + dir = sexp_string_data(sexp_car(ls)); + dirlen = sexp_string_length(sexp_car(ls)); + slash = dir[dirlen-1] == '/'; + len = dirlen+filelen+2-slash; + path = (char*) malloc(len); + memcpy(path, dir, dirlen); + if (! slash) path[dirlen] = '/'; + memcpy(path+len-filelen-1, file, filelen); + path[len-1] = '\0'; + if (file_exists_p(path, buf)) + res = sexp_c_string(ctx, path, len-1); + free(path); + } + + return res; +} + +#define sexp_file_not_found "couldn't find file in module path" + +sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { + sexp res; + sexp_gc_var1(path); + sexp_gc_preserve1(ctx, path); + path = sexp_find_module_file(ctx, file); + if (sexp_stringp(path)) { + res = sexp_load(ctx, path, env); + } else { + path = sexp_c_string(ctx, file, -1); + res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path); + } + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_MODULES +static sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + return sexp_find_module_file(ctx, sexp_string_data(file)); +} +sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + return sexp_load_module_file(ctx, sexp_string_data(file), env); +} +#endif + +sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp) { + sexp ls; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dir); + if (sexp_truep(appendp)) { + if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { + for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) + ; + sexp_cdr(ls) = sexp_list1(ctx, dir); + } else { + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir); + } + } else { + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir); + } + return SEXP_VOID; +} + +sexp sexp_load_standard_parameters (sexp ctx, sexp e) { + /* add io port and interaction env parameters */ + sexp p = sexp_make_input_port(ctx, stdin, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p); + p = sexp_make_output_port(ctx, stdout, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p); + p = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); + return SEXP_VOID; +} + +sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { + sexp_gc_var3(op, tmp, sym); + sexp_gc_preserve3(ctx, op, tmp, sym); + sexp_load_standard_parameters(ctx, e); +#if SEXP_USE_DL + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1), + tmp=sexp_c_string(ctx, sexp_so_extension, -1)); +#endif + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform, -1)); +#if SEXP_USE_DL + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading", -1)); +#endif +#if SEXP_USE_MODULES + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules", -1)); +#endif +#if SEXP_USE_BOEHM + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); +#endif +#if SEXP_USE_UTF8_STRINGS + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); +#endif + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); + sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; +#if SEXP_USE_SIMPLIFY + op = sexp_make_foreign(ctx, "simplify", 1, 0, + (sexp_proc1)sexp_simplify, SEXP_VOID); + tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); +#endif + /* load init.scm */ + tmp = sexp_load_module_file(ctx, sexp_init_file, e); + /* load and bind config env */ +#if SEXP_USE_MODULES + if (! sexp_exceptionp(tmp)) { + sym = sexp_intern(ctx, "*config-env*", -1); + if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { + tmp = sexp_make_env(ctx); + if (! sexp_exceptionp(tmp)) { + sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; + sexp_env_parent(tmp) = e; + op = sexp_load_module_file(ctx, sexp_config_file, tmp); + if (sexp_exceptionp(op)) + sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); + sexp_env_define(ctx, tmp, sym, tmp); + } + } + sexp_env_define(ctx, e, sym, tmp); + } +#endif +#if SEXP_USE_STATIC_LIBS + sexp_init_all_libraries(ctx, e); +#endif + sexp_gc_release3(ctx); + return sexp_exceptionp(tmp) ? tmp : e; +} + +sexp sexp_make_standard_env_op (sexp ctx sexp_api_params(self, n), sexp version) { + sexp_gc_var1(env); + sexp_gc_preserve1(ctx, env); + env = sexp_make_primitive_env(ctx, version); + if (! sexp_exceptionp(env)) sexp_load_standard_env(ctx, env, version); + sexp_gc_release1(ctx); + return env; +} + +sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) { + sexp oldname, newname, value; + if (! sexp_envp(to)) to = sexp_context_env(ctx); + if (! sexp_envp(from)) from = sexp_context_env(ctx); + if (sexp_not(ls)) { + if (sexp_truep(immutp)) { + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_parent(to) = value; + sexp_immutablep(value) = 1; + sexp_env_bindings(value) = sexp_env_bindings(from); + } else { + for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_env_define(ctx, to, sexp_car(ls), sexp_cdr(ls)); + } + } else { + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (sexp_pairp(sexp_car(ls))) { + newname = sexp_caar(ls); oldname = sexp_cdar(ls); + } else { + newname = oldname = sexp_car(ls); + } + value = sexp_env_ref(from, oldname, SEXP_UNDEF); + if (value != SEXP_UNDEF) { + sexp_env_define(ctx, to, newname, value); +#if SEXP_USE_WARN_UNDEFS + } else { + sexp_warn(ctx, "importing undefined variable: ", oldname); +#endif + } + } + } + return SEXP_VOID; +} + +/************************* backend ***************************/ + +#if SEXP_USE_NATIVE_X86 +#include "opt/x86.c" +#else +#include "vm.c" +#endif + +/************************** eval interface ****************************/ + +sexp sexp_compile (sexp ctx, sexp x) { + sexp_gc_var3(ast, vec, res); + sexp_gc_preserve3(ctx, ast, vec, res); + ast = sexp_analyze(ctx, x); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(res); res=sexp_cdr(res)) + ast = sexp_apply1(ctx, sexp_cdar(res), ast); + sexp_free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + emit_enter(ctx); + generate(ctx, ast); + res = finalize_bytecode(ctx); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec); + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { + sexp_sint_t top; + sexp ctx2; + sexp_gc_var2(res, err_handler); + if (! env) env = sexp_context_env(ctx); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_gc_preserve2(ctx, res, err_handler); + top = sexp_context_top(ctx); + err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = SEXP_FALSE; + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0); + res = sexp_compile(ctx2, obj); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; + sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_eval_string (sexp ctx, const char *str, sexp_sint_t len, sexp env) { + sexp res; + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); + obj = sexp_read_from_string(ctx, str, len); + res = sexp_eval(ctx, obj, env); + sexp_gc_release1(ctx); + return res; +} + +void sexp_scheme_init (void) { + if (! scheme_initialized_p) { + scheme_initialized_p = 1; + sexp_init(); + } +} diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..af7b3986 --- /dev/null +++ b/gc.c @@ -0,0 +1,346 @@ +/* gc.c -- simple mark&sweep garbage collector */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +#if SEXP_USE_MMAP_GC +#include +#endif + +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(sexp_sizeof(pair))) + +#if SEXP_USE_GLOBAL_HEAP +sexp_heap sexp_global_heap; +#endif + +#if SEXP_USE_CONSERVATIVE_GC +static sexp* stack_base; +#endif + +static sexp_heap sexp_heap_last (sexp_heap h) { + while (h->next) h = h->next; + return h; +} + +sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) { + sexp_uint_t res; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) + return sexp_heap_align(1); + t = sexp_object_type(ctx, x); + res = sexp_type_size_of_object(t, x); + return res; +} + +#if SEXP_USE_SAFE_GC_MARK +static int sexp_in_heap(sexp ctx, sexp_uint_t x) { + sexp_heap h; + if (x & (sexp_heap_align(1)-1)) { + fprintf(stderr, "invalid heap alignment: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; + } + for (h=sexp_context_heap(ctx); h; h=h->next) + if (((sexp_uint_t)h < x) && (x < (sexp_uint_t)(h->data + h->size))) + return 1; + fprintf(stderr, "invalid object outside heap: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; +} +#endif + +#if SEXP_USE_DEBUG_GC +#include "opt/gc_debug.c" +#endif + +void sexp_mark (sexp ctx, sexp x) { + 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; +#if SEXP_USE_SAFE_GC_MARK + if (! sexp_in_heap(ctx, (sexp_uint_t)x)) + return; +#endif +#if SEXP_USE_HEADER_MAGIC + if (sexp_pointer_magic(x) != SEXP_POINTER_MAGIC && sexp_pointer_tag(x) != SEXP_TYPE + && sexp_pointer_tag(x) != SEXP_OPCODE && sexp_pointer_tag(x) != SEXP_CORE + && sexp_pointer_tag(x) != SEXP_STACK) + return; +#endif + sexp_gc_mark(x) = 1; + if (sexp_contextp(x)) + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) sexp_mark(ctx, *(saves->var)); + t = sexp_object_type(ctx, x); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len = sexp_type_num_slots_of_object(t, x) - 1; + if (len >= 0) { + for (i=0; inext) { + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); + q = h->free_list; + end = (sexp) ((char*)h->data + h->size - sexp_heap_align(sexp_sizeof(pair))); + while (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) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + r->size); + continue; + } + size = sexp_heap_align(sexp_allocated_bytes(ctx, p)); + if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + /* free p */ + finalizer = sexp_type_finalize(sexp_object_type(ctx, p)); + if (finalizer) finalizer(ctx sexp_api_pass(NULL, 1), 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); + } + } + } + if (sum_freed_ptr) *sum_freed_ptr = sum_freed; + return sexp_make_fixnum(max_freed); +} + +sexp sexp_gc (sexp ctx, size_t *sum_freed) { + sexp res; +#if SEXP_USE_GLOBAL_SYMBOLS + int i; + 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(sexp_context_heap(ctx)); + 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=sexp_context_heap(ctx); 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, total_size; + sexp_heap h; + size = sexp_heap_align(size); + res = sexp_try_alloc(ctx, size); + if (! res) { + max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed)); + for (total_size=0, h=sexp_context_heap(ctx); h->next; h=h->next) + total_size += h->size; + total_size += h->size; + if (((max_freed < size) + || ((total_size > sum_freed) + && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO))) + && ((!SEXP_MAXIMUM_HEAP_SIZE) || (total_size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); + if (! res) + res = sexp_global(ctx, SEXP_G_OOM_ERROR); + } + return res; +} + +#if ! SEXP_USE_GLOBAL_HEAP + +sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { + sexp_sint_t i, off, len, freep; + sexp_heap to, from = sexp_context_heap(ctx); + sexp_free_list q; + sexp p, p2, t, end, *v; + freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP); + + /* validate input, creating a new heap if needed */ + if (from->next) { + return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx); + } else if (! dst || sexp_not(dst)) { + to = sexp_make_heap(from->size); + dst = (sexp) ((char*)ctx + ((char*)to - (char*)from)); + } else if (! sexp_contextp(dst)) { + return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst); + } else if (sexp_context_heap(dst)->size < from->size) { + return sexp_user_exception(ctx, NULL, "destination context too small", dst); + } else { + to = sexp_context_heap(dst); + } + + /* copy the raw data */ + off = (char*)to - (char*)from; + memcpy(to, from, sexp_heap_pad_size(from->size)); + to->free_list = (sexp_free_list) ((char*)to->free_list + off); + to->data += off; + end = (sexp) (from->data + from->size); + + /* adjust the free list */ + for (q=to->free_list; q->next; q=q->next) + q->next = (sexp_free_list) ((char*)q->next + off); + + /* adjust if the destination is larger */ + if (from->size < to->size) { + if (((char*)q + q->size - off) >= (char*)end) { + q->size += (to->size - from->size); + } else { + q->next = (sexp_free_list) ((char*)end + off); + q->next->next = NULL; + q->next->size = (to->size - from->size); + } + } + + /* adjust data by traversing over the _original_ heap */ + p = (sexp) (from->data + sexp_heap_align(sexp_sizeof(pair))); + q = from->free_list; + while (p < end) { + /* find the next free list pointer */ + for ( ; q && ((char*)q < (char*)p); q=q->next) + ; + if ((char*)q == (char*)p) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + q->size); + } else { + t = sexp_object_type(ctx, p); + len = sexp_type_num_slots_of_object(t, p); + p2 = (sexp)((char*)p + off); + v = (sexp*) ((char*)p2 + sexp_type_field_base(t)); + /* offset any pointers in the _destination_ heap */ + for (i=0; i 6 args */ +/* #define SEXP_USE_EXTENDED_FCALL 0 */ + +/* uncomment this if you don't need flonum support */ +/* This is only for EVAL - you'll still be able to read */ +/* and write flonums directly through the sexp API. */ +/* #define SEXP_USE_FLONUMS 0 */ + +/* uncomment this to disable reading/writing IEEE infinities */ +/* By default you can read/write +inf.0, -inf.0 and +nan.0 */ +/* #define SEXP_USE_INFINITIES 0 */ + +/* uncomment this if you want immediate flonums */ +/* This is experimental, enable at your own risk. */ +/* #define SEXP_USE_IMMEDIATE_FLONUMS 1 */ + +/* uncomment this if you don't want bignum support */ +/* Bignums are implemented with a small, custom library */ +/* in opt/bignum.c. */ +/* #define SEXP_USE_BIGNUMS 0 */ + +/* uncomment this if you don't need extended math operations */ +/* This includes the trigonometric and expt functions. */ +/* Automatically disabled if you've disabled flonums. */ +/* #define SEXP_USE_MATH 0 */ + +/* uncomment this to disable the self and n parameters to primitives */ +/* This is the old style API. */ +/* #define SEXP_USE_SELF_PARAMETER 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* This is something of a hack, but can be quite useful. */ +/* It's very fast and doesn't involve any separate analysis */ +/* passes. */ +/* #define SEXP_USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* By default (this may change) small symbols are represented */ +/* as immediates using a simple huffman encoding. This keeps */ +/* the symbol table small, and minimizes hashing when doing a */ +/* lot of reading. */ +/* #define SEXP_USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* You can trade off some space in exchange for longer read */ +/* times by disabling hashing and just putting all */ +/* non-immediate symbols in a single list. */ +/* #define SEXP_USE_HASH_SYMS 0 */ + +/* uncomment this to disable UTF-8 string support */ +/* The default settings store strings in memory as UTF-8, */ +/* and assumes strings passed to/from the C FFI are UTF-8. */ +/* #define SEXP_USE_UTF8_STRINGS 0 */ + +/* uncomment this to disable the string-set! opcode */ +/* By default (non-literal) strings are mutable. */ +/* Making them immutable allows for packed UTF-8 strings. */ +/* #define SEXP_USE_MUTABLE_STRINGS 0 */ + +/* uncomment this to disable string ports */ +/* If disabled some basic functionality such as number->string */ +/* will not be available by default. */ +/* #define SEXP_USE_STRING_STREAMS 0 */ + +/* uncomment this to disable automatic closing of ports */ +/* If enabled, the underlying FILE* for file ports will be */ +/* automatically closed when they're garbage collected. Doesn't */ +/* apply to stdin/stdout/stderr. */ +/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */ + +/* uncomment this to use the normal 1970 unix epoch */ +/* By default chibi uses an datetime epoch starting at */ +/* 2010/01/01 00:00:00 in order to be able to represent */ +/* more common times as fixnums. */ +/* #define SEXP_USE_2010_EPOCH 0 */ + +/* uncomment this to disable stack overflow checks */ +/* By default stacks are fairly small, so it's good to leave */ +/* this enabled. */ +/* #define SEXP_USE_CHECK_STACK 0 */ + +/* #define SEXP_USE_DEBUG_VM 0 */ +/* Experts only. */ +/* For *very* verbose output on every VM operation. */ + +/* uncomment this to make the VM adhere to alignment rules */ +/* This is required on some platforms, e.g. ARM */ +/* #define SEXP_USE_ALIGNED_BYTECODE */ + +/************************************************************************/ +/* These settings are configurable but only recommended for */ +/* experienced users, and only apply when using the native GC. */ +/************************************************************************/ + +/* the initial heap size in bytes */ +#ifndef SEXP_INITIAL_HEAP_SIZE +#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) +#endif + +/* the maximum heap size in bytes - if 0 there is no limit */ +#ifndef SEXP_MAXIMUM_HEAP_SIZE +#define SEXP_MAXIMUM_HEAP_SIZE 0 +#endif +#ifndef SEXP_MINIMUM_HEAP_SIZE +#define SEXP_MINIMUM_HEAP_SIZE 8*1024 +#endif + +/* if after GC more than this percentage of memory is still in use, */ +/* and we've not exceeded the maximum size, grow the heap */ +#ifndef SEXP_GROW_HEAP_RATIO +#define SEXP_GROW_HEAP_RATIO 0.75 +#endif + +/* the default number of opcodes to run each thread for */ +#ifndef SEXP_DEFAULT_QUANTUM +#define SEXP_DEFAULT_QUANTUM 500 +#endif + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#ifndef SEXP_64_BIT +#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) +#define SEXP_64_BIT 1 +#else +#define SEXP_64_BIT 0 +#endif +#endif + +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 +#ifndef _GNU_SOURCE +#define _GNU_SOURCE +#endif +#endif + +#ifndef SEXP_USE_NO_FEATURES +#define SEXP_USE_NO_FEATURES 0 +#endif + +#ifndef SEXP_USE_GREEN_THREADS +#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_NATIVE_X86 +#define SEXP_USE_NATIVE_X86 0 +#endif + +#ifndef SEXP_USE_MODULES +#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_TYPE_DEFS +#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_MAXIMUM_TYPES +#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1) +#endif + +#ifndef SEXP_USE_DL +#ifdef PLAN9 +#define SEXP_USE_DL 0 +#else +#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_STATIC_LIBS +#define SEXP_USE_STATIC_LIBS 0 +#endif + +#ifndef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 0 +#endif + +#ifndef SEXP_USE_MALLOC +#define SEXP_USE_MALLOC 0 +#endif + +#ifndef SEXP_USE_MMAP_GC +#define SEXP_USE_MMAP_GC 0 +#endif + +#ifndef SEXP_USE_DEBUG_GC +#define SEXP_USE_DEBUG_GC 0 +#endif + +#ifndef SEXP_USE_SAFE_GC_MARK +#define SEXP_USE_SAFE_GC_MARK 0 +#endif + +#ifndef SEXP_USE_CONSERVATIVE_GC +#define SEXP_USE_CONSERVATIVE_GC 0 +#endif + +#ifndef SEXP_USE_HEADER_MAGIC +#define SEXP_USE_HEADER_MAGIC 0 +#endif + +#ifndef SEXP_USE_GLOBAL_HEAP +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_HEAP 1 +#else +#define SEXP_USE_GLOBAL_HEAP 0 +#endif +#endif + +#ifndef SEXP_USE_GLOBAL_TYPES +#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS) +#endif + +#ifndef SEXP_USE_GLOBAL_SYMBOLS +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_SYMBOLS 1 +#else +#define SEXP_USE_GLOBAL_SYMBOLS 0 +#endif +#endif + +#ifndef SEXP_USE_EXTENDED_FCALL +#define SEXP_USE_EXTENDED_FCALL ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_INFINITIES +#if defined(PLAN9) || ! SEXP_USE_FLONUMS +#define SEXP_USE_INFINITIES 0 +#else +#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_IMMEDIATE_FLONUMS +#define SEXP_USE_IMMEDIATE_FLONUMS 0 +#endif + +#ifndef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MATH +#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_SELF_PARAMETER +#define SEXP_USE_SELF_PARAMETER 1 +#endif + +#ifndef SEXP_USE_WARN_UNDEFS +#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HUFF_SYMS +#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HASH_SYMS +#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_DEBUG_VM +#define SEXP_USE_DEBUG_VM 0 +#endif + +#ifndef SEXP_USE_UTF8_STRINGS +#define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MUTABLE_STRINGS +#define SEXP_USE_MUTABLE_STRINGS 1 +#endif + +#if (SEXP_USE_UTF8_STRINGS && SEXP_USE_MUTABLE_STRINGS) +#define SEXP_USE_PACKED_STRINGS 0 +#endif +#ifndef SEXP_USE_PACKED_STRINGS +#define SEXP_USE_PACKED_STRINGS 1 +#endif + +#ifndef SEXP_USE_STRING_STREAMS +#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_AUTOCLOSE_PORTS +#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_2010_EPOCH +#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_EPOCH_OFFSET +#if SEXP_USE_2010_EPOCH +#define SEXP_EPOCH_OFFSET 1262271600 +#else +#define SEXP_EPOCH_OFFSET 0 +#endif +#endif + +#ifndef SEXP_USE_CHECK_STACK +#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES +#endif + +#if SEXP_USE_NATIVE_X86 +#undef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 1 +#undef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS 0 +#undef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS 0 +#undef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY 0 +#endif + +#ifndef SEXP_USE_ALIGNED_BYTECODE +#if defined(__arm__) +#define SEXP_USE_ALIGNED_BYTECODE 1 +#else +#define SEXP_USE_ALIGNED_BYTECODE 0 +#endif +#endif + +#ifdef PLAN9 +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#endif + +#ifdef __MINGW32__ +#ifdef BUILDING_DLL +#define SEXP_API __declspec(dllexport) +#else +#define SEXP_API __declspec(dllimport) +#endif +#else +#define SEXP_API +#endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h new file mode 100644 index 00000000..a197e953 --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,1042 @@ +/* sexp.h -- header for sexp library */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_H +#define SEXP_H + +#ifdef __cplusplus +extern "C" { +#endif + +#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" + +#include "chibi/features.h" +#include "chibi/install.h" + +#if defined(_WIN32) || defined(__MINGW32__) +#include +#else +#if SEXP_USE_DL +#include +#endif +#if SEXP_USE_GREEN_THREADS +#include +#endif +#endif + +#ifdef PLAN9 +#include +#include +#include +#include +#include <9p.h> +typedef unsigned long size_t; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +#include +#include + +/* tagging system + * bits end in 00: pointer + * 01: fixnum + * 011: immediate flonum (optional) + * 111: immediate symbol (optional) + * 000110: char + * 001110: unique immediate (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 6 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 63 + +#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 + +#ifndef SEXP_POINTER_MAGIC +#define SEXP_POINTER_MAGIC 0xFDCA9764uL /* arbitrary */ +#endif + +#if SEXP_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_NUMBER, + SEXP_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_BYTES, + SEXP_STRING, + SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, + SEXP_CPOINTER, + 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_CORE_TYPES +}; + +#if SEXP_64_BIT +typedef unsigned int sexp_tag_t; +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#else +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +typedef struct sexp_struct *sexp; + +#define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1)) + +#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2)) +#define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type)) +#define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type)) + +#define SEXP_UINT_T_MAX ((sexp_uint_t)-1) +#define SEXP_UINT_T_MIN (0) +#define SEXP_SINT_T_MAX __MAX_SIGNED(sexp_sint_t) +#define SEXP_SINT_T_MIN __MIN_SIGNED(sexp_sint_t) + +#define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1) +#define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1) + +#if SEXP_USE_SELF_PARAMETER +#define sexp_api_params(self, n) , sexp self, long n +#define sexp_api_pass(self, n) , self, n +#else +#define sexp_api_params(self, n) +#define sexp_api_pass(self, n) +#endif + +/* procedure types */ +typedef sexp (*sexp_proc1) (sexp sexp_api_params(self, n)); +typedef sexp (*sexp_proc2) (sexp sexp_api_params(self, n), sexp); +typedef sexp (*sexp_proc3) (sexp sexp_api_params(self, n), sexp, sexp); +typedef sexp (*sexp_proc4) (sexp sexp_api_params(self, n), sexp, sexp, sexp); +typedef sexp (*sexp_proc5) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc6) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc7) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp); + +typedef struct sexp_free_list_t *sexp_free_list; +struct sexp_free_list_t { + sexp_uint_t size; + sexp_free_list next; +}; + +typedef struct sexp_heap_t *sexp_heap; +struct sexp_heap_t { + sexp_uint_t size; + sexp_free_list free_list; + sexp_heap next; + /* note this must be aligned on a proper heap boundary, */ + /* so we can't just use char data[] */ + char *data; +}; + +struct sexp_gc_var_t { + sexp *var; +#if SEXP_USE_DEBUG_GC + char *name; +#endif + struct sexp_gc_var_t *next; +}; + +struct sexp_type_struct { + sexp_tag_t tag; + short field_base, field_eq_len_base, field_len_base, field_len_off; + unsigned short field_len_scale; + short size_base, size_off; + unsigned short size_scale; + char *name; + sexp_proc2 finalize; +}; + +struct sexp_opcode_struct { + unsigned char op_class, code, num_args, flags, + arg1_type, arg2_type, inverse; + const char *name; + sexp data, data2, proc; + sexp_proc1 func; +}; + +struct sexp_core_form_struct { + char code; + const char *name; +}; + +struct sexp_struct { + sexp_tag_t tag; + char gc_mark; + unsigned int immutablep:1; + unsigned int freep:1; + unsigned int syntacticp:1; +#if SEXP_USE_HEADER_MAGIC + unsigned int magic; +#endif + union { + /* basic types */ + double flonum; + struct sexp_type_struct type; + struct { + sexp car, cdr; + sexp source; + } pair; + struct { + sexp_uint_t length; + sexp data[]; + } vector; + struct { + sexp_uint_t length; + char data[]; + } bytes; + struct { +#if SEXP_USE_PACKED_STRINGS + sexp_uint_t length; + char data[]; +#else + sexp_uint_t offset, length; + sexp bytes; +#endif + } string; + struct { + sexp_uint_t length; + char data[]; + } symbol; + struct { + FILE *stream; + char *buf; + char openp, no_closep, sourcep; + sexp_uint_t offset, line; + size_t size; + sexp name; + sexp cookie; + } port; + struct { + sexp kind, message, irritants, procedure, source; + } exception; + struct { + signed char sign; + sexp_uint_t length; + sexp_uint_t data[]; + } bignum; + struct { + sexp_uint_t length; + void *value; + sexp parent; + char body[]; + } cpointer; + /* runtime types */ + struct { + sexp parent, lambda, bindings; + } env; + struct { + sexp_uint_t length; + sexp name, literals, source; + 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 sexp_opcode_struct opcode; + struct sexp_core_form_struct core; + /* ast types */ + struct { + sexp name, params, body, defs, locals, flags, fv, sv, source; + } lambda; + struct { + sexp test, pass, fail, source; + } cnd; + struct { + sexp var, value, source; + } set; + struct { + sexp name, cell, source; + } ref; + struct { + sexp ls, source; + } seq; + struct { + sexp value, source; + } lit; + /* compiler state */ + struct { + sexp_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp_heap heap; + struct sexp_gc_var_t *saves; +#if SEXP_USE_GREEN_THREADS + sexp_sint_t refuel; + unsigned char* ip; + struct timeval tval; +#endif + char tailp, tracep, timeoutp, waitp; + sexp_uint_t pos, depth, last_fp; + sexp bc, lambda, stack, env, fv, parent, globals, + proc, name, specific, event; + } 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_offsetof_slot0 (offsetof(struct sexp_struct, value)) + +#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double)) + +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) +#define sexp_alloc_bytecode(ctx, i) sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE) + +#if SEXP_USE_BIGNUMS +#include "chibi/bignum.h" +#endif + +/***************************** 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_fixnump(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_flags(x) ((x)->flags) +#define sexp_immutablep(x) ((x)->immutablep) +#define sexp_freep(x) ((x)->freep) +#define sexp_pointer_magic(x) ((x)->magic) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) +#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) + +#if SEXP_USE_IMMEDIATE_FLONUMS +union sexp_flonum_conv { + float flonum; + unsigned int bits; +}; +#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x); +#if SEXP_64_BIT +SEXP_API float sexp_flonum_value (sexp x); +SEXP_API sexp sexp_make_flonum(sexp ctx, float f); +#else +#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)(((unsigned int)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) +#endif +#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_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) +#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER)) +#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_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x)) + +#if SEXP_USE_HUFF_SYMS +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +#else +#define sexp_symbolp(x) (sexp_lsymbolp(x)) +#endif + +#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_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) + +#define SEXP_NEG_ONE sexp_make_fixnum(-1) +#define SEXP_ZERO sexp_make_fixnum(0) +#define SEXP_ONE sexp_make_fixnum(1) +#define SEXP_TWO sexp_make_fixnum(2) +#define SEXP_THREE sexp_make_fixnum(3) +#define SEXP_FOUR sexp_make_fixnum(4) +#define SEXP_FIVE sexp_make_fixnum(5) +#define SEXP_SIX sexp_make_fixnum(6) +#define SEXP_SEVEN sexp_make_fixnum(7) +#define SEXP_EIGHT sexp_make_fixnum(8) +#define SEXP_NINE sexp_make_fixnum(9) +#define SEXP_TEN sexp_make_fixnum(10) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) + +#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x))) +#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x)) +#else +#define _or_integer_flonump(x) +#endif + +#if SEXP_USE_BIGNUMS +SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x); +SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); +#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) +#else +#define sexp_make_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_make_unsigned_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_exact_integerp(x) sexp_fixnump(x) +#endif + +#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) +#define sexp_numberp(x) (sexp_exact_integerp(x) || sexp_flonump(x)) +#else +#define sexp_fixnum_to_flonum(ctx, x) (x) +#define sexp_numberp(x) sexp_exact_integerp(x) +#endif + +#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS +#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0])) +#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0])) +#else +#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x)) +#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x)) +#endif + +#define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET) +#define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET) + +/*************************** 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_fixnum(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_fixnum(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_fixnum(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_bytes_length(x) ((x)->value.bytes.length) +#define sexp_bytes_data(x) ((x)->value.bytes.data) + +#define sexp_string_length(x) ((x)->value.string.length) +#if SEXP_USE_PACKED_STRINGS +#define sexp_string_data(x) ((x)->value.string.data) +#else +#define sexp_string_bytes(x) ((x)->value.string.bytes) +#define sexp_string_offset(x) ((x)->value.string.offset) +#define sexp_string_data(x) (sexp_bytes_data(sexp_string_bytes(x))+sexp_string_offset(x)) +#endif + +#define sexp_bytes_ref(x, i) (sexp_make_fixnum((unsigned char)sexp_bytes_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_bytes_set(x, i, v) (sexp_bytes_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_fixnum(v)) + +#define sexp_string_ref(x, i) (sexp_make_character((unsigned char)sexp_string_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_character(v)) + +#define sexp_symbol_data(x) ((x)->value.symbol.data) +#define sexp_symbol_length(x) ((x)->value.symbol.length) +#define sexp_symbol_string(x) (x) + +#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_no_closep(p) ((p)->value.port.no_closep) +#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_cpointer_freep(p) (sexp_freep(p)) +#define sexp_cpointer_length(p) ((p)->value.cpointer.length) +#define sexp_cpointer_body(p) ((p)->value.cpointer.body) +#define sexp_cpointer_parent(p) ((p)->value.cpointer.parent) +#define sexp_cpointer_value(p) ((p)->value.cpointer.value) +#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p)) + +#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_source(x) ((x)->value.bytecode.source) +#define sexp_bytecode_data(x) ((x)->value.bytecode.data) + +#define sexp_env_syntactic_p(x) ((x)->syntacticp) +#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_data(x) ((x)->value.opcode.data) +#define sexp_opcode_data2(x) ((x)->value.opcode.data2) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) +#define sexp_opcode_func(x) ((x)->value.opcode.func) + +#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_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) + +#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_lambda_source(x) ((x)->value.lambda.source) + +#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_cnd_source(x) ((x)->value.cnd.source) + +#define sexp_set_var(x) ((x)->value.set.var) +#define sexp_set_value(x) ((x)->value.set.value) +#define sexp_set_source(x) ((x)->value.set.source) + +#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_ref_source(x) ((x)->value.ref.source) + +#define sexp_seq_ls(x) ((x)->value.seq.ls) +#define sexp_seq_source(x) ((x)->value.seq.source) + +#define sexp_lit_value(x) ((x)->value.lit.value) +#define sexp_lit_source(x) ((x)->value.lit.source) + +#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_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.tracep) +#define sexp_context_globals(x) ((x)->value.context.globals) +#define sexp_context_last_fp(x) ((x)->value.context.last_fp) +#define sexp_context_refuel(x) ((x)->value.context.refuel) +#define sexp_context_ip(x) ((x)->value.context.ip) +#define sexp_context_proc(x) ((x)->value.context.proc) +#define sexp_context_timeval(x) ((x)->value.context.tval) +#define sexp_context_name(x) ((x)->value.context.name) +#define sexp_context_specific(x) ((x)->value.context.specific) +#define sexp_context_event(x) ((x)->value.context.event) +#define sexp_context_timeoutp(x) ((x)->value.context.timeoutp) +#define sexp_context_waitp(x) ((x)->value.context.waitp) + +#if SEXP_USE_ALIGNED_BYTECODE +#define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx)) +#else +#define sexp_context_align_pos(ctx) +#endif + +#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) + +#if SEXP_USE_GLOBAL_HEAP +#if ! SEXP_USE_BOEHM +SEXP_API sexp_heap sexp_global_heap; +#endif +#define sexp_context_heap(ctx) sexp_global_heap +#else +#define sexp_context_heap(ctx) ((ctx)->value.context.heap) +#endif + +#if SEXP_USE_GLOBAL_SYMBOLS +#define sexp_context_symbols(ctx) sexp_symbol_table +#else +#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) +#endif + +#if SEXP_USE_GLOBAL_TYPES +SEXP_API struct sexp_struct *sexp_type_specs; +#define sexp_context_types(ctx) sexp_type_specs +#define sexp_type_by_index(ctx,i) (&(sexp_context_types(ctx)[i])) +#define sexp_context_num_types(ctx) sexp_num_types +#define sexp_context_type_array_size(ctx) sexp_type_array_size +#else +#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#define sexp_type_by_index(ctx,i) (sexp_context_types(ctx)[i]) +#define sexp_context_num_types(ctx) \ + sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES)) +#define sexp_context_type_array_size(ctx) \ + sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES)) +#endif + +#define sexp_object_type(ctx,x) (sexp_type_by_index(ctx, ((x)->tag))) +#define sexp_object_type_name(ctx,x) (sexp_type_name(sexp_object_type(ctx, x))) +#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i))) + +#define sexp_type_size_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \ + * sexp_type_size_scale(t) \ + + sexp_type_size_base(t)) +#define sexp_type_num_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_len_base(t)) +#define sexp_type_num_eq_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_eq_len_base(t)) + +#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_eq_len_base(x) ((x)->value.type.field_eq_len_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_type_finalize(x) ((x)->value.type.finalize) + +#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_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b))) +#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b))) +#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1))) +#define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a)))) +#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) + +#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 *****************************/ + +enum sexp_context_globals { +#if ! SEXP_USE_GLOBAL_SYMBOLS + SEXP_G_SYMBOLS, +#endif +#if ! SEXP_USE_GLOBAL_TYPES + SEXP_G_TYPES, + SEXP_G_NUM_TYPES, +#endif + SEXP_G_OOM_ERROR, /* out of memory exception object */ + SEXP_G_OOS_ERROR, /* out of stack exception object */ + SEXP_G_OPTIMIZATIONS, + SEXP_G_SIGNAL_HANDLERS, + SEXP_G_CONFIG_ENV, + SEXP_G_MODULE_PATH, + SEXP_G_QUOTE_SYMBOL, + SEXP_G_QUASIQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SPLICING_SYMBOL, + SEXP_G_EMPTY_VECTOR, + SEXP_G_CUR_IN_SYMBOL, + SEXP_G_CUR_OUT_SYMBOL, + SEXP_G_CUR_ERR_SYMBOL, + SEXP_G_INTERACTION_ENV_SYMBOL, + SEXP_G_ERR_HANDLER, + SEXP_G_RESUMECC_BYTECODE, + SEXP_G_FINAL_RESUMER, +#if SEXP_USE_GREEN_THREADS + SEXP_G_THREADS_SCHEDULER, + SEXP_G_THREADS_FRONT, + SEXP_G_THREADS_BACK, + SEXP_G_THREADS_PAUSED, + SEXP_G_THREADS_LOCAL, +#endif + SEXP_G_NUM_GLOBALS +}; + +#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(ctx, (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 SEXP_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)) + +SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); +SEXP_API sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, const char *str, sexp_uint_t len, sexp p); +SEXP_API sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p); +SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) + +SEXP_API sexp sexp_make_context(sexp ctx, size_t size); +SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +SEXP_API sexp sexp_cons_op(sexp ctx sexp_api_params(self, n), sexp head, sexp tail); +SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_listp_op(sexp ctx sexp_api_params(self, n), sexp obj); +SEXP_API sexp sexp_reverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_nreverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_copy_list_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_append2_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_memq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_assq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_length_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen); +SEXP_API sexp sexp_make_bytes_op(sexp ctx sexp_api_params(self, n), sexp len, sexp i); +SEXP_API sexp sexp_make_string_op(sexp ctx sexp_api_params(self, n), sexp len, sexp ch); +SEXP_API sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end); +SEXP_API sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep); +SEXP_API sexp sexp_intern (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b); +SEXP_API sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt); +SEXP_API sexp sexp_list_to_vector_op (sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); +SEXP_API sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp in); +SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_write_to_string (sexp ctx, sexp obj); +SEXP_API sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port); +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_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)); +SEXP_API sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port); +SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); +SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x); +SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +SEXP_API sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out); +SEXP_API void sexp_init(void); + +#define sexp_assert_type(ctx, pred, type_id, obj) if (! pred(obj)) return sexp_type_exception(ctx, self, type_id, obj) + +#define SEXP_COPY_DEFAULT SEXP_ZERO +#define SEXP_COPY_FREEP SEXP_ONE + +#if SEXP_USE_GLOBAL_HEAP +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_destroy_context (sexp ctx); +SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags); +#endif + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots); +SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); +SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj); +#define sexp_register_c_type(ctx, name, finalizer) \ + sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ + SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer) +#endif + +#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) +#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))) + +/* simplify primitive API interface */ + +#define sexp_read(ctx, in) sexp_read_op(ctx sexp_api_pass(NULL, 1), in) +#define sexp_write(ctx, obj, out) sexp_write_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_display(ctx, obj, out) sexp_display_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx sexp_api_pass(NULL, 2), e, out) +#define sexp_flush_output(ctx, obj, out) sexp_flush_output_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_listp(ctx, x) sexp_listp_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_length(ctx, x) sexp_length_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_reverse(ctx, x) sexp_reverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_copy_list(ctx, x) sexp_copy_list_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_cons(ctx, a, b) sexp_cons_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_append2(ctx, a, b) sexp_append2_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx sexp_api_pass(NULL, 2), a, b); +#define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_string_to_number(ctx, s, b) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), s, b) +#define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx sexp_api_pass(NULL, 2), l, i) +#define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), l, c) +#define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_substring(ctx, a, b, c) sexp_substring_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx sexp_api_pass(NULL, 2), ls, s) +#define sexp_memq(ctx, a, b) sexp_memq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_assq(ctx, a, b) sexp_assq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_output_string_port(ctx) sexp_make_output_string_port_op(ctx sexp_api_pass(NULL, 0)) +#define sexp_make_input_string_port(ctx, s) sexp_make_input_string_port_op(ctx sexp_api_pass(NULL, 1), s) +#define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_expt(ctx, a, b) sexp_expt_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_simple_type(ctx, a, b) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j) sexp_register_type_op(ctx sexp_api_pass(NULL, 10), a, b, c, d, e, f, g, h, i, j) +#define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_make_setter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) + +#ifdef __cplusplus +} /* extern "C" */ +#endif + +#endif /* ! SEXP_H */ + diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c new file mode 100644 index 00000000..2b740f41 --- /dev/null +++ b/lib/chibi/ast.c @@ -0,0 +1,79 @@ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); + sexp_gc_release2(ctx); +} + +static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, + sexp_uint_t cindex, char* get, char *set) { + sexp type, index; + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + type = sexp_make_fixnum(ctype); + index = sexp_make_fixnum(cindex); + op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, get, -1), op); + op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, set, -1), op); + sexp_gc_release2(ctx); +} + +static sexp sexp_get_env_cell (sexp ctx sexp_api_params(self, n), sexp env, sexp id) { + sexp cell = sexp_env_cell(env, id); + while ((! cell) && sexp_synclop(id)) { + env = sexp_synclo_env(id); + id = sexp_synclo_expr(id); + } + return cell ? cell : SEXP_FALSE; +} + +static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + else if (! sexp_opcode_name(op)) + return SEXP_FALSE; + else + return sexp_intern(ctx, sexp_opcode_name(op), -1); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); + sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); + sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); + sexp_define_type_predicate(ctx, env, "set?", SEXP_SET); + sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF); + sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ); + sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); + sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); + sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); + sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); + sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze); + sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); + sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); + sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + return SEXP_VOID; +} + diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module new file mode 100644 index 00000000..497fc5ed --- /dev/null +++ b/lib/chibi/ast.module @@ -0,0 +1,15 @@ + +(define-module (chibi ast) + (export analyze env-cell opcode-name + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + lambda-name lambda-params lambda-body lambda-defs + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + cnd-test cnd-pass cnd-fail + cnd-test-set! cnd-pass-set! cnd-fail-set! + set-var set-value set-var-set! set-value-set! + ref-name ref-cell ref-name-set! ref-cell-set! + seq-ls seq-ls-set! lit-value lit-value-set!) + (import-immutable (scheme)) + (include-shared "ast")) + diff --git a/lib/chibi/base64.module b/lib/chibi/base64.module new file mode 100644 index 00000000..12324e1d --- /dev/null +++ b/lib/chibi/base64.module @@ -0,0 +1,7 @@ + +(define-module (chibi base64) + (export base64-encode base64-encode-string + base64-decode base64-decode-string + base64-encode-header) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "base64.scm")) diff --git a/lib/chibi/base64.scm b/lib/chibi/base64.scm new file mode 100644 index 00000000..3d95ad71 --- /dev/null +++ b/lib/chibi/base64.scm @@ -0,0 +1,351 @@ +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: base64-encode-string str +;; Return a base64 encoded representation of string according to the +;; official base64 standard as described in RFC3548. + +;; Procedure: base64-decode-string str +;; Return a base64 decoded representation of string, also interpreting +;; the alternate 62 & 63 valued characters as described in RFC3548. +;; Other out-of-band characters are silently stripped, and = signals +;; the end of the encoded string. No errors will be raised. + +;; Procedure: base64-encode [port] +;; Procedure: base64-decode [port] +;; Variations of the above which read and write to ports. + +;; Procedure: base64-encode-header enc str [start-col max-col nl] +;; Return a base64 encoded representation of string as above, +;; wrapped in =?ENC?B?...?= as per RFC1522, split across multiple +;; MIME-header lines as needed to keep each lines length less than +;; MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring +;; STR is already encoded according to ENC. The optional argument +;; NL is the newline separator, defaulting to CRLF. + +;; This API is compatible with the Gauche library rfc.base64. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-chop str n) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (+ i n))) + (if (>= j len) + (reverse (cons (substring str i len) res)) + (lp j (cons (substring str i j) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; constants and tables + +(define *default-max-col* 76) + +(define *outside-char* 99) ; luft-balloons +(define *pad-char* 101) ; dalmations + +(define *base64-decode-table* + (let ((res (make-vector #x100 *outside-char*))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res (+ i 65) i) + (vector-set! res (+ i 97) (+ i 26)) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 48) (+ i 52)) + (lp (+ i 1))))) + ;; extras (be liberal for different common base64 formats) + (vector-set! res (char->integer #\+) 62) + (vector-set! res (char->integer #\-) 62) + (vector-set! res (char->integer #\/) 63) + (vector-set! res (char->integer #\_) 63) + (vector-set! res (char->integer #\~) 63) + (vector-set! res (char->integer #\=) *pad-char*) + res)) + +(define (base64-decode-char c) + (vector-ref *base64-decode-table* (char->integer c))) + +(define *base64-encode-table* + (let ((res (make-vector 64))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res i (integer->char (+ i 65))) + (vector-set! res (+ i 26) (integer->char (+ i 97))) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 52) (integer->char (+ i 48))) + (lp (+ i 1))))) + (vector-set! res 62 #\+) + (vector-set! res 63 #\/) + res)) + +(define (enc i) + (vector-ref *base64-encode-table* i)) + +;; try to match common boundaries +(define decode-src-length + (lcm 76 78)) + +(define decode-dst-length + (* 3 (arithmetic-shift (+ 3 decode-src-length) -2))) + +(define encode-src-length + (* 3 1024)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; decoding + +;; Create a result buffer with the maximum possible length for the +;; input, and pass it to the internal base64-decode-string! utility. +;; If the resulting length used is exact, we can return that buffer, +;; otherwise we return the appropriate substring. +(define (base64-decode-string src) + (let* ((len (string-length src)) + (dst-len (* 3 (arithmetic-shift (+ 3 len) -2))) + (dst (make-string dst-len))) + (base64-decode-string! + src 0 len dst + (lambda (src-offset res-len b1 b2 b3) + (let ((res-len (base64-decode-finish dst res-len b1 b2 b3))) + (if (= res-len dst-len) + dst + (substring dst 0 res-len))))))) + +;; This is a little funky. +;; +;; We want to skip over "outside" characters (e.g. newlines inside +;; base64-encoded data, as would be passed in mail clients and most +;; large base64 data). This would normally mean two nested loops - +;; one for overall processing the input, and one for looping until +;; we get to a valid character. However, many Scheme compilers are +;; really bad about optimizing nested loops of primitives, so we +;; flatten this into a single loop, using conditionals to determine +;; which character is currently being read. +(define (base64-decode-string! src start end dst kont) + (let lp ((i start) + (j 0) + (b1 *outside-char*) + (b2 *outside-char*) + (b3 *outside-char*)) + (if (>= i end) + (kont i j b1 b2 b3) + (let ((c (base64-decode-char (string-ref src i)))) + (cond + ((eqv? c *pad-char*) + (kont i j b1 b2 b3)) + ((eqv? c *outside-char*) + (lp (+ i 1) j b1 b2 b3)) + ((eqv? b1 *outside-char*) + (lp (+ i 1) j c b2 b3)) + ((eqv? b2 *outside-char*) + (lp (+ i 1) j b1 c b3)) + ((eqv? b3 *outside-char*) + (lp (+ i 1) j b1 b2 c)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (string-set! dst + (+ j 2) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 2 0 b3) 6) + c))) + (lp (+ i 1) (+ j 3) + *outside-char* *outside-char* *outside-char*))))))) + +;; If requested, account for any "partial" results (i.e. trailing 2 or +;; 3 chars) by writing them into the destination (additional 1 or 2 +;; bytes) and returning the adjusted offset for how much data we've +;; written. +(define (base64-decode-finish dst j b1 b2 b3) + (cond + ((eqv? b1 *outside-char*) + j) + ((eqv? b2 *outside-char*) + (string-set! dst j (integer->char (arithmetic-shift b1 2))) + (+ j 1)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (cond + ((eqv? b3 *outside-char*) + (+ j 1)) + (else + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (+ j 2)))))) + +;; General port decoder: work in single blocks at a time to avoid +;; allocating memory (crucial for Scheme implementations that don't +;; allow large strings). +(define (base64-decode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string decode-src-length)) + (dst (make-string decode-dst-length))) + (let lp ((offset 0)) + (let ((src-len (+ offset + (read-string! decode-src-length src in offset)))) + (cond + ((= src-len decode-src-length) + ;; read a full chunk: decode, write and loop + (base64-decode-string! + src 0 decode-src-length dst + (lambda (src-offset dst-len b1 b2 b3) + (cond + ((and (< src-offset src-len) + (eqv? #\= (string-ref src src-offset))) + ;; done + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))) + ((eqv? b1 *outside-char*) + (write-string dst dst-len out) + (lp 0)) + (else + (write-string dst dst-len out) + ;; one to three chars left in buffer + (string-set! src 0 (enc b1)) + (cond + ((eqv? b2 *outside-char*) + (lp 1)) + (else + (string-set! src 1 (enc b2)) + (cond + ((eqv? b3 *outside-char*) + (lp 2)) + (else + (string-set! src 2 (enc b3)) + (lp 3)))))))))) + (else + ;; end of source - just decode and write once + (base64-decode-string! + src 0 src-len dst + (lambda (src-offset dst-len b1 b2 b3) + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; encoding + +(define (base64-encode-string str) + (let* ((len (string-length str)) + (quot (quotient len 3)) + (rem (- len (* quot 3))) + (res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2)) + (res (make-string res-len))) + (base64-encode-string! str 0 len res) + res)) + +(define (base64-encode-string! str start end res) + (let* ((res-len (string-length res)) + (limit (- end 2))) + (let lp ((i start) (j 0)) + (if (>= i limit) + (case (- end i) + ((1) + (let ((b1 (char->integer (string-ref str i)))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (arithmetic-shift (bitwise-and #b11 b1) 4))) + (string-set! res (+ j 2) #\=) + (string-set! res (+ j 3) #\=))) + ((2) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (arithmetic-shift (extract-bit-field 4 0 b2) + 2))) + (string-set! res (+ j 3) #\=)))) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1)))) + (b3 (char->integer (string-ref str (+ i 2))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 2) + (extract-bit-field 2 6 b3)))) + (string-set! res (+ j 3) (enc (bitwise-and #b111111 b3))) + (lp (+ i 3) (+ j 4))))))) + +(define (base64-encode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string encode-src-length)) + (dst (make-string + (arithmetic-shift (quotient encode-src-length 3) 2)))) + (let lp () + (let ((n (read-string! 2048 src in))) + (base64-encode-string! src 0 n dst) + (write-string dst (* 3 (quotient (+ n 3) 4)) out) + (if (= n 2048) + (lp))))))) + +(define (base64-encode-header encoding str . o) + (define (round4 i) (arithmetic-shift (arithmetic-shift i -2) 2)) + (let ((start-col (if (pair? o) (car o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?B?")) + (prefix-length (+ 2 (string-length prefix))) + (effective-max-col (round4 (- max-col prefix-length))) + (first-max-col (round4 (- effective-max-col start-col))) + (str (base64-encode-string str)) + (len (string-length str))) + (if (<= len first-max-col) + (string-append prefix str "?=") + (string-append + (if (positive? first-max-col) + (string-append + prefix (substring str 0 first-max-col) "?=" nl "\t" prefix) + "") + (string-concatenate (string-chop (substring str first-max-col len) + effective-max-col) + (string-append "?=" nl "\t" prefix)) + "?="))))) + diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c new file mode 100644 index 00000000..d4a7373c --- /dev/null +++ b/lib/chibi/disasm.c @@ -0,0 +1,101 @@ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" +#include "../../opt/opcode_names.h" + +#define SEXP_DISASM_MAX_DEPTH 8 +#define SEXP_DISASM_PAD_WIDTH 4 + +static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { + sexp tmp; + unsigned char *ip, opcode, i; + + if (sexp_procedurep(bc)) { + bc = sexp_procedure_code(bc); + } else if (sexp_opcodep(bc)) { + sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); + return SEXP_VOID; + } else if (! sexp_bytecodep(bc)) { + return sexp_type_exception(ctx, self, SEXP_BYTECODE, bc); + } + if (! sexp_oportp(out)) { + return sexp_type_exception(ctx, self, SEXP_OPORT, out); + } + + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + sexp_write_string(ctx, "-------------- ", out); + if (sexp_truep(sexp_bytecode_name(bc))) { + sexp_write(ctx, sexp_bytecode_name(bc), out); + sexp_write_char(ctx, ' ', out); + } + sexp_printf(ctx, out, "%p\n", bc); + + ip = sexp_bytecode_data(bc); + + loop: + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + 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 SEXP_OP_STACK_REF: + case SEXP_OP_LOCAL_REF: + case SEXP_OP_LOCAL_SET: + case SEXP_OP_CLOSURE_REF: + case SEXP_OP_JUMP: + case SEXP_OP_JUMP_UNLESS: + case SEXP_OP_TYPEP: + case SEXP_OP_FCALL0: + case SEXP_OP_FCALL1: + case SEXP_OP_FCALL2: + case SEXP_OP_FCALL3: + case SEXP_OP_FCALL4: + case SEXP_OP_FCALL5: + case SEXP_OP_FCALL6: + sexp_printf(ctx, out, "%ld", (long) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case SEXP_OP_SLOT_REF: + case SEXP_OP_SLOT_SET: + case SEXP_OP_MAKE: + ip += sizeof(sexp)*2; + break; + case SEXP_OP_GLOBAL_REF: + case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_TAIL_CALL: + case SEXP_OP_CALL: + case SEXP_OP_PUSH: + tmp = ((sexp*)ip)[0]; + if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF)) + && sexp_pairp(tmp)) + tmp = sexp_car(tmp); + else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) + sexp_write_char(ctx, '\'', out); + sexp_write(ctx, tmp, out); + ip += sizeof(sexp); + break; + } + sexp_write_char(ctx, '\n', out); + if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) + && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) + disasm(ctx, self, tmp, out, depth+1); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +static sexp sexp_disasm (sexp ctx sexp_api_params(self, n), sexp bc, sexp out) { + return disasm(ctx, self, bc, out, 0); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "*current-output-port*"); + return SEXP_VOID; +} diff --git a/lib/chibi/disasm.module b/lib/chibi/disasm.module new file mode 100644 index 00000000..9017a4bc --- /dev/null +++ b/lib/chibi/disasm.module @@ -0,0 +1,5 @@ + +(define-module (chibi disasm) + (export disasm) + (import-immutable (scheme)) + (include-shared "disasm")) diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module new file mode 100644 index 00000000..ecd4af32 --- /dev/null +++ b/lib/chibi/filesystem.module @@ -0,0 +1,27 @@ + +(define-module (chibi filesystem) + (export open-input-file-descriptor open-output-file-descriptor + duplicate-file-descriptor duplicate-file-descriptor-to + close-file-descriptor renumber-file-descriptor + delete-file link-file symbolic-link-file rename-file + directory-files directory-fold create-directory delete-directory + file-status + file-device file-inode + file-mode file-num-links + file-owner file-group + file-represented-device file-size + file-block-size file-num-blocks + file-access-time file-modification-time file-change-time + file-regular? file-directory? file-character? + file-block? file-fifo? file-link? + file-socket? file-exists? + get-file-descriptor-flags set-file-descriptor-flags! + get-file-descriptor-status set-file-descriptor-status! + open/read open/write open/read-write + open/create open/exclusive open/truncate + open/append open/non-block + is-a-tty?) + (import-immutable (scheme)) + (include-shared "filesystem") + (include "filesystem.scm")) + diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm new file mode 100644 index 00000000..aa3fc69f --- /dev/null +++ b/lib/chibi/filesystem.scm @@ -0,0 +1,43 @@ +;; filesystem.scm -- additional filesystem utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (let lp ((res knil)) + (let ((file (readdir dir))) + (if file (lp (kons (dirent-name file) res)) res))))) + +(define (directory-files dir) + (directory-fold dir cons '())) + +(define (renumber-file-descriptor old new) + (and (duplicate-file-descriptor-to old new) + (close-file-descriptor old))) + +(define (file-status file) + (if (string? file) (stat file) (fstat file))) + +(define (file-device x) (stat-dev (if (stat? x) x (file-status x)))) +(define (file-inode x) (stat-ino (if (stat? x) x (file-status x)))) +(define (file-mode x) (stat-mode (if (stat? x) x (file-status x)))) +(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x)))) +(define (file-owner x) (stat-uid (if (stat? x) x (file-status x)))) +(define (file-group x) (stat-gid (if (stat? x) x (file-status x)))) +(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x)))) +(define (file-size x) (stat-size (if (stat? x) x (file-status x)))) +(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x)))) +(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x)))) +(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x)))) +(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x)))) +(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x)))) + +(define (file-regular? x) (S_ISREG (file-mode x))) +(define (file-directory? x) (S_ISDIR (file-mode x))) +(define (file-character? x) (S_ISCHR (file-mode x))) +(define (file-block? x) (S_ISBLK (file-mode x))) +(define (file-fifo? x) (S_ISFIFO (file-mode x))) +(define (file-link? x) (S_ISLNK (file-mode x))) +(define (file-socket? x) (S_ISSOCK (file-mode x))) + +(define (file-exists? x) (and (file-status x) #t)) diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub new file mode 100644 index 00000000..5656fcdc --- /dev/null +++ b/lib/chibi/filesystem.stub @@ -0,0 +1,118 @@ + +(c-system-include "sys/types.h") +(c-system-include "unistd.h") +(c-system-include "dirent.h") +(c-system-include "fcntl.h") + +(define-c-type DIR + finalizer: closedir) + +(define-c-struct dirent + (string d_name dirent-name)) + +(define-c-struct stat + predicate: stat? + (dev_t st_dev stat-dev) + (ino_t st_ino stat-ino) + (mode_t st_mode stat-mode) + (nlink_t st_nlink stat-nlinks) + (uid_t st_uid stat-uid) + (gid_t st_gid stat-gid) + (dev_t st_rdev stat-rdev) + (off_t st_size stat-size) + (blksize_t st_blksize stat-blksize) + (blkcnt_t st_blocks stat-blocks) + (time_t st_atime stat-atime) + (time_t st_mtime stat-mtime) + (time_t st_ctime stat-ctime)) + +(define-c boolean S_ISREG (mode_t)) +(define-c boolean S_ISDIR (mode_t)) +(define-c boolean S_ISCHR (mode_t)) +(define-c boolean S_ISBLK (mode_t)) +(define-c boolean S_ISFIFO (mode_t)) +(define-c boolean S_ISLNK (mode_t)) +(define-c boolean S_ISSOCK (mode_t)) + +;;(define-c-const int ("S_IFMT")) +(define-c-const int (file/socket "S_IFSOCK")) +(define-c-const int (file/link "S_IFLNK")) +(define-c-const int (file/regular "S_IFREG")) +(define-c-const int (file/block "S_IFBLK")) +(define-c-const int (file/directory "S_IFDIR")) +(define-c-const int (file/character "S_IFCHR")) +(define-c-const int (file/fifo "S_IFIFO")) +(define-c-const int (file/suid "S_ISUID")) +(define-c-const int (file/sgid "S_ISGID")) +(define-c-const int (file/sticky "S_ISVTX")) +;;(define-c-const int ("S_IRWXU")) +(define-c-const int (perm/user-read "S_IRUSR")) +(define-c-const int (perm/user-write "S_IWUSR")) +(define-c-const int (perm/user-execute "S_IXUSR")) +;;(define-c-const int ("S_IRWXG")) +(define-c-const int (perm/group-read "S_IRGRP")) +(define-c-const int (perm/group-write "S_IWGRP")) +(define-c-const int (perm/group-execute "S_IXGRP")) +;;(define-c-const int ("S_IRWXO")) +(define-c-const int (perm/others-read "S_IROTH")) +(define-c-const int (perm/others-write "S_IWOTH")) +(define-c-const int (perm/others-execute "S_IXOTH")) + +(define-c errno stat (string (result stat))) +(define-c errno fstat (int (result stat))) +(define-c errno (file-link-status "lstat") (string (result stat))) + +(define-c input-port (open-input-file-descriptor "fdopen") + (int (value "r" string))) +(define-c output-port (open-output-file-descriptor "fdopen") + (int (value "w" string))) + +(define-c errno (delete-file "unlink") (string)) +(define-c errno (link-file "link") (string string)) +(define-c errno (symbolic-link-file "symlink") (string string)) +(define-c errno (rename-file "rename") (string string)) + +(define-c non-null-string (current-directory "getcwd") + ((result (array char (auto-expand arg1))) (value 256 int))) + +(define-c errno (create-directory "mkdir") (string int)) +(define-c errno (delete-directory "rmdir") (string)) + +(define-c (free DIR) opendir (string)) +(define-c dirent readdir ((link DIR))) + +(define-c int (duplicate-file-descriptor "dup") (int)) +(define-c errno (duplicate-file-descriptor-to "dup2") (int int)) +(define-c errno (close-file-descriptor "close") (int)) + +(define-c errno (open-pipe "pipe") ((result (array int 2)))) +(define-c errno (make-fifo "mkfifo") (string (default #o644 int))) + +(define-c int (get-file-descriptor-flags "fcntl") + (int (value F_GETFD int))) +(define-c errno (set-file-descriptor-flags! "fcntl") + (int (value F_SETFD int) long)) + +(define-c int (get-file-descriptor-status "fcntl") + (int (value F_GETFL int))) +(define-c errno (set-file-descriptor-status! "fcntl") + (int (value F_SETFL int) long)) + +;; (define-c int (get-file-descriptor-lock "fcntl") +;; (int (value F_GETLK int) flock)) +;; (define-c errno (set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLK int) flock)) +;; (define-c errno (try-set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLKW int) flock)) + +(define-c-const int (open/read "O_RDONLY")) +(define-c-const int (open/write "O_WRONLY")) +(define-c-const int (open/read-write "O_RDWR")) +(define-c-const int (open/create "O_CREAT")) +(define-c-const int (open/exclusive "O_EXCL")) +(define-c-const int (open/truncate "O_TRUNC")) +(define-c-const int (open/append "O_APPEND")) +(define-c-const int (open/non-block "O_NONBLOCK")) + +(define-c boolean (is-a-tty? "isatty") (port-or-fd)) + diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c new file mode 100644 index 00000000..976b5b27 --- /dev/null +++ b/lib/chibi/heap-stats.c @@ -0,0 +1,129 @@ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define SEXP_HEAP_VECTOR_DEPTH 1 + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); + +#if SEXP_USE_GLOBAL_HEAP +#endif + +static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { + int i; + if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x) + || sexp_flonump(x) || sexp_bignump(x)) { + sexp_write(ctx, x, out); + } else if (depth <= 0) { + goto print_name; + } else if (sexp_synclop(x)) { + sexp_write_string(ctx, "#", out); + } else if (sexp_pairp(x)) { + sexp_write_char(ctx, '(', out); + sexp_print_simple(ctx, sexp_car(x), out, depth-1); + sexp_write_string(ctx, " . ", out); + sexp_print_simple(ctx, sexp_cdr(x), out, depth-1); + sexp_write_char(ctx, ')', out); + } else if (sexp_vectorp(x)) { + sexp_write_string(ctx, "#(", out); + for (i=0; i0) + sexp_write_char(ctx, ' ', out); + sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); + } + if (i", out); + } +} + +static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { + size_t freed; + sexp_uint_t stats[256], hi_type=0, i; + sexp_heap h = sexp_context_heap(ctx); + sexp p, out=SEXP_FALSE; + sexp_free_list q, r; + char *end; + sexp_gc_var3(res, tmp, name); + + if (printp) + out = sexp_env_global_ref(sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + SEXP_FALSE); + + /* run gc once to remove unused variables */ + sexp_gc(ctx, &freed); + + /* initialize stats */ + for (i=0; i<256; i++) stats[i]=0; + + /* loop over each heap chunk */ + for ( ; h; h=h->next) { + 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) { /* this is a free block, skip */ + p = (sexp) (((char*)p) + r->size); + continue; + } + /* otherwise maybe print, then increment the stat and continue */ + if (sexp_oportp(out)) { + sexp_print_simple(ctx, p, out, depth); + sexp_write_char(ctx, '\n', out); + } + stats[sexp_pointer_tag(p)]++; + if (sexp_pointer_tag(p) > hi_type) + hi_type = sexp_pointer_tag(p); + p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p))); + } + } + + /* build and return results */ + sexp_gc_preserve3(ctx, res, tmp, name); + res = SEXP_NULL; + for (i=hi_type; i>0; i--) + if (stats[i]) { + name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i), -1); + tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); + res = sexp_cons(ctx, tmp, res); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_heap_stats (sexp ctx sexp_api_params(self, n)) { + return sexp_heap_walk(ctx, 0, 0); +} + +static sexp sexp_heap_dump (sexp ctx sexp_api_params(self, n), sexp depth) { + if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) + return sexp_xtype_exception(ctx, self, "bad heap-dump depth", depth); + return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats); + sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE); + return SEXP_VOID; +} + diff --git a/lib/chibi/heap-stats.module b/lib/chibi/heap-stats.module new file mode 100644 index 00000000..c1599c35 --- /dev/null +++ b/lib/chibi/heap-stats.module @@ -0,0 +1,6 @@ + +(define-module (chibi heap-stats) + (export heap-stats heap-dump) + (import-immutable (scheme)) + (include-shared "heap-stats")) + diff --git a/lib/chibi/io.module b/lib/chibi/io.module new file mode 100644 index 00000000..ec765c04 --- /dev/null +++ b/lib/chibi/io.module @@ -0,0 +1,13 @@ + +(define-module (chibi io) + (export read-string read-string! write-string read-line write-line + port-fold port-fold-right port-map + port->list port->string-list port->sexp-list port->string + file-position set-file-position! seek/set seek/cur seek/end + make-custom-input-port make-custom-output-port + make-null-output-port make-broadcast-port make-concatenated-port + make-generated-input-port make-filtered-output-port + make-filtered-input-port) + (import-immutable (scheme)) + (include-shared "io/io") + (include "io/io.scm")) diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm new file mode 100644 index 00000000..2d4da555 --- /dev/null +++ b/lib/chibi/io/io.scm @@ -0,0 +1,170 @@ +;; io.scm -- various input/output utilities +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define eof + (call-with-input-string " " + (lambda (in) (read-char in) (read-char in)))) + +(define (string-copy! dst start src from to) + (do ((i from (+ i 1)) (j start (+ j 1))) + ((>= i to)) + (string-set! dst j (string-ref src i)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; reading and writing + +(define (write-line str . o) + (let ((out (if (pair? o) (car o) (current-output-port)))) + (display str out) + (newline out))) + +(define (read-line . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192))) + (let ((res (%read-line n in))) + (if (not res) + eof + (let ((len (string-length res))) + (if (and (> len 0) (eqv? #\newline (string-ref res (- len 1)))) + (if (and (> len 1) (eqv? #\return (string-ref res (- len 2)))) + (substring res 0 (- len 2)) + (substring res 0 (- len 1))) + res)))))) + +(define (read-string n . o) + (let ((in (if (pair? o) (car o) (current-input-port)))) + (let ((res (%read-string n in))) + (if (if (pair? res) (= 0 (car res)) #t) + eof + (cadr res))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; higher order port operations + +(define (port-fold kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp ((acc knil)) + (let ((x (read in))) + (if (eof-object? x) acc (lp (kons x acc))))))) + +(define (port-fold-right kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp () + (let ((x (read in))) + (if (eof-object? x) knil (kons x (lp))))))) + +(define (port-map fn . o) + (reverse (apply port-fold (lambda (x ls) (cons (fn x) ls)) '() o))) + +(define (port->list read in) + (port-map (lambda (x) x) read in)) + +(define (port->sexp-list in) + (port->list read in)) + +(define (port->string-list in) + (port->list read-line in)) + +(define (port->string in) + (string-concatenate (port->list (lambda (in) (read-string 1024 in)) in))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; custom port utilities + +(define (make-custom-input-port read . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-input-port read seek close))) + +(define (make-custom-output-port write . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-output-port write seek close))) + +(define (make-null-output-port) + (make-custom-output-port (lambda (str n) 0))) + +(define (make-broadcast-port . ports) + (make-custom-output-port + (lambda (str n) + (for-each (lambda (p) (write-string str n p)) ports) + n))) + +(define (make-filtered-output-port filter out) + (make-custom-output-port + (lambda (str n) + (let* ((len (string-length str)) + (s1 (if (= n len) str (substring str 0 n))) + (s2 (filter s1))) + (if (string? s2) + (write-string s2 (string-length s2) out)))))) + +(define (make-concatenated-port . ports) + (make-custom-input-port + (lambda (str n) + (if (null? ports) + 0 + (let lp ((i (read-string! str n (car ports)))) + (cond + ((>= i n) + i) + (else + (set! ports (cdr ports)) + (cond + ((null? ports) + i) + (else + (let* ((s (read-string (- n i) (car ports))) + (len (if (string? s) (string-length s) 0))) + (if (and (string? str) (> len 0)) + (string-copy! str i s 0 len)) + (lp (+ i len)))))))))))) + +(define (make-generated-input-port generator) + (let ((buf "") + (len 0) + (offset 0)) + (make-custom-input-port + (lambda (str n) + (cond + ((>= (- len offset) n) + (string-copy! str 0 buf offset (+ offset n)) + (set! offset (+ offset n)) + n) + (else + (string-copy! str 0 buf offset len) + (let lp ((i (- len offset))) + (set! buf (generator)) + (cond + ((not (string? buf)) + (set! buf "") + (set! len 0) + (set! offset 0) + (- n i)) + (else + (set! len (string-length buf)) + (set! offset 0) + (cond + ((>= (- len offset) (- n i)) + (string-copy! str i buf offset (+ offset (- n i))) + (set! offset (+ offset (- n i))) + n) + (else + (string-copy! str i buf offset len) + (lp (+ i (- len offset)))))))))))))) + +(define (make-filtered-input-port filter in) + (make-generated-input-port + (lambda () + (let ((res (read-string 1024 in))) + (if (string? res) (filter res) res))))) diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub new file mode 100644 index 00000000..07450dc0 --- /dev/null +++ b/lib/chibi/io/io.stub @@ -0,0 +1,27 @@ + +(define-c non-null-string (%read-line "fgets") + ((result (array char arg1)) int (default (current-input-port) input-port))) + +(define-c size_t (%read-string "fread") + ((result (array char arg2)) (value 1 size_t) size_t (default (current-input-port) input-port))) + +(define-c size_t (read-string! "fread") + (string (value 1 size_t) size_t (default (current-input-port) input-port))) + +(define-c size_t (write-string "fwrite") + (string (value 1 size_t) size_t (default (current-output-port) output-port))) + +(define-c-const int (seek/set "SEEK_SET")) +(define-c-const int (seek/cur "SEEK_CUR")) +(define-c-const int (seek/end "SEEK_END")) + +(define-c long (file-position "ftell") (port)) +(define-c long (set-file-position! "fseek") (port long int)) + +(c-include "port.c") + +(define-c sexp (%make-custom-input-port "sexp_make_custom_input_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) + +(define-c sexp (%make-custom-output-port "sexp_make_custom_output_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c new file mode 100644 index 00000000..947f3400 --- /dev/null +++ b/lib/chibi/io/port.c @@ -0,0 +1,196 @@ + +#include +#include + +#define SEXP_PORT_BUFFER_SIZE 1024 +#define SEXP_LAST_CONTEXT_CHECK_LIMIT 256 + +#define sexp_cookie_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO) +#define sexp_cookie_buffer(vec) sexp_vector_ref((sexp)vec, SEXP_ONE) +#define sexp_cookie_read(vec) sexp_vector_ref((sexp)vec, SEXP_TWO) +#define sexp_cookie_write(vec) sexp_vector_ref((sexp)vec, SEXP_THREE) +#define sexp_cookie_seek(vec) sexp_vector_ref((sexp)vec, SEXP_FOUR) +#define sexp_cookie_close(vec) sexp_vector_ref((sexp)vec, SEXP_FIVE) + +#if ! SEXP_USE_BOEHM +static int sexp_in_heap_p (sexp_heap h, sexp p) { + for ( ; h; h = h->next) + if (((sexp)h < p) && (p < (sexp)((char*)h + h->size))) + return 1; + return 0; +} +#endif + +static sexp sexp_last_context (sexp ctx, sexp *cstack) { + sexp res=SEXP_FALSE, p; +#if ! SEXP_USE_BOEHM + sexp_sint_t i; + sexp_heap h = sexp_context_heap(ctx); + for (i=0; i sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_read(vec), args); + sexp_gc_release2(ctx); + if (sexp_fixnump(res)) { + memcpy(buffer, sexp_string_data(sexp_cookie_buffer(vec)), sexp_unbox_fixnum(res)); + return sexp_unbox_fixnum(res); + } else { + return -1; + } +} + +#if SEXP_BSD +static int sexp_cookie_writer (void *cookie, const char *buffer, int size) +#else +static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size) +#endif +{ + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_write(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + if (size > sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_write(vec), args); + sexp_gc_release2(ctx); + return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1); +} + +#if ! SEXP_BSD +static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + args = sexp_make_integer(ctx, *position); + args = sexp_list2(ctx, args, sexp_make_fixnum(whence)); + res = sexp_apply(ctx, sexp_cookie_seek(vec), args); + if (sexp_fixnump(res)) + *position = sexp_unbox_fixnum(res); + sexp_gc_release2(ctx); + return sexp_fixnump(res); +} +#endif + +static int sexp_cookie_cleaner (void *cookie) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_close(vec))) return 0; + ctx = sexp_cookie_ctx(vec); + res = sexp_apply(ctx, sexp_cookie_close(vec), SEXP_NULL); + return (sexp_exceptionp(res) ? -1 : sexp_truep(res)); +} + +#if ! SEXP_BSD + +static cookie_io_functions_t sexp_cookie = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = (cookie_seek_function_t*)sexp_cookie_seeker, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +static cookie_io_functions_t sexp_cookie_no_seek = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = NULL, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +#endif + +#if SEXP_USE_STRING_STREAMS + +static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode, + sexp read, sexp write, + sexp seek, sexp close) { + FILE *in; + sexp res; + sexp_gc_var1(vec); + if (sexp_truep(read) && ! sexp_procedurep(read)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read); + if (sexp_truep(write) && ! sexp_procedurep(write)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write); + if (sexp_truep(seek) && ! sexp_procedurep(seek)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek); + if (sexp_truep(close) && ! sexp_procedurep(close)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close); + sexp_gc_preserve1(ctx, vec); + vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID); + sexp_cookie_ctx(vec) = ctx; + sexp_cookie_buffer(vec) + = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID); + sexp_cookie_read(vec) = read; + sexp_cookie_write(vec) = write; + sexp_cookie_seek(vec) = seek; + sexp_cookie_close(vec) = close; +#if SEXP_BSD + in = funopen(vec, + (sexp_procedurep(read) ? sexp_cookie_reader : NULL), + (sexp_procedurep(write) ? sexp_cookie_writer : NULL), + NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */ + (sexp_procedurep(close) ? sexp_cookie_cleaner : NULL)); +#else + in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek)); +#endif + if (! in) { + res = sexp_user_exception(ctx, self, "couldn't make custom port", read); + } else { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = vec; /* for gc preserving */ + } + sexp_gc_release1(ctx); + return res; +} + +#else + +static sexp sexp_make_custom_port (sexp ctx, sexp self, + char *mode, sexp read, sexp write, + sexp seek, sexp close) { + return sexp_user_exception(ctx, self, "custom ports not supported in this configuration", SEXP_NULL); +} + +#endif + +static sexp sexp_make_custom_input_port (sexp ctx, sexp self, + sexp read, sexp seek, sexp close) { + return sexp_make_custom_port(ctx, self, "r", read, SEXP_FALSE, seek, close); +} + +static sexp sexp_make_custom_output_port (sexp ctx, sexp self, + sexp write, sexp seek, sexp close) { + sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close); + sexp_pointer_tag(res) = SEXP_OPORT; + return res; +} diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module new file mode 100644 index 00000000..5b76daf8 --- /dev/null +++ b/lib/chibi/loop.module @@ -0,0 +1,9 @@ + +(define-module (chibi loop) + (export loop in-list in-lists in-port in-file up-from down-from + listing listing-reverse appending appending-reverse + summing multiplying in-string in-string-reverse + in-vector in-vector-reverse) + (import-immutable (scheme)) + (include "loop/loop.scm")) + diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm new file mode 100644 index 00000000..09e12856 --- /dev/null +++ b/lib/chibi/loop/loop.scm @@ -0,0 +1,365 @@ +;;;; loop.scm - the chibi loop (aka foof-loop) +;; +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; The loop API is compatible with Taylor Campbell's foof-loop, but +;; the iterator API is different and subject to change. All loop +;; variables may be implicitly destructured with MATCH semantics. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (assoc-pred equal elt ls) + (and (pair? ls) + (if (equal elt (car (car ls))) + (car ls) + (assoc-pred equal elt (cdr ls))))) + +(define-syntax let-keyword-form + (syntax-rules () + ((let-keyword-form + ((labeled-arg-macro-name (positional-name . params))) + . body) + (let-syntax + ((labeled-arg-macro-name + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (named '()) (posns '())) + (cond + ((pair? ls) + (if (and (list? (car ls)) (compare (caar ls) (rename '=>))) + (lp (cdr ls) (cons (cdar ls) named) posns) + (lp (cdr ls) named (cons (car ls) posns)))) + (else + (let lp ((ls (syntax-quote params)) + (posns (reverse posns)) + (args '())) + (cond + ((null? ls) + (if (pair? posns) + (error "let-keyword-form: too many args" expr) + (cons (syntax-quote positional-name) (reverse args)))) + ((assoc-pred compare (caar ls) named) + => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args)))) + ((pair? posns) + (lp (cdr ls) (cdr posns) (cons (car posns) args))) + (else + (lp (cdr ls) posns (cons (cadar ls) args)))))))))))) + . body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax loop + (syntax-rules () + ;; unnamed, implicit recursion + ((loop (vars ...) body ...) + (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop))) + ;; named, explicit recursion + ((loop name (vars ...) body ...) + (%loop name () () () () () (vars ...) body ...)))) + +;; Main LOOP macro. Separate the variables from the iterator and +;; parameters, then walk through each parameter expanding the +;; bindings, and build the final form. + +(define-syntax %loop + (syntax-rules (=> for with let while until) + ;; automatic iteration + ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body) + (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ;; do equivalents, with optional guards + ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body) + (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init step) rest ...) . body) + (%loop name l (vars ... (var init step)) c r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init) rest ...) . body) + (%loop name l (vars ... (var init var)) c r f (rest ...) . body)) + ;; user-specified terminators + ((_ name l vars (checks ...) r f ((until expr) rest ...) . body) + (%loop name l vars (checks ... expr) r f (rest ...) . body)) + ((_ name l vars (checks ...) r f ((while expr) rest ...) . body) + (%loop name l vars (checks ... (not expr)) r f (rest ...) . body)) + ;; specify a default done? + ((_ name l v c r f ()) + (%loop name l v c r f () (#f #f))) + ((_ name l v c r f () () . body) + (%loop name l v c r f () (#f #f) . body)) + ;; final expansion + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => result + . body) + (let* (lets ...) + (letrec ((tmp (lambda (var ...) + (if (or checks ...) + (let-keyword-form ((name (tmp (var step) ...))) + (let (finals ...) result)) + (let (refs ...) + (let-keyword-form ((name (tmp (var step) ...))) + (if #f #f) + . body)))))) + (tmp init ...)))) + ;; unspecified return value case + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + . body) + (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => (if #f #f) . body)) + )) + +(define-syntax %loop-next + (syntax-rules () + ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...) + name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...) + . rest) + (%loop name (lets ... new-lets ...) (vars ... new-vars ...) + (checks ... new-checks ...) (refs ... new-refs ...) + (finals ... new-finals ...) + . rest)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Iterators + +;; Each gets passed two lists, those items left of the <- and those to +;; the right, followed by a NEXT and REST continuation. + +;; Should finish with +;; +;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...) +;; (loop-vars ...) (final-vars ...) . rest) +;; +;; OUTER-VARS: bound once outside the loop in a LET* +;; CURSOR-VARS: DO-style bindings of the form (name init update) +;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t +;; LOOP-VARS: inner variables, updated in parallel after the cursors +;; FINAL-VARS: final variables, bound only in the => result + +(define-syntax in-list ; called just "IN" in ITER + (syntax-rules () + ((in-list ((var) source) next . rest) + (in-list ((var cursor) source) next . rest)) + ((in-list ((var cursor) source) next . rest) + (in-list ((var cursor succ) source) next . rest)) + ((in-list ((var cursor succ) (source)) next . rest) + (next () ; outer let bindings + ((cursor source succ)) ; iterator, init, step + ((not (pair? cursor))) ; finish tests for iterator vars + ;; step variables and values + ((var (car cursor)) + (succ (cdr cursor))) + () ; final result bindings + . rest)) + ((in-list ((var cursor succ) (source step)) next . rest) + (next () + ((cursor source succ)) + ((not (pair? cursor))) + ((var (car cursor)) + (succ (step cursor))) + () + . rest)))) + +;; Iterator from Taylor R. Campbell. If you know the number of lists +;; ahead of time it's much more efficient to iterate over each one +;; separately. +(define-syntax in-lists + (syntax-rules () + ((in-lists ((elts) lol) next . rest) + (in-lists ((elts pairs) lol) next . rest)) + ((in-lists ((elts pairs) lol) next . rest) + (in-lists ((elts pairs succ) lol) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol step)) next . rest) + (in-lists ((elts pairs succ) (lol step null?)) next . rest)) + ((in-lists ((elts pairs succ) (lol step done?)) next . rest) + (next () + ((pairs lol succ)) + ((let lp ((ls pairs)) ; an in-lined ANY + (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls)))))) + ((elts (map car pairs)) + (succ (map step pairs))) + () + . rest)) + )) + +(define-syntax define-in-indexed + (syntax-rules () + ((define-in-indexed in-type in-type-reverse length ref) + (begin + (define-syntax in-type + (syntax-rules () + ((in-type ls next . rest) + (%in-idx >= + 0 (length tmp) ref tmp ls next . rest)))) + (define-syntax in-type-reverse + (syntax-rules () + ((in-type-reverse ls next . rest) + (%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest)))) + )))) + +(define-in-indexed in-string in-string-reverse string-length string-ref) +(define-in-indexed in-vector in-vector-reverse vector-length vector-ref) + +;; helper for the above string and vector iterators +(define-syntax %in-idx + (syntax-rules () + ;; cmp inc start end ref + ((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest) + (%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest) + (next ((tmp-vec vec) (end to)) + ((index from (+ index step))) + ((ge index end)) + ((var (r tmp-vec index))) + () + . rest)) + )) + +(define-syntax in-port + (syntax-rules () + ((in-port ((var) source) next . rest) + (in-port ((var p) source) next . rest)) + ((in-port ((var p) ()) next . rest) + (in-port ((var p) ((current-input-port))) next . rest)) + ((in-port ((var p) (port)) next . rest) + (in-port ((var p) (port read-char)) next . rest)) + ((in-port ((var p) (port read-char)) next . rest) + (in-port ((var p) (port read-char eof-object?)) next . rest)) + ((in-port ((var p) (port reader eof?)) next . rest) + (next ((p port) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + () + . rest)))) + +(define-syntax in-file + (syntax-rules () + ((in-file ((var) source) next . rest) + (in-file ((var p) source) next . rest)) + ((in-file ((var p) (file)) next . rest) + (in-file ((var p) (file read-char)) next . rest)) + ((in-file ((var p) (file reader)) next . rest) + (in-file ((var p) (file reader eof-object?)) next . rest)) + ((in-file ((var p) (file reader eof?)) next . rest) + (next ((p (open-input-file file)) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + ((dummy (close-input-port p))) + . rest)))) + +(define-syntax up-from + (syntax-rules (to by) + ((up-from (() . args) next . rest) + (up-from ((var) . args) next . rest)) + ((up-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var s (+ var e))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var s (+ var 1))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var s (+ var e))) () () () . rest)) + ((up-from ((var) (start)) next . rest) + (next ((s start)) ((var s (+ var 1))) () () () . rest)) + )) + +(define-syntax down-from + (syntax-rules (to by) + ((down-from (() . args) next . rest) + (down-from ((var) . args) next . rest)) + ((down-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var (- s e) (- var e))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var (- s 1) (- var 1))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var (- s e) (- var e))) () () () + . rest)) + ((down-from ((var) (start)) next . rest) + (next ((s start)) ((var (- s 1) (- var 1))) () () () + . rest)) + )) + +(define-syntax accumulating + (syntax-rules (initial if) + ((accumulating (kons final init) ((var) . x) next . rest) + (accumulating (kons final init) ((var cursor) . x) next . rest)) + ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest) + (accumulating (kons final i) ((var cursor) x) n . rest)) + ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (if check (tmp-kons expr cursor) cursor))) + () + () + ((var (final cursor))) + . rest)) + ((accumulating (kons final init) ((var cursor) (expr)) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (tmp-kons expr cursor))) + () + () + ((var (final cursor))) + . rest)))) + +(define-syntax listing + (syntax-rules () + ((listing args next . rest) + (accumulating (cons reverse '()) args next . rest)))) + +(define-syntax listing-reverse + (syntax-rules () + ((listing-reverse args next . rest) + (accumulating (cons (lambda (x) x) '()) args next . rest)))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define-syntax appending + (syntax-rules () + ((appending args next . rest) + (accumulating (append-reverse reverse '()) args next . rest)))) + +(define-syntax appending-reverse + (syntax-rules () + ((appending-reverse args next . rest) + (accumulating (append-reverse (lambda (x) x) '()) args next . rest)))) + +(define-syntax summing + (syntax-rules () + ((summing args next . rest) + (accumulating (+ (lambda (x) x) 0) args next . rest)))) + +(define-syntax multiplying + (syntax-rules () + ((multiplying args next . rest) + (accumulating (* (lambda (x) x) 1) args next . rest)))) diff --git a/lib/chibi/macroexpand.module b/lib/chibi/macroexpand.module new file mode 100644 index 00000000..47b0e7d4 --- /dev/null +++ b/lib/chibi/macroexpand.module @@ -0,0 +1,6 @@ + +(define-module (chibi macroexpand) + (import-immutable (scheme)) + (import (chibi ast)) + (export macroexpand) + (include "macroexpand.scm")) diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm new file mode 100644 index 00000000..a040855a --- /dev/null +++ b/lib/chibi/macroexpand.scm @@ -0,0 +1,85 @@ +;; macroexpand.scm -- macro expansion utility +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; This actually analyzes the expression then reverse-engineers an +;; sexp from the result, generating a minimal amount of renames. + +(define (macroexpand x) + (ast->sexp (analyze x))) + +(define (ast-renames ast) + (define i 0) + (define renames '()) + (define (rename-symbol id) + (set! i (+ i 1)) + (string->symbol + (string-append (symbol->string (identifier->symbol id)) + "." (number->string i)))) + (define (rename-lambda lam) + (or (assq lam renames) + (let ((res (list lam))) + (set! renames (cons res renames)) + res))) + (define (rename! id lam) + (let ((cell (rename-lambda lam))) + (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell))))) + (define (check-ref id lam env) + (let ((sym (identifier->symbol id))) + (let lp1 ((ls env)) + (cond + ((pair? ls) + (let lp2 ((ls2 (car ls)) (found? #f)) + (cond + ((null? ls2) + (if (not found?) (lp1 (cdr ls)))) + ((and (eq? id (caar ls2)) (eq? lam (cdar ls2))) + (lp2 (cdr ls2) #t)) + ((eq? sym (identifier->symbol (caar ls2))) + (rename! (caar ls2) (cdar ls2)) + (lp2 (cdr ls2) found?)) + (else + (lp2 (cdr ls2) found?))))))))) + (define (flatten-dot x) + (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) + ((null? x) x) + (else (list x)))) + (define (extend-env lam env) + (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env)) + (let lp ((x ast) (env '())) + (cond + ((lambda? x) (lp (lambda-body x) (extend-env x env))) + ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env)) + ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env)) + ((set? x) (lp (set-var x) env) (lp (set-value x) env)) + ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x))) + ((pair? x) (for-each (lambda (x) (lp x env)) x)))) + renames) + +(define (get-rename id lam renames) + (let ((ls (assq lam renames))) + (if (not ls) + (identifier->symbol id) + (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id)))))) + +(define (ast->sexp ast) + (let ((renames (ast-renames ast))) + (let a2s ((x ast)) + (cond + ((lambda? x) + `(lambda ,(map (lambda (id) (get-rename id x renames)) (lambda-params x)) + ,@(map (lambda (d) `(define ,(identifier->symbol (cadr d)) #f)) (lambda-defs x)) + ,@(if (seq? (lambda-body x)) + (map a2s (seq-ls (lambda-body x))) + (list (a2s (lambda-body x)))))) + ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) + ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) + ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) + ((seq? x) `(begin ,@(map a2s (seq-ls x)))) + ((lit? x) + (let ((v (lit-value x))) + (if (or (pair? v) (null? v) (symbol? v)) `',v v))) + ((pair? x) (cons (a2s (car x)) (a2s (cdr x)))) + ((opcode? x) (or (opcode-name x) x)) + (else x))))) + diff --git a/lib/chibi/match.module b/lib/chibi/match.module new file mode 100644 index 00000000..1366176a --- /dev/null +++ b/lib/chibi/match.module @@ -0,0 +1,6 @@ + +(define-module (chibi match) + (export match match-lambda match-lambda* match-let match-letrec match-let*) + (import-immutable (scheme)) + (include "match/match.scm")) + diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm new file mode 100644 index 00000000..963b89ff --- /dev/null +++ b/lib/chibi/match/match.scm @@ -0,0 +1,670 @@ +;;;; match.scm -- portable hygienic pattern matcher +;; +;; This code is written by Alex Shinn and placed in the +;; Public Domain. All warranties are disclaimed. + +;; This is a full superset of the popular MATCH package by Andrew +;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks +;; in R6RS SYNTAX-RULES), and thus preserving hygiene. + +;; This is a simple generative pattern matcher - each pattern is +;; expanded into the required tests, calling a failure continuation if +;; the tests fail. This makes the logic easy to follow and extend, +;; but produces sub-optimal code in cases where you have many similar +;; clauses due to repeating the same tests. Nonetheless a smart +;; compiler should be able to remove the redundant tests. For +;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance +;; hit. + +;; The original version was written on 2006/11/29 and described in the +;; following Usenet post: +;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd +;; and is still available at +;; http://synthcode.com/scheme/match-simple.scm +;; It's just 80 lines for the core MATCH, and an extra 40 lines for +;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar. +;; +;; A variant of this file which uses COND-EXPAND in a few places for +;; performance can be found at +;; http://synthcode.com/scheme/match-cond-expand.scm +;; +;; 2009/11/25 - adding `***' tree search patterns +;; 2008/03/20 - fixing bug where (a ...) matched non-lists +;; 2008/03/15 - removing redundant check in vector patterns +;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) +;; 2007/09/04 - fixing quasiquote patterns +;; 2007/07/21 - allowing ellipse patterns in non-final list positions +;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse +;; (thanks to Taylor Campbell) +;; 2007/04/08 - clean up, commenting +;; 2006/12/24 - bugfixes +;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; force compile-time syntax errors with useful messages + +(define-syntax match-syntax-error + (syntax-rules () + ((_) (match-syntax-error "invalid match-syntax-error usage")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The basic interface. MATCH just performs some basic syntax +;; validation, binds the match expression to a temporary variable `v', +;; and passes it on to MATCH-NEXT. It's a constant throughout the +;; code below that the binding `v' is a direct variable reference, not +;; an expression. + +(define-syntax match + (syntax-rules () + ((match) + (match-syntax-error "missing match expression")) + ((match atom) + (match-syntax-error "no match clauses")) + ((match (app ...) (pat . body) ...) + (let ((v (app ...))) + (match-next v ((app ...) (set! (app ...))) (pat . body) ...))) + ((match #(vec ...) (pat . body) ...) + (let ((v #(vec ...))) + (match-next v (v (set! v)) (pat . body) ...))) + ((match atom (pat . body) ...) + (match-next atom (atom (set! atom)) (pat . body) ...)) + )) + +;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure +;; thunk, which is expanded by recursing MATCH-NEXT on the remaining +;; clauses. `g+s' is a list of two elements, the get! and set! +;; expressions respectively. + +(define-syntax match-next + (syntax-rules (=>) + ;; no more clauses, the match failed + ((match-next v g+s) + (error 'match "no matching pattern")) + ;; named failure continuation + ((match-next v g+s (pat (=> failure) . body) . rest) + (let ((failure (lambda () (match-next v g+s . rest)))) + ;; match-one analyzes the pattern for us + (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ()))) + ;; anonymous failure continuation, give it a dummy name + ((match-next v g+s (pat . body) . rest) + (match-next v g+s (pat (=> failure) . body) . rest)))) + +;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to +;; MATCH-TWO. + +(define-syntax match-one + (syntax-rules () + ;; If it's a list of two or more values, check to see if the + ;; second one is an ellipse and handle accordingly, otherwise go + ;; to MATCH-TWO. + ((match-one v (p q . r) g+s sk fk i) + (match-check-ellipse + q + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()) + (match-two v (p q . r) g+s sk fk i))) + ;; Go directly to MATCH-TWO. + ((match-one . x) + (match-two . x)))) + +;; This is the guts of the pattern matcher. We are passed a lot of +;; information in the form: +;; +;; (match-two var pattern getter setter success-k fail-k (ids ...)) +;; +;; usually abbreviated +;; +;; (match-two v p g+s sk fk i) +;; +;; where VAR is the symbol name of the current variable we are +;; matching, PATTERN is the current pattern, getter and setter are the +;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding +;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure +;; continuation (which is just a thunk call and is thus safe to expand +;; multiple times) and IDS are the list of identifiers bound in the +;; pattern so far. + +(define-syntax match-two + (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!) + ((match-two v () g+s (sk ...) fk i) + (if (null? v) (sk ... i) fk)) + ((match-two v (quote p) g+s (sk ...) fk i) + (if (equal? v 'p) (sk ... i) fk)) + ((match-two v (quasiquote p) . x) + (match-quasiquote v p . x)) + ((match-two v (and) g+s (sk ...) fk i) (sk ... i)) + ((match-two v (and p q ...) g+s sk fk i) + (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i)) + ((match-two v (or) g+s sk fk i) fk) + ((match-two v (or p) . x) + (match-one v p . x)) + ((match-two v (or p ...) g+s sk fk i) + (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ())) + ((match-two v (not p) g+s (sk ...) fk i) + (match-one v p g+s (match-drop-ids fk) (sk ... i) i)) + ((match-two v (get! getter) (g s) (sk ...) fk i) + (let ((getter (lambda () g))) (sk ... i))) + ((match-two v (set! setter) (g (s ...)) (sk ...) fk i) + (let ((setter (lambda (x) (s ... x)))) (sk ... i))) + ((match-two v (? pred . p) g+s sk fk i) + (if (pred v) (match-one v (and . p) g+s sk fk i) fk)) + ((match-two v (= proc p) . x) + (let ((w (proc v))) (match-one w p . x))) + ((match-two v (p ___ . r) g+s sk fk i) + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())) + ((match-two v (p) g+s sk fk i) + (if (and (pair? v) (null? (cdr v))) + (let ((w (car v))) + (match-one w p ((car v) (set-car! v)) sk fk i)) + fk)) + ((match-two v (p *** q) g+s sk fk i) + (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) + ((match-two v (p *** . q) g+s sk fk i) + (match-syntax-error "invalid use of ***" (p *** . q))) + ((match-two v (p . q) g+s sk fk i) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-one w p ((car v) (set-car! v)) + (match-one x q ((cdr v) (set-cdr! v)) sk fk) + fk + i)) + fk)) + ((match-two v #(p ...) g+s . x) + (match-vector v 0 () (p ...) . x)) + ((match-two v _ g+s (sk ...) fk i) (sk ... i)) + ;; Not a pair or vector or special literal, test to see if it's a + ;; new symbol, in which case we just bind it, or if it's an + ;; already bound symbol or some other literal, in which case we + ;; compare it with EQUAL?. + ((match-two v x g+s (sk ...) fk (id ...)) + (let-syntax + ((new-sym? + (syntax-rules (id ...) + ((new-sym? x sk2 fk2) sk2) + ((new-sym? y sk2 fk2) fk2)))) + (new-sym? random-sym-to-match + (let ((x v)) (sk ... (id ... x))) + (if (equal? v x) (sk ... (id ...)) fk)))) + )) + +;; QUASIQUOTE patterns + +(define-syntax match-quasiquote + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ v (unquote p) g+s sk fk i) + (match-one v p g+s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g+s sk fk i) + (if (pair? v) + (match-one v + (p . tmp) + (match-quasiquote tmp rest g+s sk fk) + fk + i) + fk)) + ((_ v (quasiquote p) g+s sk fk i . depth) + (match-quasiquote v p g+s sk fk i #f . depth)) + ((_ v (unquote p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (unquote-splicing p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (p . q) g+s sk fk i . depth) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-quasiquote + w p g+s + (match-quasiquote-step x q g+s sk fk depth) + fk i . depth)) + fk)) + ((_ v #(elt ...) g+s sk fk i . depth) + (if (vector? v) + (let ((ls (vector->list v))) + (match-quasiquote ls (elt ...) g+s sk fk i . depth)) + fk)) + ((_ v x g+s sk fk i . depth) + (match-one v 'x g+s sk fk i)))) + +(define-syntax match-quasiquote-step + (syntax-rules () + ((match-quasiquote-step x q g+s sk fk depth i) + (match-quasiquote x q g+s sk fk i . depth)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities + +;; Takes two values and just expands into the first. +(define-syntax match-drop-ids + (syntax-rules () + ((_ expr ids ...) expr))) + +(define-syntax match-drop-first-arg + (syntax-rules () + ((_ arg expr) expr))) + +;; To expand an OR group we try each clause in succession, passing the +;; first that succeeds to the success continuation. On failure for +;; any clause, we just try the next clause, finally resorting to the +;; failure continuation fk if all clauses fail. The only trick is +;; that we want to unify the identifiers, so that the success +;; continuation can refer to a variable from any of the OR clauses. + +(define-syntax match-gen-or + (syntax-rules () + ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...)) + (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) + (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...)))))) + +(define-syntax match-gen-or-step + (syntax-rules () + ((_ v () g+s sk fk . x) + ;; no OR clauses, call the failure continuation + fk) + ((_ v (p) . x) + ;; last (or only) OR clause, just expand normally + (match-one v p . x)) + ((_ v (p . q) g+s sk fk i) + ;; match one and try the remaining on failure + (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) + )) + +;; We match a pattern (p ...) by matching the pattern p in a loop on +;; each element of the variable, accumulating the bound ids into lists. + +;; Look at the body of the simple case - it's just a named let loop, +;; matching each element in turn to the same pattern. The only trick +;; is that we want to keep track of the lists of each extracted id, so +;; when the loop recurses we cons the ids onto their respective list +;; variables, and on success we bind the ids (what the user input and +;; expects to see in the success body) to the reversed accumulated +;; list IDs. + +(define-syntax match-gen-ellipses + (syntax-rules () + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to (p ...), just bind the list + (let ((p v)) + (if (list? p) + (sk ... i) + fk)) + ;; simple case, match all elements of the list + (let loop ((ls v) (id-ls '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) + fk i))) + (else + fk))))) + ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking + (match-verify-no-ellipses + r + (let* ((tail-len (length 'r)) + (ls v) + (len (length ls))) + (if (< len tail-len) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond + ((= n tail-len) + (let ((id (reverse id-ls)) ...) + (match-one ls r (#f #f) (sk ... i) fk i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids + (loop (cdr ls) (- n 1) (cons id id-ls) ...)) + fk + i))) + (else + fk))))))))) + +;; This is just a safety check. Although unlike syntax-rules we allow +;; trailing patterns after an ellipses, we explicitly disable multiple +;; ellipses at the same level. This is because in the general case +;; such patterns are exponential in the number of ellipses, and we +;; don't want to make it easy to construct very expensive operations +;; with simple looking patterns. For example, it would be O(n^2) for +;; patterns like (a ... b ...) because we must consider every trailing +;; element for every possible break for the leading "a ...". + +(define-syntax match-verify-no-ellipses + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipse + x + (match-syntax-error + "multiple ellipse patterns not allowed at same level") + (match-verify-no-ellipses y sk))) + ((_ () sk) + sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipse" x)))) + +;; Matching a tree search pattern is only slightly more complicated. +;; Here we allow patterns of the form +;; +;; (x *** y) +;; +;; to represent the pattern y located somewhere in a tree where the +;; path from the current object to y can be seen as a list of the form +;; (X ...). Y can immediately match the current object in which case +;; the path is the empty list. In a sense it's a 2-dimensional +;; version of the ... pattern. +;; +;; As a common case the pattern (_ *** y) can be used to search for Y +;; anywhere in a tree, regardless of the path used. +;; +;; To implement the search, we use two recursive procedures. TRY +;; attempts to match Y once, and on success it calls the normal SK on +;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we +;; call NEXT which first checks if the current value is a list +;; beginning with X, then calls TRY on each remaining element of the +;; list. Since TRY will recursively call NEXT again on failure, this +;; effects a full depth-first search. +;; +;; The failure continuation throughout is a jump to the next step in +;; the tree search, initialized with the original failure continuation +;; FK. + +(define-syntax match-gen-search + (syntax-rules () + ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) + (letrec ((try (lambda (w fail id-ls ...) + (match-one w q g+s + (match-drop-ids + (let ((id (reverse id-ls)) ...) + sk)) + (next w fail id-ls ...) i))) + (next (lambda (w fail id-ls ...) + (if (not (pair? w)) + (fail) + (let ((u (car w))) + (match-one + u p ((car w) (set-car! w)) + (match-drop-ids + ;; accumulate the head variables from + ;; the p pattern, and loop over the tail + (let ((id-ls (cons id id-ls)) ...) + (let lp ((ls (cdr w))) + (if (pair? ls) + (try (car ls) + (lambda () (lp (cdr ls))) + id-ls ...) + (fail))))) + (fail) i)))))) + ;; the initial id-ls binding here is a dummy to get the right + ;; number of '()s + (let ((id-ls '()) ...) + (try v (lambda () fk) id-ls ...)))))) + +;; Vector patterns are just more of the same, with the slight +;; exception that we pass around the current vector index being +;; matched. + +(define-syntax match-vector + (syntax-rules (___) + ((_ v n pats (p q) . x) + (match-check-ellipse q + (match-gen-vector-ellipses v n pats p . x) + (match-vector-two v n pats (p q) . x))) + ((_ v n pats (p ___) sk fk i) + (match-gen-vector-ellipses v n pats p sk fk i)) + ((_ . x) + (match-vector-two . x)))) + +;; Check the exact vector length, then check each element in turn. + +(define-syntax match-vector-two + (syntax-rules () + ((_ v n ((pat index) ...) () sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (= len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) . x) + (match-vector v (+ n 1) (pats ... (p n)) q . x)))) + +(define-syntax match-vector-step + (syntax-rules () + ((_ v () (sk ...) fk i) (sk ... i)) + ((_ v ((pat index) . rest) sk fk i) + (let ((w (vector-ref v index))) + (match-one w pat ((vector-ref v index) (vector-set! v index)) + (match-vector-step v rest sk fk) + fk i))))) + +;; With a vector ellipse pattern we first check to see if the vector +;; length is at least the required length. + +(define-syntax match-gen-vector-ellipses + (syntax-rules () + ((_ v n ((pat index) ...) p sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (>= len n) + (match-vector-step v ((pat index) ...) + (match-vector-tail v p n len sk fk) + fk i) + fk)) + fk)))) + +(define-syntax match-vector-tail + (syntax-rules () + ((_ v p n len sk fk i) + (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())))) + +(define-syntax match-vector-tail-two + (syntax-rules () + ((_ v p n len (sk ...) fk i ((id id-ls) ...)) + (let loop ((j n) (id-ls '()) ...) + (if (>= j len) + (let ((id (reverse id-ls)) ...) (sk ... i)) + (let ((w (vector-ref v j))) + (match-one w p ((vector-ref v j) (vetor-set! v j)) + (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) + fk i))))))) + +;; Extract all identifiers in a pattern. A little more complicated +;; than just looking for symbols, we need to ignore special keywords +;; and non-pattern forms (such as the predicate expression in ? +;; patterns), and also ignore previously bound identifiers. +;; +;; Calls the continuation with all new vars as a list of the form +;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely +;; pair with the original variable (e.g. it's used in the ellipse +;; generation for list variables). +;; +;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) + +(define-syntax match-extract-vars + (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!) + ((match-extract-vars (? pred . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars ($ rec . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (= proc p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (quote x) (k ...) i v) + (k ... v)) + ((match-extract-vars (quasiquote x) k i v) + (match-extract-quasiquote-vars x k i v (#t))) + ((match-extract-vars (and . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (or . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (not . p) . x) + (match-extract-vars p . x)) + ;; A non-keyword pair, expand the CAR with a continuation to + ;; expand the CDR. + ((match-extract-vars (p q . r) k i v) + (match-check-ellipse + q + (match-extract-vars (p . r) k i v) + (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) + ((match-extract-vars (p . q) k i v) + (match-extract-vars p (match-extract-vars-step q k i v) i ())) + ((match-extract-vars #(p ...) . x) + (match-extract-vars (p ...) . x)) + ((match-extract-vars _ (k ...) i v) (k ... v)) + ((match-extract-vars ___ (k ...) i v) (k ... v)) + ((match-extract-vars *** (k ...) i v) (k ... v)) + ;; This is the main part, the only place where we might add a new + ;; var if it's an unbound symbol. + ((match-extract-vars p (k ...) (i ...) v) + (let-syntax + ((new-sym? + (syntax-rules (i ...) + ((new-sym? p sk fk) sk) + ((new-sym? x sk fk) fk)))) + (new-sym? random-sym-to-match + (k ... ((p p-ls) . v)) + (k ... v)))) + )) + +;; Stepper used in the above so it can expand the CAR and CDR +;; separately. + +(define-syntax match-extract-vars-step + (syntax-rules () + ((_ p k i v ((v2 v2-ls) ...)) + (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) + )) + +(define-syntax match-extract-quasiquote-vars + (syntax-rules (quasiquote unquote unquote-splicing) + ((match-extract-quasiquote-vars (quasiquote x) k i v d) + (match-extract-quasiquote-vars x k i v (#t . d))) + ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) + (match-extract-quasiquote-vars (unquote x) k i v d)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t)) + (match-extract-vars x k i v)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) + (match-extract-quasiquote-vars x k i v d)) + ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) + (match-extract-quasiquote-vars + x + (match-extract-quasiquote-vars-step y k i v d) i ())) + ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) + (match-extract-quasiquote-vars (x ...) k i v d)) + ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) + (k ... v)) + )) + +(define-syntax match-extract-quasiquote-vars-step + (syntax-rules () + ((_ x k i v d ((v2 v2-ls) ...)) + (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d)) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gimme some sugar baby. + +(define-syntax match-lambda + (syntax-rules () + ((_ clause ...) (lambda (expr) (match expr clause ...))))) + +(define-syntax match-lambda* + (syntax-rules () + ((_ clause ...) (lambda expr (match expr clause ...))))) + +(define-syntax match-let + (syntax-rules () + ((_ (vars ...) . body) + (match-let/helper let () () (vars ...) . body)) + ((_ loop . rest) + (match-named-let loop () . rest)))) + +(define-syntax match-letrec + (syntax-rules () + ((_ vars . body) (match-let/helper letrec () () vars . body)))) + +(define-syntax match-let/helper + (syntax-rules () + ((_ let ((var expr) ...) () () . body) + (let ((var expr) ...) . body)) + ((_ let ((var expr) ...) ((pat tmp) ...) () . body) + (let ((var expr) ...) + (match-let* ((pat tmp) ...) + . body))) + ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((a expr) . rest) . body) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)))) + +(define-syntax match-named-let + (syntax-rules () + ((_ loop ((pat expr var) ...) () . body) + (let loop ((var expr) ...) + (match-let ((pat var) ...) + . body))) + ((_ loop (v ...) ((pat expr) . rest) . body) + (match-named-let loop (v ... (pat expr tmp)) rest . body)))) + +(define-syntax match-let* + (syntax-rules () + ((_ () . body) + (begin . body)) + ((_ ((pat expr) . rest) . body) + (match expr (pat (match-let* rest . body)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Otherwise COND-EXPANDed bits. + +;; This *should* work, but doesn't :( +;; (define-syntax match-check-ellipse +;; (syntax-rules (...) +;; ((_ ... sk fk) sk) +;; ((_ x sk fk) fk))) + +;; This is a little more complicated, and introduces a new let-syntax, +;; but should work portably in any R[56]RS Scheme. Taylor Campbell +;; originally came up with the idea. +(define-syntax match-check-ellipse + (syntax-rules () + ;; these two aren't necessary but provide fast-case failures + ((match-check-ellipse (a . b) success-k failure-k) failure-k) + ((match-check-ellipse #(a ...) success-k failure-k) failure-k) + ;; matching an atom + ((match-check-ellipse id success-k failure-k) + (let-syntax ((ellipse? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipse? (foo id) sk fk) sk) + ((ellipse? other sk fk) fk)))) + ;; this list of three elements will only many the (foo id) list + ;; above if `id' is `...' + (ellipse? (a b c) success-k failure-k))))) + + +;; This is portable but can be more efficient with non-portable +;; extensions. This trick was originally discovered by Oleg Kiselyov. + +(define-syntax match-check-identifier + (syntax-rules () + ;; fast-case failures, lists and vectors are not identifiers + ((_ (x . y) success-k failure-k) failure-k) + ((_ #(x ...) success-k failure-k) failure-k) + ;; x is an atom + ((_ x success-k failure-k) + (let-syntax + ((sym? + (syntax-rules () + ;; if the symbol `abracadabra' matches x, then x is a + ;; symbol + ((sym? x sk fk) sk) + ;; otherwise x is a non-symbol datum + ((sym? y sk fk) fk)))) + (sym? abracadabra success-k failure-k))))) diff --git a/lib/chibi/mime.module b/lib/chibi/mime.module new file mode 100644 index 00000000..2c10dbd1 --- /dev/null +++ b/lib/chibi/mime.module @@ -0,0 +1,7 @@ + +(define-module (chibi mime) + (export mime-ref assoc-ref mime-header-fold mime-headers->list + mime-parse-content-type mime-decode-header + mime-message-fold mime-message->sxml) + (import-immutable (scheme) (chibi base64) (chibi quoted-printable) (chibi io)) + (include "mime.scm")) diff --git a/lib/chibi/mime.scm b/lib/chibi/mime.scm new file mode 100644 index 00000000..e712d7fa --- /dev/null +++ b/lib/chibi/mime.scm @@ -0,0 +1,410 @@ +;; mime.scm -- RFC2045 MIME library +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2822 headers + +;; Procedure: mime-header-fold kons knil [source [limit [kons-from]]] +;; +;; Performs a fold operation on the MIME headers of source which can be +;; either a string or port, and defaults to current-input-port. kons +;; is called on the three values: +;; kons header value accumulator +;; where accumulator begins with knil. Neither the header nor the +;; value are modified, except wrapped lines are handled for the value. +;; +;; The optional procedure KONS-FROM is a procedure to be called when +;; the first line of the headers is an "From
" line, to +;; enable this procedure to be used as-is on mbox files and the like. +;; It defaults to KONS, and if such a line is found the fold will begin +;; with (KONS-FROM "%from"
(KONS-FROM "%date" KNIL)). +;; +;; The optional LIMIT gives a limit on the number of headers to read. + +;; Procedure: mime-headers->list [source] +;; Return an alist of the MIME headers from source with headers all +;; downcased. + +;; Procedure: mime-parse-content-type str +;; Parses STR as a Content-Type style-value returning the list +;; (type (attr . val) ...) +;; For example: +;; (mime-parse-content-type +;; "text/html; CHARSET=US-ASCII; filename=index.html") +;; => ("text/html" ("charset" . "US-ASCII") ("filename" . "index.html")) + +;; Procedure: mime-decode-header str +;; Replace all occurrences of RFC1522 =?ENC?...?= escapes in STR with +;; the appropriate decoded and charset converted value. + +;; Procedure: mime-ref headers str [default] +;; A case-insensitive assoc-ref. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2045 MIME encoding + +;; Procedure: mime-message-fold src headers kons knil +;; Performs a fold operation on the given string or port SRC as a MIME +;; body corresponding to the headers give in HEADERS. KONS is called +;; on the successive values: +;; +;; KONS part-headers part-body accumulator +;; +;; where part-headers are the headers for the given MIME part (the +;; original headers for single-part MIME), part-body is the +;; appropriately decoded and charset-converted body of the message, +;; and the accumulator begins with KNIL. +;; +;; TODO: Extend mime-message-fold to (optionally?) pass KONS an +;; input-port instead of string for the body to handle very large bodies +;; (this is not much of an issue for SMTP since the messages are in +;; practice limited, but it could be problematic for large HTTP bodies). +;; +;; This does a depth-first search, folding in sequence. It should +;; probably be doing a tree-fold as in html-parser. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define mime-line-length-limit 4096) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; association lists + +(define (assoc* key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (cond + ((null? ls) #f) + ((eq key (caar ls)) (car ls)) + (else (lp (cdr ls))))))) + +(define (assoc-ref ls key . o) + (let ((default (and (pair? o) (car o))) + (eq (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) equal?))) + (cond ((assoc* key ls eq) => cdr) + (else default)))) + +(define (mime-ref ls key . o) + (assoc-ref ls key (and (pair? o) (car o)) string-ci=?)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; simple matching instead of regexps + +(define (match-mbox-from-line line) + (let ((len (string-length line))) + (and (> len 5) + (string=? (substring line 0 5) "From ") + (let lp ((i 6)) + (cond + ((= i len) (list (substring line 5 len) "")) + ((memq (string-ref line i) '(#\space #\tab)) + (list (substring line 5 i) (substring line (+ i 1) len))) + (else (lp (+ i 1)))))))) + +(define (string-scan-colon-or-maybe-equal str) + (let ((len (string-length str))) + (let lp ((i 0) (best #f)) + (if (= i len) + best + (let ((c (string-ref str i))) + (cond ((or (char-alphabetic? c) + (char-numeric? c) + (memv c '(#\- #\_))) + (lp (+ i 1) best)) + ((eq? c #\:) + (if (= i 0) #f i)) + ((eqv? c #\=) + (lp (+ i 1) (or best i))) + (else + best))))))) + +(define (string-skip-white-space str i) + (let ((lim (string-length str))) + (let lp ((i i)) + (cond ((>= i lim) lim) + ((char-whitespace? (string-ref str i)) (lp (+ i 1))) + (else i))))) + +(define (match-mime-header-line line) + (let ((i (string-scan-colon-or-maybe-equal line))) + (and i + (let ((j (string-skip-white-space line (+ i 1)))) + (list (substring line 0 i) + (substring line j (string-length line))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dummy encoder + +(define (ces-convert str . x) + str) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; some srfi-13 & string utils + +(define (string-copy! to tstart from . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length from)))) + (let lp ((i start) (j tstart)) + (cond + ((< i end) + (string-set! to j (string-ref from i)) + (lp (+ i 1) (+ j 1))))))) + +(define (string-concatenate-reverse ls) + (let lp ((ls ls) (rev '()) (len 0)) + (if (null? ls) + (let ((res (make-string len))) + (let lp ((ls rev) (i 0)) + (cond + ((null? ls) + res) + (else + (string-copy! res i (car ls)) + (lp (cdr ls) (+ i (string-length (car ls)))))))) + (lp (cdr ls) (cons (car ls) rev) (+ len (string-length (car ls))))))) + +(define (string-downcase s . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length s)))) + (let* ((len (- end start)) (s2 (make-string len))) + (let lp ((i start) (j 0)) + (cond + ((>= i end) + s2) + (else + (string-set! s2 j (char-downcase (string-ref s i))) + (lp (+ i 1) (+ j 1)))))))) + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-trim-white-space s) + (let ((len (string-length s))) + (let lp ((i 0)) + (cond ((= i len) "") + ((char-whitespace? (string-ref s i)) (lp (+ i 1))) + (else + (let lp ((j (- len 1))) + (cond ((<= j i) "") + ((char-whitespace? (string-ref s j)) (lp (- j 1))) + (else (substring s i (+ j 1)))))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; header parsing + +(define (mime-header-fold kons knil . o) + (let ((src (and (pair? o) (car o))) + (limit (and (pair? o) (pair? (cdr o)) (car (cdr o)))) + (kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (caddr o) kons))) + ((if (string? src) mime-header-fold-string mime-header-fold-port) + kons knil (or src (current-input-port)) limit kons-from))) + +(define (mime-header-fold-string kons knil str limit kons-from) + (call-with-input-string str + (lambda (in) (mime-header-fold-port kons knil in limit kons-from)))) + +(define (mime-header-fold-port kons knil port limit kons-from) + (define (out line acc count) + (cond + ((or (and limit (> count limit)) (eof-object? line) (string=? line "")) + acc) + ((match-mime-header-line line) + => (lambda (m) (in (car m) (list (cadr m)) acc (+ count 1)))) + (else + ;;(warn "invalid header line: ~S\n" line) + (out (read-line port mime-line-length-limit) acc (+ count 1))))) + (define (in header value acc count) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((and limit (> count limit)) + acc) + ((or (eof-object? line) (string=? line "")) + (kons header (string-concatenate-reverse value) acc)) + ((char-whitespace? (string-ref line 0)) + (in header (cons line value) acc (+ count 1))) + (else + (out line + (kons header (string-concatenate-reverse value) acc) + (+ count 1)))))) + (let ((first-line (read-line port mime-line-length-limit))) + (cond + ((eof-object? first-line) + knil) + ((and kons-from (match-mbox-from-line first-line)) + => (lambda (m) ; special case check on first line for mbox files + (out (read-line port mime-line-length-limit) + (kons-from "%from" (car m) + (kons-from "%date" (cadr m) knil)) + 0))) + (else + (out first-line knil 0))))) + +(define (mime-headers->list . o) + (reverse + (apply + mime-header-fold + (lambda (h v acc) (cons (cons (string-downcase h) v) acc)) + '() + o))) + +(define (mime-split-name+value s) + (let ((i (string-char-index s #\=))) + (if i + (cons (string-downcase (string-trim-white-space (substring s 0 i))) + (if (= i (string-length s)) + "" + (if (eqv? #\" (string-ref s (+ i 1))) + (substring s (+ i 2) (- (string-length s) 1)) + (substring s (+ i 1) (string-length s))))) + (cons (string-downcase (string-trim-white-space s)) "")))) + +(define (mime-parse-content-type str) + (map mime-split-name+value (string-split str #\;))) + +(define (mime-decode-header str) + (let* ((len (string-length str)) + (limit (- len 8))) ; need at least 8 chars: "=?Q?X??=" + (let lp ((i 0) (from 0) (res '())) + (if (>= i limit) + (string-concatenate (reverse (cons (substring str from len) res))) + (if (and (eqv? #\= (string-ref str i)) + (eqv? #\? (string-ref str (+ i 1)))) + (let* ((j (string-char-index str #\? (+ i 3))) + (k (string-char-index str #\? (+ j 3)))) + (if (and j k (< (+ k 1) len) + (eqv? #\? (string-ref str (+ j 2))) + (memq (string-ref str (+ j 1)) '(#\Q #\B #\q #\b)) + (eqv? #\= (string-ref str (+ k 1)))) + (let ((decode (if (memq (string-ref str (+ j 1)) '(#\Q #\q)) + quoted-printable-decode-string + base64-decode-string)) + (cset (substring str (+ i 2) j)) + (content (substring str (+ j 3) k)) + (k2 (+ k 2))) + (lp k2 k2 (cons (ces-convert (decode content) cset) + (cons (substring str from i) res)))) + (lp (+ i 2) from res))) + (lp (+ i 1) from res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; message parsing + +(define (mime-read-to-boundary port boundary next final) + (let ((final-boundary (and boundary (string-append boundary "--")))) + (let lp ((res '())) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((or (eof-object? line) (equal? line final-boundary)) + (final (string-concatenate (reverse res) + (call-with-output-string newline)))) + ((equal? line boundary) + (next (string-concatenate (reverse res) + (call-with-output-string newline)))) + (else + (lp (cons line res)))))))) + +(define (mime-convert-part str cte enc) + (let ((str (cond + ((and (string? cte) (string-ci=? cte "quoted-printable")) + (quoted-printable-decode-string str)) + ((and (string? cte) (string-ci=? cte "base64")) + (base64-decode-string str)) + (else + str)))) + (if (string? enc) (ces-convert str enc) str))) + +(define (mime-read-part port cte enc boundary next final) + (mime-read-to-boundary + port boundary + (lambda (x) (next (mime-convert-part x cte enc))) + (lambda (x) (final (mime-convert-part x cte enc))))) + +;; (kons parent-headers part-headers part-body seed) +;; (start headers seed) +;; (end headers parent-seed seed) +(define (mime-message-fold src kons init-seed . o) + (let ((port (if (string? src) (open-input-string src) src))) + (let ((kons-start + (if (pair? o) (car o) (lambda (headers seed) '()))) + (kons-end + (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)))) + (headers + (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + (mime-headers->list port)))) + (let tfold ((parent-headers '()) + (headers headers) + (seed init-seed) + (boundary #f) + (next (lambda (x) x)) + (final (lambda (x) x))) + (let* ((ctype (mime-parse-content-type + (mime-ref headers "Content-Type" "text/plain"))) + (type (string-trim-white-space (caar ctype))) + (enc (string-trim-white-space + (or (mime-ref ctype "charset") + (mime-ref headers "charset" "ASCII")))) + (cte (string-trim-white-space + (or (mime-ref headers "Content-Transfer-Encoding") + (mime-ref headers "Encoding" "7-bit"))))) + (cond + ((and (string-ci=? type "multipart/") + (mime-ref ctype "boundary")) + => (lambda (boundary2) + (let ((boundary2 (string-append "--" boundary2))) + ;; skip preamble + (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x)) + (let lp ((part-seed (kons-start headers seed))) + (let ((part-headers (mime-headers->list port))) + (tfold parent-headers part-headers + part-seed boundary2 + lp + (lambda (x) + ;; skip epilogue + (if boundary + (mime-read-to-boundary port boundary + (lambda (x) x) (lambda (x) x))) + (next (kons-end headers seed x))) + )))))) + (else + (mime-read-part + port cte enc boundary + (lambda (x) (next (kons parent-headers headers x seed))) + (lambda (x) (final (kons parent-headers headers x seed))))))))))) + +;; (mime (^ (header . value) ...) parts ...) +(define (mime-message->sxml . o) + (car + (apply + mime-message-fold + (if (pair? o) (car o) (current-input-port)) + (lambda (parent-headers headers body seed) + `((mime (^ ,@headers) ,body) ,@seed)) + '() + (lambda (headers seed) '()) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)) + (if (pair? o) (cdr o) '())))) + diff --git a/lib/chibi/net.module b/lib/chibi/net.module new file mode 100644 index 00000000..845a7aa8 --- /dev/null +++ b/lib/chibi/net.module @@ -0,0 +1,11 @@ + +(define-module (chibi net) + (export sockaddr? address-info? get-address-info socket connect + with-net-io open-net-io + address-info-family address-info-socket-type address-info-protocol + address-info-address address-info-address-length address-info-next) + (import-immutable (scheme)) + (import (chibi filesystem)) + (include-shared "net") + (include "net.scm")) + diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm new file mode 100644 index 00000000..5f912cb5 --- /dev/null +++ b/lib/chibi/net.scm @@ -0,0 +1,32 @@ +;; net.scm -- the high-level network interface +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (open-net-io host service) + (let lp ((addr (get-address-info host + (if (integer? service) + (number->string service) + service) + #f))) + (if (not addr) + (error "couldn't find address" host service) + (let ((sock (socket (address-info-family addr) + (address-info-socket-type addr) + (address-info-protocol addr)))) + (if (negative? sock) + (lp (address-info-next addr)) + (if (negative? + (connect sock + (address-info-address addr) + (address-info-address-length addr))) + (lp (address-info-next addr)) + (list (open-input-file-descriptor sock) + (open-output-file-descriptor sock)))))))) + +(define (with-net-io host service proc) + (let ((io (open-net-io host service))) + (if (not (pair? io)) + (error "couldn't find address" host service) + (let ((res (proc (car io) (car (cdr io))))) + (close-input-port (car io)) + res)))) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub new file mode 100644 index 00000000..0d72bc90 --- /dev/null +++ b/lib/chibi/net.stub @@ -0,0 +1,25 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/socket.h") +(c-system-include "netdb.h") + +(define-c-struct sockaddr + predicate: sockaddr?) + +(define-c-struct addrinfo + finalizer: freeaddrinfo + predicate: address-info? + (int ai_family address-info-family) + (int ai_socktype address-info-socket-type) + (int ai_protocol address-info-protocol) + ((link sockaddr) ai_addr address-info-address) + (size_t ai_addrlen address-info-address-length) + ((link addrinfo) ai_next address-info-next)) + +(define-c errno (get-address-info getaddrinfo) + (string string (maybe-null addrinfo) (result free addrinfo))) + +(define-c int bind (int sockaddr int)) +(define-c int listen (int int)) +(define-c int socket (int int int)) +(define-c int connect (int sockaddr int)) diff --git a/lib/chibi/net/http.module b/lib/chibi/net/http.module new file mode 100644 index 00000000..352bf7b4 --- /dev/null +++ b/lib/chibi/net/http.module @@ -0,0 +1,7 @@ + +(define-module (chibi net http) + (export http-get call-with-input-url with-input-from-url + http-parse-request http-parse-form) + (import-immutable (scheme) (srfi 39) (chibi net) (chibi io) + (chibi uri) (chibi mime)) + (include "http.scm")) diff --git a/lib/chibi/net/http.scm b/lib/chibi/net/http.scm new file mode 100644 index 00000000..37cac5e6 --- /dev/null +++ b/lib/chibi/net/http.scm @@ -0,0 +1,180 @@ +;; http.scm -- http client +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; client utils + +(define http-user-agent "chibi") + +(define http-redirect-limit 10) +(define http-chunked-buffer-size 4096) +(define http-chunked-size-limit 409600) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (http-parse-response line) + (let* ((len (string-length line)) + (i (or (string-scan line #\space 0 len) len)) + (j (or (string-scan line #\space (+ i 1) len) len)) + (n (and (< i j) (string->number (substring line (+ i 1) j))))) + (if (not (integer? n)) + (error "bad response" line i j) + (list (substring line 0 i) + n + (if (>= j len) "" (substring line (+ j 1) len)))))) + +(define (http-wrap-chunked-input-port in) + (define (read-chunk in) + (let* ((line (read-line in)) + (n (and (string? line) (string->number line 16)))) + (display "read-chunk ") (write line) (newline) + (cond + ((not (and (integer? n) (<= 0 n http-chunked-size-limit))) + (error "invalid chunked size line" line)) + ((zero? n) "") + (else (read-string n in))))) + (make-generated-input-port + (lambda () (read-chunk in)))) + +(define (http-get/raw url in-headers limit) + (if (<= limit 0) + (error "http-get: redirect limit reached" url) + (let* ((uri (if (uri? url) url (string->uri url))) + (host (and uri (uri-host uri)))) + (if (not host) + (error "invalid url" url) + (let* ((io (open-net-io + host + (or (uri-port uri) + (if (eq? 'https (uri-scheme uri)) 443 80)))) + (in (car io)) + (out (car (cdr io)))) + (display "GET " out) + (display (or (uri-path uri) "/") out) + (display " HTTP/1.0\r\n" out) + (display "Host: " out) (display host out) (display "\r\n" out) + (cond + ((not (mime-ref in-headers "user-agent")) + (display "User-Agent: " out) + (display http-user-agent out) + (display "\r\n" out))) + (for-each + (lambda (x) + (display (car x) out) (display ": " out) + (display (cdr x) out) (display "\r\n" out)) + in-headers) + (display "Connection: close\r\n\r\n" out) + (flush-output out) + (let* ((resp (http-parse-response (read-line in))) + (headers (mime-headers->list in)) + (status (quotient (cadr resp) 100))) + (case status + ((2) + (let ((enc (mime-ref headers "transfer-encoding"))) + (cond + ((equal? enc "chunked") + (http-wrap-chunked-input-port in)) + (else + in)))) + ((3) + (close-input-port in) + (close-output-port out) + (let ((url2 (mime-ref headers "location"))) + (if url2 + (http-get/raw url2 in-headers (- limit 1)) + (error "redirect with no location header")))) + (else + (close-input-port in) + (close-output-port out) + (error "couldn't retrieve url" url resp))))))))) + +(define (http-get url . headers) + (http-get/raw url + (if (pair? headers) (car headers) '()) + http-redirect-limit)) + +(define (call-with-input-url url proc) + (let* ((p (http-get url)) + (res (proc p))) + (close-input-port p) + res)) + +(define (with-input-from-url url thunk) + (let ((p (http-get url))) + (let ((res (parameterize ((current-input-port p)) (thunk)))) + (close-input-port p) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; server utils + +;; read and parse a request line +(define (http-parse-request . o) + (let ((line (string-split + (read-line (if (pair? o) (car o) (current-input-port)) 4096)))) + (cons (string->symbol (car line)) (cdr line)))) + +;; Parse a form body with a given URI and MIME headers (as parsed with +;; mime-headers->list). Returns an alist of (name . value) for every +;; query or form parameter. +(define (http-parse-form uri headers . o) + (let* ((in (if (pair? o) (car o) (current-input-port))) + (type (mime-ref headers + "content-type" + "application/x-www-form-urlencoded")) + (query0 (or (uri-query (if (string? uri) (string->uri uri) uri)) '())) + (query (if (string? query0) (uri-query->alist query0) query0))) + (cond + ((string-ci=? "multipart/" type) + (let ((mime (mime-message->sxml in headers))) + (append + (let lp ((ls (cddr mime)) + (res '())) + (cond + ((null? ls) + res) + ((and (pair? (car ls)) + (eq? 'mime (caar ls)) + (pair? (cdar ls)) + (pair? (cadar ls)) + (memq (caadar ls) '(^ @))) + (let* ((disp0 (mime-ref (cdadar ls) "content-disposition" "")) + (disp (mime-parse-content-type disp0)) + (name (mime-ref disp "name"))) + (if name + (lp (cdr ls) (cons (cons name (caddar ls)) res)) + (lp (cdr ls) res)))) + (else + (lp (cdr ls) res)))) + query))) + (else + query)))) + diff --git a/lib/chibi/pathname.module b/lib/chibi/pathname.module new file mode 100644 index 00000000..765ee189 --- /dev/null +++ b/lib/chibi/pathname.module @@ -0,0 +1,7 @@ + +(define-module (chibi pathname) + (export path-strip-directory path-directory path-extension-pos + path-extension path-strip-extension path-replace-extension + path-absolute? path-relative? path-normalize make-path) + (import-immutable (scheme)) + (include "pathname.scm")) diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm new file mode 100644 index 00000000..de27ad61 --- /dev/null +++ b/lib/chibi/pathname.scm @@ -0,0 +1,180 @@ +;; pathname.scm -- a general, non-host-specific path lib +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-scan-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (- i 1)))))) + +(define (string-skip c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (+ i 1))))))) + +(define (string-skip-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (- i 1)))))) + +;; POSIX basename +;; (define (path-strip-directory path) +;; (if (string=? path "") +;; path +;; (let ((end (string-skip-right #\/ path))) +;; (if (not end) +;; "/" +;; (let ((start (string-scan-right #\/ path (- end 1)))) +;; (substring path (if start (+ start 1) 0) (+ end 1))))))) + +;; GNU basename +(define (path-strip-directory path) + (if (string=? path "") + path + (let ((len (string-length path))) + (if (eqv? #\/ (string-ref path (- len 1))) + "" + (let ((slash (string-scan-right #\/ path))) + (if (not slash) + path + (substring path (+ slash 1) len))))))) + +(define (path-directory path) + (if (string=? path "") + "." + (let ((end (string-skip-right #\/ path))) + (if (not end) + "/" + (let ((start (string-scan-right #\/ path (- end 1)))) + (if (not start) + "." + (let ((start (string-skip-right #\/ path start))) + (if (not start) "/" (substring path 0 (+ start 1)))))))))) + +(define (path-extension-pos path) (string-scan-right #\. path)) + +(define (path-extension path) + (let ((i (path-extension-pos path))) + (and i + (let ((start (+ i 1)) (end (string-length path))) + (and (< start end) (substring path start end)))))) + +(define (path-strip-extension path) + (let ((i (path-extension-pos path))) + (if (and i (< (+ i 1) (string-length path))) + (substring path 0 i) + path))) + +(define (path-replace-extension path ext) + (string-append (path-strip-extension path) "." ext)) + +(define (path-absolute? path) + (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0)))) + +(define (path-relative? path) (not (path-absolute? path))) + +;; This looks big and hairy, but it's mutation-free and guarantees: +;; (string=? s (path-normalize s)) <=> (eq? s (path-normalize s)) +;; i.e. fast and simple for already normalized paths. + +(define (path-normalize path) + (let* ((len (string-length path)) (len-1 (- len 1))) + (define (collect i j res) + (if (>= i j) res (cons (substring path i j) res))) + (define (finish i res) + (if (zero? i) + path + (apply string-append (reverse (collect i len res))))) + ;; loop invariants: + ;; - res is a list such that (string-concatenate-reverse res) + ;; is always the normalized string up to j + ;; - the tail of the string from j onward can be concatenated to + ;; the above value to get a partially normalized path referring + ;; to the same location as the original path + (define (inside i j res) + (if (>= j len) + (finish i res) + (if (eqv? #\/ (string-ref path j)) + (boundary i (+ j 1) res) + (inside i (+ j 1) res)))) + (define (boundary i j res) + (if (>= j len-1) + (finish i res) + (case (string-ref path j) + ((#\.) + (case (string-ref path (+ j 1)) + ((#\.) + (if (or (>= j (- len 2)) (eqv? #\/ (string-ref path (+ j 2)))) + (if (>= i (- j 1)) + (if (null? res) + (backup j "" '()) + (backup j (car res) (cdr res))) + (backup j (substring path i j) res)) + (inside i (+ j 2) res))) + ((#\/) + (if (= i j) + (boundary (+ j 2) (+ j 2) res) + (let ((s (substring path i j))) + (boundary (+ j 2) (+ j 2) (cons s res))))) + (else (inside i (+ j 1) res)))) + ((#\/) (boundary (+ j 1) (+ j 1) (collect i j res))) + (else (inside i (+ j 1) res))))) + (define (backup j s res) + (let ((pos (+ j 3))) + (cond + ;; case 1: we're reduced to accumulating parents of the cwd + ((or (string=? s "/..") (string=? s "..")) + (boundary pos pos (cons "/.." (cons s res)))) + ;; case 2: the string isn't a component itself, skip it + ((or (string=? s "") (string=? s ".") (string=? s "/")) + (if (pair? res) + (backup j (car res) (cdr res)) + (boundary pos pos (if (string=? s "/") '("/") '(".."))))) + ;; case3: just take the directory of the string + (else + (let ((d (path-directory s))) + (cond + ((string=? d "/") + (boundary pos pos (if (null? res) '("/") res))) + ((string=? d ".") + (boundary pos pos res)) + (else (boundary pos pos (cons "/" (cons d res)))))))))) + ;; start with boundary if abs path, otherwise inside + (if (zero? len) + path + ((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '())))) + +(define (make-path . args) + (define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "not a valid path component" x)))) + (define (trim-trailing-slash s) + (let ((i (string-skip-right #\/ s))) + (if i (substring s 0 (+ i 1)) ""))) + (if (null? args) + "" + (let ((start (trim-trailing-slash (x->string (car args))))) + (let lp ((ls (cdr args)) + (res (if (string=? "" start) '() (list start)))) + (cond + ((null? ls) + (apply string-append (reverse res))) + ((pair? (car ls)) + (lp (append (car ls) (cdr ls)) res)) + (else + (let ((x (trim-trailing-slash (x->string (car ls))))) + (lp (cdr ls) + (if (string=? x "") res (cons x (cons "/" res))))))))))) diff --git a/lib/chibi/process.module b/lib/chibi/process.module new file mode 100644 index 00000000..fe03c2e5 --- /dev/null +++ b/lib/chibi/process.module @@ -0,0 +1,17 @@ + +(define-module (chibi process) + (export exit sleep alarm fork kill execute waitpid + set-signal-action! make-signal-set signal-set-contains? + signal-set-fill! signal-set-add! signal-set-delete! + current-signal-mask + signal-mask-block! signal-mask-unblock! signal-mask-set! + signal/hang-up signal/interrupt signal/quit + signal/illegal signal/abort signal/fpe + signal/kill signal/segv signal/pipe + signal/alarm signal/term signal/user1 + signal/user2 signal/child signal/continue + signal/stop signal/tty-stop signal/tty-input + signal/tty-output) + (import-immutable (scheme)) + (include-shared "process")) + diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub new file mode 100644 index 00000000..17287d30 --- /dev/null +++ b/lib/chibi/process.stub @@ -0,0 +1,72 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/wait.h") +(c-system-include "signal.h") +(c-system-include "unistd.h") + +(define-c-type siginfo_t + predicate: signal-info? + (int si_signo signal-number) + (int si_errno signal-error-number) + (int si_code signal-code) + (pid_t si_pid signal-pid) + (uid_t si_uid signal-uid) + (int si_status signal-status) + ;;(clock_t si_utime signal-user-time) + ;;(clock_t si_stime signal-system-time) + ) + +(define-c-type sigset_t + predicate: signal-set?) + +(define-c-const int (signal/hang-up "SIGHUP")) +(define-c-const int (signal/interrupt "SIGINT")) +(define-c-const int (signal/quit "SIGQUIT")) +(define-c-const int (signal/illegal "SIGILL")) +(define-c-const int (signal/abort "SIGABRT")) +(define-c-const int (signal/fpe "SIGFPE")) +(define-c-const int (signal/kill "SIGKILL")) +(define-c-const int (signal/segv "SIGSEGV")) +(define-c-const int (signal/pipe "SIGPIPE")) +(define-c-const int (signal/alarm "SIGALRM")) +(define-c-const int (signal/term "SIGTERM")) +(define-c-const int (signal/user1"SIGUSR1")) +(define-c-const int (signal/user2 "SIGUSR2")) +(define-c-const int (signal/child "SIGCHLD")) +(define-c-const int (signal/continue "SIGCONT")) +(define-c-const int (signal/stop "SIGSTOP")) +(define-c-const int (signal/tty-stop "SIGTSTP")) +(define-c-const int (signal/tty-input "SIGTTIN")) +(define-c-const int (signal/tty-output "SIGTTOU")) + +(c-include "signal.c") + +(define-c sexp (set-signal-action! "sexp_set_signal_action") + ((value ctx sexp) (value self sexp) sexp sexp)) + +(define-c errno (make-signal-set "sigemptyset") ((result sigset_t))) +(define-c errno (signal-set-fill! "sigfillset") (sigset_t)) +(define-c errno (signal-set-add! "sigaddset") (sigset_t int)) +(define-c errno (signal-set-delete! "sigaddset") (sigset_t int)) +(define-c boolean (signal-set-contains? "sigismember") (sigset_t int)) + +(define-c errno (signal-mask-block! "sigprocmask") + ((value SIG_BLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-unblock! "sigprocmask") + ((value SIG_UNBLOCK int) sigset_t (value NULL sigset_t))) +(define-c errno (signal-mask-set! "sigprocmask") + ((value SIG_SETMASK int) sigset_t (value NULL sigset_t))) +(define-c errno (current-signal-mask "sigprocmask") + ((value SIG_BLOCK int) (value NULL sigset_t) (result sigset_t))) + +(define-c unsigned-int alarm (unsigned-int)) +(define-c unsigned-int sleep (unsigned-int)) + +(define-c pid_t fork ()) +;;(define-c pid_t wait ((result int))) +(define-c pid_t waitpid (int (result int) int)) +(define-c errno kill (int int)) +;;(define-c errno raise (int)) +(define-c void exit (int)) +(define-c int (execute execvp) (string (array string))) + diff --git a/lib/chibi/quoted-printable.module b/lib/chibi/quoted-printable.module new file mode 100644 index 00000000..9cbec430 --- /dev/null +++ b/lib/chibi/quoted-printable.module @@ -0,0 +1,7 @@ + +(define-module (chibi quoted-printable) + (export quoted-printable-encode quoted-printable-encode-string + quoted-printable-encode-header + quoted-printable-decode quoted-printable-decode-string) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "quoted-printable.scm")) diff --git a/lib/chibi/quoted-printable.scm b/lib/chibi/quoted-printable.scm new file mode 100644 index 00000000..80709026 --- /dev/null +++ b/lib/chibi/quoted-printable.scm @@ -0,0 +1,157 @@ +;; quoted-printable.scm -- RFC2045 implementation +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: quoted-printable-encode-string str [start-col max-col] +;; Return a quoted-printable encoded representation of string +;; according to the official standard as described in RFC2045. +;; +;; ? and _ are always encoded for compatibility with RFC1522 encoding, +;; and soft newlines are inserted as necessary to keep each lines +;; length less than MAX-COL (default 76). The starting column may be +;; overridden with START-COL (default 0). + +;; Procedure: quoted-printable-decode-string str [mime?] +;; Return a quoted-printable decoded representation of string. If +;; MIME? is specified and true, _ will be decoded as as space in +;; accordance with RFC1522. No errors will be raised on invalid +;; input. + +;; Procedure: quoted-printable-encode [port start-col max-col] +;; Procedure: quoted-printable-decode [port start-col max-col] +;; Variations of the above which read and write to ports. + +;; Procedure: quoted-printable-encode-header enc str [start-col max-col] +;; Return a quoted-printable encoded representation of string as +;; above, wrapped in =?ENC?Q?...?= as per RFC1522, split across +;; multiple MIME-header lines as needed to keep each lines length less +;; than MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring STR +;; is already encoded according to ENC. + +;; Example: + +;; (define (mime-encode-header header value charset) +;; (let ((prefix (string-append header ": ")) +;; (str (ces-convert value "UTF8" charset))) +;; (string-append +;; prefix +;; (quoted-printable-encode-header charset str (string-length prefix))))) + +;; This API is backwards compatible with the Gauche library +;; rfc.quoted-printable. + +(define *default-max-col* 76) + +;; Allow for RFC1522 quoting for headers by always escaping ? and _ +(define (qp-encode str start-col max-col separator) + (define (hex i) (integer->char (+ i (if (<= i 9) 48 55)))) + (let ((end (string-length str)) + (buf (make-string max-col))) + (let lp ((i 0) (col start-col) (res '())) + (cond + ((= i end) + (if (pair? res) + (string-concatenate (reverse (cons (substring buf 0 col) res)) + separator) + (substring buf start-col col))) + ((>= col (- max-col 3)) + (lp i 0 (cons (substring buf (if (pair? res) 0 start-col) col) res))) + (else + (let ((c (char->integer (string-ref str i)))) + (cond + ((and (<= 33 c 126) (not (memq c '(61 63 95)))) + (string-set! buf col (integer->char c)) + (lp (+ i 1) (+ col 1) res)) + (else + (string-set! buf col #\=) + (string-set! buf (+ col 1) (hex (arithmetic-shift c -4))) + (string-set! buf (+ col 2) (hex (bitwise-and c #b1111))) + (lp (+ i 1) (+ col 3) res))))))))) + +(define (quoted-printable-encode-string . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*))) + (qp-encode (if (string? src) src (read-string #f src)) + start-col max-col "=\r\n"))) + +(define (quoted-printable-encode . o) + (display (apply (quoted-printable-encode-string o)))) + +(define (quoted-printable-encode-header encoding . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdddr o))) + (cadddr o) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?Q?")) + (prefix-length (+ 2 (string-length prefix))) + (separator (string-append "?=" nl "\t" prefix)) + (effective-max-col (- max-col prefix-length))) + (string-append prefix + (qp-encode (if (string? src) src (read-string #f src)) + start-col effective-max-col separator) + "?=")))) + +(define (quoted-printable-decode-string . o) + (define (hex? c) (or (char-numeric? c) (<= 65 (char->integer c) 70))) + (define (unhex1 c) + (let ((i (char->integer c))) (if (>= i 65) (- i 55) (- i 48)))) + (define (unhex c1 c2) + (integer->char (+ (arithmetic-shift (unhex1 c1) 4) (unhex1 c2)))) + (let ((src (if (pair? o) (car o) (current-input-port))) + (mime-header? (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (let* ((str (if (string? src) src (read-string #f src))) + (end (string-length str))) + (call-with-output-string + (lambda (out) + (let lp ((i 0)) + (cond + ((< i end) + (let ((c (string-ref str i))) + (case c + ((#\=) ; = escapes + (cond + ((< (+ i 2) end) + (let ((c2 (string-ref str (+ i 1)))) + (cond + ((eq? c2 #\newline) (lp (+ i 2))) + ((eq? c2 #\return) + (lp (if (eq? (string-ref str (+ i 2)) #\newline) + (+ i 3) + (+ i 2)))) + ((hex? c2) + (let ((c3 (string-ref str (+ i 2)))) + (if (hex? c3) (write-char (unhex c2 c3) out)) + (lp (+ i 3)))) + (else (lp (+ i 3)))))))) + ((#\_) ; maybe translate _ to space + (write-char (if mime-header? #\space c) out) + (lp (+ i 1))) + ((#\space #\tab) ; strip trailing whitespace + (let lp2 ((j (+ i 1))) + (cond + ((not (= j end)) + (case (string-ref str j) + ((#\space #\tab) (lp2 (+ j 1))) + ((#\newline) + (lp (+ j 1))) + ((#\return) + (let ((k (+ j 1))) + (lp (if (and (< k end) + (eqv? #\newline (string-ref str k))) + (+ k 1) k)))) + (else (display (substring str i j) out) (lp j))))))) + (else ; a literal char + (write-char c out) + (lp (+ i 1))))))))))))) + +(define (quoted-printable-decode . o) + (display (apply quoted-printable-decode-string o))) + diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c new file mode 100644 index 00000000..ea23929f --- /dev/null +++ b/lib/chibi/signal.c @@ -0,0 +1,62 @@ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_MAX_SIGNUM 32 + +static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM]; + +static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { + sexp ctx, sigctx, handler; + sexp_gc_var1(args); + ctx = sexp_signal_contexts[signum]; + if (ctx) { + handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), + sexp_make_fixnum(signum)); + if (sexp_truep(handler)) { + sigctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve1(sigctx, args); + args = sexp_cons(sigctx, SEXP_FALSE, SEXP_NULL); + sexp_car(args) + = sexp_make_cpointer(sigctx, sexp_siginfo_t_type_id, info, SEXP_FALSE, 0); + args = sexp_cons(sigctx, SEXP_FALSE, args); + sexp_car(args) = sexp_make_fixnum(signum); + sexp_apply(sigctx, handler, args); + sexp_gc_release1(sigctx); + } + } +} + +static struct sigaction call_sigaction = { + .sa_sigaction = sexp_call_sigaction, + .sa_flags = SA_SIGINFO | SA_NODEFER +}; + +static struct sigaction call_sigdefault = {.sa_handler = SIG_DFL}; +static struct sigaction call_sigignore = {.sa_handler = SIG_IGN}; + +static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newaction) { + int res; + sexp oldaction; + if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0 + && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) + return sexp_xtype_exception(ctx, self, "not a valid signal number", signum); + if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) + || sexp_booleanp(newaction))) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, newaction); + if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS))) + sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS) + = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE); + oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); + res = sigaction(sexp_unbox_fixnum(signum), + (sexp_booleanp(newaction) ? + (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore) + : &call_sigaction), + NULL); + if (res) + return sexp_user_exception(ctx, self, "couldn't set signal", signum); + sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction); + sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx; + return oldaction; +} + diff --git a/lib/chibi/stty.module b/lib/chibi/stty.module new file mode 100644 index 00000000..4540cb18 --- /dev/null +++ b/lib/chibi/stty.module @@ -0,0 +1,11 @@ + +(define-module (chibi stty) + (export stty with-stty with-raw-io + get-terminal-width get-terminal-dimensions + TCSANOW TCSADRAIN TCSAFLUSH) + (import-immutable (scheme) + (srfi 33) + (srfi 69)) + (include-shared "stty") + (include "stty.scm")) + diff --git a/lib/chibi/stty.scm b/lib/chibi/stty.scm new file mode 100644 index 00000000..b4aee004 --- /dev/null +++ b/lib/chibi/stty.scm @@ -0,0 +1,235 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; symbolic representation of attributes + +(define stty-lookup (make-hash-table eq?)) + +(for-each + (lambda (c) + (let ((type (cadr c)) + (value (caddr c))) + (hash-table-set! stty-lookup (car c) (cdr c)))) + + ;; ripped from the stty man page, then trimmed down to what seemed + ;; available on most systems + + `(;; characters + ;;(dsusp char ,VDSUSP) ; CHAR will send a terminal stop signal + (eof char ,VEOF) ; CHAR will send an EOF (terminate input) + (eol char ,VEOL) ; CHAR will end the line + (eol2 char ,VEOL2) ; alternate CHAR for ending the line + (erase char ,VERASE) ; CHAR will erase the last character typed + (intr char ,VINTR) ; CHAR will send an interrupt signal + (kill char ,VKILL) ; CHAR will erase the current line + (lnext char ,VLNEXT) ; CHAR will enter the next character quoted + (quit char ,VQUIT) ; CHAR will send a quit signal + (rprnt char ,VREPRINT) ; CHAR will redraw the current line + (start char ,VSTART) ; CHAR will restart output after stopping it + (stop char ,VSTOP) ; CHAR will stop the output + (susp char ,VSUSP) ; CHAR will send a terminal stop signal + (werase char ,VWERASE) ; CHAR will erase the last word typed + + ;; special settings + (cols special #f) ; tell the kernel that the terminal has N columns + (columns special #f) ; same as cols N + (ispeed special #f) ; set the input speed to N + (line special #f) ; use line discipline N + (min special #f) ; with -icanon, set N characters minimum for a completed read + (ospeed special #f) ; set the output speed to N + (rows special #f) ; tell the kernel that the terminal has N rows + (size special #f) ; print the number of rows and columns according to the kernel + (speed special #f) ; print the terminal speed + (time special #f) ; with -icanon, set read timeout of N tenths of a second + + ;; control settings + (clocal control ,CLOCAL) ; disable modem control signals + (cread control ,CREAD) ; allow input to be received + (crtscts control ,CRTSCTS) ; enable RTS/CTS handshaking + (cs5 control ,CS5) ; set character size to 5 bits + (cs6 control ,CS6) ; set character size to 6 bits + (cs7 control ,CS7) ; set character size to 7 bits + (cs8 control ,CS8) ; set character size to 8 bits + (cstopb control ,CSTOPB) ; use two stop bits per character (one with `-') + (hup control ,HUPCL) ; send a hangup signal when the last process closes the tty + (hupcl control ,HUPCL) ; same as [-]hup + (parenb control ,PARENB) ; generate parity bit in output and expect parity bit in input + (parodd control ,PARODD) ; set odd parity (even with `-') + + ;; input settings + (brkint input ,BRKINT) ; breaks cause an interrupt signal + (icrnl input ,ICRNL) ; translate carriage return to newline + (ignbrk input ,IGNBRK) ; ignore break characters + (igncr input ,IGNCR) ; ignore carriage return + (ignpar input ,IGNPAR) ; ignore characters with parity errors + (imaxbel input ,IMAXBEL) ; * beep and do not flush a full input buffer on a character + (inlcr input ,INLCR) ; translate newline to carriage return + (inpck input ,INPCK) ; enable input parity checking + (istrip input ,ISTRIP) ; clear high (8th) bit of input characters + ;;(iuclc input ,IUCLC) ; * translate uppercase characters to lowercase + (ixany input ,IXANY) ; * let any character restart output, not only start character + (ixoff input ,IXOFF) ; enable sending of start/stop characters + (ixon input ,IXON) ; enable XON/XOFF flow control + (parmrk input ,PARMRK) ; mark parity errors (with a 255-0-character sequence) + (tandem input ,IXOFF) ; same as [-]ixoff + + ;; output settings + ;;(bs0 output ,BS0) ; backspace delay style, N in [0..1] + ;;(bs1 output ,BS1) ; backspace delay style, N in [0..1] + ;;(cr0 output ,CR0) ; carriage return delay style, N in [0..3] + ;;(cr1 output ,CR1) ; carriage return delay style, N in [0..3] + ;;(cr2 output ,CR2) ; carriage return delay style, N in [0..3] + ;;(cr3 output ,CR3) ; carriage return delay style, N in [0..3] + ;;(ff0 output ,FF0) ; form feed delay style, N in [0..1] + ;;(ff1 output ,FF1) ; form feed delay style, N in [0..1] + ;;(nl0 output ,NL0) ; newline delay style, N in [0..1] + ;;(nl1 output ,NL1) ; newline delay style, N in [0..1] + (ocrnl output ,OCRNL) ; translate carriage return to newline + ;;(ofdel output ,OFDEL) ; use delete characters for fill instead of null characters + ;;(ofill output ,OFILL) ; use fill (padding) characters instead of timing for delays + ;;(olcuc output ,OLCUC) ; translate lowercase characters to uppercase + (onlcr output ,ONLCR) ; translate newline to carriage return-newline + (onlret output ,ONLRET) ; newline performs a carriage return + (onocr output ,ONOCR) ; do not print carriage returns in the first column + (opost output ,OPOST) ; postprocess output + (tab0 output #f) ; horizontal tab delay style, N in [0..3] + (tab1 output #f) ; horizontal tab delay style, N in [0..3] + (tab2 output #f) ; horizontal tab delay style, N in [0..3] + (tab3 output #f) ; horizontal tab delay style, N in [0..3] + (tabs output #f) ; same as tab0 + ;;(-tabs output #f) ; same as tab3 + ;;(vt0 output ,VT0) ; vertical tab delay style, N in [0..1] + ;;(vt1 output ,VT1) ; vertical tab delay style, N in [0..1] + + ;; local settings + (crterase local ,ECHOE) ; echo erase characters as backspace-space-backspace + (crtkill local ,ECHOKE) ; kill all line by obeying the echoprt and echoe settings + ;;(-crtkill local #f) ; kill all line by obeying the echoctl and echok settings + (ctlecho local ,ECHOCTL) ; echo control characters in hat notation (`^c') + (echo local ,ECHO) ; echo input characters + (echoctl local ,ECHOCTL) ; same as [-]ctlecho + (echoe local ,ECHOE) ; same as [-]crterase + ;;(echok local ,ECHOK) ; echo a newline after a kill character + (echoke local ,ECHOKE) ; same as [-]crtkill + (echonl local ,ECHONL) ; echo newline even if not echoing other characters + (echoprt local ,ECHOPRT) ; echo erased characters backward, between `\' and '/' + (icanon local ,ICANON) ; enable erase, kill, werase, and rprnt special characters + ;;(iexten local ,IEXTEN) ; enable non-POSIX special characters + (isig local ,ISIG) ; enable interrupt, quit, and suspend special characters + (noflsh local ,NOFLSH) ; disable flushing after interrupt and quit special characters + (prterase local ,ECHOPRT) ; same as [-]echoprt + (tostop local ,TOSTOP) ; stop background jobs that try to write to the terminal + ;;(xcase local ,XCASE) ; with icanon, escape with `\' for uppercase characters + + ;; combination settings + (LCASE combine (lcase)) + (cbreak combine (not icanon)) + (cooked combine (brkint ignpar istrip icrnl ixon opost isig icanon)) + ; also eof and eol characters + ; to their default values + (crt combine (echoe echoctl echoke)) + (dec combine (echoe echoctl echoke (not ixany))) + ; also intr ^c erase 0177 kill ^u + (decctlq combine (ixany)) + (ek combine ()) ; erase and kill characters to their default values + (evenp combine (parenb (not parodd) cs7)) + ;;(-evenp combine #f) ; same as -parenb cs8 + (lcase combine (xcase iuclc olcuc)) + (litout combine (cs8 (not parenb istrip opost))) + ;;(-litout combine #f) ; same as parenb istrip opost cs7 + (nl combine (not icrnl onlcr)) + ;;(-nl combine #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret + (oddp combine (parenb parodd cs7)) + (parity combine (evenp)) ; same as [-]evenp + (pass8 combine (cs8 (not parenb istrip))) + ;;(-pass8 combine #f) ; same as parenb istrip cs7 + (raw combine (not ignbrk brkint ignpar parmrk + inpck istrip inlcr igncr icrnl)) + (ixon combine (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc + ;;(time combine #f) ; 0 + ;;(-raw combine #f) ; same as cooked + (sane combine (cread brkint icrnl imaxbel opost onlcr + isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0 + echo echoe echoctl echoke ;; iexten echok + (not ignbrk igncr ixoff ixany inlcr ;; iuclc + ocrnl onocr onlret ;; olcuc ofill ofdel + echonl noflsh tostop echoprt))) ;; xcase + ; plus all special characters to + ; their default values + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; high-level interface + +(define (port? x) (or (input-port? x) (output-port? x))) + +(define (stty . args) + (let* ((port (if (and (pair? args) (port? (car args))) + (car args) + (current-output-port))) + (attr (get-terminal-attributes port))) + ;; parse change requests + (let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args)) + (iflag (term-attrs-iflag attr)) + (oflag (term-attrs-oflag attr)) + (cflag (term-attrs-cflag attr)) + (lflag (term-attrs-lflag attr)) + (invert? #f) + (return (lambda (iflag oflag cflag lflag) + (term-attrs-iflag-set! attr iflag) + (term-attrs-oflag-set! attr oflag) + (term-attrs-cflag-set! attr cflag) + (term-attrs-lflag-set! attr lflag) + (set-terminal-attributes! port TCSANOW attr)))) + (define (join old new) + (if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new))) + (cond + ((pair? lst) + (let ((command (car lst))) + (cond + ((pair? command) ;; recurse on sub-expr + (lp command iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((eq? command 'not) ;; toggle current setting + (lp (cdr lst) iflag oflag cflag lflag (not invert?) return)) + (else + (let ((x (hash-table-ref/default stty-lookup command #f))) + (case (and x (car x)) + ((input) + (lp (cdr lst) (join iflag (cadr x)) oflag cflag lflag invert? return)) + ((output) + (lp (cdr lst) iflag (join oflag (cadr x)) cflag lflag invert? return)) + ((control) + (lp (cdr lst) iflag oflag (join cflag (cadr x)) lflag invert? return)) + ((local) + (lp (cdr lst) iflag oflag cflag (join lflag (cadr x)) invert? return)) + ((char) + ;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0)) + (lp (cddr lst) iflag oflag cflag lflag invert? return)) + ((combine) + (lp (cadr x) iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((special) + (error "special settings not yet supported" command)) + (else + (error "unknown stty command" command)))))))) + (else + (return iflag oflag cflag lflag)))))) + +(define (with-stty setting thunk . o) + (let* ((port (if (pair? o) (car o) (current-input-port))) + (orig-attrs (get-terminal-attributes port))) + (dynamic-wind + (lambda () (stty setting)) + thunk + (lambda () (set-terminal-attributes! port TCSANOW orig-attrs))))) + +(define (with-raw-io port thunk) + (with-stty '(not icanon echo) thunk port)) + +(define (get-terminal-width x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (winsize-col ws)))) + +(define (get-terminal-dimensions x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (list (winsize-col ws) (winsize-row ws))))) diff --git a/lib/chibi/stty.stub b/lib/chibi/stty.stub new file mode 100644 index 00000000..3c5939c5 --- /dev/null +++ b/lib/chibi/stty.stub @@ -0,0 +1,106 @@ + +(c-system-include "termios.h") +(c-system-include "sys/ioctl.h") + +(define-c-struct termios + predicate: term-attrs? + constructor: (make-term-attrs) + (unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!) + (unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!) + (unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!) + (unsigned-long c_lflag term-attrs-lflag term-attrs-lflag-set!) + ;;(unsigned-char (c_cc 22) term-attrs-cc term-attrs-cc-set!) + (unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!) + (unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!)) + +(define-c-struct winsize + predicate: winsize? + (unsigned-short ws_row winsize-row) + (unsigned-short ws_col winsize-col)) + +(define-c errno ioctl (port-or-fd unsigned-long (result winsize))) + +(define-c-const int TIOCGWINSZ) + +(define-c-const int TCSANOW) +(define-c-const int TCSADRAIN) +(define-c-const int TCSAFLUSH) + +(define-c-const unsigned-long IGNBRK) +(define-c-const unsigned-long BRKINT) +(define-c-const unsigned-long IGNPAR) +(define-c-const unsigned-long PARMRK) +(define-c-const unsigned-long INPCK) +(define-c-const unsigned-long ISTRIP) +(define-c-const unsigned-long INLCR) +(define-c-const unsigned-long IGNCR) +(define-c-const unsigned-long ICRNL) +(define-c-const unsigned-long IXON) +(define-c-const unsigned-long IXOFF) +(define-c-const unsigned-long IXANY) +(define-c-const unsigned-long IMAXBEL) +;; (define-c-const unsigned-long IUCLC) + +(define-c-const unsigned-long OPOST) +(define-c-const unsigned-long ONLCR) +;; (define-c-const unsigned-long OXTABS) +;; (define-c-const unsigned-long ONOEOT) +(define-c-const unsigned-long OCRNL) +;; (define-c-const unsigned-long OLCUC) +(define-c-const unsigned-long ONOCR) +(define-c-const unsigned-long ONLRET) + +(define-c-const unsigned-long CSIZE) +(define-c-const unsigned-long CS5) +(define-c-const unsigned-long CS6) +(define-c-const unsigned-long CS7) +(define-c-const unsigned-long CS8) +(define-c-const unsigned-long CSTOPB) +(define-c-const unsigned-long CREAD) +(define-c-const unsigned-long PARENB) +(define-c-const unsigned-long PARODD) +(define-c-const unsigned-long HUPCL) +(define-c-const unsigned-long CLOCAL) +;; (define-c-const unsigned-long CCTS_OFLOW) +(define-c-const unsigned-long CRTSCTS) +;; (define-c-const unsigned-long CRTS_IFLOW) +;; (define-c-const unsigned-long MDMBUF) + +(define-c-const unsigned-long ECHOKE) +(define-c-const unsigned-long ECHOE) +(define-c-const unsigned-long ECHO) +(define-c-const unsigned-long ECHONL) +(define-c-const unsigned-long ECHOPRT) +(define-c-const unsigned-long ECHOCTL) +(define-c-const unsigned-long ISIG) +(define-c-const unsigned-long ICANON) +;; (define-c-const unsigned-long ALTWERASE) +(define-c-const unsigned-long IEXTEN) +;; (define-c-const unsigned-long EXTPROC) +(define-c-const unsigned-long TOSTOP) +(define-c-const unsigned-long FLUSHO) +;; (define-c-const unsigned-long NOKERNINFO) +(define-c-const unsigned-long PENDIN) +(define-c-const unsigned-long NOFLSH) + +(define-c-const unsigned-long VEOF) +(define-c-const unsigned-long VEOL) +(define-c-const unsigned-long VEOL2) +(define-c-const unsigned-long VERASE) +;; (define-c-const unsigned-long VERASE2) +(define-c-const unsigned-long VWERASE) +(define-c-const unsigned-long VINTR) +(define-c-const unsigned-long VKILL) +(define-c-const unsigned-long VQUIT) +(define-c-const unsigned-long VSUSP) +(define-c-const unsigned-long VSTART) +(define-c-const unsigned-long VSTOP) +;; (define-c-const unsigned-long VDSUSP) +(define-c-const unsigned-long VLNEXT) +(define-c-const unsigned-long VREPRINT) +;; (define-c-const unsigned-long VSTATUS) + +(define-c errno (get-terminal-attributes "tcgetattr") + (port-or-fd (result termios))) +(define-c errno (set-terminal-attributes! "tcsetattr") + (port-or-fd int termios)) diff --git a/lib/chibi/system.module b/lib/chibi/system.module new file mode 100644 index 00000000..adc26ddc --- /dev/null +++ b/lib/chibi/system.module @@ -0,0 +1,15 @@ + +(define-module (chibi system) + (export user-information user-name user-password + user-id user-group-id user-gecos user-home user-shell + current-user-id current-group-id + current-effective-user-id current-effective-group-id + set-current-user-id! set-current-effective-user-id! + set-current-group-id! set-current-effective-group-id! + current-session-id create-session + set-root-directory!) + (import-immutable (scheme)) + (include-shared "system") + ;;(include "system.scm") + ) + diff --git a/lib/chibi/system.stub b/lib/chibi/system.stub new file mode 100644 index 00000000..7d4a836f --- /dev/null +++ b/lib/chibi/system.stub @@ -0,0 +1,34 @@ + +(c-system-include "unistd.h") +(c-system-include "pwd.h") +(c-system-include "sys/types.h") + +(define-c-struct passwd + predicate: user? + (string pw_name user-name) + (string pw_passwd user-password) + (uid_t pw_uid user-id) + (gid_t pw_gid user-group-id) + (string pw_gecos user-gecos) + (string pw_dir user-home) + (string pw_shell user-shell)) + +(define-c uid_t (current-user-id "getuid") ()) +(define-c gid_t (current-group-id "getgid") ()) +(define-c uid_t (current-effective-user-id "geteuid") ()) +(define-c gid_t (current-effective-group-id "getegid") ()) + +(define-c errno (set-current-user-id! "setuid") (uid_t)) +(define-c errno (set-current-effective-user-id! "seteuid") (uid_t)) +(define-c errno (set-current-group-id! "setgid") (gid_t)) +(define-c errno (set-current-effective-group-id! "setegid") (gid_t)) + +(define-c pid_t (current-session-id "getsid") ((default 0 pid_t))) +(define-c pid_t (create-session "setsid") ()) + +(define-c errno (set-root-directory! "chroot") (string)) + +;; (define-c errno getpwuid_r +;; (uid_t (result passwd) (result (array char arg3)) +;; (value 256 int) (result pointer passwd))) + diff --git a/lib/chibi/term/edit-line.module b/lib/chibi/term/edit-line.module new file mode 100644 index 00000000..d8116473 --- /dev/null +++ b/lib/chibi/term/edit-line.module @@ -0,0 +1,5 @@ + +(define-module (chibi term edit-line) + (export edit-line edit-line-repl) + (import-immutable (scheme) (chibi stty) (srfi 9)) + (include "edit-line.scm")) diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm new file mode 100644 index 00000000..cd8fd376 --- /dev/null +++ b/lib/chibi/term/edit-line.scm @@ -0,0 +1,493 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; vt100 terminal utilities + +(define (terminal-escape out ch arg) + (write-char (integer->char 27) out) + (write-char #\[ out) + (if arg (display arg out)) + (write-char ch out)) + +;; we use zero-based columns +(define (terminal-goto-col out n) (terminal-escape out #\G (+ n 1))) +(define (terminal-up out n) (terminal-escape out #\A n)) +(define (terminal-down out n) (terminal-escape out #\B n)) +(define (terminal-clear-below out) (terminal-escape out #\J #f)) +(define (terminal-clear-right out) (terminal-escape out #\K #f)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; history + +(define maximum-history-size 128) + +(define-record-type history + (%make-history remaining past future) + history? + (remaining history-remaining history-remaining-set!) + (past history-past history-past-set!) + (future history-future history-future-set!)) + +(define (make-history . o) + (%make-history (if (pair? o) (car o) maximum-history-size) '() '())) + +(define (history-current h) + (let ((p (history-past h))) + (and (pair? p) (car p)))) + +(define (history->list h) + (let ((past (history-past h)) (future (history-future h))) + (if (pair? past) (cons (car past) (append future (cdr past))) future))) + +(define (history-flatten! h) + (history-past-set! h (history->list h)) + (history-future-set! h '())) + +(define (drop-last ls) (reverse (cdr (reverse ls)))) + +(define (history-past-push! h x) + (if (positive? (history-remaining h)) + (history-remaining-set! h (- (history-remaining h) 1)) + (if (pair? (history-past h)) + (history-past-set! h (drop-last (history-past h))) + (history-future-set! h (drop-last (history-future h))))) + (history-past-set! h (cons x (history-past h)))) + +(define (history-insert! h x) + (history-flatten! h) + (history-past-push! h x)) + +(define (history-commit! h x) + (cond + ((pair? (history-future h)) + (history-past-set! + h (cons x (append (drop-last (history-future h)) (history-past h)))) + (history-future-set! h '())) + (else + (history-insert! h x)))) + +(define (history-prev! h) + (let ((past (history-past h))) + (and (pair? past) + (pair? (cdr past)) + (begin + (history-future-set! h (cons (car past) (history-future h))) + (history-past-set! h (cdr past)) + (cadr past))))) + +(define (history-next! h) + (let ((future (history-future h))) + (and (pair? future) + (begin + (history-past-set! h (cons (car future) (history-past h))) + (history-future-set! h (cdr future)) + (car future))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; char and string utils + +(define (char-word-constituent? ch) + (or (char-alphabetic? ch) (char-numeric? ch) + (memv ch '(#\_ #\- #\+ #\:)))) + +(define (char-non-word-constituent? ch) (not (char-word-constituent? ch))) + +(define (string-copy! dst dstart src start end) + (if (>= start dstart) + (do ((i start (+ i 1)) (j dstart (+ j 1))) + ((= i end)) + (string-set! dst j (string-ref src i))) + (do ((i (- end 1) (- i 1)) (j (+ dstart (- end start 1)) (- j 1))) + ((< i start)) + (string-set! dst j (string-ref src i))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; buffers + +(define-record-type buffer + (%make-buffer refresh? min pos row max-row col gap width string history) + buffer? + (refresh? buffer-refresh? buffer-refresh?-set!) + (min buffer-min buffer-min-set!) + (pos buffer-pos buffer-pos-set!) + (row buffer-row buffer-row-set!) + (max-row buffer-max-row buffer-max-row-set!) + (col buffer-col buffer-col-set!) + (gap buffer-gap buffer-gap-set!) + (width buffer-width buffer-width-set!) + (string buffer-string buffer-string-set!) + (kill-ring buffer-kill-ring buffer-kill-ring-set!) + (history buffer-history buffer-history-set!)) + +(define default-buffer-size 256) +(define default-buffer-width 80) + +(define (make-buffer) + (%make-buffer #f 0 0 0 0 0 default-buffer-size default-buffer-width + (make-string default-buffer-size) '())) + +(define (buffer->string buf) + (let ((str (buffer-string buf))) + (string-append (substring str (buffer-min buf) (buffer-pos buf)) + (substring str (buffer-gap buf) (string-length str))))) + +(define (buffer-right-length buf) + (- (string-length (buffer-string buf)) (buffer-gap buf))) +(define (buffer-length buf) + (+ (buffer-pos buf) (buffer-right-length buf))) +(define (buffer-free-space buf) + (- (buffer-gap buf) (buffer-pos buf))) + +(define (buffer-clamp buf n) + (max (buffer-min buf) (min n (buffer-length buf)))) + +(define (buffer-resize buf n) + (cond ((<= (buffer-free-space buf) n) + (let* ((right-len (buffer-right-length buf)) + (new-len (* 2 (max n (buffer-length buf)))) + (new-gap (- new-len right-len)) + (new (make-string new-len)) + (old (buffer-string buf))) + (string-copy! new 0 old 0 (buffer-pos buf)) + (string-copy! new new-gap old (buffer-gap buf) (string-length old)) + (buffer-string-set! buf new) + (buffer-gap-set! buf new-gap))))) + +(define (buffer-update-position! buf) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (end (string-length (buffer-string buf))) + (width (buffer-width buf))) + (let lp ((i 0) (row 0) (col 0)) ;; update row/col + (cond ((= i pos) + (buffer-row-set! buf row) + (buffer-col-set! buf col) + (lp gap row col)) + ((>= i end) + (buffer-max-row-set! + buf (if (and (zero? col) (> row 0)) (- row 1) row))) + ((= (+ col 1) width) + (lp (+ i 1) (+ row 1) 0)) + (else + (lp (+ i 1) row (+ col 1))))))) + +(define (buffer-draw buf out) + (let* ((gap (buffer-gap buf)) + (str (buffer-string buf)) + (end (string-length str)) + (old-row (buffer-row buf)) + (old-col (buffer-col buf))) + (buffer-update-position! buf) + ;; goto start of input + (terminal-goto-col out 0) + (if (positive? old-row) + (terminal-up out old-row)) + ;; clear and display new buffer + (terminal-clear-below out) + (display (substring str 0 (buffer-pos buf)) out) + (display (substring str (buffer-gap buf) end) out) + ;; move to next line if point at eol + (if (and (zero? (buffer-col buf)) (positive? (buffer-row buf))) + (write-char #\space out)) + ;; move to correct row then col + (if (< (buffer-row buf) (buffer-max-row buf)) + (terminal-up out (- (buffer-max-row buf) (buffer-row buf)))) + (terminal-goto-col out (buffer-col buf)))) + +(define (buffer-refresh buf out) + (cond ((buffer-refresh? buf) + (buffer-draw buf out) + (buffer-refresh?-set! buf #f)))) + +(define (buffer-goto! buf out n) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (n (buffer-clamp buf n))) + (cond ((not (= n pos)) + (buffer-update-position! buf) ;; XXXX shouldn't be needed + (if (< n pos) + (string-copy! str (- gap (- pos n)) str n pos) + (string-copy! str pos str gap (+ gap (- n pos)))) + (buffer-pos-set! buf n) + (buffer-gap-set! buf (+ gap (- n pos))) + (cond + ((not (buffer-refresh? buf)) + (let ((old-row (buffer-row buf))) + (buffer-update-position! buf) + (let ((row-diff (- old-row (buffer-row buf)))) + (cond ((> row-diff 0) (terminal-up out row-diff)) + ((< row-diff 0) (terminal-down out (- row-diff))))) + (terminal-goto-col out (buffer-col buf))))))))) + +(define (buffer-insert! buf out x) + (let ((len (if (char? x) 1 (string-length x))) + (pos (buffer-pos buf))) + (buffer-resize buf len) + (if (char? x) + (string-set! (buffer-string buf) pos x) + (string-copy! (buffer-string buf) pos x 0 len)) + (buffer-pos-set! buf (+ (buffer-pos buf) len)) + (cond + ((buffer-refresh? buf)) + ((and (= (buffer-gap buf) (string-length (buffer-string buf))) + (< (+ (buffer-col buf) len) (buffer-width buf))) + ;; fast path - append to end of buffer w/o wrapping to next line + (display x out) + (buffer-col-set! buf (+ (buffer-col buf) len))) + (else + (buffer-refresh?-set! buf #t))))) + +(define (buffer-delete! buf out start end) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (start (buffer-clamp buf start)) + (end (buffer-clamp buf end))) + (if (not (buffer-refresh? buf)) + (if (and (= start pos) (>= end (buffer-length buf))) + (terminal-clear-below out) + (buffer-refresh?-set! buf #t))) + (cond ((< end pos) + (string-copy! str start str end pos) + (buffer-pos-set! buf (+ start (- pos end)))) + ((> start gap) + (string-copy! str start str gap (+ gap (- end start))) + (buffer-gap-set! buf (+ gap (- end start)))) + (else + (buffer-pos-set! buf (min pos start)) + (buffer-gap-set! buf (max gap (+ pos (- gap pos) (- end pos)))))))) + +(define (buffer-skip buf pred) + (let* ((str (buffer-string buf)) (end (string-length str))) + (let lp ((i (buffer-gap buf))) + (if (or (>= i end) (not (pred (string-ref str i)))) + (+ (- i (buffer-gap buf)) (buffer-pos buf)) + (lp (+ i 1)))))) + +(define (buffer-skip-reverse buf pred) + (let ((str (buffer-string buf))) + (let lp ((i (- (buffer-pos buf) 1))) + (if (or (< i 0) (not (pred (string-ref str i)))) i (lp (- i 1)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; keymaps + +(define keymap? pair?) + +(define (make-keymap . o) + (cons (make-vector 256 #f) (and (pair? o) (car o)))) + +(define (make-sparse-keymap . o) + (cons '() (and (pair? o) (car o)))) + +(define (make-printable-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (do ((i #x20 (+ i 1))) ((= i #x7F) keymap) + (vector-set! v i command/self-insert)))) + +(define (make-standard-escape-bracket-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 65 command/backward-history) + (vector-set! v 66 command/forward-history) + (vector-set! v 67 command/forward-char) + (vector-set! v 68 command/backward-char) + keymap)) + +(define (make-standard-escape-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 8 command/backward-delete-word) + (vector-set! v 91 (make-standard-escape-bracket-keymap)) + (vector-set! v 98 command/backward-word) + (vector-set! v 100 command/forward-delete-word) + (vector-set! v 102 command/forward-word) + (vector-set! v 127 command/backward-delete-word) + keymap)) + +(define (make-standard-keymap) + (let* ((keymap (make-printable-keymap)) + (v (car keymap))) + (vector-set! v 1 command/beggining-of-line) + (vector-set! v 2 command/backward-char) + (vector-set! v 4 command/forward-delete-char) + (vector-set! v 5 command/end-of-line) + (vector-set! v 6 command/forward-char) + (vector-set! v 8 command/backward-delete-char) + (vector-set! v 10 command/enter) + (vector-set! v 11 command/forward-delete-line) + (vector-set! v 12 command/refresh) + (vector-set! v 13 command/enter) + (vector-set! v 21 command/backward-delete-line) + (vector-set! v 27 (make-standard-escape-keymap)) + (vector-set! v 127 command/backward-delete-char) + keymap)) + +(define (keymap-lookup keymap n) + (let ((table (car keymap))) + (or (if (vector? table) + (and (< n (vector-length table)) (vector-ref table n)) + (cond ((assv n table) => cdr) (else #f))) + (if (keymap? (cdr keymap)) + (keymap-lookup (cdr keymap) n) + (cdr keymap))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; commands + +(define (command/self-insert ch buf out return) + (buffer-insert! buf out ch)) + +(define (command/enter ch buf out return) + (command/end-of-line ch buf out return) + (newline out) + (return)) + +(define (command/beep ch buf out return) + (write-char (integer->char 7) out)) + +(define (command/refresh ch buf out return) + (buffer-draw buf out)) + +(define (command/beggining-of-line ch buf out return) + (buffer-goto! buf out 0)) + +(define (command/end-of-line ch buf out return) + (buffer-goto! buf out (buffer-length buf))) + +(define (command/forward-char ch buf out return) + (buffer-goto! buf out (+ (buffer-pos buf) 1))) + +(define (command/backward-char ch buf out return) + (buffer-goto! buf out (- (buffer-pos buf) 1))) + +(define (command/forward-delete-char ch buf out return) + (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1))) + +(define (command/backward-delete-char ch buf out return) + (buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf))) + +(define (command/forward-delete-line ch buf out return) + (buffer-delete! buf out (buffer-pos buf) (buffer-length buf))) + +(define (command/backward-delete-line ch buf out return) + (buffer-delete! buf out 0 (buffer-pos buf))) + +(define (command/backward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-past history))) + (if (null? (history-future history)) + (history-insert! history (buffer->string buf))) + (cond + ((pair? (cdr (history-past history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (buffer-insert! buf out (history-prev! history)))))))) + +(define (command/forward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-future history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (let ((res (buffer-insert! buf out (history-next! history)))) + (if (null? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + res))))) + +(define (command/forward-word ch buf out return) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-goto! buf out (buffer-skip buf char-word-constituent?))) + +(define (command/backward-word ch buf out return) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (buffer-goto! buf out (+ (buffer-skip-reverse buf char-word-constituent?) 1))) + +(define (command/forward-delete-word ch buf out return) + (let ((start (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-delete! buf out start (buffer-skip buf char-word-constituent?)))) + +(define (command/backward-delete-word ch buf out return) + (let ((end (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (let ((start (buffer-skip-reverse buf char-word-constituent?))) + (buffer-delete! buf out (+ start 1) end)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; line-editing + +(define standard-keymap (make-standard-keymap)) + +(define (get-key ls key . o) + (let ((x (memq key ls))) + (if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o))))) + +(define (with-leading-ports ls proc) + (if (and (pair? ls) (input-port? (car ls))) + (if (and (pair? (cdr ls)) (output-port? (cadr ls))) + (proc (car ls) (cadr ls) (cddr ls)) + (proc (car ls) (current-output-port) (cdr ls))) + (proc (current-input-port) (current-output-port) ls))) + +(define (make-line-editor . args) + (let* ((prompt (get-key args 'prompt: "> ")) + (history (get-key args 'history:)) + (terminal-width (get-key args 'terminal-width:)) + (keymap (get-key args 'keymap: standard-keymap))) + (lambda (in out) + (let* ((width (or terminal-width (get-terminal-width out))) + (buf (make-buffer)) + (done? #f) + (return (lambda o (set! done? #t)))) + (buffer-refresh?-set! buf #t) + (buffer-width-set! buf width) + (buffer-insert! buf out prompt) + (buffer-min-set! buf (string-length prompt)) + (buffer-history-set! buf history) + (buffer-refresh buf out) + (flush-output out) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp ((kmap keymap)) + (let ((ch (read-char in))) + (if (eof-object? ch) + (buffer->string buf) + (let ((x (keymap-lookup kmap (char->integer ch)))) + (cond + ((keymap? x) + (lp x)) + ((procedure? x) + (x ch buf out return) + (buffer-refresh buf out) + (if done? (buffer->string buf) (lp keymap))) + (else + ;;(command/beep ch buf out return) + (lp keymap))))))))))))) + +(define (edit-line . args) + (with-leading-ports + args + (lambda (in out rest) ((apply make-line-editor rest) in out)))) + +(define (edit-line-repl . args) + (with-leading-ports + args + (lambda (in out rest) + (let ((eval (get-key rest 'eval: (lambda (x) x))) + (print (get-key rest 'write: write)) + (history (or (get-key rest 'history:) (make-history)))) + (let ((edit-line + (apply make-line-editor 'no-stty?: #t 'history: history rest))) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp () + (let ((line (edit-line in out))) + (if (pair? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + (history-commit! history line) + (print (eval line) out) + (newline out) + (lp)))))))))) diff --git a/lib/chibi/time.module b/lib/chibi/time.module new file mode 100644 index 00000000..8d591100 --- /dev/null +++ b/lib/chibi/time.module @@ -0,0 +1,12 @@ + +(define-module (chibi time) + (export current-seconds get-time-of-day set-time-of-day! + seconds->time seconds->string time->seconds time->string + timeval-seconds timeval-microseconds + timezone-offset timezone-dst-time + time-second time-minute time-hour time-day time-month time-year + time-day-of-week time-day-of-year time-dst? + tm? timeval? timezone?) + (import-immutable (scheme)) + (include-shared "time")) + diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub new file mode 100644 index 00000000..adde486e --- /dev/null +++ b/lib/chibi/time.stub @@ -0,0 +1,46 @@ + +(c-system-include "time.h") +(c-system-include "sys/time.h") + +(define-c-struct tm + predicate: tm? + (int tm_sec time-second) + (int tm_min time-minute) + (int tm_hour time-hour) + (int tm_mday time-day) + (int tm_mon time-month) + (int tm_year time-year) + (int tm_wday time-day-of-week) + (int tm_yday time-day-of-year) + (int tm_isdst time-dst?)) + +(define-c-struct timeval + predicate: timeval? + (time_t tv_sec timeval-seconds) + (int tv_usec timeval-microseconds)) + +(define-c-struct timezone + predicate: timezone? + (int tz_minuteswest timezone-offset) + (int tz_dsttime timezone-dst-time)) + +(define-c time_t (current-seconds "time") ((value NULL))) + +(define-c errno (get-time-of-day "gettimeofday") + ((result timeval) (result timezone))) + +(define-c errno (set-time-of-day! "settimeofday") + (timeval (maybe-null default NULL timezone))) + +(define-c non-null-pointer (seconds->time "localtime_r") + ((pointer time_t) (result tm))) + +(define-c time_t (time->seconds "mktime") + (tm)) + +(define-c non-null-string (seconds->string "ctime_r") + ((pointer time_t) (result (array char 64)))) + +(define-c non-null-string (time->string "asctime_r") + (tm (result (array char 64)))) + diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module new file mode 100644 index 00000000..46f9e6a6 --- /dev/null +++ b/lib/chibi/uri.module @@ -0,0 +1,10 @@ + +(define-module (chibi uri) + (export uri? uri->string make-uri string->uri + uri-scheme uri-user uri-host uri-port uri-path uri-query uri-fragment + uri-with-scheme uri-with-user uri-with-host uri-with-path + uri-with-query uri-with-fragment + uri-encode uri-decode uri-query->alist uri-alist->query) + (import-immutable (scheme) + (srfi 9)) + (include "uri.scm")) diff --git a/lib/chibi/uri.scm b/lib/chibi/uri.scm new file mode 100644 index 00000000..41507961 --- /dev/null +++ b/lib/chibi/uri.scm @@ -0,0 +1,306 @@ +;; uri.scm -- URI parsing library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URI representation + +(define-record-type uri + (%make-uri scheme user host port path query fragment) + uri? + (scheme uri-scheme) + (user uri-user) + (host uri-host) + (port uri-port) + (path uri-path) + (query uri-query) + (fragment uri-fragment)) + +;; (make-uri scheme [user host port path query fragment]) +(define (make-uri scheme . o) + (let* ((user (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (host (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (port (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (path (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (query (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f))) + (%make-uri scheme user host port path query fragment))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils (don't feel like using SRFI-13 and these are more +;; specialised) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (string-scan-right str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i (- end 1))) + (and (>= i start) + (if (eqv? ch (string-ref str i)) + i + (lp (- i 1))))))) + +(define (string-index-of str pred . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond ((>= i end) #f) + ((pred (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase->symbol str) + (let ((len (string-length str))) + (let lp ((i 0)) + (cond + ((= i len) + (string->symbol str)) + ((char-upper-case? (string-ref str i)) + (let ((res (make-string len))) + (do ((j 0 (+ j 1))) + ((= j i)) + (string-set! res j (string-ref str j))) + (string-set! res i (char-downcase (string-ref str i))) + (do ((j (+ i 1) (+ j 1))) + ((= j len)) + (string-set! res j (char-downcase (string-ref str j)))) + (string->symbol res))) + (else + (lp (+ i 1))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; functional updaters (uses as much shared state as possible) + +(define (uri-with-scheme u scheme) + (%make-uri scheme (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-user u user) + (%make-uri (uri-scheme u) user (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-host u host) + (%make-uri (uri-scheme u) (uri-user u) host (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-port u port) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) port + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-path u path) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + path (uri-query u) (uri-fragment u))) + +(define (uri-with-query u query) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) query (uri-fragment u))) + +(define (uri-with-fragment u fragment) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) fragment)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parsing - without :// we just split into scheme & path + +(define (char-uri-scheme-unsafe? ch) + (not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\_ #\-))))) + +(define (string->path-uri scheme str . o) + (define decode? (and (pair? o) (car o))) + (define decode (if decode? uri-decode (lambda (x) x))) + (define decode-query + (if (and (pair? o) (pair? (cdr o)) (cadr o)) + uri-query->alist + decode)) + (if (pair? str) + str + (let* ((len (string-length str)) + (colon0 (string-scan str #\:)) + (colon + (and (not (string-index-of str char-uri-scheme-unsafe? + 0 (or colon0 len))) + colon0))) + (if (or (not colon) (zero? colon)) + (and scheme + (let* ((quest (string-scan str #\? 0)) + (pound (string-scan str #\# (or quest 0)))) + (make-uri scheme #f #f #f + (decode (substring str 0 (or quest pound len))) + (and quest + (decode-query + (substring str (+ quest 1) (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len)))))) + (let ((sc1 (+ colon 1)) + (scheme (string-downcase->symbol (substring str 0 colon)))) + (if (= sc1 len) + (make-uri scheme) + (if (or (>= (+ sc1 1) len) + (not (and (eqv? #\/ (string-ref str sc1)) + (eqv? #\/ (string-ref str (+ sc1 1)))))) + (make-uri scheme #f #f #f (substring str sc1 len)) + (if (>= (+ sc1 2) len) + (make-uri scheme #f "") + (let* ((sc2 (+ sc1 2)) + (slash (string-scan str #\/ sc2)) + (sc3 (or slash len)) + (at (string-scan-right str #\@ sc2 sc3)) + (colon3 (string-scan str #\: (or at sc2) sc3)) + (quest (string-scan str #\? sc3)) + (pound (string-scan str #\# (or quest sc3)))) + (%make-uri + scheme + (and at (decode (substring str sc2 at))) + (decode + (substring str + (if at (+ at 1) sc2) + (or colon3 sc3))) + (and colon3 + (string->number + (substring str (+ colon3 1) sc3))) + (and slash + (decode + (substring str slash (or quest pound len)))) + (and quest + (decode-query + (substring str (+ quest 1) + (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len))) + )))))))))) + +(define (string->uri str . o) + (apply string->path-uri #f str o)) + +(define (uri->string uri . o) + (define encode? (and (pair? o) (car o))) + (define encode (if encode? uri-encode (lambda (x) x))) + (if (string? uri) + uri + (let ((fragment (uri-fragment uri)) + (query (uri-query uri)) + (path (uri-path uri)) + (port (uri-port uri)) + (host (uri-host uri)) + (user (uri-user uri))) + (string-append + (symbol->string (uri-scheme uri)) ":" + (if (or user host port) "//" "") + (if user (encode user) "") (if user "@" "") + (or host "") ; host shouldn't need encoding + (if port ":" "") (if port (number->string port) "") + (if path (encode path) "") + (if query "?" "") + (if (pair? query) (uri-alist->query query) (or query "")) + (if fragment "#" "") (if fragment (encode fragment) ""))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; query encoding and decoding + +(define (uri-safe-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (case ch + ((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t) + (else #f)))) + +(define (collect str from to res) + (if (>= from to) + res + (cons (substring str from to) res))) + +(define (uri-encode str . o) + (define (encode-1-space ch) + (if (eqv? ch #\space) + "+" + (encode-1-normal ch))) + (define (encode-1-normal ch) + (let* ((i (char->integer ch)) + (hex (number->string i 16))) + (if (< i 16) + (string-append "%0" hex) + (string-append "%" hex)))) + (let ((start 0) + (end (string-length str)) + (encode-1 (if (and (pair? o) (car o)) + encode-1-space + encode-1-normal))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (if (uri-safe-char? ch) + (lp from next res) + (lp next next (cons (encode-1 ch) + (collect str from to res))))))))) + +(define (uri-decode str . o) + (let ((space-as-plus? (and (pair? o) (car o))) + (start 0) + (end (string-length str))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (cond + ((eqv? ch #\%) + (if (>= next end) + (lp next next (collect str from to res)) + (let ((next2 (+ next 1))) + (if (>= next2 end) + (lp next2 next2 (collect str from to res)) + (let* ((next3 (+ next2 1)) + (hex (substring str next next3)) + (i (string->number hex 16))) + (lp next3 next3 (cons (string (integer->char i)) + (collect str from to res)))))))) + ((and space-as-plus? (eqv? ch #\+)) + (lp next next (cons " " (collect str from to res)))) + (else + (lp from next res)))))))) + +(define (uri-query->alist str . o) + (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;))) + (let ((len (string-length str)) + (plus? (and (pair? o) (car o)))) + (let lp ((i 0) (res '())) + (if (>= i len) + (reverse res) + (let* ((j (or (string-index-of str split-char? i) len)) + (k (string-scan str #\= i j)) + (cell (if k + (cons (uri-decode (substring str i k) plus?) + (uri-decode (substring str (+ k 1) j) plus?)) + (cons (uri-decode (substring str i j) plus?) #f)))) + (lp (+ j 1) (cons cell res))))))) + +(define (uri-alist->query ls . o) + (define plus? (and (pair? o) (car o))) + (define (encode key val res) + (let ((res (cons (uri-encode key plus?) res))) + (if val (cons (uri-encode val plus?) (cons "=" res)) res))) + (if (null? ls) + "" + (let lp ((x (car ls)) (ls (cdr ls)) (res '())) + (let ((res (encode (car x) (cdr x) res))) + (if (null? ls) + (string-concatenate (reverse res)) + (lp (car ls) (cdr ls) (cons "&" res))))))) diff --git a/lib/config.scm b/lib/config.scm new file mode 100644 index 00000000..be6fb36a --- /dev/null +++ b/lib/config.scm @@ -0,0 +1,177 @@ +;; config.scm -- configuration module +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *this-module* '()) + +(define (make-module exports env meta) (vector exports env meta)) +(define (%module-exports mod) (vector-ref mod 0)) +(define (module-env mod) (vector-ref mod 1)) +(define (module-meta-data mod) (vector-ref mod 2)) +(define (module-env-set! mod env) (vector-set! mod 1 env)) + +(define (module-exports mod) + (or (%module-exports mod) (env-exports (module-env mod)))) + +(define (module-name->strings ls res) + (if (null? ls) + res + (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls))) + ((number? (car ls)) (number->string (car ls))) + ((string? (car ls)) (car ls)) + (else (error "invalid module name" (car ls)))))) + (module-name->strings (cdr ls) (cons "/" (cons str res)))))) + +(define (module-name->file name) + (string-concatenate + (reverse (cons ".module" (cdr (module-name->strings name '())))))) + +(define (module-name-prefix name) + (string-concatenate (reverse (cdr (cdr (module-name->strings name '())))))) + +(define (load-module-definition name) + (let* ((file (module-name->file name)) + (path (find-module-file file))) + (if path (load path *config-env*)))) + +(define (find-module name) + (cond + ((assoc name *modules*) => cdr) + (else + (load-module-definition name) + (cond ((assoc name *modules*) => cdr) + (else #f))))) + +(define (symbol-append a b) + (string->symbol (string-append (symbol->string a) (symbol->string b)))) + +(define (to-id id) (if (pair? id) (car id) id)) +(define (from-id id) (if (pair? id) (cdr id) id)) +(define (id-filter pred ls) + (cond ((null? ls) '()) + ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls)))) + (else (id-filter pred (cdr ls))))) + +(define (resolve-import x) + (cond + ((not (and (pair? x) (list? x))) + (error "invalid module syntax" x)) + ((and (pair? (cdr x)) (pair? (cadr x))) + (if (memq (car x) '(only except rename)) + (let* ((mod-name+imports (resolve-import (cadr x))) + (imp-ids (cdr mod-name+imports)) + (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x)))) + (begin + (set-cdr! mod-name+imports + (module-exports + (find-module (car mod-name+imports)))) + (cdr mod-name+imports)) + imp-ids))) + (cons (car mod-name+imports) + (case (car x) + ((only) + (if (not imp-ids) + (cddr x) + (id-filter (lambda (i) (memq i (cddr x))) imp-ids))) + ((except) + (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids)) + ((rename) + (map (lambda (i) + (let ((rename (assq (to-id i) (cddr x)))) + (if rename (cons (cdr rename) (from-id i)) i))) + imp-ids))))) + (error "invalid import modifier" x))) + ((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x))) + (let ((mod-name+imports (resolve-import (caddr x)))) + (cons (car mod-name+imports) + (map (lambda (i) + (cons (symbol-append (cadr x) (if (pair? i) (car i) i)) + (if (pair? i) (cdr i) i))) + (cdr mod-name+imports))))) + ((find-module x) + => (lambda (mod) (cons x (%module-exports mod)))) + (else + (error "couldn't find import" x)))) + +(define (eval-module name mod) + (let ((env (make-environment)) + (dir (module-name-prefix name))) + (define (load-modules files extension) + (for-each + (lambda (f) + (let ((f (string-append dir f extension))) + (cond ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + files)) + (for-each + (lambda (x) + (case (and (pair? x) (car x)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2 (load-module (car mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports) + (eq? (car x) 'import-immutable)))) + (cdr x))) + ((include) + (load-modules (cdr x) "")) + ((include-shared) + (cond-expand + (dynamic-loading (load-modules (cdr x) *shared-object-extension*)) + (else #f))) + ((body) + (for-each (lambda (expr) (eval expr env)) (cdr x))))) + (module-meta-data mod)) + env)) + +(define (load-module name) + (let ((mod (find-module name))) + (if (and mod (not (module-env mod))) + (module-env-set! mod (eval-module name mod))) + mod)) + +(define-syntax define-module + (er-macro-transformer + (lambda (expr rename compare) + (let ((name (cadr expr)) + (body (cddr expr))) + `(let ((tmp *this-module*)) + (set! *this-module* '()) + ,@body + (set! *this-module* (reverse *this-module*)) + (let ((exports + (cond ((assq 'export *this-module*) => cdr) + (else '())))) + (set! *modules* + (cons (cons ',name (make-module exports #f *this-module*)) + *modules*))) + (set! *this-module* tmp)))))) + +(define-syntax define-config-primitive + (er-macro-transformer + (lambda (expr rename compare) + `(define-syntax ,(cadr expr) + (er-macro-transformer + (lambda (expr rename compare) + `(set! *this-module* (cons ',expr *this-module*)))))))) + +(define-config-primitive import) +(define-config-primitive import-immutable) +(define-config-primitive export) +(define-config-primitive include) +(define-config-primitive include-shared) +(define-config-primitive body) + +(define *modules* + (list (cons '(scheme) (make-module #f (interaction-environment) '())) + (cons '(srfi 0) (make-module (list 'cond-expand) + (interaction-environment) + (list (list 'export 'cond-expand)))) + (cons '(srfi 46) (make-module (list 'syntax-rules) + (interaction-environment) + (list (list 'export 'syntax-rules)))))) + diff --git a/lib/init.scm b/lib/init.scm new file mode 100644 index 00000000..d5191caf --- /dev/null +++ b/lib/init.scm @@ -0,0 +1,875 @@ +;; init.scm -- R5RS library procedures +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; 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 f ls . lol) + (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls))))) + (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f)))) + +(define (any pred ls) + (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f)) + +(define (every pred ls) + (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t)) + +(define (delq x ls) + (if (pair? ls) + (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls)))) + '())) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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) + (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 (rename 'else) (car cl)) + (if (pair? (cddr expr)) + (error "non-final else in cond" expr) + (cons (rename 'begin) (cdr cl))) + (if (if (null? (cdr cl)) #t (compare (rename '=>) (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 + ((compare (rename 'unquote) (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((compare (rename '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))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (compare (rename '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 (null? (cdr expr)) (error "empty let" expr)) + (if (null? (cddr expr)) (error "no let body" expr)) + ((lambda (bindings) + (if (list? bindings) #f (error "bad let bindings")) + (if (every (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + bindings) + ((lambda (vars vals) + (if (identifier? (cadr expr)) + `((,(rename 'lambda) ,vars + (,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,vars + ,@(cdddr expr)))) + (,(cadr expr) ,@vars))) + ,@vals) + `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals))) + (map car bindings) + (map cadr bindings)) + (error "bad let syntax" expr))) + (if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let*" expr)) + (if (null? (cddr expr)) (error "no let* body" expr)) + (if (null? (cadr expr)) + `(,(rename 'let) () ,@(cddr expr)) + (if (if (list? (cadr expr)) + (every + (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + (cadr expr)) + #f) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))) + (error "bad let* syntax")))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare (rename '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)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; promises + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exceptions + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f))) + +(define (with-exception-handler handler thunk) + (letrec ((orig-handler (current-exception-handler)) + (self (lambda (exn) + (current-exception-handler orig-handler) + (let ((res (handler exn))) + (current-exception-handler self) + res)))) + (current-exception-handler self) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; library functions + +;; 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 . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (and (pair? ls) (if (eq obj (car ls)) ls (lp (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 (if (bignum? x) #t (flonum? x)))) +(define complex? number?) +(define rational? number?) +(define real? number?) +(define (exact? x) (if (fixnum? x) #t (bignum? x))) +(define inexact? flonum?) +(define (integer? x) + (if (fixnum? x) #t (if (bignum? 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 (numerator x) + (if (integer? x) x (numerator (* x 10)))) +(define (denominator x) + (if (exact? x) + 1 + (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10)))))) + +(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) + (if (<= n 9) + (integer->char (+ n (char->integer #\0))) + (integer->char (+ (- n 10) (char->integer #\A))))) +(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)) 55)))) + +(define (number->string num . o) + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-output-string (lambda (out) (write num out))) + (let lp ((n (abs num)) (d (car o)) (res '())) + (if (> n 0) + (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) + (if (null? res) + "0" + (list->string (if (negative? num) (cons #\- 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 (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-output-port)) + (tmp-out (open-output-file file))) + (current-output-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)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dynamic-wind + +(define *dk* (list #f)) + +(define (dynamic-wind before thunk after) + (let ((dk *dk*)) + (set-dk! (cons (cons before after) dk)) + (let ((res (thunk))) (set-dk! dk) res))) + +(define (set-dk! dk) + (if (not (eq? dk *dk*)) + (begin + (set-dk! (cdr dk)) + (let ((before (car (car dk))) (dk dk)) + (set-car! *dk* (cons (cdr (car dk)) before)) + (set-cdr! *dk* dk) + (set-car! dk #f) + (set-cdr! dk '()) + (set! *dk* dk) + (before))))) + +(define (call-with-current-continuation proc) + (let ((dk *dk*)) + (%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((ellipse-specified? (identifier? (cadr 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 'syntax-quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_len (rename'len)) (_length (rename 'length)) + (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error)) + (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define ellipse (rename (if ellipse-specified? (cadr expr) '...))) + (define lits (if ellipse-specified? (caddr expr) (cadr expr))) + (define forms (if ellipse-specified? (cdddr expr) (cddr expr))) + (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))) + (cond + ((not (list? (cddr p))) + (error "dotted ellipse" p)) + ((any (lambda (x) (and (identifier? x) (compare x ellipse))) + (cddr p)) + (error "multiple ellipses" p)) + (else + (let ((len (length (cdr (cdr p))))) + `(,_let ((,_len (,_length ,v))) + (,_and (,_>= ,_len ,len) + (,_let ,_lp ((,_ls ,v) + (,_i (,_- ,_len ,len)) + (,_res (,_quote ()))) + (,_if (,_>= 0 ,_i) + ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p))) + `(,_append ,_ls (,_reverse ,_res)) + dim + vars + k) + (,_lp (,_cdr ,_ls) + (,_- ,_i 1) + (,_cons (,_car ,_ls) ,_res)))))))))) + ((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-escape? x) (and (pair? x) (compare ellipse (car x)))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare ellipse (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 (any (lambda (lit) (compare x lit)) 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 + ((any (lambda (v) (compare t (car v))) vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (cond + ((ellipse-escape? t) + (if (pair? (cdr t)) + (if (pair? (cddr t)) (cddr t) (cadr t)) + (cdr t))) + ((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))))))) + (else (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 for" + (list (rename 'strip-syntactic-closures) _expr))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *config-env* #f) + +(define-syntax import + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (res '())) + (cond + ((null? ls) + (cons 'begin (reverse res))) + (else + (let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*))) + (if (pair? mod+imps) + (lp (cdr ls) + (cons `(%env-copy! + #f + (vector-ref + (eval '(load-module ',(car mod+imps)) *config-env*) + 1) + ',(cdr mod+imps) + #f) + res)) + (error "couldn't find module" (car ls)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SRFI-0 + +(define-syntax cond-expand + (er-macro-transformer + (lambda (expr rename compare) + (define (check x) + (if (pair? x) + (case (car x) + ((and) (every check (cdr x))) + ((or) (any check (cdr x))) + ((not) (not (check (cadr x)))) + (else (error "cond-expand: bad feature" x))) + (memq (identifier->symbol x) *features*))) + (let expand ((ls (cdr expr))) + (cond ((null? ls) (error "cond-expand: no expansions" expr)) + ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) + ((eq? 'else (identifier->symbol (caar ls))) + (if (pair? (cdr ls)) + (error "cond-expand: else in non-final position") + `(,(rename 'begin) ,@(cdar ls)))) + ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) + (else (expand (cdr ls)))))))) + diff --git a/lib/srfi/1.module b/lib/srfi/1.module new file mode 100644 index 00000000..3d3da044 --- /dev/null +++ b/lib/srfi/1.module @@ -0,0 +1,31 @@ + +(define-module (srfi 1) + (export + xcons cons* make-list list-tabulate list-copy circular-list iota + proper-list? circular-list? dotted-list? not-pair? null-list? list= + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr take drop take-right drop-right take! drop-right! split-at split-at! + last last-pair length+ concatenate append! concatenate! reverse! + append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 count + fold unfold pair-fold reduce fold-right unfold-right + pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter partition remove filter! partition! remove! find find-tail any every + list-index take-while drop-while take-while! span break span! break! + delete delete-duplicates delete! delete-duplicates! + alist-cons alist-copy alist-delete alist-delete! + lset<= lset= lset-adjoin lset-union lset-union! lset-intersection + lset-intersection! lset-difference lset-difference! lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection!) + (import (scheme)) + (include "1/predicates.scm" + "1/selectors.scm" + "1/search.scm" + "1/misc.scm" + "1/constructors.scm" + "1/fold.scm" + "1/deletion.scm" + "1/alists.scm" + "1/lset.scm")) + diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm new file mode 100644 index 00000000..a35db42c --- /dev/null +++ b/lib/srfi/1/alists.scm @@ -0,0 +1,14 @@ +;; alist.scm -- association list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (alist-cons key value ls) (cons (cons key value) ls)) + +(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls)) + +(define (alist-delete key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (remove (lambda (x) (eq (car x) key)) ls))) + +(define alist-delete! alist-delete) + diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm new file mode 100644 index 00000000..1f8a8d5e --- /dev/null +++ b/lib/srfi/1/constructors.scm @@ -0,0 +1,36 @@ +;; constructors.scm -- list construction utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (xcons a b) (cons b a)) + +(define (cons* x . args) + (let lp ((rev '()) (x x) (ls args)) + (if (null? ls) + (append-reverse rev x) + (lp (cons x rev) (car ls) (cdr ls))))) + +(define (make-list n . o) + (let ((default (if (pair? o) (car o)))) + (let lp ((n n) (res '())) + (if (<= n 0) res (lp (- n 1) (cons default res)))))) + +(define (list-tabulate n proc) + (let lp ((n n) (res '())) + (if (< n 0) res (lp (- n 1) (cons (proc n) res))))) + +(define (list-copy ls) (reverse! (reverse ls))) + +(define (circular-list x . args) + (let ((res (cons x args))) + (set-cdr! (last-pair res) res) + res)) + +(define (iota count . o) + (let ((start (if (pair? o) (car o) 0)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) + (let lp ((i count) (n (+ start (* (- count 1) step))) (res '())) + (if (<= i 0) + res + (lp (- i 1) (- n step) (cons n res)))))) + diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm new file mode 100644 index 00000000..70ee5cc5 --- /dev/null +++ b/lib/srfi/1/deletion.scm @@ -0,0 +1,25 @@ +;; deletion.scm -- list deletion utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (delete x ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (if (eq? eq eq?) + (let lp ((ls ls) (rev '())) ;; fast path for delq + (let ((tail (memq x ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls)))) + (filter (lambda (y) (eq x y)) ls)))) + +(define delete! delete) + +(define (delete-duplicates ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res))) + (reverse! res))))) + +(define delete-duplicates! delete-duplicates) + diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm new file mode 100644 index 00000000..892b075c --- /dev/null +++ b/lib/srfi/1/fold.scm @@ -0,0 +1,115 @@ +;; fold.scm -- list fold/reduce utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (map-onto car lists (list acc)))) + acc)))) + +(define (fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (map-onto car lists (lp (map cdr lists)))) + knil)))) + +(define (pair-fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (append lists (list acc)))) + acc)))) + +(define (pair-fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (append lists (lp (map cdr lists)))) + knil)))) + +(define (reduce f identity ls) + (if (null? ls) identity (fold f (car ls) (cdr ls)))) + +(define (reduce-right f identity ls) + (if (null? ls) identity (fold-right f (car ls) (cdr ls)))) + +(define (unfold p f g seed . o) + (let lp ((seed seed)) + (if (p seed) + (if (pair? o) ((car o) seed) '()) + (cons (f seed) (lp (g seed)))))) + +(define (unfold-right p f g seed . o) + (let lp ((seed seed) (res (if (pair? o) (car o) '()))) + (if (p seed) res (lp (g seed) (cons (f seed) res))))) + +(define (append-map-helper append f ls lists) + (if (null? lists) + (if (null? ls) + '() + (let ((rev-ls (reverse ls))) + (let lp ((ls (cdr rev-ls)) (res (car rev-ls))) + (if (null? ls) res (lp (cdr ls) (append (f (car ls) res)))) + ))) + (if (and (pair? ls) (every pair? lists)) + (let lp ((lists (cons ls lists))) + (let ((vals (apply f (map car lists))) + (cdrs (map cdr lists))) + (if (every pair? cdrs) (append vals (lp cdrs)) vals))) + '()))) + +(define (append-map f ls . lists) + (append-map-helper append f ls lists)) + +(define (append-map! f ls . lists) + (append-map-helper append! f ls lists)) + +(define map! map) +(define map-in-order map) + +(define (pair-for-each f ls . lists) + (apply pair-fold (lambda (x _) (f x)) ls lists)) + +(define (filter-map f ls . lists) + (if (null? lists) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res))) + (reverse! res))) + (filter (lambda (x) x) (apply map f ls lists)))) + +(define (take-up-to-reverse from to init) + (if (eq? from to) + init + (take-up-to-reverse (cdr from) to (cons (car from) init)))) + +(define (remove pred ls) + (let lp ((ls ls) (rev '())) + (let ((tail (find-tail pred ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls))))) + +(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls)) + +(define (partition pred ls) + (let lp ((ls ls) (good '()) (bad '())) + (cond ((null? ls) (values (reverse! good) (reverse! bad))) + ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad)) + (else (lp (cdr ls) good (cons (car ls) bad)))))) + +(define filter! filter) +(define remove! remove) +(define partition! partition) + diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm new file mode 100644 index 00000000..8565fac3 --- /dev/null +++ b/lib/srfi/1/lset.scm @@ -0,0 +1,51 @@ +;; lset.scm -- list set library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (lset<= eq . sets) + (if (null? sets) + #t + (let lp1 ((set1 (car sets)) (sets (cdr sets))) + (if (null? sets) + #t + (let ((set2 (car sets))) + (let lp2 ((ls set1)) + (if (pair? ls) + (and (member (car set1) set2 eq) (lp2 (cdr ls))) + (lp1 set2 (cdr sets))))))))) + +(define (lset= eq . sets) + (and (apply lset<= eq sets) (apply lset<= eq (reverse sets)))) + +(define (lset-adjoin eq set . elts) + (lset-union2 eq elts set)) + +(define (lset-union2 eq a b) + (if (null? b) + a + (lset-union2 eq (if (member (car b) a eq) a (cons (car b) a)) (cdr b)))) + +(define (lset-union eq . sets) + (reduce (lambda (a b) (lset-union2 eq a b)) '() sets)) + +(define (lset-intersection eq . sets) + (reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-difference eq . sets) + (reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-xor eq . sets) + (reduce (lambda (a b) + (append (filter (lambda (x) (member x b eq)) a) + (filter (lambda (x) (member x a eq)) b))) + '() + sets)) + +(define (lset-diff+intersection eq . sets) + (values (apply lset-difference eq sets) (apply lset-intersection eq sets))) + +(define lset-diff+intersection! lset-diff+intersection) +(define lset-xor! lset-xor) +(define lset-difference! lset-difference) +(define lset-intersection! lset-intersection) +(define lset-union! lset-union) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm new file mode 100644 index 00000000..1e7568df --- /dev/null +++ b/lib/srfi/1/misc.scm @@ -0,0 +1,54 @@ +;; misc.scm -- miscellaneous list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (map-onto proc ls init) + (let lp ((ls ls) (res init)) + (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res))))) + +(define (append! . lists) (concatenate! lists)) + +(define (concatenate lists) + (let lp ((ls (reverse lists)) (res '())) + (if (null? ls) res (lp (cdr ls) (append (car ls) res))))) + +(define (concatenate! lists) + (if (null? lists) + '() + (let lp ((ls lists)) + (cond ((not (pair? (cdr ls))) + lists) + (else + (set-cdr! (last-pair (car ls)) (cadr ls)) + (lp (cdr ls))))))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define (append-reverse! rev tail) + (if (null? rev) + tail + (let ((head (reverse! rev))) + (set-cdr! rev tail) + head))) + +(define (zip . lists) (apply map list lists)) + +(define (unzip1 ls) (map car ls)) +(define (unzip2 ls) (values (map car ls) (map cadr ls))) +(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls))) +(define (unzip4 ls) + (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) +(define (unzip5 ls) + (values (map car ls) (map cadr ls) (map caddr ls) + (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls))) + +(define (count pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (res 0)) + (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res)) + (let lp ((lists (cons ls lists)) (res 0)) + (if (every pair? lists) + (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res)) + res)))) + diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm new file mode 100644 index 00000000..be84e085 --- /dev/null +++ b/lib/srfi/1/predicates.scm @@ -0,0 +1,42 @@ +;; predicates.scm -- list prediates +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (proper-list? x) + (cond ((null? x) #t) + ((pair? x) (proper-list? (cdr x))) + (else #f))) + +(define (circular-list? x) + (and (pair? x) (pair? (cdr x)) + (let race ((hare (cdr x)) (tortoise x)) + (or (eq? hare tortoise) + (and (pair? hare) (pair? (cdr hare)) + (race (cddr hare) (cdr tortoise))))))) + +(define (dotted-list? x) + (not (proper-list? x))) + +(define (not-pair? x) (not (pair? x))) + +(define (null-list? x) (null? x)) ; no error + +(define (list= eq . lists) + (let lp1 ((lists lists)) + (or (null? lists) + (null? (cdr lists)) + (let lp2 ((ls1 (car lists)) (ls2 (cadr lists))) + (if (null? ls1) + (and (null? ls2) + (lp1 (cdr lists))) + (and (eq (car ls1) (car ls2)) + (lp2 (cdr ls1) (cdr ls2)))))))) + +(define (length+ x) + (if (not (pair? x)) + 0 + (let lp ((hare (cdr x)) (tortoise x) (res 0)) + (and (not (eq? hare tortoise)) + (if (pair? hare) + (lp (cddr hare) (cdr tortoise) (+ res 1)) + res))))) diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm new file mode 100644 index 00000000..ea31d931 --- /dev/null +++ b/lib/srfi/1/search.scm @@ -0,0 +1,54 @@ +;; search.scm -- list searching and splitting +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (find pred ls) + (cond ((find-tail pred ls) => car) (else #f))) + +(define (find-tail pred ls) + (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls))))) + +(define (take-while pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (reverse! res)))) + +(define take-while! take-while) + +(define (drop-while pred ls) + (or (find-tail (lambda (x) (not (pred x))) ls) '())) + +(define (span pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (values (reverse! res) ls)))) + +(define span! span) + +(define (break pred ls) (span (lambda (x) (not (pred x))) ls)) + +(define break! break) + +(define (any pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls))))) + (let lp ((lists (cons ls lists))) + (and (every pair? lists) + (let ((args (map car lists))) + (if (apply pred args) args (lp (map cdr lists)))))))) + +(define (every pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t)) + (not (apply any (lambda (x) (not (pred x))) ls lists)))) + +(define (list-index pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (n 0)) + (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1))))) + (let lp ((lists (cons ls lists)) (n 0)) + (and (every pair? lists) + (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1))) + )))) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm new file mode 100644 index 00000000..74ef7119 --- /dev/null +++ b/lib/srfi/1/selectors.scm @@ -0,0 +1,59 @@ +;; selectors.scm -- extended list selectors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth ls) (car (cdr (cdr (cdr (cdr ls)))))) +(define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls))))))) +(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (eighth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (ninth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))) +(define (tenth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))) + +(define (car+cdr x) (values (car x) (cdr x))) + +(define (take ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (reverse! res) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (take! ls i) + (if (<= i 0) + '() + (let ((tail (list-tail ls (- i 1)))) + (set-cdr! tail '()) + ls))) + +(define (drop ls i) + (if (<= i 0) ls (drop (cdr ls) (- i 1)))) + +(define (take-right ls i) + (drop ls (- (length+ ls) i))) + +(define (drop-right ls i) + (take ls (- (length+ ls) i))) + +(define (drop-right! ls i) + (take! ls (- (length+ ls) i))) + +(define (split-at ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (values (reverse! res) ls) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (split-at! ls i) + (if (<= i 0) + (values '() ls) + (let* ((tail (list-tail ls (- i 1))) + (right (cdr tail))) + (set-cdr! tail '()) + (values ls right)))) + +(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls)))) +(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls)))) + diff --git a/lib/srfi/11.module b/lib/srfi/11.module new file mode 100644 index 00000000..f3c91df8 --- /dev/null +++ b/lib/srfi/11.module @@ -0,0 +1,28 @@ + +(define-module (srfi 11) + (export let-values let*-values) + (import-immutable (scheme)) + (body + (define-syntax let*-values + (syntax-rules () + ((let*-values () . body) + (begin . body)) + ((let*-values (((a) expr) . rest) . body) + (let ((a expr)) (let*-values rest . body))) + ((let*-values ((params expr) . rest) . body) + (call-with-values (lambda () expr) + (lambda params (let*-values rest . body)))))) + (define-syntax let-values + (syntax-rules () + ((let-values ("step") (binds ...) bind expr maps () () . body) + (let*-values (binds ... (bind expr)) (let maps . body))) + ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body) + (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body) + (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body) + (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body)) + ((let-values ((params expr) . rest) . body) + (let-values ("step") () () expr () params rest . body)) + )))) + diff --git a/lib/srfi/16.module b/lib/srfi/16.module new file mode 100644 index 00000000..f931a376 --- /dev/null +++ b/lib/srfi/16.module @@ -0,0 +1,24 @@ + +(define-module (srfi 16) + (export case-lambda) + (import-immutable (scheme)) + (body + (define-syntax %case + (syntax-rules () + ((%case args len n p ((params ...) . body) . rest) + (if (= len (length '(params ...))) + (apply (lambda (params ...) . body) args) + (%case args len 0 () . rest))) + ((%case args len n (p ...) ((x . y) . body) . rest) + (%case args len (+ n 1) (p ... x) (y . body) . rest)) + ((%case args len n (p ...) (y . body) . rest) + (if (>= len n) + (apply (lambda (p ... y) . body) args) + (%case args len 0 () . rest))) + ((%case args len n p) + (error "case-lambda: no cases matched")))) + (define-syntax case-lambda + (syntax-rules () + ((case-lambda . clauses) + (lambda args (let ((len (length args))) (%case args len 0 () . clauses)))))))) + diff --git a/lib/srfi/18.module b/lib/srfi/18.module new file mode 100644 index 00000000..930e800e --- /dev/null +++ b/lib/srfi/18.module @@ -0,0 +1,23 @@ + +(define-module (srfi 18) + (export + current-thread thread? make-thread thread-name + thread-specific thread-specific-set! thread-start! + thread-yield! thread-sleep! thread-terminate! + thread-join! mutex? make-mutex mutex-name + mutex-specific mutex-specific-set! mutex-state + mutex-lock! mutex-unlock! condition-variable? + make-condition-variable condition-variable-name + condition-variable-specific condition-variable-specific-set! + condition-variable-signal! condition-variable-broadcast! + current-time time? time->seconds seconds->time + current-exception-handler with-exception-handler raise + join-timeout-exception? abandoned-mutex-exception? + terminated-thread-exception? uncaught-exception? + uncaught-exception-reason) + (import-immutable (scheme) + (srfi 9) + (chibi time)) + (include-shared "18/threads") + (include "18/types.scm" "18/interface.scm")) + diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm new file mode 100644 index 00000000..7dde92aa --- /dev/null +++ b/lib/srfi/18/interface.scm @@ -0,0 +1,39 @@ + +(define (thread-join! thread . o) + (let ((timeout (if (pair? o) (car o) #f))) + (cond + ((%thread-join! thread timeout)) + (else + (thread-yield!) + (if (thread-timeout?) + (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (error "timed out waiting for thread" thread)) + #t))))) + +(define (thread-terminate! thread) + (if (%thread-terminate! thread) ;; need to yield if terminating ourself + (thread-yield!))) + +(define (thread-sleep! timeout) + (%thread-sleep! timeout) + (thread-yield!)) + +(define (mutex-lock! mutex . o) + (let ((timeout (and (pair? o) (car o))) + (thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t))) + (cond ((%mutex-lock! mutex timeout thread)) + (else + (thread-yield!) + (not (thread-timeout?)))))) + +(define (mutex-unlock! mutex . o) + (let ((condvar (and (pair? o) (car o))) + (timeout (if (and (pair? o) (pair? (cdr o))) (cadr o) #f))) + (cond ((%mutex-unlock! mutex condvar timeout)) + (else + (thread-yield!) + (not (thread-timeout?)))))) + +(define current-time get-time-of-day) +(define time? timeval?) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c new file mode 100644 index 00000000..046d8bf4 --- /dev/null +++ b/lib/srfi/18/threads.c @@ -0,0 +1,383 @@ +/* threads.c -- SRFI-18 thread primitives */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include +#include +#include + +#define sexp_mutex_name(x) sexp_slot_ref(x, 0) +#define sexp_mutex_specific(x) sexp_slot_ref(x, 1) +#define sexp_mutex_thread(x) sexp_slot_ref(x, 2) +#define sexp_mutex_lockp(x) sexp_slot_ref(x, 3) + +#define sexp_condvar_name(x) sexp_slot_ref(x, 0) +#define sexp_condvar_specific(x) sexp_slot_ref(x, 1) +#define sexp_condvar_threads(x) sexp_slot_ref(x, 2) + +#define timeval_le(a, b) (((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec < (b).tv_usec))) +#define sexp_context_before(c, t) (((sexp_context_timeval(c).tv_sec != 0) || (sexp_context_timeval(c).tv_usec != 0)) && timeval_le(sexp_context_timeval(c), t)) + +/* static int mutex_id, condvar_id; */ + +/**************************** threads *************************************/ + +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); + sexp_gc_release2(ctx); +} + +sexp sexp_thread_timeoutp (sexp ctx sexp_api_params(self, n)) { + return sexp_make_boolean(sexp_context_timeoutp(ctx)); +} + +sexp sexp_thread_name (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + return sexp_context_name(thread); +} + +sexp sexp_thread_specific (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + return sexp_context_specific(thread); +} + +sexp sexp_thread_specific_set (sexp ctx sexp_api_params(self, n), sexp thread, sexp val) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + sexp_context_specific(thread) = val; + return SEXP_VOID; +} + +sexp sexp_current_thread (sexp ctx sexp_api_params(self, n)) { + return ctx; +} + +sexp sexp_make_thread (sexp ctx sexp_api_params(self, n), sexp thunk, sexp name) { + sexp res, *stack; + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk); + res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0); + sexp_context_proc(res) = thunk; + sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk)); + stack = sexp_stack_data(sexp_context_stack(res)); + stack[0] = stack[1] = stack[3] = SEXP_ZERO; + stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + sexp_context_top(res) = 4; + sexp_context_last_fp(res) = 0; + return res; +} + +sexp sexp_thread_start (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp cell; + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + cell = sexp_cons(ctx, thread, SEXP_NULL); + if (sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = cell; + sexp_global(ctx, SEXP_G_THREADS_BACK) = cell; + } else { /* init queue */ + sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) = cell; + } + return SEXP_VOID; +} + +sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_context_refuel(thread) = 0; + for ( ; sexp_pairp(ls2) && (sexp_car(ls2) != thread); ls2=sexp_cdr(ls2)) + ls1 = ls2; + if (sexp_pairp(ls2)) { + if (ls1 == SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(ls2); + else /* splice */ + sexp_cdr(ls1) = sexp_cdr(ls2); + if (ls2 == sexp_global(ctx, SEXP_G_THREADS_BACK)) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1; + } else { /* check for paused threads */ + ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + for ( ; sexp_pairp(ls2) && (sexp_car(ls2) != thread); ls2=sexp_cdr(ls2)) + ls1 = ls2; + if (sexp_pairp(ls2)) { + if (ls1 == SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else /* splice */ + sexp_cdr(ls1) = sexp_cdr(ls2); + } + } + /* return true if terminating self */ + return sexp_make_boolean(ctx == thread); +} + +static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { +#if SEXP_USE_FLONUMS + double d; +#endif + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + if (sexp_integerp(timeout) || sexp_flonump(timeout)) + gettimeofday(&sexp_context_timeval(ctx), NULL); + if (sexp_integerp(timeout)) { + sexp_context_timeval(ctx).tv_sec += sexp_unbox_fixnum(timeout); +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(timeout)) { + d = sexp_flonum_value(timeout); + sexp_context_timeval(ctx).tv_sec += trunc(d); + sexp_context_timeval(ctx).tv_usec += (d-trunc(d))*1000000; +#endif + } else { + sexp_context_timeval(ctx).tv_sec = 0; + sexp_context_timeval(ctx).tv_usec = 0; + } + if (sexp_numberp(timeout)) + while (sexp_pairp(ls2) + && sexp_context_before(sexp_car(ls2), sexp_context_timeval(ctx))) + ls1=ls2, ls2=sexp_cdr(ls2); + else + while (sexp_pairp(ls2) && sexp_context_timeval(sexp_car(ls2)).tv_sec) + ls1=ls2, ls2=sexp_cdr(ls2); + if (ls1 == SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cons(ctx, thread, ls2); + else + sexp_cdr(ls1) = sexp_cons(ctx, thread, ls2); +} + +sexp sexp_thread_join (sexp ctx sexp_api_params(self, n), sexp thread, sexp timeout) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + if (sexp_context_refuel(thread) <= 0) /* return true if already terminated */ { + return SEXP_TRUE; + } + sexp_context_timeoutp(ctx) = 0; + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = thread; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; +} + +sexp sexp_thread_sleep (sexp ctx sexp_api_params(self, n), sexp timeout) { + sexp_assert_type(ctx, sexp_numberp, SEXP_NUMBER, timeout); + sexp_context_waitp(ctx) = 1; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; +} + +/**************************** mutexes *************************************/ + +sexp sexp_mutex_state (sexp ctx sexp_api_params(self, n), sexp mutex) { + /* sexp_assert_type(ctx, sexp_mutexp, mutex_id, timeout); */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + if (sexp_contextp(sexp_mutex_thread(mutex))) + return sexp_mutex_thread(mutex); + else + return sexp_intern(ctx, "not-owned", -1); + } else { + return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1); + } +} + +sexp sexp_mutex_lock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp timeout, sexp thread) { + if (thread == SEXP_TRUE) + thread = ctx; + if (sexp_not(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_TRUE; + sexp_mutex_thread(mutex) = thread; + return SEXP_TRUE; + } else { + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = mutex; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; + } +} + +sexp sexp_mutex_unlock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp condvar, sexp timeout) { + sexp ls1, ls2; + if (sexp_not(condvar)) { + /* normal unlock - always succeeds, just need to unblock threads */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_FALSE; + sexp_mutex_thread(mutex) = ctx; + /* search for threads blocked on this mutex */ + for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == mutex) { + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2; + if (! sexp_pairp(sexp_cdr(ls2))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + sexp_context_waitp(sexp_car(ls2)) + = sexp_context_timeoutp(sexp_car(ls2)) = 0; + break; + } + } + return SEXP_TRUE; + } else { + /* wait on condition var */ + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = condvar; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; + } +} + +/**************************** condition variables *************************/ + +sexp sexp_condition_variable_signal (sexp ctx sexp_api_params(self, n), sexp condvar) { + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + for ( ; sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == condvar) { + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2; + if (! sexp_pairp(sexp_cdr(ls2))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + sexp_context_waitp(sexp_car(ls2)) = sexp_context_timeoutp(sexp_car(ls2)) = 0; + return SEXP_TRUE; + } + return SEXP_FALSE; +} + +sexp sexp_condition_variable_broadcast (sexp ctx sexp_api_params(self, n), sexp condvar) { + sexp res = SEXP_FALSE; + while (sexp_truep(sexp_condition_variable_signal(ctx, self, n, condvar))) + res = SEXP_TRUE; + return res; +} + +/**************************** the scheduler *******************************/ + +void sexp_wait_on_single_thread (sexp ctx) { + struct timeval tval; + useconds_t usecs = 0; + gettimeofday(&tval, NULL); + if (tval.tv_sec < sexp_context_timeval(ctx).tv_sec) + usecs = (sexp_context_timeval(ctx).tv_sec - tval.tv_sec) * 1000000; + if (tval.tv_usec < sexp_context_timeval(ctx).tv_usec) + usecs += sexp_context_timeval(ctx).tv_usec - tval.tv_usec; + usleep(usecs); +} + +sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { + struct timeval tval; + sexp res, ls1, ls2, tmp, paused, front=sexp_global(ctx, SEXP_G_THREADS_FRONT); + + paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); + + /* if we've terminated, check threads joining us */ + if (sexp_context_refuel(ctx) <= 0) { + for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { + if (sexp_context_event(sexp_car(ls2)) == ctx) { + sexp_context_waitp(sexp_car(ls2)) = 0; + sexp_context_timeoutp(sexp_car(ls2)) = 0; + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + tmp = sexp_cdr(ls2); + sexp_cdr(ls2) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + ls2 = tmp; + } else { + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + } + } + + /* check timeouts */ + if (sexp_pairp(paused)) { + if (gettimeofday(&tval, NULL) == 0) { + ls1 = SEXP_NULL; + ls2 = paused; + while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), tval)) { + sexp_context_timeoutp(sexp_car(ls2)) = 1; + sexp_context_waitp(ctx) = 0; + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + if (sexp_pairp(ls1)) { + sexp_cdr(ls1) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = paused; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1; + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = ls2; + } + } + } + + /* dequeue next thread */ + if (sexp_pairp(front)) { + res = sexp_car(front); + if ((sexp_context_refuel(ctx) <= 0) || sexp_context_waitp(ctx)) { + /* either terminated or paused */ + sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(front); + if (! sexp_pairp(sexp_cdr(front))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + } else { + /* swap with front of queue */ + sexp_car(sexp_global(ctx, SEXP_G_THREADS_FRONT)) = ctx; + /* rotate front of queue to back */ + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) + = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) + = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_FRONT)); + sexp_global(ctx, SEXP_G_THREADS_BACK) + = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)); + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = SEXP_NULL; + } + } else { + res = ctx; + } + + if (sexp_context_waitp(res)) { + /* the only thread available was waiting */ + sexp_wait_on_single_thread(res); + sexp_context_timeoutp(res) = 1; + sexp_context_waitp(res) = 0; + } + + return res; +} + +/**************************************************************************/ + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + + sexp_define_type_predicate(ctx, env, "thread?", SEXP_CONTEXT); + sexp_define_foreign(ctx, env, "thread-timeout?", 0, sexp_thread_timeoutp); + sexp_define_foreign(ctx, env, "current-thread", 0, sexp_current_thread); + sexp_define_foreign_opt(ctx, env, "make-thread", 2, sexp_make_thread, SEXP_FALSE); + sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start); + sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate); + sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join); + sexp_define_foreign(ctx, env, "%thread-sleep!", 1, sexp_thread_sleep); + sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name); + sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific); + sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set); + sexp_define_foreign(ctx, env, "mutex-state", 1, sexp_mutex_state); + sexp_define_foreign(ctx, env, "%mutex-lock!", 3, sexp_mutex_lock); + sexp_define_foreign(ctx, env, "%mutex-unlock!", 3, sexp_mutex_unlock); + sexp_define_foreign(ctx, env, "condition-variable-signal!", 1, sexp_condition_variable_signal); + sexp_define_foreign(ctx, env, "condition-variable-broadcast!", 1, sexp_condition_variable_broadcast); + + sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) + = sexp_make_foreign(ctx, "scheduler", 0, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); + + return SEXP_VOID; +} + diff --git a/lib/srfi/18/types.scm b/lib/srfi/18/types.scm new file mode 100644 index 00000000..093c97a7 --- /dev/null +++ b/lib/srfi/18/types.scm @@ -0,0 +1,24 @@ +;; types.scm -- thread types +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type mutex + (%make-mutex name specific thread lock) + mutex? + (name mutex-name) + (specific mutex-specific mutex-specific-set!) + (thread %mutex-thread %mutex-thread-set!) + (lock %mutex-lock %mutex-lock-set!)) + +(define (make-mutex . o) + (%make-mutex (and (pair? o) (car o)) #f #f #f)) + +(define-record-type condition-variable + (%make-condition-variable name specific threads) + condition-variable? + (name condition-variable-name) + (specific condition-variable-specific condition-variable-specific-set!) + (threads %condition-variable-threads %condition-variable-threads-set!)) + +(define (make-condition-variable . o) + (%make-condition-variable (and (pair? o) (car o)) #f #f)) diff --git a/lib/srfi/2.module b/lib/srfi/2.module new file mode 100644 index 00000000..4ceb8b6b --- /dev/null +++ b/lib/srfi/2.module @@ -0,0 +1,16 @@ + +(define-module (srfi 2) + (export and-let*) + (import-immutable (scheme)) + (body + (define-syntax and-let* + (syntax-rules () + ((and-let* () . body) + (begin . body)) + ((and-let* ((var expr) . rest) . body) + (let ((var expr)) + (and var (and-let* rest . body)))) + ((and-let* ((expr) . rest) . body) + (let ((tmp expr)) + (and tmp (and-let* rest . body)))))))) + diff --git a/lib/srfi/26.module b/lib/srfi/26.module new file mode 100644 index 00000000..f97ab783 --- /dev/null +++ b/lib/srfi/26.module @@ -0,0 +1,24 @@ + +(define-module (srfi 26) + (export cut cute) + (import-immutable (scheme)) + (body + (define-syntax %cut + (syntax-rules (<> <...>) + ((%cut e? params args) + (lambda params args)) + ((%cut e? (params ...) (args ...) <> . rest) + (%cut e? (params ... tmp) (args ... tmp) . rest)) + ((%cut e? (params ...) (args ...) <...>) + (%cut e? (params ... . tmp) (apply args ... tmp))) + ((%cut e? (params ...) (args ...) <...> . rest) + (error "cut: non-terminal <...>")) + ((%cut #t (params ...) (args ...) x . rest) + (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest))) + ((%cut #f (params ...) (args ...) x . rest) + (%cut #t (params ...) (args ... x) . rest)))) + (define-syntax cut + (syntax-rules () ((cut args ...) (%cut #f () () args ...)))) + (define-syntax cute + (syntax-rules () ((cute args ...) (%cut #t () () args ...)))))) + diff --git a/lib/srfi/27.module b/lib/srfi/27.module new file mode 100644 index 00000000..5c451629 --- /dev/null +++ b/lib/srfi/27.module @@ -0,0 +1,11 @@ + +(define-module (srfi 27) + (export random-integer random-real default-random-source + make-random-source random-source? + random-source-state-ref random-source-state-set! + random-source-randomize! random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals) + (import-immutable (scheme)) + (include-shared "27/rand") + (include "27/constructors.scm")) + diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm new file mode 100644 index 00000000..dbd0a8c6 --- /dev/null +++ b/lib/srfi/27/constructors.scm @@ -0,0 +1,10 @@ +;; constructors.scm -- random function constructors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (random-source-make-integers rs) + (lambda (n) (%random-integer rs n))) + +(define (random-source-make-reals rs . o) + (lambda () (%random-real rs))) + diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c new file mode 100644 index 00000000..d70f8726 --- /dev/null +++ b/lib/srfi/27/rand.c @@ -0,0 +1,204 @@ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include + +#define SEXP_RANDOM_STATE_SIZE 128 + +#define ZERO sexp_make_fixnum(0) +#define ONE sexp_make_fixnum(1) +#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE) + +#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id) + +#define sexp_random_init(x, seed) \ + initstate_r(seed, \ + sexp_string_data(sexp_random_state(x)), \ + SEXP_RANDOM_STATE_SIZE, \ + sexp_random_data(x)) + +#if SEXP_BSD +typedef unsigned int sexp_random_t; +#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs))) +#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n) +#else +typedef struct random_data sexp_random_t; +#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst) +#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs)) +#endif + +#define sexp_random_state(x) (sexp_slot_ref((x), 0)) +#define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1))) + +#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp)) + +static sexp_uint_t rs_type_id; +static sexp default_random_source; + +static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, sexp bound) { + sexp res; + int32_t m; +#if SEXP_USE_BIGNUMS + int32_t hi, mod, len, i, *data; +#endif + if (! sexp_random_source_p(rs)) + res = sexp_type_exception(ctx, self, rs_type_id, rs); + if (sexp_fixnump(bound)) { + sexp_call_random(rs, m); + res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(bound)) { + hi = sexp_bignum_hi(bound); + len = hi * sizeof(sexp_uint_t) / sizeof(int32_t); + res = sexp_make_bignum(ctx, hi); + data = (int32_t*) sexp_bignum_data(res); + for (i=0; i +#include + +#if SEXP_USE_BIGNUMS +#include +#else +#define sexp_bignum_normalize(x) x +#endif + +static sexp sexp_bit_and (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { + sexp res; +#if SEXP_USE_BIGNUMS + sexp_sint_t len, i; +#endif + if (sexp_fixnump(x)) { + if (sexp_fixnump(y)) + res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(y)) + res = sexp_bit_and(ctx sexp_api_pass(self, n), y, x); +#endif + else + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + if (sexp_fixnump(y)) { + res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); + } else if (sexp_bignump(y)) { + if (sexp_bignum_length(x) < sexp_bignum_length(y)) + res = sexp_copy_bignum(ctx, NULL, x, 0); + else + res = sexp_copy_bignum(ctx, NULL, y, 0); + for (i=0, len=sexp_bignum_length(res); i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i> -c); + } else { + tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c; +#if SEXP_USE_BIGNUMS + if (((tmp >> c) == sexp_unbox_fixnum(i)) + && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) { +#endif + res = sexp_make_fixnum(tmp); +#if SEXP_USE_BIGNUMS + } else { + sexp_gc_preserve1(ctx, res); + res = sexp_fixnum_to_bignum(ctx, i); + res = sexp_arithmetic_shift(ctx sexp_api_pass(self, n), res, count); + sexp_gc_release1(ctx); + } +#endif + } +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(i)) { + len = sexp_bignum_hi(i); + if (c < 0) { + c = -c; + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + if (len < offset) { + res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1); + } else { + res = sexp_make_bignum(ctx, len - offset + 1); + for (j=len-offset, tmp=0; j>=0; j--) { + sexp_bignum_data(res)[j] + = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp; + tmp = sexp_bignum_data(i)[j+offset] + << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + } + } else { + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + res = sexp_make_bignum(ctx, len + offset + 1); + for (j=tmp=0; j> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + sexp_bignum_data(res)[len+offset] = tmp; + } +#endif + } else { + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + } + return sexp_bignum_normalize(res); +} + +/* bit-count and integer-length were adapted from: */ +/* http://graphics.stanford.edu/~seander/bithacks.html */ +static sexp_uint_t bit_count (sexp_uint_t i) { + i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3); + i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3) + + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3)); + i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15; + return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255)) + >> (sizeof(i) - 1) * CHAR_BIT); +} + +static sexp sexp_bit_count (sexp ctx sexp_api_params(self, n), sexp x) { + sexp res; + sexp_sint_t i; +#if SEXP_USE_BIGNUMS + sexp_uint_t count; +#endif + if (sexp_fixnump(x)) { + i = sexp_unbox_fixnum(x); + res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + for (i=count=0; i> 32)) + return integer_log2(tt) + 32; + else +#endif + if ((tt = x >> 16)) + return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt]; + else + return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; +} + +static sexp sexp_integer_length (sexp ctx sexp_api_params(self, n), sexp x) { + sexp_sint_t tmp; +#if SEXP_USE_BIGNUMS + sexp_sint_t hi; +#endif + if (sexp_fixnump(x)) { + tmp = sexp_unbox_fixnum(x); + return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + hi = sexp_bignum_hi(x); + return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi]) + + hi*sizeof(sexp_uint_t)); +#endif + } else { + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + } +} + +static sexp sexp_bit_set_p (sexp ctx sexp_api_params(self, n), sexp i, sexp x) { +#if SEXP_USE_BIGNUMS + sexp_uint_t pos; +#endif + if (! sexp_fixnump(i)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + if (sexp_fixnump(x)) { + return sexp_make_boolean(sexp_unbox_fixnum(x) & (1<hash-table + hash-table-equivalence-function hash-table-hash-function + hash-table-ref hash-table-ref/default hash-table-set! + hash-table-delete! hash-table-exists? + hash-table-update! hash-table-update!/default + hash-table-size hash-table-keys hash-table-values + hash-table-walk hash-table-fold hash-table->alist + hash-table-copy hash-table-merge! + hash string-hash string-ci-hash hash-by-identity) + (import-immutable (scheme) + (srfi 9)) + (include-shared "69/hash") + (include "69/type.scm" "69/interface.scm")) + diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c new file mode 100644 index 00000000..e739ff1c --- /dev/null +++ b/lib/srfi/69/hash.c @@ -0,0 +1,242 @@ +/* hash.c -- type-general hashing */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define HASH_DEPTH 5 +#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM) + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0) +#define sexp_hash_table_size(x) sexp_slot_ref(x, 1) +#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2) +#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3) + +#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2)) + +static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc % bound; +} + +static sexp sexp_string_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); + return sexp_make_fixnum(string_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= tolower(*str++);} + return acc % bound; +} + +static sexp sexp_string_ci_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); + return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) { + sexp_uint_t acc = FNV_OFFSET_BASIS, size; + sexp_sint_t i, len; + sexp t, *p; + char *p0; + loop: +#if SEXP_USE_FLONUMS + if (sexp_flonump(obj)) + acc ^= (sexp_sint_t) sexp_flonum_value(obj); + else +#endif + if (sexp_pointerp(obj)) { + if (depth) { + t = sexp_object_type(ctx, obj); + p = (sexp*) (((char*)obj) + sexp_type_field_base(t)); + p0 = ((char*)obj) + offsetof(struct sexp_struct, value); + if ((sexp)p == obj) p=(sexp*)p0; + /* hash trailing non-object data */ + size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp)); + if (((char*)obj + size) > p0) + for (i=0; i 0) { + depth--; + for (i=0; ialist table) + (hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '())) + +(define (hash-table-keys table) + (hash-table-fold table (lambda (k v a) (cons k a)) '())) + +(define (hash-table-values table) + (hash-table-fold table (lambda (k v a) (cons v a)) '())) + +(define (alist->hash-table ls . o) + (let ((res (apply make-hash-table o))) + (for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls) + res)) + +(define (hash-table-merge! a b) + (hash-table-walk b (lambda (k v) (hash-table-set! a k v))) + a) + +(define (hash-table-copy table) + (assert-hash-table "hash-table-copy" table) + (let ((res (make-hash-table (hash-table-equivalence-function table)))) + (hash-table-merge! res table) + res)) + diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm new file mode 100644 index 00000000..1fca9953 --- /dev/null +++ b/lib/srfi/69/type.scm @@ -0,0 +1,12 @@ +;; types.scm -- the hash-table record type +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type hash-table + (%make-hash-table buckets size hash-fn eq-fn) + hash-table? + (buckets hash-table-buckets hash-table-buckets-set!) + (size hash-table-size hash-table-size-set!) + (hash-fn %hash-table-hash-function) + (eq-fn %hash-table-equivalence-function)) + diff --git a/lib/srfi/8.module b/lib/srfi/8.module new file mode 100644 index 00000000..64a3e6e2 --- /dev/null +++ b/lib/srfi/8.module @@ -0,0 +1,10 @@ + +(define-module (srfi 8) + (export receive) + (import-immutable (scheme)) + (body + (define-syntax receive + (syntax-rules () + ((receive params expr . body) + (call-with-values (lambda () expr) (lambda params . body))))))) + diff --git a/lib/srfi/9.module b/lib/srfi/9.module new file mode 100644 index 00000000..1c9aad91 --- /dev/null +++ b/lib/srfi/9.module @@ -0,0 +1,85 @@ + +(define-module (srfi 9) + (export define-record-type) + (import-immutable (scheme)) + (body + (define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((name (cadr expr)) + (name-str (symbol->string (identifier->symbol name))) + (make (caaddr expr)) + (make-fields (cdaddr expr)) + (pred (cadddr expr)) + (fields (cddddr expr)) + (num-fields (length fields)) + (index (register-simple-type name-str num-fields)) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let))) + (define (index-of field ls) + (let lp ((ls ls) (i 0)) + (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) + `(,(rename 'begin) + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string (identifier->symbol pred)) + ,index)) + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string + (identifier->symbol (cadar ls))) + ,index + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string + (identifier->symbol (caddar ls))) + ,index + ,i)) + res) + res))))) + (,_define ,make + ,(let lp ((ls make-fields) (sets '()) (set-defs '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string (identifier->symbol make)) + ,index)) + ,@set-defs) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets) + set-defs)) + (else + (let* ((setter-name + (string-append "%" name-str "-" + (symbol->string (car ls)) "-set!")) + (setter (rename (string->symbol setter-name))) + (i (index-of (car ls) fields))) + (lp (cdr ls) + (cons (list setter 'res (car ls)) sets) + (cons (list setter + (list (rename 'make-setter) + setter-name + index + (index-of (car ls) fields))) + set-defs))))))))))))))))) + diff --git a/lib/srfi/95.module b/lib/srfi/95.module new file mode 100644 index 00000000..43bab9dd --- /dev/null +++ b/lib/srfi/95.module @@ -0,0 +1,7 @@ + +(define-module (srfi 95) + (export sorted? merge merge! sort sort! object-cmp) + (import-immutable (scheme)) + (include-shared "95/qsort") + (include "95/sort.scm")) + diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c new file mode 100644 index 00000000..0f430874 --- /dev/null +++ b/lib/srfi/95/qsort.c @@ -0,0 +1,228 @@ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#if SEXP_USE_HUFF_SYMS +#include "../../../opt/sexp-hufftabs.c" +#endif + +#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var) + +static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) { + sexp_sint_t i; + sexp ls, *data=sexp_vector_data(vec); + for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls)) + sexp_car(ls) = data[i]; + return seq; +} + +static sexp sexp_vector_nreverse (sexp ctx, sexp vec) { + int i, j; + sexp tmp, *data=sexp_vector_data(vec); + for (i=0, j=sexp_vector_length(vec)-1; i>3, d = ((sexp_uint_t)b)>>3; + while (c && d) { +#include "../../../opt/sexp-unhuff.c" +#define c d +#define res res2 +#include "../../../opt/sexp-unhuff.c" +#undef c +#undef res + if ((tmp=res-res2) != 0) + return tmp; + } + return c ? 1 : d ? -1 : 0; +} +#endif + +static int sexp_object_compare (sexp ctx, sexp a, sexp b) { + int res; + if (a == b) + return 0; + if (sexp_pointerp(a)) { + if (sexp_pointerp(b)) { + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) { + res = sexp_pointer_tag(a) - sexp_pointer_tag(b); + } else { + switch (sexp_pointer_tag(a)) { + case SEXP_FLONUM: + res = sexp_flonum_value(a) - sexp_flonum_value(b); + break; + case SEXP_BIGNUM: + res = sexp_bignum_compare(a, b); + break; + case SEXP_STRING: + res = strcmp(sexp_string_data(a), sexp_string_data(b)); + break; + case SEXP_SYMBOL: + res = strcmp(sexp_string_data(sexp_symbol_string(a)), + sexp_string_data(sexp_symbol_string(b))); + break; + default: + res = 0; + break; + } + } +#if SEXP_USE_HUFF_SYMS + } else if (sexp_lsymbolp(a) && sexp_isymbolp(b)) { + res = strcmp(sexp_string_data(sexp_symbol_string(a)), + sexp_string_data(sexp_write_to_string(ctx, b))); +#endif + } else { + res = 1; + } + } else if (sexp_pointerp(b)) { +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_lsymbolp(b)) + res = strcmp(sexp_string_data(sexp_write_to_string(ctx, a)), + sexp_string_data(sexp_symbol_string(b))); + else +#endif + res = -1; + } else { +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_isymbolp(b)) + return sexp_isymbol_compare(ctx, a, b); + else +#endif + res = (sexp_sint_t)a - (sexp_sint_t)b; + } + return res; +} + +static sexp sexp_object_compare_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + return sexp_make_fixnum(sexp_object_compare(ctx, a, b)); +} + +static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) { + sexp_sint_t mid, i, j; + sexp tmp, tmp2; + loop: + if (lo < hi) { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + for (i=j=lo; i < hi; i++) + if (sexp_object_compare(ctx, vec[i], tmp) < 0) + swap(tmp2, vec[i], vec[j]), j++; + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + sexp_qsort(ctx, vec, lo, j-1); + lo = j+1; + goto loop; + } + } +} + +static sexp sexp_qsort_less (sexp ctx, sexp *vec, + sexp_sint_t lo, sexp_sint_t hi, + sexp less, sexp key) { + sexp_sint_t mid, i, j; + sexp tmp, res, args1; + sexp_gc_var3(a, b, args2); + sexp_gc_preserve3(ctx, a, b, args2); + args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID); + args1 = sexp_cdr(args2); + loop: + if (lo >= hi) { + res = SEXP_VOID; + } else { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + if (sexp_truep(key)) { + sexp_car(args1) = tmp; + b = sexp_apply(ctx, key, args1); + } else { + b = tmp; + } + for (i=j=lo; i < hi; i++) { + if (sexp_truep(key)) { + sexp_car(args1) = vec[i]; + a = sexp_apply(ctx, key, args1); + } else { + a = vec[i]; + } + sexp_car(args2) = a; + sexp_car(args1) = b; + res = sexp_apply(ctx, less, args2); + if (sexp_exceptionp(res)) + goto done; + else if (sexp_truep(res)) + swap(res, vec[i], vec[j]), j++; + } + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + res = sexp_qsort_less(ctx, vec, lo, j-1, less, key); + if (sexp_exceptionp(res)) + goto done; + lo = j+1; + goto loop; + } + } + done: + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, + sexp less, sexp key) { + sexp_sint_t len; + sexp res, *data; + sexp_gc_var1(vec); + + if (sexp_nullp(seq)) return seq; + + sexp_gc_preserve1(ctx, vec); + + vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); + + if (! sexp_vectorp(vec)) { + res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec); + } else { + data = sexp_vector_data(vec); + len = sexp_vector_length(vec); + if (sexp_not(key) && sexp_basic_comparator(less)) { + sexp_qsort(ctx, data, 0, len-1); + if (sexp_opcodep(less) && sexp_opcode_inverse(less)) + sexp_vector_nreverse(ctx, vec); + } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less); + } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key); + } else { + res = sexp_qsort_less(ctx, data, 0, len-1, less, key); + } + } + + if (sexp_pairp(seq)) + res = sexp_vector_copy_to_list(ctx, vec, seq); + else if (! sexp_exceptionp(res)) + res = vec; + + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "object-cmp", 2, sexp_object_compare_op); + sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE); + return SEXP_VOID; +} diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm new file mode 100644 index 00000000..14e24517 --- /dev/null +++ b/lib/srfi/95/sort.scm @@ -0,0 +1,70 @@ +;; sort.scm -- SRFI-95 sorting utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (copy seq) + (if (vector? seq) + (let* ((len (vector-length seq)) + (res (make-vector len))) + (do ((i (- len 1) (- i 1))) + ((< i 0) res) + (vector-set! res i (vector-ref seq i)))) + (map (lambda (x) x) seq))) + +(define (sort seq . o) + (let ((less (and (pair? o) (car o))) + (key (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (sort! (copy seq) less key))) + +(define (sorted? seq less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (cond + ((vector? seq) + (let ((len (- (vector-length seq) 1))) + (let lp ((i 0)) + (cond + ((>= i len) #t) + ((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f) + (else (lp (+ i 1))))))) + ((null? seq) + #t) + (else + (let lp ((ls1 seq) (ls2 (cdr seq))) + (cond ((null? ls2) #t) + ((less (key (car ls2)) (key (car ls1))) #f) + (else (lp ls2 (cdr ls2))))))))) + +(define (merge! ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (define (lp prev ls1 ls2 a b less key) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))) + (else + (set-cdr! prev ls2) + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))))) + (cond + ((null? ls1) ls2) + ((null? ls2) ls1) + (else + (let ((a (key (car ls1))) + (b (key (car ls2)))) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)) + ls1) + (else + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)) + ls2))))))) + +(define (merge ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (merge! (copy ls1) (copy ls2) less key))) diff --git a/lib/srfi/98.module b/lib/srfi/98.module new file mode 100644 index 00000000..9d124d66 --- /dev/null +++ b/lib/srfi/98.module @@ -0,0 +1,5 @@ + +(define-module (srfi 98) + (export get-environment-variable get-environment-variables) + (include-shared "98/env")) + diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c new file mode 100644 index 00000000..f8e519f3 --- /dev/null +++ b/lib/srfi/98/env.c @@ -0,0 +1,48 @@ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifdef __APPLE__ +#include +#define environ (*_NSGetEnviron()) +#else +extern char **environ; +#endif + +#include + +sexp sexp_get_environment_variable (sexp ctx sexp_api_params(self, n), sexp str) { + char *cstr; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + cstr = getenv(sexp_string_data(str)); + return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE; +} + +sexp sexp_get_environment_variables (sexp ctx sexp_api_params(self, n)) { + int i; + char **env, *cname, *cval; + sexp_gc_var3(res, name, val); + sexp_gc_preserve3(ctx, res, name, val); + res = SEXP_NULL; + env = environ; + for (i=0; env[i]; i++) { + cname = env[i]; + cval = strchr(cname, '='); + if (cval) { + name = sexp_c_string(ctx, cname, cval-cname); + val = sexp_c_string(ctx, cval+1, -1); + val = sexp_cons(ctx, name, val); + res = sexp_cons(ctx, val, res); + } + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable); + sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables); + return SEXP_VOID; +} + diff --git a/main.c b/main.c new file mode 100644 index 00000000..03caf762 --- /dev/null +++ b/main.c @@ -0,0 +1,219 @@ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define sexp_argv_symbol "*command-line-arguments*" +#define sexp_argv_proc "(define (command-line-arguments) "sexp_argv_symbol")" + +#define sexp_import_prefix "(import (" +#define sexp_import_suffix "))" + +#define sexp_version_string "chibi-scheme "sexp_version" \""sexp_release_name"\" " + +#ifdef PLAN9 +#define exit_failure() exits("ERROR") +#else +#define exit_failure() exit(70) +#endif + +static void repl (sexp ctx) { + sexp in, out, err; + sexp_gc_var4(obj, tmp, res, env); + sexp_gc_preserve4(ctx, obj, tmp, res, env); + env = sexp_make_env(ctx); + sexp_env_parent(env) = sexp_context_env(ctx); + sexp_env_define(ctx, sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); + sexp_context_tracep(ctx) = 1; + in = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE); + out = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE); + err = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE); + 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, env); + if (sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); + } else { +#if SEXP_USE_WARN_UNDEFS + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + if (res != SEXP_VOID) { + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + } + } + } + sexp_gc_release4(ctx); +} + +static void check_nonull_arg (int c, char *arg) { + if (! arg) { + fprintf(stderr, "chibi-scheme: option '%c' requires an argument\n", c); + exit_failure(); + } +} + +static sexp check_exception (sexp ctx, sexp res) { + sexp err; + if (res && sexp_exceptionp(res)) { + err = sexp_current_error_port(ctx); + if (! sexp_oportp(err)) + err = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); + exit_failure(); + } + return res; +} + +#define init_context() if (! ctx) do { \ + ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \ + env = sexp_context_env(ctx); \ + sexp_gc_preserve2(ctx, tmp, args); \ + } while (0) + +#define load_init() if (! init_loaded++) do { \ + init_context(); \ + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \ + } while (0) + +void run_main (int argc, char **argv) { + char *arg, *impmod, *p; + sexp env, out=SEXP_FALSE, res=SEXP_VOID, ctx=NULL; + sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0; + sexp_uint_t heap_size=0; + sexp_gc_var2(tmp, args); + args = SEXP_NULL; + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + case 'p': + load_init(); + print = (argv[i][1] == 'p'); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('e', arg); + res = check_exception(ctx, sexp_read_from_string(ctx, arg, -1)); + res = check_exception(ctx, sexp_eval(ctx, res, env)); + if (print) { + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + quit = 1; + break; + case 'l': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('l', arg); + check_exception(ctx, sexp_load_module_file(ctx, arg, env)); + break; + case 'm': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('m', arg); + len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); + impmod = (char*) malloc(len+1); + strcpy(impmod, sexp_import_prefix); + strcpy(impmod+strlen(sexp_import_prefix), arg); + strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix); + impmod[len] = '\0'; + for (p=impmod; *p; p++) + if (*p == '.') *p=' '; + check_exception(ctx, sexp_eval_string(ctx, impmod, -1, env)); + free(impmod); + break; + case 'q': + init_context(); + if (! init_loaded++) sexp_load_standard_parameters(ctx, env); + break; + case 'A': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('A', arg); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); + break; + case 'I': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('I', arg); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); + break; + case '-': + i++; + goto done_options; + case 'h': + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('h', arg); + heap_size = atol(arg); + len = strlen(arg); + if (heap_size && isalpha(arg[len-1])) { + switch (tolower(arg[len-1])) { + case 'k': heap_size *= 1024; break; + case 'm': heap_size *= (1024*1024); break; + } + } + break; + case 'V': + load_init(); + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + sexp_write_string(ctx, sexp_version_string, out); + tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*", -1), SEXP_NULL); + sexp_write(ctx, tmp, out); + sexp_newline(ctx, out); + return; + default: + fprintf(stderr, "unknown option: %s\n", argv[i]); + exit_failure(); + } + } + + done_options: + if (! quit) { + load_init(); + if (i < argc) + for (j=argc-1; j>i; j--) + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); + else + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); + sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args); + sexp_eval_string(ctx, sexp_argv_proc, -1, env); + if (i < argc) { /* script usage */ + check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); + tmp = sexp_intern(ctx, "main", -1); + tmp = sexp_env_ref(env, tmp, SEXP_FALSE); + if (sexp_procedurep(tmp)) { + args = sexp_list1(ctx, args); + check_exception(ctx, sexp_apply(ctx, tmp, args)); + } + } else { + repl(ctx); + } + } + + sexp_gc_release2(ctx); + sexp_destroy_context(ctx); +} + +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..a193e9b6 --- /dev/null +++ b/mkfile @@ -0,0 +1,28 @@ + include/chibi/install.h + echo '#define sexp_platform "plan9"' >> include/chibi/install.h + echo '#define sexp_version "'`{cat VERSION}'"' >> include/chibi/install.h + echo '#define sexp_release_name "'`{cat RELEASE}'"' >> include/chibi/install.h + +install:V: $BIN/$TARG + test -d $MODDIR || mkdir -p $MODDIR + cp -r lib/* $MODDIR/ + +test:V: + ./$O.out tests/r5rs-tests.scm + +sexp.c:N: gc.c opt/bignum.c diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..085238f1 --- /dev/null +++ b/opcodes.c @@ -0,0 +1,174 @@ + +#define _OP(c,o,n,m,t,u,i,s,d,f) {c, o, n, m, t, u, i, s, d, NULL, NULL, f} +#define _FN(o,n,m,t,u,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f) +#define _FN0(s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, 0, 0, s, d, f) +#define _FN1(t, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, t, 0, s, d, f) +#define _FN1OPT(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, t, u, s, d, f) +#define _FN1OPTP(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, t, 0, s, d, f) +#define _FN2(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, t, u, s, d, f) +#define _FN2OPT(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, t, u, s, d, f) +#define _FN2OPTP(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, t, u, s, d, f) +#define _FN3(t, u, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, t, u, s, d, f) +#define _FN4(t, u, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, t, u, s, d, f) +#define _FN5(t, u, s, d, f) _FN(SEXP_OP_FCALL5, 5, 0, t, u, s, d, f) +#define _FN6(t, u, s, d, f) _FN(SEXP_OP_FCALL6, 6, 0, t, u, s, d, f) +#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, 0, 0, n, a, 0) + +static struct sexp_opcode_struct opcodes[] = { +_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF,2,0, SEXP_BYTES, SEXP_FIXNUM, 0,"byte-vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET,3,0, SEXP_BYTES, SEXP_FIXNUM, 0,"byte-vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH,1,0, SEXP_BYTES, 0, 0,"byte-vector-length", 0, NULL), +#if SEXP_USE_UTF8_STRINGS +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-cursor-ref", 0, NULL), +#else +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +#endif +#if SEXP_USE_MUTABLE_STRINGS +#if SEXP_USE_UTF8_STRINGS +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-cursor-set!", 0, NULL), +#else +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +#endif +#endif +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, SEXP_FIXNUM, 0, 1, "-", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 1, 1, SEXP_FIXNUM, 0, 1, "/", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), +#if SEXP_USE_IMMEDIATE_FLONUMS +_FN1(0, "flonum?", 0, sexp_flonump_op), +#else +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), +#endif +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read_op), +_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write_op), +_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display_op), +_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op), +_FN2(0, 0, "equal?", 0, sexp_equalp_op), +_FN1(0, "list?", 0, sexp_listp_op), +_FN1(0, "identifier?", 0, sexp_identifierp_op), +_FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr_op), +_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq_op), +_FN1(SEXP_PAIR, "length", 0, sexp_length_op), +_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse_op), +_FN1(SEXP_PAIR, "reverse!", 0, sexp_nreverse_op), +_FN2(SEXP_PAIR, SEXP_PAIR, "append2", 0, sexp_append2_op), +_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector_op), +_FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file_op), +_FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file_op), +_FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port_op), +_FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port_op), +_FN0("make-environment", 0, sexp_make_env_op), +_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env_op), +_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env_op), +_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval_op), +_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load_op), +_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy_op), +_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception_op), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_op), +_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string_op), +_FN2OPT(SEXP_FIXNUM, SEXP_FIXNUM, "make-byte-vector", SEXP_ZERO, sexp_make_bytes_op), +_FN2OPT(SEXP_FIXNUM, SEXP_FIXNUM, "string->number", SEXP_TEN, sexp_string_to_number_op), +_FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp_op), +_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring_op), +_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol_op), +_FN2OPT(SEXP_PAIR, SEXP_STRING, "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op), +_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq_op), +_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq_op), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo_op), +_FN1(0, "strip-syntactic-closures", 0, sexp_strip_synclos), +_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), +_FN0("open-output-string", 0, sexp_make_output_string_port_op), +_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port_op), +_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string_op), +#if SEXP_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), +#endif +_FN2(0, 0, "expt", 0, sexp_expt_op), +#if SEXP_USE_UTF8_STRINGS +_FN2(SEXP_STRING, SEXP_FIXNUM, "string-index->offset", 0, sexp_string_index_to_offset), +_FN2(SEXP_STRING, SEXP_FIXNUM, "string-ref", 0, sexp_string_utf8_index_ref), +_FN3(SEXP_STRING, SEXP_FIXNUM, "string-set!", 0, sexp_string_utf8_index_set), +#endif +#if SEXP_USE_TYPE_DEFS +_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type_op), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate_op), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor_op), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter_op), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter_op), +#endif +#if PLAN9 +#include "opt/plan9-opcodes.c" +#endif +#if SEXP_USE_MODULES +_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports_op), +_FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), +_FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), +_FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory_op), +#endif +#if SEXP_USE_GREEN_THREADS +_OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, 0, 0, 0, "thread-yield!", 0, NULL), +#endif +}; + diff --git a/opt/bignum.c b/opt/bignum.c new file mode 100644 index 00000000..09c82ded --- /dev/null +++ b/opt/bignum.c @@ -0,0 +1,775 @@ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_INIT_BIGNUM_SIZE 2 + +#define sexp_negate(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_fixnump(x)) \ + x = sexp_fx_neg(x); + +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { + sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + sexp_bignum_length(res) = len; + sexp_bignum_sign(res) = 1; + return res; +} + +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { + sexp res = sexp_make_bignum(ctx, 1); + sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a)); + sexp_bignum_sign(res) = sexp_fx_sign(a); + return res; +} + +sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { + sexp res; + if ((SEXP_MIN_FIXNUM <= x) && (x <= SEXP_MAX_FIXNUM)) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + if (x < 0) { + sexp_bignum_sign(res) = -1; + sexp_bignum_data(res)[0] = -x; + } else { + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + } + return res; +} + +sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { + sexp res; + if (x <= SEXP_MAX_FIXNUM) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + return res; +} + +#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) +#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) + +sexp sexp_double_to_bignum (sexp ctx, double f) { + int sign; + sexp_gc_var3(res, scale, tmp); + sexp_gc_preserve3(ctx, res, scale, tmp); + res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + sign = (f < 0 ? -1 : 1); + for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { + tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); + res = sexp_bignum_add(ctx, res, res, tmp); + scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); + } + sexp_bignum_sign(res) = sign; + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { + sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size; + size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + if (! dst || sexp_bignum_length(dst) < len) { + dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + memmove(dst, a, size); + sexp_bignum_length(dst) = len; + } else { + memset(dst->value.bignum.data, 0, + sexp_bignum_length(dst)*sizeof(sexp_uint_t)); + memmove(dst->value.bignum.data, a->value.bignum.data, + sexp_bignum_length(a)*sizeof(sexp_uint_t)); + } + return dst; +} + +int sexp_bignum_zerop (sexp a) { + int i; + sexp_uint_t *data = sexp_bignum_data(a); + for (i=sexp_bignum_length(a)-1; i>=0; i--) + if (data[i]) + return 0; + return 1; +} + +sexp_uint_t sexp_bignum_hi (sexp a) { + sexp_uint_t i=sexp_bignum_length(a)-1; + while ((i>0) && ! sexp_bignum_data(a)[i]) + i--; + return i+1; +} + +sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) { + int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b); + sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b); + if (ai != bi) + return ai - bi; + for (--ai; ai >= 0; ai--) { + if (adata[ai] > bdata[ai]) + return 1; + else if (adata[ai] < bdata[ai]) + return -1; + } + return 0; +} + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { + if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) + return sexp_bignum_sign(a); + return sexp_bignum_compare_abs(a, b); +} + +sexp sexp_bignum_normalize (sexp a) { + sexp_uint_t *data; + if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) + return a; + data = sexp_bignum_data(a); + if ((data[0] > SEXP_MAX_FIXNUM) + && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1))) + return a; + return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a)); +} + +double sexp_bignum_to_double (sexp a) { + double res = 0; + sexp_sint_t i; + sexp_uint_t *data=sexp_bignum_data(a); + for (i=sexp_bignum_hi(a)-1; i>=0; i--) + res = res * ((double)SEXP_UINT_T_MAX+1) + data[i]; + return res * sexp_bignum_sign(a); +} + +sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), + carry=b, i=0, n; + do { n = data[i]; + data[i] += carry; + carry = (n > (SEXP_UINT_T_MAX - carry)); + } while (++i> (sizeof(sexp_uint_t)*8); + } + if (carry) { + if (sexp_bignum_length(d)+offset <= len) + d = sexp_copy_bignum(ctx, NULL, d, len+offset+1); + sexp_bignum_data(d)[len+offset] = carry; + } + sexp_gc_release1(ctx); + return d; +} + +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0; + int i; + sexp_luint_t n = 0; + for (i=len-1; i>=offset; i--) { + n = (n << sizeof(sexp_uint_t)*8) + data[i]; + q = n / b; + r = n - (sexp_luint_t)q * b; + data[i] = q; + n = r; + } + return r; +} + +sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, + char sign, sexp_uint_t base) { + int c, digit; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE); + sexp_bignum_sign(res) = sign; + sexp_bignum_data(res)[0] = init; + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + res = sexp_bignum_fxmul(ctx, res, res, base, 0); + res = sexp_bignum_fxadd(ctx, res, digit); + } + if (c=='.' || c=='e' || c=='E') { + if (base != 10) { + res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + } else { + if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */ + res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); + } + } else if ((c!=EOF) && ! is_separator(c)) { + res = sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + } else { + sexp_push_char(ctx, c, in); + } + sexp_gc_release1(ctx); + return sexp_bignum_normalize(res); +} + +static int log2i(int v) { + int i; + for (i = 0; i < sizeof(v)*8; i++) + if ((1<<(i+1)) > v) + break; + return i; +} + +sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { + int i, str_len, lg_base = log2i(base); + char *data; + sexp_gc_var2(b, str); + sexp_gc_preserve2(ctx, b, str); + b = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(b) = 1; + i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) + / lg_base + 1; + str = sexp_make_string(ctx, sexp_make_fixnum(str_len), + sexp_make_character(' ')); + data = sexp_string_data(str); + while (! sexp_bignum_zerop(b)) + data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0)); + if (i == str_len) + data[--i] = '0'; + else if (sexp_bignum_sign(a) == -1) + data[--i] = '-'; + sexp_write_string(ctx, data + i, out); + sexp_gc_release2(ctx); + return SEXP_VOID; +} + +/****************** bignum arithmetic *************************/ + +sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(c); + sexp_gc_preserve1(ctx, c); + c = sexp_copy_bignum(ctx, NULL, a, 0); + if (sexp_bignum_sign(c) == sexp_fx_sign(b)) + c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + else + c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + sexp_gc_release1(ctx); + return c; +} + +sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), + borrow=0, i, *adata, *bdata, *cdata; + sexp_gc_var1(c); + if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) + return sexp_bignum_sub_digits(ctx, dst, b, a); + sexp_gc_preserve1(ctx, c); + c = ((dst && sexp_bignum_hi(dst) >= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0); + } + for ( ; carry && (i= 0 ? a : b); + } + return res; +} + +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { + sexp res; + if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { + res = sexp_bignum_sub_digits(ctx, dst, a, b); + sexp_bignum_sign(res) + = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a) + : -sexp_bignum_sign(a)); + } else { + res = sexp_bignum_add_digits(ctx, dst, a, b); + sexp_bignum_sign(res) = sexp_bignum_sign(a); + } + return res; +} + +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, + *bdata=sexp_bignum_data(b); + sexp_gc_var2(c, d); + if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); + sexp_gc_preserve2(ctx, c, d); + c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); + d = sexp_make_bignum(ctx, alen+blen+1); + for (i=0; i 0) { + *rem = a; + return sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + } + sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); + k2 = sexp_bignum_double(ctx, k); + i2 = sexp_bignum_double(ctx, i); + x = quot_step(ctx, rem, a, b, k2, i2); + prod = sexp_bignum_mul(ctx, NULL, x, b); + diff = sexp_bignum_sub_digits(ctx, NULL, a, prod); + if (sexp_bignum_compare(diff, k) >= 0) { + *rem = sexp_bignum_sub_digits(ctx, NULL, diff, k); + res = sexp_bignum_add_digits(ctx, NULL, x, i); + } else { + *rem = diff; + res = x; + } + sexp_gc_release5(ctx); + return res; +} + +sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { + sexp res; + sexp_gc_var4(k, i, a1, b1); + sexp_gc_preserve4(ctx, k, i, a1, b1); + a1 = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(a1) = 1; + b1 = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_bignum_sign(b1) = 1; + k = sexp_copy_bignum(ctx, NULL, b1, 0); + i = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + res = quot_step(ctx, rem, a1, b1, k, i); + sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); + if (sexp_bignum_sign(a) < 0) { + sexp_negate(*rem); + } + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { + sexp res; + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + res = sexp_bignum_quot_rem(ctx, &rem, a, b); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */ + sexp_gc_release1(ctx); + return rem; +} + +sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { + sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b)); + sexp_gc_var2(res, acc); + sexp_gc_preserve2(ctx, res, acc); + res = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + acc = sexp_copy_bignum(ctx, NULL, a, 0); + for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) + if (e & 1) + res = sexp_bignum_mul(ctx, NULL, res, acc); + sexp_gc_release2(ctx); + return res; +} + +/****************** generic arithmetic ************************/ + +enum sexp_number_types { + SEXP_NUM_NOT = 0, + SEXP_NUM_FIX, + SEXP_NUM_FLO, + SEXP_NUM_BIG +}; + +enum sexp_number_combs { + SEXP_NUM_NOT_NOT = 0, + SEXP_NUM_NOT_FIX, + SEXP_NUM_NOT_FLO, + SEXP_NUM_NOT_BIG, + SEXP_NUM_FIX_NOT, + SEXP_NUM_FIX_FIX, + SEXP_NUM_FIX_FLO, + SEXP_NUM_FIX_BIG, + SEXP_NUM_FLO_NOT, + SEXP_NUM_FLO_FIX, + SEXP_NUM_FLO_FLO, + SEXP_NUM_FLO_BIG, + SEXP_NUM_BIG_NOT, + SEXP_NUM_BIG_FIX, + SEXP_NUM_BIG_FLO, + SEXP_NUM_BIG_BIG +}; + +static int sexp_number_types[] = + {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0}; + +static int sexp_number_type (sexp a) { + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] +#if SEXP_USE_IMMEDIATE_FLONUMS + : sexp_flonump(a) ? 2 +#endif + : sexp_fixnump(a); +} + +sexp sexp_add (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_add(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_add(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_add(ctx, NULL, b, a)); + break; + } + return r; +} + +sexp sexp_sub (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_sub(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + tmp = sexp_fixnum_to_bignum(ctx, a); + r = sexp_bignum_sub(ctx, NULL, b, tmp); + sexp_negate(r); + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)+sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_sub(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + tmp = sexp_fixnum_to_bignum(ctx, b); + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, tmp)); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) - sexp_flonum_value(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_mul (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_mul(a, b); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0); + sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_mul(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_mul(ctx, NULL, a, b); + break; + } + return r; +} + +sexp sexp_div (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + double f; + sexp r=SEXP_VOID; + sexp_gc_var2(tmp, rem); + sexp_gc_preserve2(ctx, tmp, rem); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: + f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b); + r = ((f == trunc(f)) ? sexp_make_fixnum((sexp_sint_t)f) + : sexp_make_flonum(ctx, f)); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_flonum_value(a)/sexp_fixnum_to_double(b)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_div(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_quot_rem(ctx, &rem, a, b); + if (sexp_bignum_normalize(rem) != SEXP_ZERO) + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) + / sexp_bignum_to_double(b)); + else + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b)); + break; + } + sexp_gc_release2(ctx); + return r; +} + +sexp sexp_quotient (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_div(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = SEXP_ZERO; + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_remainder (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_rem(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = a; + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_compare (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + double f; + if (at > bt) { + r = sexp_compare(ctx, b, a); + sexp_negate(r); + } else { + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); + break; + case SEXP_NUM_FIX_FLO: + f = sexp_fixnum_to_double(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(-1); + break; + case SEXP_NUM_FLO_FLO: + f = sexp_flonum_value(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FLO_BIG: + f = sexp_flonum_value(a) - sexp_bignum_to_double(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_make_fixnum(sexp_bignum_compare(a, b)); + break; + } + } + return r; +} + diff --git a/opt/fcall.c b/opt/fcall.c new file mode 100644 index 00000000..17e7b82f --- /dev/null +++ b/opt/fcall.c @@ -0,0 +1,31 @@ + +typedef sexp (*sexp_proc8) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc9) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc10) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc11) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc12) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc13) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc14) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc15) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc16) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc17) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); + +#define _A(i) stack[top-i] + +sexp sexp_fcall (sexp ctx, sexp self, sexp_sint_t n, sexp f) { + sexp *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx); + switch (n) { + case 7: return ((sexp_proc8)sexp_opcode_func(f))(ctx, f, 7, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7)); + case 8: return ((sexp_proc9)sexp_opcode_func(f))(ctx, f, 8, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8)); + case 9: return ((sexp_proc10)sexp_opcode_func(f))(ctx, f, 9, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9)); + case 10: return ((sexp_proc11)sexp_opcode_func(f))(ctx, f, 10, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10)); + case 11: return ((sexp_proc12)sexp_opcode_func(f))(ctx, f, 11, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11)); + case 12: return ((sexp_proc13)sexp_opcode_func(f))(ctx, f, 12, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12)); + case 13: return ((sexp_proc14)sexp_opcode_func(f))(ctx, f, 13, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13)); + case 14: return ((sexp_proc15)sexp_opcode_func(f))(ctx, f, 14, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14)); + case 15: return ((sexp_proc16)sexp_opcode_func(f))(ctx, f, 15, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15)); + case 16: return ((sexp_proc17)sexp_opcode_func(f))(ctx, f, 16, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16)); + default: return sexp_user_exception(ctx, self, "too many FFI arguments", f); + } +} diff --git a/opt/opcode_names.h b/opt/opcode_names.h new file mode 100644 index 00000000..52c639f9 --- /dev/null +++ b/opt/opcode_names.h @@ -0,0 +1,21 @@ + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", + "TAIL-CALL", "CALL", "FCALL0", "FCALL1", "FCALL2", + "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALLN", + "JUMP-UNLESS", "JUMP", "PUSH", "DROP", + "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", + "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", + "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", + "BYTES-REF", "BYTES-SET", "BYTES-LENGTH", + "STRING-REF", "STRING-SET", "STRING-LENGTH", + "MAKE-PROCEDURE", "MAKE-VECTOR", + "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", + "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", + "MUL", "DIV", "QUOTIENT", "REMAINDER", + "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", + "YIELD", "RET", "DONE", + }; diff --git a/opt/plan9-opcodes.c b/opt/plan9-opcodes.c new file mode 100644 index 00000000..9f7cac33 --- /dev/null +++ b/opt/plan9-opcodes.c @@ -0,0 +1,19 @@ +_FN0("random-integer", 0, sexp_rand), +_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), +_FN0("current-directory", 0, sexp_getwd), +_FN0("current-user", 0, sexp_getuser), +_FN0("system-name", 0, sexp_sysname), +_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), +_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), +_FN0("fork", 0, sexp_fork), +_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), +_FN1(SEXP_STRING, "exits", 0, sexp_exits), +_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), +_FN0("pipe", 0, sexp_pipe), +_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), +_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), +_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), +_FN0("wait", 0, sexp_wait), +_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), +_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), +_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), diff --git a/opt/plan9.c b/opt/plan9.c new file mode 100644 index 00000000..ca25afba --- /dev/null +++ b/opt/plan9.c @@ -0,0 +1,351 @@ +/* plan9.c -- extended Plan 9 system utils */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +sexp sexp_rand (sexp ctx sexp_api_params(self, n)) { + return sexp_make_fixnum(rand()); +} + +sexp sexp_srand (sexp ctx sexp_api_params(self, n), sexp seed) { + srand(sexp_unbox_fixnum(seed)); + return SEXP_VOID; +} + +sexp sexp_file_exists_p (sexp ctx sexp_api_params(self, n), sexp path) { + int res; + uchar statbuf[STATMAX]; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "file-exists?: not a string", path); + res = stat(sexp_string_data(path), statbuf, sizeof(statbuf)); + return (res < 0) ? SEXP_FALSE : SEXP_TRUE; +} + +sexp sexp_fdopen (sexp ctx sexp_api_params(self, n), sexp fd, sexp mode) { + FILE *f; + if (! sexp_integerp(fd)) + return sexp_type_exception(ctx, "fdopen: not an integer", fd); + if (! sexp_stringp(mode)) + return sexp_type_exception(ctx, "fdopen: not a mode string", mode); + f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode)); + if (! f) + return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd); + /* maybe use fd2path to get the name of the fd */ + if (sexp_string_data(mode)[0] == 'w') + return sexp_make_output_port(ctx, f, SEXP_FALSE); + else + return sexp_make_input_port(ctx, f, SEXP_FALSE); +} + +sexp sexp_fileno (sexp ctx sexp_api_params(self, n), sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "fileno: not a port", port); + return sexp_make_fixnum(fileno(sexp_port_stream(port))); +} + +sexp sexp_fork (sexp ctx sexp_api_params(self, n)) { + return sexp_make_fixnum(fork()); +} + +sexp sexp_exec (sexp ctx sexp_api_params(self, n), sexp name, sexp args) { + int i, len = sexp_unbox_fixnum(sexp_length(ctx, args)); + char **argv = malloc((len+1)*sizeof(char*)); + for (i=0; imsg, -1); + res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg); + sexp_gc_release(ctx, msg, s_msg); + return res; +} + +sexp sexp_postnote (sexp ctx sexp_api_params(self, n), sexp pid, sexp note) { + if (! sexp_integerp(pid)) + return sexp_type_exception(ctx, "postnote: not an integer", pid); + if (! sexp_stringp(note)) + return sexp_type_exception(ctx, "postnote: not a string", note); + postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note)); + return SEXP_VOID; +} + +/**********************************************************************/ +/* 9p interface */ + +typedef struct sexp_plan9_srv { + sexp context, auth, attach, walk, walk1, clone, open, create, remove, + read, write, stat, wstat, flush, destroyfid, destroyreq, end; +} *sexp_plan9_srv; + +void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) { + s->context = ctx; + s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open + = s->create = s->remove = s->read = s->write = s->stat = s->wstat + = s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE; + for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) { + if (sexp_car(ls) == sexp_intern(ctx, "auth:", -1)) { + s->auth = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "attach:", -1)) { + s->attach = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk:", -1)) { + s->walk = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:", -1)) { + s->walk1 = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "clone:", -1)) { + s->clone = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "open:", -1)) { + s->open = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "create:", -1)) { + s->create = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "remove:", -1)) { + s->remove = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "read:", -1)) { + s->read = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "write:", -1)) { + s->write = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "stat:", -1)) { + s->stat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:", -1)) { + s->wstat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "flush:", -1)) { + s->flush = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:", -1)) { + s->destroyfid = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:", -1)) { + s->destroyreq = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "end:", -1)) { + s->end = sexp_cadr(ls); + } + } +} + +void sexp_run_9p_handler (Req *r, sexp handler) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, handler, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +#define sexp_def_9p_handler(name, field) \ + void name (Req *r) { \ + sexp_run_9p_handler(r, ((sexp_plan9_srv)r->srv->aux)->field); \ + } + +sexp_def_9p_handler(sexp_9p_auth, auth) +sexp_def_9p_handler(sexp_9p_attach, attach) +sexp_def_9p_handler(sexp_9p_walk, walk) +sexp_def_9p_handler(sexp_9p_open, open) +sexp_def_9p_handler(sexp_9p_create, create) +sexp_def_9p_handler(sexp_9p_remove, remove) +sexp_def_9p_handler(sexp_9p_read, read) +sexp_def_9p_handler(sexp_9p_write, write) +sexp_def_9p_handler(sexp_9p_stat, stat) +sexp_def_9p_handler(sexp_9p_wstat, wstat) +sexp_def_9p_handler(sexp_9p_flush, flush) + +char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_c_string(ctx, name, -1); + args = sexp_cons(ctx, ptr, args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->walk1, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +char* sexp_9p_clone (Fid *oldfid, Fid *newfid) { + sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->clone, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +void sexp_9p_destroyfid (Fid *fid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyfid, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_destroyreq (Req *r) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyreq, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_end (Srv *srv) { + sexp_plan9_srv s = (sexp_plan9_srv)srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->end, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +sexp sexp_postmountsrv (sexp ctx sexp_api_params(self, n), sexp ls, sexp name, sexp mtpt, sexp flags) { + Srv s; + struct sexp_plan9_srv p9s; + if (! sexp_listp(ctx, ls)) + return sexp_type_exception(ctx, "postmountsrv: not a list", ls); + if (! sexp_stringp(name)) + return sexp_type_exception(ctx, "postmountsrv: not a string", name); + if (! sexp_stringp(mtpt)) + return sexp_type_exception(ctx, "postmountsrv: not a string", mtpt); + if (! sexp_integerp(flags)) + return sexp_type_exception(ctx, "postmountsrv: not an integer", flags); + sexp_build_srv(ctx, &p9s, ls); + s.aux = &p9s; + s.auth = &sexp_9p_auth; + s.attach = &sexp_9p_attach; + s.walk = &sexp_9p_walk; + s.walk1 = &sexp_9p_walk1; + s.clone = &sexp_9p_clone; + s.open = &sexp_9p_open; + s.create = &sexp_9p_create; + s.remove = &sexp_9p_remove; + s.read = &sexp_9p_read; + s.write = &sexp_9p_write; + s.stat = &sexp_9p_stat; + s.wstat = &sexp_9p_wstat; + s.flush = &sexp_9p_flush; + s.destroyfid = &sexp_9p_destroyfid; + s.destroyreq = &sexp_9p_destroyreq; + s.end = &sexp_9p_end; + postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt), + sexp_unbox_fixnum(flags)); + return SEXP_UNDEF; +} + +sexp sexp_9p_req_offset (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset); +} + +sexp sexp_9p_req_count (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count); +} + +#if 0 +sexp sexp_9p_req_path (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1); +} +#endif + +sexp sexp_9p_req_fid (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0); +} + +sexp sexp_9p_req_newfid (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0); +} + +sexp sexp_9p_respond (sexp ctx sexp_api_params(self, n), sexp req, sexp err) { + char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil; + respond(sexp_cpointer_value(req), cerr); + return SEXP_VOID; +} + +sexp sexp_9p_responderror (sexp ctx sexp_api_params(self, n), sexp req) { + responderror(sexp_cpointer_value(req)); + return SEXP_VOID; +} + 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/opt/simplify.c b/opt/simplify.c new file mode 100644 index 00000000..4217a1bb --- /dev/null +++ b/opt/simplify.c @@ -0,0 +1,143 @@ +/* simplify.c -- basic simplification pass */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda)) + +static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { + int check; + sexp ls1, ls2, p1, p2, sv, ctx2; + sexp_gc_var4(res, substs, tmp, app); + sexp_gc_preserve4(ctx, res, substs, tmp, app); + res = ast; /* return the ast as-is by default */ + substs = init_substs; + + loop: + switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) { + + case SEXP_PAIR: + /* don't simplify the operator if it's a lambda because we + simplify that as a special case below, with the appropriate + substs list */ + app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res) + : (tmp=simplify(ctx, sexp_car(res), substs, lambda))); + for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); + app = sexp_nreverse(ctx, app); + /* app now holds a copy of the list, and is the default result + (res = app below) if we don't replace it with a simplification */ + if (sexp_opcodep(sexp_car(app))) { + /* opcode app - right now we just constant fold arithmetic */ + if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) { + for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { + if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { + check = 0; + break; + } + } + if (check) { + ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0); + generate(ctx2, app); + res = finalize_bytecode(ctx2); + if (! sexp_exceptionp(res)) { + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp); + if (! sexp_exceptionp(tmp)) { + tmp = sexp_apply(ctx2, tmp, SEXP_NULL); + if (! sexp_exceptionp(tmp)) + app = sexp_make_lit(ctx2, tmp); + } + } + } + } + } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */ + p1 = NULL; + p2 = sexp_lambda_params(sexp_car(app)); + ls1 = app; + ls2 = sexp_cdr(app); + sv = sexp_lambda_sv(sexp_car(app)); + for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) { + if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv)) + && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2)) + || (sexp_refp(sexp_car(ls2)) + && sexp_lambdap(sexp_ref_loc(sexp_car(ls2))) + && sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)), + sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) { + tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2)); + tmp = sexp_cons(ctx, sexp_car(p2), tmp); + sexp_push(ctx, substs, tmp); + sexp_cdr(ls1) = sexp_cdr(ls2); + if (p1) + sexp_cdr(p1) = sexp_cdr(p2); + else + sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2); + } else { + p1 = p2; + ls1 = ls2; + } + } + sexp_lambda_body(sexp_car(app)) + = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app)); + if (sexp_nullp(sexp_cdr(app)) + && sexp_nullp(sexp_lambda_params(sexp_car(app))) + && sexp_nullp(sexp_lambda_defs(sexp_car(app)))) + app = sexp_lambda_body(sexp_car(app)); + } + res = app; + break; + + case SEXP_LAMBDA: + sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res); + break; + + case SEXP_CND: + tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda); + if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) { + res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp)) + ? sexp_cnd_fail(res) : sexp_cnd_pass(res); + goto loop; + } else { + sexp_cnd_test(res) = tmp; + simplify_it(sexp_cnd_pass(res)); + simplify_it(sexp_cnd_fail(res)); + } + break; + + case SEXP_REF: + tmp = sexp_ref_name(res); + for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) { + res = sexp_cddar(ls1); + break; + } + break; + + case SEXP_SET: + simplify_it(sexp_set_value(res)); + break; + + case SEXP_SEQ: + app = SEXP_NULL; + for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { + tmp = simplify(ctx, sexp_car(ls2), substs, lambda); + if (! (sexp_pairp(sexp_cdr(ls2)) + && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) + || sexp_lambdap(tmp)))) + sexp_push(ctx, app, tmp); + } + if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app))) + res = sexp_car(app); + else + sexp_seq_ls(res) = sexp_nreverse(ctx, app); + break; + + } + + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_simplify (sexp ctx sexp_api_params(self, n), sexp ast) { + return simplify(ctx, ast, SEXP_NULL, NULL); +} + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..aac5569b --- /dev/null +++ b/sexp.c @@ -0,0 +1,1819 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* optional huffman-compressed immediate symbols */ +struct sexp_huff_entry { + unsigned char len; + unsigned short bits; +}; + +#if SEXP_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; + +sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp); + +static const 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 (int c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int hex_digit (int n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + +static int is_separator(int c) { + return 0= SEXP_MAXIMUM_TYPES) { + res = sexp_user_exception(ctx, self, "register-type: exceeded maximum type limit", name); + } else if (! sexp_stringp(name)) { + res = sexp_type_exception(ctx, self, SEXP_STRING, name); + } else { + if (num_types >= type_array_size) { + len = type_array_size*2; + if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES; +#if SEXP_USE_GLOBAL_TYPES + new = malloc(len * sizeof(_sexp_type_specs[0])); + for (i=0; i num_types) free(tmp); + sexp_type_array_size = len; +#else + res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID); + v1 = sexp_vector_data(res); + v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)); + for (i=0; ivalue), &(_sexp_type_specs[i]), sizeof(_sexp_type_specs[0])); + vec[i] = type; + } +#endif +} + +#if ! SEXP_USE_GLOBAL_HEAP +sexp sexp_bootstrap_context (sexp_uint_t size) { + sexp dummy_ctx, ctx; + sexp_heap heap; + if (size < SEXP_MINIMUM_HEAP_SIZE) size = SEXP_INITIAL_HEAP_SIZE; + heap = sexp_make_heap(sexp_heap_align(size)); + dummy_ctx = (sexp) malloc(sexp_sizeof(context)); + sexp_pointer_tag(dummy_ctx) = SEXP_CONTEXT; + sexp_context_saves(dummy_ctx) = NULL; + sexp_context_heap(dummy_ctx) = heap; + ctx = sexp_alloc_type(dummy_ctx, context, SEXP_CONTEXT); + sexp_context_heap(dummy_ctx) = NULL; + sexp_context_heap(ctx) = heap; + free(dummy_ctx); + return ctx; +} +#endif + +sexp sexp_make_context (sexp ctx, size_t size) { + sexp_gc_var1(res); + if (ctx) sexp_gc_preserve1(ctx, res); +#if ! SEXP_USE_GLOBAL_HEAP + if (! ctx) res = sexp_bootstrap_context(size); + else +#endif + { + res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); +#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC + sexp_context_heap(res) = sexp_context_heap(ctx); +#endif + } + sexp_context_parent(res) = ctx; + sexp_context_lambda(res) = SEXP_FALSE; + sexp_context_name(res) = sexp_context_specific(res) = SEXP_FALSE; + sexp_context_fv(res) = SEXP_NULL; + sexp_context_saves(res) = NULL; + sexp_context_depth(res)=sexp_context_tracep(res)=sexp_context_pos(res)=0; + sexp_context_tailp(res) = 1; +#if SEXP_USE_GREEN_THREADS + sexp_context_refuel(res) = SEXP_DEFAULT_QUANTUM; +#endif + if (ctx) { + sexp_context_globals(res) = sexp_context_globals(ctx); + sexp_gc_release1(ctx); + } else { + sexp_init_context_globals(res); + } + return res; +} + +#if ! SEXP_USE_GLOBAL_HEAP +void sexp_destroy_context (sexp ctx) { + sexp_heap heap, tmp; + size_t sum_freed; + if (sexp_context_heap(ctx)) { + heap = sexp_context_heap(ctx); + sexp_sweep(ctx, &sum_freed); /* sweep w/o mark to run finalizers */ + sexp_context_heap(ctx) = NULL; + for ( ; heap; heap=tmp) { + tmp = heap->next; +#if SEXP_USE_MMAP_GC + munmap(heap, sexp_heap_pad_size(heap->size)); +#else + free(heap); +#endif + } + } +} +#endif + +/***************************** exceptions *****************************/ + +sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, + 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_source(exn) = source; + return exn; +} + +sexp sexp_string_cat3 (sexp ctx, char *pre, char *mid, char* suf) { + int plen=strlen(pre), mlen=strlen(mid), slen=strlen(suf); + char *s; + sexp str; + str = sexp_make_string(ctx, sexp_make_fixnum(plen+mlen+slen), SEXP_VOID); + memcpy(s=sexp_string_data(str), pre, plen); + memcpy(s+plen, mid, mlen); + memcpy(s+plen+mlen, suf, slen); + return str; +} + +sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { + sexp res; + sexp_gc_var3(sym, str, irr); + sexp_gc_preserve3(ctx, sym, str, irr); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user", -1), + str = sexp_c_string(ctx, ms, -1), + ((sexp_pairp(ir) || sexp_nullp(ir)) + ? ir : (irr = sexp_list1(ctx, ir))), + self, SEXP_FALSE); + sexp_gc_release3(ctx); + return res; +} + +static sexp type_exception (sexp ctx, sexp self, sexp str, sexp obj, sexp src) { + sexp_gc_var2(res, sym); + sexp_gc_preserve2(ctx, res, sym); + sym = sexp_intern(ctx, "type", -1); + res = sexp_make_exception(ctx, sym, str, obj, self, src); + sexp_exception_irritants(res)=sexp_list1(ctx, sexp_exception_irritants(res)); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_c_string(ctx, msg, -1); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_string_cat3(ctx, "invalid type, expected ", + sexp_type_name_by_index(ctx, type_id), ""); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { + sexp_gc_var2(res, msg); + sexp_gc_preserve2(ctx, res, 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", -1), msg, res, + SEXP_FALSE, SEXP_FALSE); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out) { + sexp ls; + if (! sexp_oportp(out)) + out = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_write_string(ctx, "ERROR", out); + if (sexp_exceptionp(exn)) { + if (sexp_exception_procedure(exn)) { + if (sexp_procedurep(sexp_exception_procedure(exn))) { + ls = sexp_bytecode_name( + sexp_procedure_code(sexp_exception_procedure(exn))); + if (sexp_symbolp(ls)) { + sexp_write_string(ctx, " in ", out); + sexp_write(ctx, ls, out); + } + } else if (sexp_opcodep(sexp_exception_procedure(exn))) { + sexp_write_string(ctx, " in ", out); + sexp_write_string(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out); + } + } + ls = sexp_exception_source(exn); + if ((! (ls && sexp_pairp(ls))) + && sexp_exception_procedure(exn) + && sexp_procedurep(sexp_exception_procedure(exn))) + ls = sexp_bytecode_source(sexp_procedure_code(sexp_exception_procedure(exn))); + if (ls && sexp_pairp(ls)) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(sexp_exception_message(exn))) + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); + else + sexp_write(ctx, 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, const char *msg, sexp ir, sexp port) { + sexp res; + sexp_gc_var4(sym, name, str, irr); + sexp_gc_preserve4(ctx, sym, name, str, irr); + name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); + name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port))); + str = sexp_c_string(ctx, msg, -1); + irr = ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir)); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read", -1), + str, irr, SEXP_FALSE, name); + sexp_gc_release4(ctx); + return res; +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons_op (sexp ctx sexp_api_params(self, n), sexp head, sexp tail) { + sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); + if (sexp_exceptionp(pair)) return 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_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_listp_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(ctx, sexp_car(ls), res); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp a, b, tmp; + if (ls == SEXP_NULL) return ls; + sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, ls); + 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_copy_list_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp tmp; + sexp_gc_var1(res); + if (! sexp_pairp(ls)) return ls; + sexp_gc_preserve1(ctx, res); + tmp = res = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + for (ls=sexp_cdr(ls); sexp_pairp(ls); ls=sexp_cdr(ls), tmp=sexp_cdr(tmp)) + sexp_cdr(tmp) = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_append2_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + sexp_gc_var2(a1, b1); + sexp_gc_preserve2(ctx, a1, 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_release2(ctx); + return b1; +} + +sexp sexp_length_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp_uint_t res=0; + for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) + ; + return sexp_make_fixnum(res); +} + +sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + sexp_uint_t size; + sexp_sint_t i, len; + sexp t, *p, *q; + char *p0, *q0; + + loop: + if (a == b) + return SEXP_TRUE; + else if ((! sexp_pointerp(a)) || (! sexp_pointerp(b)) + || (sexp_pointer_tag(a) != sexp_pointer_tag(b))) + return SEXP_FALSE; + + /* a and b are both pointers of the same type */ +#if SEXP_USE_BIGNUMS + if (sexp_pointer_tag(a) == SEXP_BIGNUM) + return sexp_make_boolean(!sexp_bignum_compare(a, b)); +#endif +#if SEXP_USE_FLONUMS && ! SEXP_USE_IMMEDIATE_FLONUMS + if (sexp_pointer_tag(a) == SEXP_FLONUM) + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); +#endif + t = sexp_object_type(ctx, a); + p0 = ((char*)a) + offsetof(struct sexp_struct, value); + p = (sexp*) (((char*)a) + sexp_type_field_base(t)); + q0 = ((char*)b) + offsetof(struct sexp_struct, value); + q = (sexp*) (((char*)b) + sexp_type_field_base(t)); + if ((sexp)p == a) {p=(sexp*)p0; q=(sexp*)q0;} + /* check preliminary non-object data */ + if ((p0 < (char*)p) && memcmp(p0, q0, ((char*)p - p0))) + return SEXP_FALSE; + /* check trailing non-object data */ + size = sexp_type_size_of_object(t, a) - offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,a)*sizeof(sexp)); + if (((char*)a + size) > p0) { + q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp)); + if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value)) + return SEXP_FALSE; + if (memcmp(p0, q0, size)) + return SEXP_FALSE; + } + /* check eq-object slots */ + len = sexp_type_num_eq_slots_of_object(t, a); + if (len > 0) { + for (i=0; i> 32; + return r.flonum; +} +sexp sexp_make_flonum (sexp ctx, float f) { + union sexp_flonum_conv x; + x.flonum = f; + return (sexp)(((sexp_uint_t)(x.bits) << 32) + SEXP_IFLONUM_TAG); +} +#endif +#endif + +sexp sexp_make_bytes_op (sexp ctx sexp_api_params(self, n), sexp len, sexp i) { + sexp_sint_t clen = sexp_unbox_fixnum(len); + sexp s; + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len); + if (clen < 0) return sexp_xtype_exception(ctx, self, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(bytes)+clen+1); + if (sexp_exceptionp(s)) return s; + sexp_pointer_tag(s) = SEXP_BYTES; +#if SEXP_USE_HEADER_MAGIC + sexp_pointer_magic(s) = SEXP_POINTER_MAGIC; +#endif + sexp_bytes_length(s) = clen; + if (sexp_fixnump(i)) + memset(sexp_bytes_data(s), sexp_unbox_fixnum(i), clen); + sexp_bytes_data(s)[clen] = '\0'; + return s; +} + +sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) +{ + sexp i = (sexp_charp(ch) ? sexp_make_fixnum(sexp_unbox_character(ch)) : ch); + sexp_gc_var2(b, s); + b = sexp_make_bytes_op(ctx sexp_api_pass(self, n), len, i); + if (sexp_exceptionp(b)) return b; +#if SEXP_USE_PACKED_STRINGS + sexp_pointer_tag(b) = SEXP_STRING; + return b; +#else + sexp_gc_preserve2(ctx, b, s); + s = sexp_alloc_type(ctx, string, SEXP_STRING); + sexp_string_bytes(s) = b; + sexp_string_offset(s) = 0; + sexp_string_length(s) = sexp_unbox_fixnum(len); + sexp_gc_release2(ctx); + return s; +#endif +} + +sexp sexp_c_string (sexp ctx, const char *str, sexp_sint_t slen) { + sexp_sint_t len = ((slen >= 0) ? slen : strlen(str)); + sexp s = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID); + memcpy(sexp_string_data(s), str, len); + sexp_string_data(s)[len] = '\0'; + return s; +} + +sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start); + if (sexp_not(end)) + end = sexp_make_fixnum(sexp_string_length(str)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end); + if ((sexp_unbox_fixnum(start) < 0) + || (sexp_unbox_fixnum(start) > sexp_string_length(str)) + || (sexp_unbox_fixnum(end) < 0) + || (sexp_unbox_fixnum(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_fixnum(start), + sexp_string_length(res)); + sexp_string_data(res)[sexp_string_length(res)] = '\0'; + return res; +} + +sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep) { + sexp res, ls; + sexp_uint_t len=0, i=0, sep_len=0; + char *p, *csep; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception(ctx, self, SEXP_STRING, sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + if (sexp_stringp(sep) && ((sep_len=sexp_string_length(sep)) > 0)) { + csep = sexp_string_data(sep); + len += sep_len*(i-1); + } + res = sexp_make_string(ctx, sexp_make_fixnum(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; + if (sep_len && sexp_pairp(sexp_cdr(ls))) { + memcpy(p, csep, sep_len); + p += sep_len; + } + } + *p = '\0'; + return res; +} + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#if SEXP_USE_HASH_SYMS + +static sexp_uint_t sexp_string_hash(const char *str, sexp_sint_t len, + sexp_uint_t acc) { + for ( ; len; len--) {acc *= FNV_PRIME; acc ^= *str++;} + return acc; +} + +#endif + +sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { +#if SEXP_USE_HUFF_SYMS + struct sexp_huff_entry he; + sexp_uint_t space=3, newbits; + char c; +#endif + sexp_uint_t res=FNV_OFFSET_BASIS, bucket, i=0; + const char *p=str; + sexp ls, tmp; + sexp_gc_var1(sym); + + if (len < 0) len = strlen(str); + +#if SEXP_USE_HUFF_SYMS + res = 0; + for ( ; i 127) + goto normal_intern; + 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); + + normal_intern: +#endif +#if SEXP_USE_HASH_SYMS + bucket = (sexp_string_hash(p, len-i, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if ((sexp_symbol_length(tmp=sexp_car(ls)) == len) + && ! strncmp(str, sexp_symbol_data(tmp), len)) + return sexp_car(ls); + + /* not found, make a new symbol */ + sexp_gc_preserve1(ctx, sym); + sym = sexp_c_string(ctx, str, len); + if (sexp_exceptionp(sym)) return sym; +#if ! SEXP_USE_PACKED_STRINGS + sym = sexp_string_bytes(sym); +#endif + sexp_pointer_tag(sym) = SEXP_SYMBOL; + sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); + sexp_gc_release1(ctx); + return sym; +} + +sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); +} + +sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt) { + sexp vec, *x; + int i, clen = sexp_unbox_fixnum(len); + if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR); + vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); + if (sexp_exceptionp(vec)) return vec; + x = sexp_vector_data(vec); + 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_fixnum(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_fixnum(sexp_stream_size(vec)); + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_stream_ctx(vec), + sexp_make_fixnum(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_fixnum(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_fixnum(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_fixnum(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_fixnum(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_fixnum(pos); + return pos; +} + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + FILE *in; + sexp res; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = str; + sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str)); + sexp_stream_pos(cookie) = SEXP_ZERO; + 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_release1(ctx); + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + FILE *out; + sexp res, size; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + size = sexp_make_fixnum(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(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_ZERO; + 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_release1(ctx); + return res; +} + +sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(ctx, + sexp_stream_buf(cookie), + SEXP_ZERO, + sexp_stream_pos(cookie)); +} + +#else + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + FILE *in; + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + if (sexp_string_length(str) == 0) + in = fopen("/dev/null", "r"); + else + in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + if (in) { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + if (sexp_string_length(str) == 0) + sexp_port_name(res) = sexp_c_string(ctx, "/dev/null", -1); + sexp_port_cookie(res) = str; /* for gc preservation */ + } else { + res = sexp_user_exception(ctx, SEXP_FALSE, "couldn't open string", str); + } + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + 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_op (sexp ctx sexp_api_params(self, n), 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, const 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, const 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_var1(tmp); + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, p); + 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_preserve1(ctx, tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_gc_release1(ctx); + } + sexp_port_offset(p) = 0; + return SEXP_VOID; + } +} + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + 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_op (sexp ctx sexp_api_params(self, n)) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + 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_op (sexp ctx sexp_api_params(self, n), sexp out) { + sexp res; + sexp_gc_var2(ls, tmp); + sexp_gc_preserve2(ctx, ls, 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_FALSE); + sexp_gc_release2(ctx); + return res; +} + +#endif + +sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { + sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); + if (sexp_exceptionp(p)) return p; + 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_no_closep(p) = 0; + sexp_port_sourcep(p) = 0; + 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); + if (sexp_exceptionp(p)) return p; + sexp_pointer_tag(p) = SEXP_OPORT; + return p; +} + +#define NUMBUF_LEN 32 + +sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { +#if SEXP_USE_HUFF_SYMS + unsigned long res, c; +#endif + unsigned long len; + long i=0; + double f; + sexp x, *elts; + char *str=NULL, numbuf[NUMBUF_LEN]; + + 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_one(ctx, sexp_car(obj), out); + for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { + sexp_write_char(ctx, ' ', out); + sexp_write_one(ctx, sexp_car(x), out); + } + if (! sexp_nullp(x)) { + sexp_write_string(ctx, " . ", out); + sexp_write_one(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_one(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_symbol_length(obj); + str = sexp_symbol_data(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; +#if SEXP_USE_BIGNUMS + case SEXP_BIGNUM: + sexp_write_bignum(ctx, obj, out, 10); + break; +#endif + case SEXP_OPCODE: + sexp_write_string(ctx, "#', out); + break; + default: + i = sexp_pointer_tag(obj); + sexp_write_string(ctx, "#<", out); + sexp_write_string(ctx, + (i < sexp_context_num_types(ctx)) + ? sexp_type_name_by_index(ctx, i) : "invalid", + out); + sexp_write_char(ctx, '>', out); + break; + } + } else if (sexp_fixnump(obj)) { + snprintf(numbuf, NUMBUF_LEN, "%ld", (long)sexp_unbox_fixnum(obj)); + sexp_write_string(ctx, numbuf, out); +#if SEXP_USE_IMMEDIATE_FLONUMS + } else if (sexp_flonump(obj)) { + f = sexp_flonum_value(obj); +#if SEXP_USE_INFINITIES + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else +#endif + { + i = snprintf(numbuf, NUMBUF_LEN, "%.8g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + 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); + c = sexp_unbox_character(obj); + if (c >= 0x100) { + if (c >= 0x10000) { + sexp_write_char(ctx, hex_digit((c>>20)&0x0F), out); + sexp_write_char(ctx, hex_digit((c>>16)&0x0F), out); + } + sexp_write_char(ctx, hex_digit((c>>12)&0x0F), out); + sexp_write_char(ctx, hex_digit((c>>8)&0x0F), out); + } + sexp_write_char(ctx, hex_digit((c>>4)&0x0F), out); + sexp_write_char(ctx, hex_digit(c&0x0F), out); + } + } else if (sexp_symbolp(obj)) { + +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(obj)) { + 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); + } + } + return SEXP_VOID; +} + +sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + return sexp_write_one(ctx, obj, out); +} + +sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { + sexp res=SEXP_VOID; + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + if (sexp_stringp(obj)) + sexp_write_string(ctx, sexp_string_data(obj), out); + else if (sexp_charp(obj)) + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else + res = sexp_write_one(ctx, obj, out); + return res; +} + +sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), sexp out) { + sexp_flush(ctx, out); + return SEXP_VOID; +} + +#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 'r': c = '\r'; 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, i) : 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, double whole, int negp) { + sexp exponent=SEXP_VOID; + 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; + if (c=='e' || c=='E') { + exponent = sexp_read_number(ctx, in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(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); + } else { + sexp_push_char(ctx, c, in); + } + res = (whole + res) * pow(10, e); + if (negp) res *= -1; + return sexp_make_flonum(ctx, res); +} + +sexp sexp_read_number (sexp ctx, sexp in, int base) { + sexp den; + sexp_uint_t res = 0, tmp; + int c, digit, negativep = 0; + + c = sexp_read_char(ctx, in); + if (c == '-') { + negativep = 1; + c = sexp_read_char(ctx, in); + } + + for ( ; isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + tmp = res * base + digit; +#if SEXP_USE_BIGNUMS + if ((tmp < res) || (tmp > SEXP_MAX_FIXNUM)) { + sexp_push_char(ctx, c, in); + return sexp_read_bignum(ctx, in, res, (negativep ? -1 : 1), base); + } +#endif + res = tmp; + } + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + return sexp_read_float_tail(ctx, in, res, negativep); + } else if (c=='/') { + den = sexp_read_number(ctx, in, base); + if (! sexp_fixnump(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_fixnum(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_fixnum(negativep ? -res : res); +} + +sexp sexp_read_raw (sexp ctx, sexp in) { + char *str; + int c1, c2, line; + sexp tmp2; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, 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); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res); + break; + case '`': + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res); + break; + case ',': + if ((c1 = sexp_read_char(ctx, in)) == '@') { + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_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)) { + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } + res = sexp_cons(ctx, tmp, res); + tmp = sexp_read_raw(ctx, in); + } + 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_fixnum(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_fixnum((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(ctx, in); + if (sexp_fixnump(res)) + res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res)); + break; + case 'f': case 'F': + case 't': case 'T': + c2 = sexp_read_char(ctx, in); + if (c2 == EOF || is_separator(c2)) { + res = (tolower(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; + break; + case '!': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + sexp_port_line(in)++; + 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); + sexp_push_char(ctx, c1, in); + if (c1 == EOF || is_separator(c1)) { + res = SEXP_RAWDOT; + } else if (isdigit(c1)) { + res = sexp_read_float_tail(ctx, in, 0, 0); + } else { + 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 SEXP_USE_FLONUMS + if (sexp_flonump(res)) +#if SEXP_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 +#if SEXP_USE_BIGNUMS + if (sexp_bignump(res)) { + if ((sexp_bignum_hi(res) == 1) + && (sexp_bignum_data(res)[0] == (SEXP_MAX_FIXNUM+1))) + res = sexp_make_fixnum(-sexp_bignum_data(res)[0]); + else + sexp_bignum_sign(res) = -sexp_bignum_sign(res); + } else +#endif + res = sexp_fx_mul(res, SEXP_NEG_ONE); + } + } else { + sexp_push_char(ctx, c2, in); + res = sexp_read_symbol(ctx, in, c1, 1); +#if SEXP_USE_INFINITIES + if (res == sexp_intern(ctx, "+inf.0", -1)) + res = sexp_make_flonum(ctx, 1.0/0.0); + else if (res == sexp_intern(ctx, "-inf.0", -1)) + res = sexp_make_flonum(ctx, -1.0/0.0); + else if (res == sexp_intern(ctx, "+nan.0", -1)) + res = sexp_make_flonum(ctx, 0.0/0.0); +#endif + } + 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_release2(ctx); + return res; +} + +sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in) { + sexp res; + sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in); + res = sexp_read_raw(ctx, in); + if (res == SEXP_CLOSE) + res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); + if (res == SEXP_RAWDOT) + res = sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); + return res; +} + +sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) { + sexp res; + sexp_gc_var2(s, in); + sexp_gc_preserve2(ctx, s, in); + s = sexp_c_string(ctx, str, len); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b) { + int base; + sexp_gc_var1(in); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b); + if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36)) + return sexp_user_exception(ctx, self, "invalid numeric base", b); + sexp_gc_preserve1(ctx, in); + in = sexp_make_input_string_port(ctx, str); + in = ((sexp_string_data(str)[0] == '#') ? + sexp_read(ctx, in) : sexp_read_number(ctx, in, base)); + sexp_gc_release1(ctx); + return sexp_numberp(in) ? in : SEXP_FALSE; +} + +sexp sexp_write_to_string (sexp ctx, sexp obj) { + sexp str; + sexp_gc_var1(out); + sexp_gc_preserve1(ctx, out); + out = sexp_make_output_string_port(ctx); + str = sexp_write(ctx, obj, out); + if (! sexp_exceptionp(str)) + str = sexp_get_output_string(ctx, out); + sexp_gc_release1(ctx); + return str; +} + +void sexp_init (void) { +#if SEXP_USE_GLOBAL_SYMBOLS + int i; +#endif + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if SEXP_USE_BOEHM + GC_init(); +#if SEXP_USE_GLOBAL_SYMBOLS + GC_add_roots((char*)&sexp_symbol_table, + ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); +#endif +#elif ! SEXP_USE_MALLOC + sexp_gc_init(); +#endif +#if SEXP_USE_GLOBAL_SYMBOLS + 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..820020c1 --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,48 @@ + +(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)))) 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/build/build-opts.txt b/tests/build/build-opts.txt new file mode 100644 index 00000000..e6bcd056 --- /dev/null +++ b/tests/build/build-opts.txt @@ -0,0 +1,21 @@ +CPPFLAGS=-DSEXP_USE_MODULES=0 +CPPFLAGS=-DSEXP_USE_DL=0 +CPPFLAGS=-DSEXP_USE_SIMPLIFY=0 +CPPFLAGS=-DSEXP_USE_TYPE_DEFS=0 +SEXP_USE_BOEHM=1 +CPPFLAGS=-DSEXP_USE_DEBUG_GC=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_HEAP=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_TYPES=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_SYMBOLS=1 +CPPFLAGS=-DSEXP_USE_FLONUMS=0 +CPPFLAGS=-DSEXP_USE_IMMEDIATE_FLONUMS=1 +CPPFLAGS=-DSEXP_USE_BIGNUMS=0 +CPPFLAGS=-DSEXP_USE_MATH=0 +CPPFLAGS=-DSEXP_WARN_UNDEFS=0 +CPPFLAGS=-DSEXP_USE_HUFF_SYMS=0 +CPPFLAGS=-DSEXP_USE_HASH_SYMS=0 +CPPFLAGS=-DSEXP_USE_STRING_STREAMS=0 +CPPFLAGS=-DSEXP_USE_AUTOCLOSE_PORTS=0 +CPPFLAGS=-DSEXP_USE_2010_EPOCH=0 +CPPFLAGS=-DSEXP_USE_CHECK_STACK=0 +CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 diff --git a/tests/build/build-tests.sh b/tests/build/build-tests.sh new file mode 100755 index 00000000..1d239629 --- /dev/null +++ b/tests/build/build-tests.sh @@ -0,0 +1,37 @@ +#! /bin/bash + +# test basic build options + +# for bootstrapping reasons this is a shell script, instead of a +# scheme script using (chibi process) + +# we just check each build against r5rs-tests.scm - +# some of the libraries will fail to build (notably +# if modules or user-defined types are disabled). + +BUILDDIR=tests/build +FAILURES=0 +i=0 + +for opts in `cat ${BUILDDIR}/build-opts.txt`; do + make cleaner 2>&1 >/dev/null + if make $opts chibi-scheme 2>&1 >${BUILDDIR}/build${i}-make.out; then + if make test 2>&1 | tee ${BUILDDIR}/build${i}-test.out | grep -q -E 'FAIL|ERROR'; then + echo "[FAIL] ${i}: tests failed with $opts" + FAILURES=$((FAILURES + 1)) + else + echo "[PASS] ${i}: tests passed with $opts" + fi + else + echo "[FAIL] ${i}: couldn't build with $opts" + FAILURES=$((FAILURES + 1)) + fi + i=$((i+1)) +done + +if (( FAILURES == 0 )); then + echo "build-tests: all tests passed" +else + echo "build-tests: ${FAILURES} tests failed" +fi + diff --git a/tests/hash-tests.scm b/tests/hash-tests.scm new file mode 100644 index 00000000..54fb4fc7 --- /dev/null +++ b/tests/hash-tests.scm @@ -0,0 +1,74 @@ + +(import (srfi 69)) + +(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) + (write *tests-run* out) + (display ". " 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test + 'white + (let ((ht (make-hash-table eq?))) + (hash-table-set! ht 'cat 'black) + (hash-table-set! ht 'dog 'white) + (hash-table-set! ht 'elephant 'pink) + (hash-table-ref/default ht 'dog #f))) + +(test + 'white + (let ((ht (make-hash-table equal?))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "dog" #f))) + +(test + 'white + (let ((ht (make-hash-table string-ci=? string-ci-hash))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "DOG" #f))) + +(test 625 + (let ((ht (make-hash-table))) + (do ((i 0 (+ i 1))) ((= i 1000)) + (hash-table-set! ht i (* i i))) + (hash-table-ref/default ht 25 #f))) + +(test-report) + diff --git a/tests/install/install-tests.pl b/tests/install/install-tests.pl new file mode 100755 index 00000000..63681324 --- /dev/null +++ b/tests/install/install-tests.pl @@ -0,0 +1,57 @@ +#! /usr/bin/env perl + +use strict; +use warnings; + +my $ROOT="tests/install/root"; +my $USER=$ENV{USER}; + +my $ignore = qr!/lib\d*/modules|/X11|alsa-lib|aspell|dosemu|emacs|erlang|/perl|python|ruby|lisp|sbcl|/ghc-|ocaml|evolution|office|gimp|gtk|mysql|postgres|wordnet|xulrunner!; + +sub linkdir ($$$) { + my ($FROM, $TO, $DEPTH) = @_; + mkdir $TO; + for my $f (`ls $FROM`) { + chomp $f; + if (-d "$FROM/$f") { + if (($DEPTH > 0) && ($FROM !~ $ignore)) { + linkdir("$FROM/$f", "$TO/$f", $DEPTH-1); + } + } else { + link "$FROM/$f", "$TO/$f"; + } + } +} + +mkdir "$ROOT"; +mkdir "$ROOT/bin"; +mkdir "$ROOT/sbin"; +mkdir "$ROOT/dev"; +mkdir "$ROOT/etc"; +mkdir "$ROOT/etc/alternatives"; +mkdir "$ROOT/lib"; +mkdir "$ROOT/lib64"; +mkdir "$ROOT/usr"; +mkdir "$ROOT/usr/bin"; +mkdir "$ROOT/usr/include"; +mkdir "$ROOT/usr/lib"; +mkdir "$ROOT/usr/lib/gcc"; + +linkdir "/bin", "$ROOT/bin", 1; +linkdir "/sbin", "$ROOT/sbin", 1; +link "/etc/passwd", "$ROOT/etc/passwd"; +linkdir "/etc/alternatives", "$ROOT/etc/alternatives", 1; +linkdir "/lib", "$ROOT/lib", 3; +linkdir "/lib64", "$ROOT/lib64", 3; +linkdir "/usr/bin", "$ROOT/usr/bin", 3; +linkdir "/usr/include", "$ROOT/usr/include", 2; +linkdir "/usr/lib", "$ROOT/usr/lib", 3; +linkdir "/usr/lib/gcc", "$ROOT/usr/lib/gcc", 3; + +`make dist`; +my $VERSION=`cat VERSION`; +chomp $VERSION; +`cp chibi-scheme-$VERSION.tgz $ROOT/`; +`sed -e 's/\@VERSION\@/$VERSION/g' $ROOT/bin/run-install-test.sh`; +`chmod 755 $ROOT/bin/run-install-test.sh`; +exec "sudo chroot $ROOT run-install-test.sh"; diff --git a/tests/install/run-install-test.sh b/tests/install/run-install-test.sh new file mode 100755 index 00000000..c558e7cd --- /dev/null +++ b/tests/install/run-install-test.sh @@ -0,0 +1,12 @@ +#! /bin/bash + +export PATH=/usr/local/bin:$PATH +export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH + +tar xzvf chibi-scheme-@VERSION@.tgz +cd chibi-scheme-@VERSION@ +make +make install +cp tests/r5rs-tests.scm .. +cd .. +chibi-scheme r5rs-tests.scm | tee r5rs-tests.out diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm new file mode 100644 index 00000000..1c49d48f --- /dev/null +++ b/tests/loop-tests.scm @@ -0,0 +1,202 @@ + +(import (chibi loop)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test + "stepping" + '(0 1 2) + (loop lp ((with i 0 (+ i 1)) + (with res '() (cons i res))) + (if (= i 3) + (reverse res) + (lp)))) + +(test + "basic in-list" + '(c b a) + (let ((res '())) + (loop ((for x (in-list '(a b c)))) + (set! res (cons x res))) + res)) + +(test + "in-list with result" + '(c b a) + (loop ((for x (in-list '(a b c))) + (with res '() (cons x res))) + => res)) + +(test + "in-list with listing" + '(a b c) + (loop ((for x (in-list '(a b c))) (for res (listing x))) => res)) + +(test + "in-list with listing-reverse" + '(c b a) + (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res)) + +(test + "uneven length in-list's" + '((a . 1) (b . 2) (c . 3)) + (loop ((for x (in-list '(a b c))) + (for y (in-list '(1 2 3 4))) + (for res (listing (cons x y)))) + => res)) + +(test + "in-lists" + '((a 1) (b 2) (c 3)) + (loop ((for ls (in-lists '((a b c) (1 2 3)))) + (for res (listing ls))) + => res)) + +(define (flatten ls) + (reverse + (loop lp ((for x ls (in-list ls)) (with res '())) + => res + (if (pair? x) + (lp (=> res (lp (=> ls x)))) + (lp (=> res (cons x res))))))) + +(test + "flatten (recursion test)" + '(1 2 3 4 5 6 7) + (flatten '(1 (2) (3 (4 (5)) 6) 7))) + +(test + "in-string" + '(#\h #\e #\l #\l #\o) + (loop ((for c (in-string "hello")) (for res (listing c))) => res)) + +(test + "in-string with start" + '(#\l #\o) + (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res)) + +(test + "in-string with start and end" + '(#\h #\e #\l #\l) + (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res)) + +(test + "in-string with start, end and step" + '(#\e #\l) + (loop ((for c (in-string "hello" 1 4 2)) (for res (listing c))) => res)) + +(test + "in-string-reverse" + '(#\o #\l #\l #\e #\h) + (loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res)) + +(test + "in-vector" + '(1 2 3) + (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res)) + +(test "up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 8))) + (for res (listing i))) + => res)) + +(test "up-from by" '(5 10 15) + (loop ((for i (up-from 5 (to 20) (by 5))) + (for res (listing i))) + => res)) + +(test "up-from listing if" '(10 12 14 16 18) + (loop ((for i (up-from 10 (to 20))) + (for res (listing i (if (even? i))))) + => res)) + +(test "down-from" '(7 6 5) + (loop ((for i (down-from 8 (to 5))) + (for res (listing i))) + => res)) + +(test "down-from by" '(15 10 5) + (loop ((for i (down-from 20 (to 5) (by 5))) + (for res (listing i))) + => res)) + +(test "down-from listing if" '(18 16 14 12 10) + (loop ((for i (down-from 20 (to 10))) + (for res (listing i (if (even? i))))) + => res)) + +(test "appending" '(1 2 3 4 5 6 7 8 9) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending ls))) + => res)) + +(test "appending-reverse" '(9 8 7 6 5 4 3 2 1) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending-reverse ls))) + => res)) + +(test "while + up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 10))) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "up-from by, open-ended" '(5 7 9) + (loop ((for i (up-from 5 (by 2))) + (while (< i 10)) + (for res (listing i))) + => res)) + +(test "up-from open-ended" '(5 6 7) + (loop ((for i (up-from 5)) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "down-from by, open-ended" '(5 3 1) + (loop ((for i (down-from 7 (by 2))) + (until (< i 1)) + (for res (listing i))) + => res)) + +(test "down-from open-ended" '(4 3 2) + (loop ((for i (down-from 5)) + (until (< i 2)) + (for res (listing i))) + => res)) + +(test-report) + diff --git a/tests/match-tests.scm b/tests/match-tests.scm new file mode 100644 index 00000000..a223e729 --- /dev/null +++ b/tests/match-tests.scm @@ -0,0 +1,196 @@ + +(import (chibi match)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test "any" (match 'any (_ 'ok)) 'ok) +(test "symbol" (match 'ok (x x)) 'ok) +(test "number" (match 28 (28 'ok)) 'ok) +(test "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok) +(test "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok) +(test "null" (match '() (() 'ok)) 'ok) +(test "pair" (match '(ok) ((x) x)) 'ok) +(test "vector" (match '#(ok) (#(x) x)) 'ok) +(test "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok) +(test "and empty" (match '(o k) ((and) 'ok)) 'ok) +(test "and single" (match 'ok ((and x) x)) 'ok) +(test "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok) +(test "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok) +(test "or single" (match 'ok ((or x) 'ok)) 'ok) +(test "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok) +(test "not" (match 28 ((not (a . b)) 'ok)) 'ok) +(test "pred" (match 28 ((? number?) 'ok)) 'ok) +(test "named pred" (match 28 ((? number? x) (+ x 1))) 29) + +(test "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok) +(test "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok) +(test "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok) + +(test "ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ___) (list x y))) + '((a b c) (1 2 3))) + +(test "real ellipses" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ...) (list x y))) + '((a b c) (1 2 3))) + +(test "vector ellipses" + (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) + (#(a b c (hd . tl) ...) (list a b c hd tl))) + '(1 2 3 (a b c) (1 2 3))) + +(test "pred ellipses" + (match '(1 2 3) + (((? odd? n) ___) n) + (((? number? n) ___) n)) + '(1 2 3)) + +(test "failure continuation" + (match '(1 2) + ((a . b) (=> next) (if (even? a) 'fail (next))) + ((a . b) 'ok)) + 'ok) + +(test "let" + (match-let ((x 'ok) (y '(o k))) + y) + '(o k)) + +(test "let*" + (match-let* ((x 'f) (y 'o) ((z w) (list y x))) + (list x y z w)) + '(f o o f)) + +(test "getter car" + (match '(1 . 2) (((get! a) . b) (list (a) b))) + '(1 2)) + +(test "getter cdr" + (match '(1 . 2) ((a . (get! b)) (list a (b)))) + '(1 2)) + +(test "getter vector" + (match '#(1 2 3) (#((get! a) b c) (list (a) b c))) + '(1 2 3)) + +(test "setter car" + (let ((x (cons 1 2))) + (match x (((set! a) . b) (a 3))) + x) + '(3 . 2)) + +(test "setter cdr" + (let ((x (cons 1 2))) + (match x ((a . (set! b)) (b 3))) + x) + '(1 . 3)) + +(test "setter vector" + (let ((x (vector 1 2 3))) + (match x (#(a (set! b) c) (b 0))) + x) + '#(1 0 3)) + +(test "single tail" + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) (c . 3))) + +(test "single tail 2" + (match '((a . 1) (b . 2) 3) + (((x . y) ... last) (list x y last))) + '((a b) (1 2) 3)) + +(test "multiple tail" + (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) + (((x . y) ... u v w) (list x y u v w))) + '((a b) (1 2) (c . 3) (d . 4) (e . 5))) + +(test "Riastradh quasiquote" + (match '(1 2 3) (`(1 ,b ,c) (list b c))) + '(2 3)) + +(test "trivial tree search" + (match '(1 2 3) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "simple tree search" + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "deep tree search" + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "non-tail tree search" + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "restricted tree search" + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))) + '(1 2 3)) + +(test "fail restricted tree search" + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f)) + #f) + +(test "sxml tree search" + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f)) + '(((href . "http://synthcode.com/")) ("synthcode"))) + +(test "failed sxml tree search" + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f)) + #f) + +(test "collect tree search" + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f)) + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))) + +(test-report) + diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm new file mode 100644 index 00000000..76a783f0 --- /dev/null +++ b/tests/numeric-tests.scm @@ -0,0 +1,150 @@ + +;; these tests are only valid if chibi-scheme is compiled with full +;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-neighborhoods x) + (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) + +(test '(536870912 536870913 536870911 -536870912 -536870911 -536870913) + (integer-neighborhoods (expt 2 29))) + +(test '(1073741824 1073741825 1073741823 -1073741824 -1073741823 -1073741825) + (integer-neighborhoods (expt 2 30))) + +(test '(2147483648 2147483649 2147483647 -2147483648 -2147483647 -2147483649) + (integer-neighborhoods (expt 2 31))) + +(test '(4294967296 4294967297 4294967295 -4294967296 -4294967295 -4294967297) + (integer-neighborhoods (expt 2 32))) + +(test '(4611686018427387904 4611686018427387905 4611686018427387903 + -4611686018427387904 -4611686018427387903 -4611686018427387905) + (integer-neighborhoods (expt 2 62))) + +(test '(9223372036854775808 9223372036854775809 9223372036854775807 + -9223372036854775808 -9223372036854775807 -9223372036854775809) + (integer-neighborhoods (expt 2 63))) + +(test '(18446744073709551616 18446744073709551617 18446744073709551615 + -18446744073709551616 -18446744073709551615 -18446744073709551617) + (integer-neighborhoods (expt 2 64))) + +(test '(85070591730234615865843651857942052864 + 85070591730234615865843651857942052865 + 85070591730234615865843651857942052863 + -85070591730234615865843651857942052864 + -85070591730234615865843651857942052863 + -85070591730234615865843651857942052865) + (integer-neighborhoods (expt 2 126))) + +(test '(170141183460469231731687303715884105728 + 170141183460469231731687303715884105729 + 170141183460469231731687303715884105727 + -170141183460469231731687303715884105728 + -170141183460469231731687303715884105727 + -170141183460469231731687303715884105729) + (integer-neighborhoods (expt 2 127))) + +(test '(340282366920938463463374607431768211456 + 340282366920938463463374607431768211457 + 340282366920938463463374607431768211455 + -340282366920938463463374607431768211456 + -340282366920938463463374607431768211455 + -340282366920938463463374607431768211457) + (integer-neighborhoods (expt 2 128))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-arithmetic-combinations a b) + (list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b))) + +(define (sign-combinations a b) + (list (integer-arithmetic-combinations a b) + (integer-arithmetic-combinations (- a) b) + (integer-arithmetic-combinations a (- b)) + (integer-arithmetic-combinations (- a) (- b)))) + +;; fix x fix +(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0)) + (sign-combinations 0 1)) +(test '((2 0 1 1 0) (0 -2 -1 -1 0) (0 2 -1 -1 0) (-2 0 1 1 0)) + (sign-combinations 1 1)) +(test '((59 25 714 2 8) (-25 -59 -714 -2 -8) + (25 59 -714 -2 8) (-59 -25 714 2 -8)) + (sign-combinations 42 17)) + +;; fix x big +(test '((4294967338 -4294967254 180388626432 0 42) + (4294967254 -4294967338 -180388626432 0 -42) + (-4294967254 4294967338 -180388626432 0 42) + (-4294967338 4294967254 180388626432 0 -42)) + (sign-combinations 42 (expt 2 32))) + +;; big x fix +(test '((4294967338 4294967254 180388626432 102261126 4) + (-4294967254 -4294967338 -180388626432 -102261126 -4) + (4294967254 4294967338 -180388626432 -102261126 4) + (-4294967338 -4294967254 180388626432 102261126 -4)) + (sign-combinations (expt 2 32) 42)) + +;; big x bigger +(test '((12884901889 -4294967297 36893488151714070528 0 4294967296) + (4294967297 -12884901889 -36893488151714070528 0 -4294967296) + (-4294967297 12884901889 -36893488151714070528 0 4294967296) + (-12884901889 4294967297 36893488151714070528 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) + +(test '((18446744078004518913 -18446744069414584321 79228162514264337597838917632 0 4294967296) + (18446744069414584321 -18446744078004518913 -79228162514264337597838917632 0 -4294967296) + (-18446744069414584321 18446744078004518913 -79228162514264337597838917632 0 4294967296) + (-18446744078004518913 18446744069414584321 79228162514264337597838917632 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 64)))) + +;; bigger x big +(test '((12884901889 4294967297 36893488151714070528 2 1) + (-4294967297 -12884901889 -36893488151714070528 -2 -1) + (4294967297 12884901889 -36893488151714070528 -2 1) + (-12884901889 -4294967297 36893488151714070528 2 -1)) + (sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) + +(test '((18446744078004518913 18446744069414584321 79228162514264337597838917632 4294967296 1) + (-18446744069414584321 -18446744078004518913 -79228162514264337597838917632 -4294967296 -1) + (18446744069414584321 18446744078004518913 -79228162514264337597838917632 -4294967296 1) + (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1)) + (sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) + +(test-report) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..a9197fb1 --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,465 @@ + +(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) + (write *tests-run*) + (display ". ") + (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 -2 (let () + (define x 2) + (define f (lambda () (- x))) + (f))) + +(define let*-def 1) +(let* () (define let*-def 2) #f) +(test 1 let*-def) + +(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 4 16 9 8) + `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 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 #f (eqv? 2 2.0)) + +;;(test #f (equal? 2.0 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 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 127 (string->number "177" 8)) + +(test 5 (string->number "101" 2)) + +(test 100.0 (string->number "1e2")) + +(test "100" (number->string 100)) + +(test "100" (number->string 256 16)) + +(test "FF" (number->string 255 16)) + +(test "177" (number->string 127 8)) + +(test "101" (number->string 5 2)) + +(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 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + +(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 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad)))) + +(test 'ok (let ((=> 1)) (cond (#t => 'ok)))) + +(test '(,foo) (let ((unquote 1)) `(,foo))) + +(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) + +(test 'ok + (let ((... 2)) + (let-syntax ((s (syntax-rules () + ((_ x ...) 'bad) + ((_ . r) 'ok)))) + (s a b c)))) + +(test 'ok (let () + (let-syntax () + (define internal-def 'ok)) + internal-def)) + +(test 'ok (let () + (letrec-syntax () + (define internal-def 'ok)) + internal-def)) + +(test '(2 1) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y)))))) + +(test '(2 2) + ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y)))))) + +(test '(1 2) + ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y)))))) + +(test '(2 3) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) + +(test '(a b c) + (let* ((path '()) + (add (lambda (s) (set! path (cons s path))))) + (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) + (reverse path))) + +(test '(connect talk1 disconnect connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + +(test 2 (let-syntax + ((foo (syntax-rules ::: () + ((foo ... args :::) + (args ::: ...))))) + (foo 3 - 5))) + +(test '(5 4 1 2 3) + (let-syntax + ((foo (syntax-rules () + ((foo args ... penultimate ultimate) + (list ultimate penultimate args ...))))) + (foo 1 2 3 4 5))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm new file mode 100644 index 00000000..5471e648 --- /dev/null +++ b/tests/sort-tests.scm @@ -0,0 +1,57 @@ + +(import (srfi 95)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test "sort null" (sort '()) '()) +(test "sort null <" (sort '() <) '()) +(test "sort null < car" (sort '() < car) '()) +(test "sort list" (sort '(7 5 2 8 1 6 4 9 3)) '(1 2 3 4 5 6 7 8 9)) +(test "sort list <" (sort '(7 5 2 8 1 6 4 9 3) <) '(1 2 3 4 5 6 7 8 9)) +(test "sort list < car" (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car) + '((1) (2) (3) (4) (5) (6) (7) (8) (9))) +(test "sort list (lambda (a b) (< (car a) (car b)))" + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) + (lambda (a b) (< (car a) (car b)))) + '((1) (2) (3) (4) (5) (6) (7) (8) (9))) +(test "sort 1-char symbols" (sort '(h b k d a c j i e g f)) + '(a b c d e f g h i j k)) +(test "sort short symbols" (sort '(h b aa k d a ee c j i e g f)) + '(a aa b c d e ee f g h i j k)) +(test "sort long symbols" (sort '(h b aa k d a ee c j i bzzzzzzzzzzzzzzzzzzzzzzz e g f)) + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz c d e ee f g h i j k)) + +(test-report) diff --git a/tests/thread-tests.scm b/tests/thread-tests.scm new file mode 100644 index 00000000..df6d8a69 --- /dev/null +++ b/tests/thread-tests.scm @@ -0,0 +1,58 @@ + +(import (srfi 18)) + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test name expr expect) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display name 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; run tests + +(test "no threads" (begin 'ok) 'ok) +(test "unstarted thread" (let ((t (make-thread (lambda () (error "oops"))))) 'ok) 'ok) +(test "ignored thread terminates" (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) 'ok) 'ok) +(test "ignored thread hangs" (let ((t (make-thread (lambda () (let lp () (lp)))))) (thread-start! t) 'ok) 'ok) +(test "joined thread terminates" (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) (thread-join! t) 'ok) 'ok) +(test "joined thread hangs, timeout" (let ((t (make-thread (lambda () (let lp () (lp)))))) (thread-start! t) (thread-join! t 1 'timeout)) 'timeout) + +(test "basic mutex" (let ((m (make-mutex))) (and (mutex? m) 'ok)) 'ok) +(test "mutex unlock" (let ((m (make-mutex))) (and (mutex-unlock! m) 'ok)) 'ok) +(test "mutex lock/unlock" (let ((m (make-mutex))) (and (mutex-lock! m) (mutex-unlock! m) 'ok)) 'ok) +(test "mutex lock timeout" (let* ((m (make-mutex)) (t (make-thread (lambda () (mutex-lock! m))))) (thread-start! t) (thread-yield!) (if (mutex-lock! m 1) 'fail 'timeout)) 'timeout) + +;(test "basic condition-variable" () 'ok) +;(test "condition-variable signal" () 'ok) +;(test "condition-variable broadcast" () 'ok) + +;(test "mailbox") + +(test-report) + diff --git a/tools/genstatic.scm b/tools/genstatic.scm new file mode 100755 index 00000000..3382698e --- /dev/null +++ b/tools/genstatic.scm @@ -0,0 +1,135 @@ +#! /usr/bin/env chibi-scheme + +(import (chibi filesystem) + (chibi pathname)) + +(define c-libs '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (path-relative path dir) + (let ((p-len (string-length path)) + (d-len (string-length dir))) + (and (> p-len d-len) + (string=? dir (substring path 0 d-len)) + (cond + ((eqv? #\/ (string-ref path d-len)) + (substring path (+ d-len 1) p-len)) + ((eqv? #\/ (string-ref path (- d-len 1))) + (substring path d-len p-len)) + (else #f))))) + +(define (path-split file) + (let ((len (string-length file))) + (let lp ((i 0) (res '())) + (let ((j (string-scan #\/ file i))) + (cond + (j (lp (+ j 1) (cons (substring file i j) res))) + (else (reverse (if (= i len) + res + (cons (substring file i len) res))))))))) + +(define (init-name mod) + (string-append "sexp_init_lib_" + (string-concatenate (map mangle mod) "_"))) + +(define (find-c-libs basedir) + (define (process-dir dir) + (directory-fold + dir + (lambda (f x) + (if (and (not (equal? "" f)) (not (eqv? #\. (string-ref f 0)))) + (process (string-append dir "/" f)))) + #f)) + (define (process file) + (cond + ((file-directory? file) + (process-dir file)) + ((equal? "module" (path-extension file)) + (let* ((mod-path (path-strip-extension (path-relative file basedir))) + (mod-name (map (lambda (x) (or (string->number x) (string->symbol x))) + (path-split mod-path)))) + (cond + ((eval `(find-module ',mod-name) *config-env*) + => (lambda (mod) + (cond + ((assq 'include-shared (vector-ref mod 2)) + => (lambda (x) + (set! c-libs + (cons (cons (string-append + (path-directory file) + "/" + (cadr x) + ".c") + (init-name mod-name)) + c-libs)))))))))))) + (process-dir basedir)) + +(define (include-c-lib lib) + (display "#define sexp_init_library ") + (display (cdr lib)) + (newline) + (display "#include \"") + (display (car lib)) + (display "\"") + (newline) + (display "#undef sexp_init_library") + (newline) + (newline)) + +(define (init-c-lib lib) + (display " ") + (display (cdr lib)) + (display "(ctx, env);\n")) + +(define (main args) + (find-c-libs (if (pair? (cdr args)) (cadr args) "lib")) + (newline) + (for-each include-c-lib c-libs) + (newline) + (display "static sexp sexp_init_all_libraries (sexp ctx, sexp env) {\n") + (for-each init-c-lib c-libs) + (display " return SEXP_VOID;\n") + (display "}\n\n")) + diff --git a/tools/genstubs.scm b/tools/genstubs.scm new file mode 100755 index 00000000..114320b4 --- /dev/null +++ b/tools/genstubs.scm @@ -0,0 +1,1268 @@ +#! /usr/bin/env chibi-scheme + +;; Note: this evolved as a throw-away script to provide certain core +;; modules, and so is a mess. Tread carefully. + +;; Simple C FFI. "genstubs.scm file.stub" will read in the C function +;; FFI definitions from file.stub and output the appropriate C +;; wrappers into file.c. You can then compile that file with: +;; +;; cc -fPIC -shared file.c -lchibi-scheme +;; +;; (or using whatever flags are appropriate to generate shared libs on +;; your platform) and then the generated .so file can be loaded +;; directly with load, or portably using (include-shared "file") in a +;; module definition (note that include-shared uses no suffix). + +;; The goal of this interface is to make access to C types and +;; functions easy, without requiring the user to write any C code. +;; That means the stubber needs to be intelligent about various C +;; calling conventions and idioms, such as return values passed in +;; actual parameters. Writing C by hand is still possible, and +;; several of the core modules provide C interfaces directly without +;; using the stubber. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Struct Interface +;; +;; (define-c-struct struct-name +;; [predicate: predicate-name] +;; [constructor: constructor-name] +;; [finalizer: c_finalizer_name] +;; (type c_field_name getter-name setter-name) ...) +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Function Interface +;; +;; (define-c return-type name-spec (arg-type ...)) +;; +;; where name-space is either a symbol name, or a list of +;; (scheme-name c_name). If just a symbol, the C name is taken +;; to be the same with -'s replaced by _'s. +;; +;; arg-type is a type suitable for input validation and conversion. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Types +;; +;; Types +;; +;; Basic Types +;; void +;; boolean +;; char +;; sexp (no conversions) +;; +;; Integer Types: +;; signed-char short int long +;; unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t +;; time_t (in seconds, but using the chibi epoch of 2010/01/01) +;; errno (as a return type returns #f on error) +;; +;; Float Types: +;; float double long-double +;; +;; String Types: +;; string - a null-terminated char* +;; env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme +;; in addition you can use (array char) as a string +;; +;; Port Types: +;; input-port output-port +;; port-or-fd - an fd-backed port or a fixnum +;; +;; Struct Types: +;; +;; Struct types are by default just referred to by the bare +;; struct-name from define-c-struct, and it is assumed you want a +;; pointer to that type. To refer to the full struct, use the struct +;; modifier, as in (struct struct-name). + +;; Type modifiers +;; +;; Any type may also be written as a list of modifiers followed by the +;; type itself. The supported modifiers are: +;; +;; const: prepends the "const" C type modifier +;; * as a return or result parameter, makes non-immediates immutable +;; +;; free: it's Scheme's responsibility to "free" this resource +;; * as a return or result parameter, registers the freep flag +;; this causes the type finalizer to be run when GCed +;; +;; maybe-null: this pointer type may be NULL +;; * as a result parameter, NULL is translated to #f +;; normally this would just return a wrapped NULL pointer +;; * as an input parameter, #f is translated to NULL +;; normally this would be a type error +;; +;; pointer: create a pointer to this type +;; * as a return parameter, wraps the result in a vanilla cpointer +;; * as a result parameter, boxes then unboxes the value +;; +;; struct: treat this struct type as a struct, not a pointer +;; * as an input parameter, dereferences the pointer +;; * as a type field, indicates a nested struct +;; +;; link: add a gc link +;; * as a field getter, link to the parent object, so the +;; parent won't be GCed so long as we have a reference +;; to the child. this behavior is automatic for nested +;; structs. +;; +;; result: return a result in this parameter +;; * if there are multiple results (including the return type), +;; they are all returned in a list +;; * if there are any result parameters, a return type +;; of errno returns #f on failure, and as eliminated +;; from the list of results otherwise +;; +;; (value ): specify a fixed value +;; * as an input parameter, this parameter is not provided +;; in the Scheme API but always passed as +;; +;; (default ): specify a default value +;; * as the final input parameter, makes the Scheme parameter +;; optional, defaulting to +;; +;; (array []) an array type +;; * length must be specified for return and result parameters +;; * if specified, length can be any of +;; ** an integer, for a fixed size +;; ** the symbol null, indicating a NULL-terminated array + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; globals + +(define *types* '()) +(define *funcs* '()) +(define *consts* '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type objects + +(define (parse-type type . o) + (cond + ((vector? type) + type) + (else + (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) + (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f) + (value #f) (default? #f)) + (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) + (case (and (pair? type) (car type)) + ((free) + (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) + ((const) + (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) + ((maybe-null) + (lp (next) free? const? #t ptr? struct? link? result? array value default?)) + ((pointer) + (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) + ((struct) + (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) + ((link) + (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) + ((result) + (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) + ((array) + (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) + ((value) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) + ((default) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) + (else + (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) + +(define (type-base type) (vector-ref type 0)) +(define (type-free? type) (vector-ref type 1)) +(define (type-const? type) (vector-ref type 2)) +(define (type-null? type) (vector-ref type 3)) +(define (type-pointer? type) (vector-ref type 4)) +(define (type-struct? type) (vector-ref type 5)) +(define (type-link? type) (vector-ref type 6)) +(define (type-result? type) (vector-ref type 7)) +(define (type-array type) (vector-ref type 8)) +(define (type-value type) (vector-ref type 9)) +(define (type-default? type) (vector-ref type 10)) +(define (type-index type) (vector-ref type 11)) + +(define (type-auto-expand? type) + (and (pair? (type-array type)) + (memq 'auto-expand (type-array type)))) + +(define (type-index-string type) + (if (integer? (type-index type)) + (number->string (type-index type)) + "")) + +(define (struct-fields ls) + (let lp ((ls ls) (res '())) + (cond ((null? ls) (reverse res)) + ((symbol? (car ls)) (lp (cddr ls) res)) + (else (lp (cdr ls) (cons (car ls) res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type predicates + +(define (signed-int-type? type) + (memq type '(signed-char short int long boolean))) + +(define (unsigned-int-type? type) + (memq type '(unsigned-char unsigned-short unsigned-int unsigned-long + size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t + uid_t gid_t pid_t blksize_t blkcnt_t sigval_t))) + +(define (int-type? type) + (or (signed-int-type? type) (unsigned-int-type? type))) + +(define (float-type? type) + (memq type '(float double long-double long-long-double))) + +(define (string-type? type) + (or (memq type '(char* string env-string non-null-string)) + (and (vector? type) + (type-array type) + (not (type-pointer? type)) + (eq? 'char (type-base type))))) + +(define (port-type? type) + (memq type '(port input-port output-port))) + +(define (error-type? type) + (memq type '(errno non-null-string non-null-pointer))) + +(define (array-type? type) + (and (type-array type) (not (eq? 'char (type-base type))))) + +(define (basic-type? type) + (let ((type (parse-type type))) + (and (not (type-array type)) + (not (void-pointer-type? type)) + (not (assq (type-base type) *types*))))) + +(define (void-pointer-type? type) + (or (and (eq? 'void (type-base type)) (type-pointer? type)) + (eq? 'void* (type-base type)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; function objects + +(define (parse-func func) + (if (not (and (= 3 (length func)) + (or (identifier? (cadr func)) (list (cadr func))) + (list (caddr func)))) + (error "bad function definition" func)) + (let* ((ret-type (parse-type (car func))) + (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) + (c-name (if (pair? (cadr func)) + (cadadr func) + (mangle scheme-name))) + (stub-name (if (and (pair? (cadr func)) (pair? (cddadr func))) + (car (cddadr func)) + (generate-stub-name scheme-name)))) + (let lp ((ls (caddr func)) + (i 0) + (results '()) + (c-args '()) + (s-args '())) + (cond + ((null? ls) + ;;(if (> i 6) + ;; (error "FFI currently only supports up to 6 scheme args" func)) + (vector scheme-name c-name stub-name ret-type + (reverse results) (reverse c-args) (reverse s-args))) + (else + (let ((type (parse-type (car ls) i))) + (cond + ((type-result? type) + (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) + ((and (type-value type) (not (type-default? type))) + (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) + (else + (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) + ))))))) + +(define (func-scheme-name func) (vector-ref func 0)) +(define (func-c-name func) (vector-ref func 1)) +(define (func-stub-name func) (vector-ref func 2)) +(define (func-ret-type func) (vector-ref func 3)) +(define (func-results func) (vector-ref func 4)) +(define (func-c-args func) (vector-ref func 5)) +(define (func-scheme-args func) (vector-ref func 6)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (cat . args) + (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (filter pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (cons (car ls) (filter pred (cdr ls)))) + (else (filter pred (cdr ls))))) + +(define (remove pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (filter pred (cdr ls))) + (else (cons (car ls) (filter pred (cdr ls)))))) + +(define (strip-extension path) + (let lp ((i (- (string-length path) 1))) + (cond ((<= i 0) path) + ((eq? #\. (string-ref path i)) (substring path 0 i)) + (else (lp (- i 1)))))) + +(define (string-concatenate-reverse ls) + (cond ((null? ls) "") + ((null? (cdr ls)) (car ls)) + (else (string-concatenate (reverse ls))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase str) + (list->string (map char-downcase (string->list str)))) + +(define (with-output-to-string thunk) + (call-with-output-string + (lambda (out) + (let ((old-out (current-output-port))) + (current-output-port out) + (thunk) + (current-output-port old-out))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; naming + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +(define (generate-stub-name sym) + (string-append "sexp_" (mangle sym) "_stub")) + +(define (type-id-name sym) + (string-append "sexp_" (mangle sym) "_type_id")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; .stub file interface + +(define (c-declare . args) + (apply cat args) + (newline)) + +(define (c-include header) + (cat "\n#include \"" header "\"\n")) + +(define (c-system-include header) + (cat "\n#include <" header ">\n")) + +(define (parse-struct-like ls) + (let lp ((ls ls) (res '())) + (cond + ((null? ls) + (reverse res)) + ((symbol? (car ls)) + (lp (cddr ls) (cons (cadr ls) (cons (car ls) res)))) + ((pair? (car ls)) + (lp (cdr ls) (cons (cons (parse-type (caar ls)) (cdar ls)) res))) + (else + (lp (cdr ls) (cons (car ls) res)))))) + +(define-syntax define-struct-like + (er-macro-transformer + (lambda (expr rename compare) + (set! *types* + `((,(cadr expr) + ,@(parse-struct-like (cddr expr))) + ,@*types*)) + `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) + +(define-syntax define-c-struct + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr))))) + +(define-syntax define-c-class + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) + +(define-syntax define-c-type + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) ,@(cddr expr))))) + +(define-syntax define-c + (er-macro-transformer + (lambda (expr rename compare) + (set! *funcs* (cons (parse-func (cdr expr)) *funcs*)) + #f))) + +(define-syntax define-c-const + (er-macro-transformer + (lambda (expr rename compare) + (set! *consts* + (cons (cons (parse-type (cadr expr)) (cddr expr)) *consts*))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; C code generation + +(define (c->scheme-converter type val . o) + (let ((base (type-base type))) + (cond + ((and (eq? base 'void) (not (type-pointer? type))) + (cat "((" val "), SEXP_VOID)")) + ((or (eq? base 'sexp) (error-type? base)) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_make_boolean(" val ")")) + ((eq? base 'time_t) + (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) + ((unsigned-int-type? base) + (cat "sexp_make_unsigned_integer(ctx, " val ")")) + ((signed-int-type? base) + (cat "sexp_make_integer(ctx, " val ")")) + ((eq? base 'char) + (if (type-array type) + (cat "sexp_c_string(ctx, " val ", -1)") + (cat "sexp_make_character(ctx, " val ")"))) + ((eq? 'env-string base) + (cat "(p=strchr(" val ", '=') ? " + "sexp_cons(ctx, str=sexp_c_string(ctx, " val ", p - " val "), str=sexp_c_string(ctx, p, -1))" + " : sexp_cons(ctx, str=" val ", SEXP_FALSE)")) + ((string-type? base) + (cat "sexp_c_string(ctx, " val ", -1)")) + ((eq? 'input-port base) + (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)")) + ((eq? 'output-port base) + (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) + (else + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) + (cond + ((or ctype void*?) + (cat "sexp_make_cpointer(ctx, " + (if void*? "SEXP_CPOINTER" (type-id-name base)) ", " + val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " + (if (or (type-free? type) + (and (type-result? type) (not (basic-type? type)))) + 1 + 0) + ")")) + (else + (error "unknown type" base)))))))) + +(define (scheme->c-converter type val) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'sexp) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_truep(" val ")")) + ((eq? base 'time_t) + (cat "sexp_unshift_epoch(sexp_uint_value(" val "))")) + ((signed-int-type? base) + (cat "sexp_sint_value(" val ")")) + ((unsigned-int-type? base) + (cat "sexp_uint_value(" val ")")) + ((eq? base 'char) + (cat "sexp_unbox_character(" val ")")) + ((eq? base 'env-string) + (cat "sexp_concat_env_string(" val ")")) + ((string-type? base) + (cat "sexp_string_data(" val ")")) + ((eq? base 'port-or-fd) + (cat "(sexp_portp(" val ") ? fileno(sexp_port_stream(" val "))" + " : sexp_unbox_fixnum(" val "))")) + ((port-type? base) + (cat "sexp_port_stream(" val ")")) + (else + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) + (cond + ((or ctype void*?) + (cat "(" (type-c-name type) ")" + (if (type-null? type) + "sexp_cpointer_maybe_null_value" + "sexp_cpointer_value") + "(" val ")")) + (else + (error "unknown type" base)))))))) + +(define (type-predicate type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "sexp_exact_integerp") + ((float-type? base) "sexp_flonump") + ((string-type? base) "sexp_stringp") + ((eq? base 'char) "sexp_charp") + ((eq? base 'boolean) "sexp_booleanp") + ((eq? base 'port) "sexp_portp") + ((eq? base 'input-port) "sexp_iportp") + ((eq? base 'output-port) "sexp_oportp") + (else #f)))) + +(define (type-name type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "integer") + ((float-type? base) "flonum") + ((eq? 'boolean base) "int") + (else base)))) + +(define (base-type-c-name base) + (case base + ((string env-string non-null-string) "char*") + (else (symbol->string base)))) + +(define (type-struct-type type) + (let ((type-spec (assq (if (vector? type) (type-base type) type) *types*))) + (cond ((and type-spec (memq 'type: type-spec)) => cadr) + (else #f)))) + +(define (type-c-name type) + (let* ((type (parse-type type)) + (base (type-base type)) + (type-spec (assq base *types*)) + (struct-type (type-struct-type type))) + (string-append + (if (type-const? type) "const " "") + (if struct-type (string-append (symbol->string struct-type) " ") "") + (string-replace (base-type-c-name base) #\- " ") + (if type-spec "*" "") + (if (type-pointer? type) "*" "")))) + +(define (check-type arg type) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'env-string) + (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg + ")) && sexp_stringp(sexp_cdr(" arg ")))")) + ((or (int-type? base) (float-type? base) + (string-type? base) (port-type? base)) + (cat (type-predicate type) "(" arg ")")) + ((or (assq base *types*) (void-pointer-type? type)) + (cat + (if (type-null? type) "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " + (if (void-pointer-type? type) "SEXP_CPOINTER" (type-id-name base)) "))" + (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) + (else + (display "WARNING: don't know how to check: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (cat "1"))))) + +(define (type-id-number type) + (let ((base (type-base type))) + (cond + ((int-type? base) "SEXP_FIXNUM") + ((float-type? base) "SEXP_FLONUM") + ((string-type? base) "SEXP_STRING") + ((eq? base 'char) "SEXP_CHAR") + ((eq? base 'boolean) "SEXP_BOOLEAN") + ((eq? base 'port) "SEXP_IPORT") + ((eq? base 'input-port) "SEXP_IPORT") + ((eq? base 'output-port) "SEXP_OPORT") + (else (type-id-name base))))) + +(define (write-validator arg type) + (let* ((type (parse-type type)) + (array (type-array type)) + (base-type (type-base type))) + (cond + ((and array (not (string-type? type))) + (cond + ((number? array) + (cat " if (!sexp_listp(ctx, " arg ")" + " || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n" + " return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n"))) + (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" + " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" + " return sexp_xtype_exception(ctx, self, \"not a list of " + (type-name type) "s\", " arg ");\n") + (if (not (number? array)) + (cat " if (! sexp_nullp(res))\n" + " return sexp_xtype_exception(ctx, self, \"not a list of " + (type-name type) "s\", " arg ");\n"))) + ((eq? base-type 'port-or-fd) + (cat " if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" + " return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n")) + ((or (int-type? base-type) + (float-type? base-type) + (string-type? base-type) + (port-type? base-type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) + ((or (assq base-type *types*) (void-pointer-type? type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) + ((eq? 'sexp base-type)) + ((string-type? type) + (write-validator arg 'string)) + (else + (display "WARNING: don't know how to validate: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)))))) + +(define (write-parameters args) + (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) + +(define (get-array-length func x) + (let ((len (if (pair? (type-array x)) + (car (reverse (type-array x))) + (type-array x)))) + (if (number? len) + len + (and (symbol? len) + (let* ((str (symbol->string len)) + (len2 (string-length str))) + (and (> len2 3) + (string=? "arg" (substring str 0 3)) + (let ((i (string->number (substring str 3 len2)))) + (if i + (let ((y (list-ref (func-c-args func) i))) + (or (type-value y) len)))))))))) + +(define (write-locals func) + (define (arg-res x) + (string-append "res" (type-index-string x))) + (let* ((ret-type (func-ret-type func)) + (results (func-results func)) + (scheme-args (func-scheme-args func)) + (return-res? (not (error-type? (type-base ret-type)))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons ret-type results))) + (gc-vars (map arg-res results)) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (sexps (if preserve-res? '() '("res"))) + (num-gc-vars (length gc-vars)) + (ints (if (or return-res? + (memq (type-base ret-type) + '(non-null-string non-null-pointer))) + '() + '("err"))) + (ints (if (or (array-type? ret-type) + (any array-type? results) + (any array-type? scheme-args)) + (cons "i" ints) + ints))) + (case (type-base ret-type) + ((non-null-string) (cat " char *err;\n")) + ((non-null-pointer) (cat " void *err;\n"))) + (cond + ((pair? ints) + (cat " int " (car ints)) + (for-each (lambda (x) (display ", ") (display x)) (cdr ints)) + (cat ";\n"))) + (if (any (lambda (a) (eq? 'env-string (type-base a))) + (cons ret-type results)) + (cat " char *p;\n")) + (for-each + (lambda (x) + (let ((len (get-array-length func x))) + (cat " " (type-c-name (type-base x)) " ") + (if (and (type-array x) (not (number? len))) + (cat "*")) + (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) + (if (number? len) + (cat "[" len "]")) + (cat ";\n") + (if (or (vector? len) (type-auto-expand? x)) + (cat " int len" (type-index x) ";\n")) + (if (type-auto-expand? x) + (cat " " (type-c-name (type-base x)) + " *tmp" (type-index-string x) ";\n")))) + (append (if (type-array ret-type) (list ret-type) '()) + results + (remove type-result? (filter type-array scheme-args)))) + (for-each + (lambda (arg) + (cond + ((and (type-pointer? arg) (basic-type? arg)) + (cat " " (type-c-name (type-base arg)) + " tmp" (type-index arg) ";\n")))) + scheme-args) + (cond + ((pair? sexps) + (cat " sexp " (car sexps)) + (for-each (lambda (x) (display ", ") (display x)) (cdr sexps)) + (cat ";\n"))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_var" num-gc-vars "(") + (display (car gc-vars)) + (for-each (lambda (x) (display ", ") (display x)) (cdr gc-vars)) + (cat ");\n") + (cat " sexp_gc_preserve" num-gc-vars "(ctx") + (for-each (lambda (x) (display ", ") (display x)) gc-vars) + (cat ");\n"))))) + +(define (write-validators args) + (for-each + (lambda (a) + (write-validator (string-append "arg" (type-index-string a)) a)) + args)) + +(define (write-temporaries func) + (for-each + (lambda (a) + (let ((len (and (type-array a) (get-array-length func a)))) + (cond + ((and (type-array a) (or (vector? len) (type-auto-expand? a))) + (cat " len" (type-index a) " = " + (lambda () + (if (number? len) (cat len) (scheme->c-converter 'int len))) + ";\n" + " tmp" (type-index a) " = buf" (type-index a) ";\n"))) + (cond + ((and (not (type-result? a)) (type-array a) (not (string-type? a))) + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) + " = (" (type-c-name (type-base a)) "*) malloc(" + "(sexp_unbox_fixnum(sexp_length(ctx, arg" (type-index a) + "))+1) * sizeof(tmp" (type-index a) "[0]));\n")) + (cat " for (i=0, res=arg" (type-index a) + "; sexp_pairp(res); res=sexp_cdr(res), i++) {\n" + " tmp" (type-index a) "[i] = " + (lambda () (scheme->c-converter (type-base a) "sexp_car(res)")) + ";\n" + " }\n") + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) "[i] = NULL;\n"))) + ((and (type-result? a) (not (basic-type? a)) + (not (type-free? a)) (not (type-pointer? a)) + (not (type-auto-expand? a)) + (or (not (type-array a)) + (not (integer? len)))) + (cat " tmp" (type-index a) " = malloc(" + (if (and (symbol? len) (not (eq? len 'null))) + (lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len)) + "*sizeof(tmp" (type-index a) "[0])")) + (lambda () (cat "sizeof(tmp" (type-index a) "[0])"))) + ");\n")) + ((and (type-pointer? a) (basic-type? a)) + (cat " tmp" (type-index a) " = " + (lambda () + (scheme->c-converter + a + (string-append "arg" (type-index-string a)))) + ";\n"))))) + (func-c-args func))) + +(define (write-actual-parameter func arg) + (cond + ((and (not (type-default? arg)) (type-value arg)) + => (lambda (x) + (cond + ((any (lambda (y) + (and (type-array y) + (type-auto-expand? y) + (eq? x (get-array-length func y)))) + (func-c-args func)) + => (lambda (y) (cat "len" (type-index y)))) + (else (write x))))) + ((or (type-result? arg) (type-array arg)) + (cat (if (or (type-pointer? arg) (type-free? arg) (basic-type? arg)) + "&" + "") + "tmp" (type-index arg))) + ((and (type-pointer? arg) (basic-type? arg)) + (cat "&tmp" (type-index arg))) + (else + (scheme->c-converter + arg + (string-append "arg" (type-index-string arg)))))) + +(define (write-call func) + (let ((ret-type (func-ret-type func)) + (c-name (func-c-name func)) + (c-args (func-c-args func))) + (if (any type-auto-expand? (func-c-args func)) + (cat " loop:\n")) + (cat (cond ((error-type? (type-base ret-type)) " err = ") + ((type-array ret-type) " tmp = ") + (else " res = "))) + ((if (type-array ret-type) + (lambda (t f x) (f)) + c->scheme-converter) + ret-type + (lambda () + (cat c-name "(") + (for-each + (lambda (arg) + (if (> (type-index arg) 0) (cat ", ")) + (write-actual-parameter func arg)) + c-args) + (cat ")")) + (cond + ((any type-link? (func-c-args func)) + => (lambda (a) (string-append "arg" (type-index-string a)))) + (else #f))) + (cat ";\n") + (if (type-array ret-type) + (write-result ret-type)))) + +(define (write-result result) + (let ((res (string-append "res" (type-index-string result))) + (tmp (string-append "tmp" (type-index-string result)))) + (cond + ((and (type-array result) (eq? 'char (type-base result))) + (cat " " res " = " (lambda () (c->scheme-converter result tmp)) ";\n")) + ((type-array result) + (cat " " res " = SEXP_NULL;\n") + (let ((auto-expand? + (and (pair? (type-array result)) + (memq 'auto-expand (type-array result)))) + (len (if (pair? (type-array result)) + (car (reverse (type-array result))) + (type-array result)))) + (cond + ((eq? 'null len) + (cat " for (i=0; " tmp "[i]; i++) {\n" + " sexp_push(ctx, " res ", " + (if (eq? 'string (type-base result)) + "str=" + (lambda () (cat "SEXP_VOID);\n sexp_car(" res ") = "))) + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ");\n" + " }\n" + " " res " = sexp_nreverse(ctx, " res ");\n")) + (else + (cat " for (i=" len "-1; i>=0; i--) {\n" + " sexp_push(ctx, " res ", SEXP_VOID);\n" + " sexp_car(" res ") = " + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ";\n" + " }\n"))))) + (else + (cat " " res " = ") + (c->scheme-converter + result + (string-append "tmp" (type-index-string result))) + (cat ";\n"))))) + +(define (write-results func) + (let ((error-res? (error-type? (type-base (func-ret-type func)))) + (results (func-results func))) + (if error-res? + (cat " if (" + (if (memq (type-base (func-ret-type func)) + '(non-null-string non-null-pointer)) + "!" + "") + "err) {\n" + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (lambda () + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")) + (cat " len" i " *= 2;\n" + " tmp" i + " = malloc(len" i "*sizeof(tmp" i "[0]));\n" + " goto loop;\n"))))) + (else + " res = SEXP_FALSE;\n")) + " } else {\n")) + (if (null? results) + (if error-res? + (cat " res = SEXP_TRUE;\n")) + (for-each write-result results)) + (cond + ((> (length results) (if error-res? 1 0)) + (if error-res? + (cat " res = SEXP_NULL;\n") + (cat " res = sexp_cons(ctx, res, SEXP_NULL);\n")) + (for-each + (lambda (x) + (if error-res? + (cat " sexp_push(ctx, res, res" (type-index x) ");\n") + (cat " sexp_push(ctx, res, sexp_car(res));\n" + " sexp_cadr(res) = res" (type-index x) ";\n"))) + (reverse results))) + ((pair? results) + (cat " res = res" (type-index (car results)) ";\n"))) + (if error-res? + (cat " }\n")))) + +(define (write-free type) + (if (type-array type) + (cat " free(tmp" (type-index-string type) ");\n"))) + +(define (write-cleanup func) + (for-each write-free (func-scheme-args func)) + (for-each + (lambda (a) + (cond + ((type-auto-expand? a) + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")))) + ((and (type-result? a) (not (basic-type? a)) + (not (assq (type-base a) *types*)) + (not (type-free? a)) (not (type-pointer? a)) + (or (not (type-array a)) + (not (integer? (get-array-length func a))))) + ;; the above is hairy - basically this frees temporary strings + (cat " free(tmp" (type-index a) ");\n")))) + (func-c-args func)) + (let* ((results (func-results func)) + (return-res? (not (error-type? (type-base (func-ret-type func))))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons (func-ret-type func) + (func-results func)))) + (gc-vars results) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (num-gc-vars (length gc-vars))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_release" num-gc-vars "(ctx);\n"))))) + +(define (write-func func) + (cat "static sexp " (func-stub-name func) + " (sexp ctx sexp_api_params(self, n)" + (write-parameters (func-scheme-args func)) ") {\n") + (write-locals func) + (write-validators (func-scheme-args func)) + (write-temporaries func) + (write-call func) + (write-results func) + (write-cleanup func) + (cat " return res;\n" + "}\n\n")) + +(define (parameter-default? x) + (and (pair? x) + (member x '((current-input-port) + (current-output-port) + (current-error-port))))) + +(define (write-default x) ;; this is a hack but very convenient + (lambda () + (let ((value (type-value x))) + (cond + ((equal? value '(current-input-port)) + (cat "\"*current-input-port*\"")) + ((equal? value '(current-output-port)) + (cat "\"*current-output-port*\"")) + ((equal? value '(current-error-port)) + (cat "\"*current-error-port*\"")) + (else + (c->scheme-converter x value)))))) + +(define (write-func-binding func) + (let ((default (and (pair? (func-scheme-args func)) + (type-default? (car (reverse (func-scheme-args func)))) + (car (reverse (func-scheme-args func)))))) + (cat (if default + (if (parameter-default? (type-value default)) + " sexp_define_foreign_param(ctx, env, " + " sexp_define_foreign_opt(ctx, env, ") + " sexp_define_foreign(ctx, env, ") + (lambda () (write (symbol->string (func-scheme-name func)))) + ", " (length (func-scheme-args func)) ", " + (if default "(sexp_proc1)" "") + (func-stub-name func) + (if default ", " "") + (if default (write-default default) "") + ");\n"))) + +(define (write-type type) + (let ((name (car type)) + (type (cdr type))) + (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" + " " (type-id-name name) + " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, " + (cond ((memq 'finalizer: type) + => (lambda (x) (generate-stub-name (cadr x)))) + (else "sexp_finalize_c_type")) + "));\n") + (cond + ((memq 'predicate: type) + => (lambda (x) + (let ((pred (cadr x))) + (cat " tmp = sexp_make_type_predicate(ctx, name, " + "sexp_make_fixnum(" (type-id-name name) "));\n" + " name = sexp_intern(ctx, \"" pred "\", " + (string-length (x->string pred)) ");\n" + " sexp_env_define(ctx, env, name, tmp);\n"))))))) + +(define (type-getter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_get_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-getter type name field) + (cat "static sexp " (type-getter-name type name field) + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" + (lambda () (write-validator "x" name)) + " return " + (lambda () + (c->scheme-converter + (car field) + (string-append (if (type-struct? (car field)) "&" "") + "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" "->" + (x->string (cadr field))) + (and (or (type-struct? (car field)) (type-link? (car field))) "x"))) + ";\n" + "}\n\n")) + +(define (type-setter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_set_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-setter-assignment type name field dst val) + (cond + ((type-struct? (car field)) + ;; assign to a nested struct - copy field-by-field + (let ((field-type + (cond ((assq (type-name (car field)) *types*) => cdddr) + (else (cdr field))))) + (lambda () + (for-each + (lambda (subfield) + (let ((subname (x->string (cadr subfield)))) + (cat + " " + (string-append dst "." (x->string (cadr subfield))) + " = " + (string-append + "((" (x->string (or (type-struct-type (type-name (car field))) "")) + " " (mangle (type-name (car field))) "*)" "sexp_cpointer_value(" val "))" + "->" (x->string (cadr subfield))) + ";\n"))) + (struct-fields field-type))))) + (else + (lambda () + (cat " " dst " = " (lambda () (scheme->c-converter (car field) val)) ";\n"))))) + +(define (write-type-setter type name field) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx sexp_api_params(self, n), sexp x, sexp v) {\n" + (lambda () (write-validator "x" name)) + (lambda () (write-validator "v" (car field))) + (write-type-setter-assignment + type name field + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" "sexp_cpointer_value(x))" + "->" (x->string (cadr field))) + "v") + " return SEXP_VOID;\n" + "}\n\n")) + +(define (write-type-funcs type) + (let ((name (car type)) + (type (cdr type))) + ;; maybe write finalizer + (cond + ((memq 'finalizer: type) + => (lambda (x) + (cat "static sexp " (generate-stub-name (cadr x)) + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" + " if (sexp_cpointer_freep(x))\n" + " " (cadr x) "(sexp_cpointer_value(x));\n" + " return SEXP_VOID;\n" + "}\n\n")))) + ;; maybe write constructor + (cond + ((memq 'constructor: type) + => (lambda (x) + (let ((make (caadr x)) + (args (cdadr x))) + (cat "static sexp " (generate-stub-name make) + " (sexp ctx sexp_api_params(self, n)" + (lambda () + (let lp ((ls args) (i 0)) + (cond ((pair? ls) + (cat ", sexp arg" i) + (lp (cdr ls) (+ i 1)))))) + ") {\n" + " struct " (type-name name) " *r;\n" + " sexp_gc_var1(res);\n" + " sexp_gc_preserve1(ctx, res);\n" + ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + ;; (type-id-name name) + ;; ");\n" + ;; " r = sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), " + (type-id-name name) + ");\n" + " r = sexp_cpointer_value(res) = malloc(sizeof(struct " + (type-name name) "));\n" + " sexp_freep(res) = 1;\n" + (lambda () + (let lp ((ls args) (i 0)) + (cond + ((pair? ls) + (let* ((a (car ls)) + (field + (any (lambda (f) (and (pair? f) (eq? a (cadr f)))) + (cddr x)))) + (if field + (cat " r->" (cadr field) " = " + (lambda () + (scheme->c-converter + (car field) + (string-append "arg" + (number->string i)))) + ";\n")) + (lp (cdr ls) (+ i 1))))))) + " sexp_gc_release1(ctx);\n" + " return res;\n" + "}\n\n") + (set! *funcs* + (cons (parse-func `(void ,make ,args)) *funcs*)))))) + ;; write field accessors + (for-each + (lambda (field) + (cond + ((and (pair? field) (pair? (cdr field))) + (cond + ((and (pair? (cddr field)) (caddr field)) + (write-type-getter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(caddr field) + #f + ,(type-getter-name type name field)) + (,name))) + *funcs*)))) + (cond + ((and (pair? (cddr field)) + (pair? (cdddr field)) + (car (cdddr field))) + (write-type-setter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(car (cdddr field)) + #f + ,(type-setter-name type name field)) + (,name ,(car field)))) + *funcs*))))))) + (struct-fields type)))) + +(define (write-const const) + (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) + (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) + (cat " name = sexp_intern(ctx, \"" scheme-name "\", " + (string-length (x->string scheme-name)) ");\n" + " sexp_env_define(ctx, env, name, tmp=" + (lambda () (c->scheme-converter (car const) c-name)) ");\n"))) + +(define (write-utilities) + (define (input-env-string? x) + (and (eq? 'env-string (type-base x)) (not (type-result? x)))) + (cond + ((any (lambda (f) + (or (any input-env-string? (func-results f)) + (any input-env-string? (func-scheme-args f)))) + *funcs*) + (cat "static char* sexp_concat_env_string (sexp x) {\n" + " int klen=sexp_string_length(sexp_car(x)), vlen=sexp_string_length(sexp_cdr(x));\n" + " char *res = (char*) malloc(klen+vlen+2);\n" + " strncpy(res, sexp_string_data(sexp_car(x)), klen);\n" + " res[sexp_string_length(sexp_car(x))] = '=';\n" + " strncpy(res+sexp_string_length(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n" + " res[len-1] = '\\0';\n" + " return res;\n" + "}\n\n")))) + +(define (write-init) + (newline) + (write-utilities) + (for-each write-func *funcs*) + (for-each write-type-funcs *types*) + (cat "sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {\n" + " sexp_gc_var2(name, tmp);\n" + " sexp_gc_preserve2(ctx, name, tmp);\n") + (for-each write-const *consts*) + (for-each write-type *types*) + (for-each write-func-binding *funcs*) + (cat " sexp_gc_release2(ctx);\n" + " return SEXP_VOID;\n" + "}\n\n")) + +(define (generate file) + (display "/* automatically generated by chibi genstubs */\n") + (c-system-include "chibi/eval.h") + (load file) + (write-init)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main + +(define (main args) + (case (length args) + ((1) + (with-output-to-file (string-append (strip-extension (car args)) ".c") + (lambda () (generate (car args))))) + ((2) + (if (equal? "-" (cadr args)) + (generate (car args)) + (with-output-to-file (cadr args) (lambda () (generate (car args)))))) + (else + (error "usage: genstubs []")))) diff --git a/vm.c b/vm.c new file mode 100644 index 00000000..50f8e8b8 --- /dev/null +++ b/vm.c @@ -0,0 +1,1373 @@ +/* vm.c -- stack-based virtual machine backend */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#if SEXP_USE_DEBUG_VM > 1 +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { + int i; + if (! sexp_oportp(out)) out = sexp_current_error_port(ctx); + for (i=0; i4; i=sexp_unbox_fixnum(stack[i+3])) { + self = stack[i+2]; + if (sexp_procedurep(self)) { + sexp_write_string(ctx, " called from ", out); + bc = sexp_procedure_code(self); + if (sexp_truep(sexp_bytecode_name(bc))) + sexp_write(ctx, sexp_bytecode_name(bc), out); + else + sexp_printf(ctx, out, "anon: %p", bc); + if ((ls=sexp_bytecode_source(bc)) && sexp_pairp(ls)) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_char(ctx, '\n', out); + } + } +} + +/************************* code generation ****************************/ + +static void emit_word (sexp ctx, sexp_uint_t val) { + unsigned char *data; + expand_bcode(ctx, sizeof(sexp)); + data = sexp_bytecode_data(sexp_context_bc(ctx)); + sexp_context_align_pos(ctx); + *((sexp_uint_t*)(&(data[sexp_context_pos(ctx)]))) = val; + sexp_context_pos(ctx) += sizeof(sexp); +} + +static void emit_push (sexp ctx, sexp obj) { + emit(ctx, SEXP_OP_PUSH); + emit_word(ctx, (sexp_uint_t)obj); + if (sexp_pointerp(obj) && ! sexp_symbolp(obj)) + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); +} + +static void emit_enter (sexp ctx) {return;} +static void bless_bytecode (sexp ctx, sexp bc) {return;} + +static void emit_return (sexp ctx) { + emit(ctx, SEXP_OP_RET); +} + +static sexp_sint_t sexp_context_make_label (sexp ctx) { + sexp_sint_t label; + sexp_context_align_pos(ctx); + 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 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, SEXP_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, SEXP_OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, SEXP_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, SEXP_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, SEXP_OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, SEXP_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) + ? SEXP_OP_GLOBAL_REF : SEXP_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, SEXP_OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, SEXP_OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, SEXP_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, inv_default=0; + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); + + num_args = sexp_unbox_fixnum(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_data(op) + && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { + if (sexp_opcode_inverse(op)) { + inv_default = 1; + } else { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + } + + /* push the arguments onto the stack in reverse order */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC)) + ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the default for inverse opcodes */ + if (inv_default) { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case SEXP_OPC_ARITHMETIC: + /* fold variadic arithmetic operators */ + for (i=num_args-1; i>0; i--) + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + emit(ctx, SEXP_OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_FOREIGN: + emit(ctx, sexp_opcode_code(op)); + emit_word(ctx, (sexp_uint_t)op); + break; + case SEXP_OPC_TYPE_PREDICATE: + case SEXP_OPC_GETTER: + case SEXP_OPC_SETTER: + case SEXP_OPC_CONSTRUCTOR: + emit(ctx, sexp_opcode_code(op)); + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE) { + if (sexp_opcode_data(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); + if (sexp_opcode_data2(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + } + break; + case SEXP_OPC_PARAMETER: + emit_push(ctx, sexp_opcode_data(op)); + emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + sexp_context_depth(ctx) -= (num_args-1); + sexp_gc_release1(ctx); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, 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 ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); + + sexp_context_tailp(ctx) = tailp; + sexp_context_depth(ctx) -= len; + sexp_gc_release1(ctx); +} + +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_var2(tmp, bc); + sexp_gc_preserve2(ctx, tmp, 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_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); + 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, SEXP_OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, SEXP_OP_CONS); + emit(ctx2, SEXP_OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, SEXP_OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_fixnum((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); + sexp_bytecode_source(bc) = sexp_lambda_source(lambda); + if (sexp_nullp(fv)) { + /* shortcut, no free vars */ + tmp = sexp_make_vector(ctx2, SEXP_ZERO, 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, SEXP_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_fixnum(k)); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_VECTOR_SET); + emit(ctx, SEXP_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, SEXP_OP_MAKE_PROCEDURE); + } + sexp_gc_release2(ctx); +} + +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 make_param_list (sexp ctx, sexp_uint_t i) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_fixnum(i), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ls, bc, res, env; + sexp_gc_var5(params, ref, refs, lambda, ctx2); + if (i == sexp_opcode_num_args(op)) { /* return before preserving */ + if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); + } else if (i < sexp_opcode_num_args(op)) { + return sexp_compile_error(ctx, "not enough args for opcode", op); + } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ + return sexp_compile_error(ctx, "too many args for opcode", op); + } + sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = sexp_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), sexp_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_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + sexp_gc_release5(ctx); + 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_fixnum(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= SEXP_INIT_STACK_SIZE) { + _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); + goto end_loop; + } +#endif + _ALIGN_IP(); + i = sexp_unbox_fixnum(_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_fixnum(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_fixnum(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_fixnum(i); + stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + stack[top+1] = self; + stack[top+2] = sexp_make_fixnum(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 SEXP_OP_FCALL0: + tmp1 = _WORD0; + _ALIGN_IP(); + sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = fp; + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 0))); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL1: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 1), _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL2: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 2), _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL3: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 3), _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL4: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 4), _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL5: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 5), _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL6: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 6), _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; +#if SEXP_USE_EXTENDED_FCALL + case SEXP_OP_FCALLN: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + i = sexp_opcode_num_args(_WORD0); + tmp1 = sexp_fcall(ctx, self, i, _WORD0); + top -= (i-1); + _ARG1 = tmp1; + ip += sizeof(sexp); + sexp_check_exception(); + break; +#endif + case SEXP_OP_JUMP_UNLESS: + _ALIGN_IP(); + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case SEXP_OP_JUMP: + _ALIGN_IP(); + ip += _SWORD0; + break; + case SEXP_OP_PUSH: + _ALIGN_IP(); + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case SEXP_OP_DROP: + top--; + break; + case SEXP_OP_GLOBAL_REF: + _ALIGN_IP(); + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case SEXP_OP_GLOBAL_KNOWN_REF: + _ALIGN_IP(); + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_STACK_REF: /* `pick' in forth */ + _ALIGN_IP(); + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_REF: + _ALIGN_IP(); + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_SET: + _ALIGN_IP(); + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case SEXP_OP_CLOSURE_REF: + _ALIGN_IP(); + _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); + ip += sizeof(sexp); + break; + case SEXP_OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_VECTOR_LENGTH: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); + break; + case SEXP_OP_BYTES_REF: + case SEXP_OP_STRING_REF: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + if (ip[-1] == SEXP_OP_BYTES_REF) + _ARG2 = sexp_bytes_ref(_ARG1, _ARG2); + else +#if SEXP_USE_UTF8_STRINGS + _ARG2 = sexp_string_utf8_ref(ctx, _ARG1, _ARG2); +#else + _ARG2 = sexp_string_ref(_ARG1, _ARG2); +#endif + top--; + break; + case SEXP_OP_BYTES_SET: + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2)); + else if (! sexp_charp(_ARG3)) + sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + if (ip[-1] == SEXP_OP_BYTES_SET) + sexp_bytes_set(_ARG1, _ARG2, _ARG3); + else +#if SEXP_USE_UTF8_STRINGS + sexp_string_utf8_set(ctx, _ARG1, _ARG2, _ARG3); +#else + sexp_string_set(_ARG1, _ARG2, _ARG3); +#endif + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_BYTES_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("bytes-length: not a byte-vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_bytes_length(_ARG1)); + break; + case SEXP_OP_STRING_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_UTF8_STRINGS + _ARG1 = sexp_make_fixnum(sexp_string_utf8_length((unsigned char*)sexp_string_data(_ARG1), sexp_string_length(_ARG1))); +#else + _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); +#endif + break; + case SEXP_OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; + _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case SEXP_OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; + if (! sexp_fixnump(_ARG1)) + sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); + _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_MAKE_EXCEPTION: + _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + break; + case SEXP_OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case SEXP_OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case SEXP_OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case SEXP_OP_FIXNUMP: + _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; + case SEXP_OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case SEXP_OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case SEXP_OP_TYPEP: + _ALIGN_IP(); + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_MAKE: + _ALIGN_IP(); + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_REF: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_SET: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); + sexp_slot_set(_ARG1, _UWORD1, _ARG2); + _ARG2 = SEXP_VOID; + ip += sizeof(sexp)*2; + top--; + break; + case SEXP_OP_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case SEXP_OP_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case SEXP_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 SEXP_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 SEXP_OP_CONS: + sexp_context_top(ctx) = top; + _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_ADD: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(j); + } + else { + _ARG1 = sexp_add(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_add(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_add(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) + (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) + sexp_flonum_value(tmp2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_SUB: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(j); + } + else { + _ARG1 = sexp_sub(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_sub(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_sub(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) - (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) - sexp_flonum_value(tmp2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_MUL: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); + if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(prod); + } + else { + _ARG1 = sexp_mul(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_mul(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_mul(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) * (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) * sexp_flonum_value(tmp2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_DIV: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (tmp2 == SEXP_ZERO) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(tmp1) && sexp_flonum_value(tmp1) == 0.0) + _ARG1 = sexp_make_flonum(ctx, 0.0/0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { +#if SEXP_USE_FLONUMS + tmp1 = sexp_fixnum_to_flonum(ctx, tmp1); + tmp2 = sexp_fixnum_to_flonum(ctx, tmp2); + _ARG1 = sexp_fp_div(ctx, tmp1, tmp2); + if (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1))) + _ARG1 = sexp_make_fixnum(sexp_flonum_value(_ARG1)); +#else + _ARG1 = sexp_fx_div(tmp1, tmp2); +#endif + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_div(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_div(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) / (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) / sexp_flonum_value(tmp2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_QUOTIENT: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + if (tmp2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG1 = sexp_fx_div(tmp1, tmp2); + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_quotient(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, tmp2)); +#endif + break; + case SEXP_OP_REMAINDER: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + if (tmp2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG1 = sexp_fx_rem(tmp1, tmp2); + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_remainder(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, tmp2)); +#endif + break; + case SEXP_OP_LT: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = (sexp_sint_t)tmp1 < (sexp_sint_t)tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) < 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) < sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) < sexp_flonum_value(tmp2); +#endif + } else sexp_raise("<: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_LE: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = (sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) <= 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) <= sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) <= (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) <= sexp_flonum_value(tmp2); +#endif + } else sexp_raise("<=: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_EQN: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = tmp1 == tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) == 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) == sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) == (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) == sexp_flonum_value(tmp2); +#endif + } else sexp_raise("=: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case SEXP_OP_FIX2FLO: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); +#endif + else if (! sexp_flonump(_ARG1)) + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case SEXP_OP_FLO2FIX: + if (sexp_flonump(_ARG1)) { + if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { + sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_BIGNUMS + } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { + _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); +#endif + } else { + _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); + } + } else if (! sexp_fixnump(_ARG1) && ! sexp_bignump(_ARG1)) { + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + } + break; + case SEXP_OP_CHAR2INT: + if (! sexp_charp(_ARG1)) + sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); + break; + case SEXP_OP_INT2CHAR: + if (! sexp_fixnump(_ARG1)) + sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); + break; + case SEXP_OP_CHAR_UPCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_CHAR_DOWNCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_WRITE_CHAR: + if (! sexp_charp(_ARG1)) + sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); + if (! sexp_oportp(_ARG2)) + sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2)); +#if SEXP_USE_UTF8_STRINGS + if (sexp_unbox_character(_ARG1) >= 0x80) + sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + else +#endif + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_NEWLINE: + if (! sexp_oportp(_ARG1)) + sexp_raise("newline: not an output-port", sexp_list1(ctx, _ARG1)); + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case SEXP_OP_READ_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); +#if SEXP_USE_UTF8_STRINGS + if (i >= 0x80) + _ARG1 = sexp_read_utf8_char(ctx, _ARG1, i); + else +#endif + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_PEEK_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); + sexp_push_char(ctx, i, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_YIELD: + fuel = 0; + _PUSH(SEXP_VOID); + break; + case SEXP_OP_RET: + i = sexp_unbox_fixnum(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_fixnum(stack[fp+1]); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_fixnum(stack[fp+3]); + break; + case SEXP_OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); + } + goto loop; + + end_loop: +#if SEXP_USE_GREEN_THREADS + if (ctx != root_thread) { /* don't return from child threads */ + sexp_context_refuel(ctx) = fuel = 0; + goto loop; + } +#endif + sexp_gc_release3(ctx); + sexp_context_top(ctx) = top; + return _ARG1; +} + +/******************************* apply ********************************/ + +sexp sexp_apply1 (sexp ctx, sexp f, sexp x) { + sexp res; + sexp_gc_var1(args); + if (sexp_opcodep(f)) { + res = ((sexp_proc2)sexp_opcode_func(f))(ctx sexp_api_pass(f, 1), x); + } else { + sexp_gc_preserve1(ctx, args); + res = sexp_apply(ctx, f, args=sexp_list1(ctx, x)); + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_apply (sexp ctx, sexp proc, sexp args) { + sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx), len, offset; + len = sexp_unbox_fixnum(sexp_length(ctx, args)); + if (sexp_opcodep(proc)) + proc = make_opcode_procedure(ctx, proc, len); + if (! sexp_procedurep(proc)) { + res = sexp_exceptionp(proc) ? proc : + sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); + } else { + offset = top + len; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) + stack[--offset] = sexp_car(ls); + stack[top++] = sexp_make_fixnum(len); + stack[top++] = SEXP_ZERO; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + stack[top++] = SEXP_ZERO; + sexp_context_top(ctx) = top; + res = sexp_vm(ctx, proc); + if (! res) res = SEXP_VOID; /* shouldn't happen */ + } + return res; +} From e3f4d51ef7eab4d2a6bc5d8d2be78b61c5d3c6f3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 15 Jul 2010 22:19:47 +0900 Subject: [PATCH 456/535] more windows updates, library compiles in VC++ now --- chibi-scheme.vcproj | 206 +++++++++++++++++++++++++++++++++++++++ eval.c | 2 +- include/chibi/bignum.h | 2 +- include/chibi/features.h | 26 ++++- include/chibi/sexp.h | 11 ++- sexp.c | 12 +-- vm.c | 4 +- 7 files changed, 250 insertions(+), 13 deletions(-) create mode 100644 chibi-scheme.vcproj diff --git a/chibi-scheme.vcproj b/chibi-scheme.vcproj new file mode 100644 index 00000000..86bd69e9 --- /dev/null +++ b/chibi-scheme.vcproj @@ -0,0 +1,206 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/eval.c b/eval.c index 7cfa3650..7c45ddf0 100644 --- a/eval.c +++ b/eval.c @@ -1334,9 +1334,9 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data) { + sexp res = SEXP_VOID; sexp_gc_var1(op); sexp_gc_preserve1(ctx, op); - sexp res = SEXP_VOID; op = sexp_make_foreign(ctx, name, num_args, flags, f, data); if (sexp_exceptionp(op)) res = op; diff --git a/include/chibi/bignum.h b/include/chibi/bignum.h index 580b0a7d..9c6ede07 100644 --- a/include/chibi/bignum.h +++ b/include/chibi/bignum.h @@ -5,7 +5,7 @@ #ifndef SEXP_BIGNUM_H #define SEXP_BIGNUM_H -#if (SEXP_64_BIT) +#if (SEXP_64_BIT) && defined(__GNUC__) typedef unsigned int uint128_t __attribute__((mode(TI))); typedef int sint128_t __attribute__((mode(TI))); typedef uint128_t sexp_luint_t; diff --git a/include/chibi/features.h b/include/chibi/features.h index 093628ce..0aec32a1 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -230,7 +230,7 @@ #define SEXP_BSD 1 #else #define SEXP_BSD 0 -#ifndef _GNU_SOURCE +#if ! defined(_GNU_SOURCE) && ! defined(_WIN32) && ! defined(PLAN9) #define _GNU_SOURCE #endif #endif @@ -260,7 +260,7 @@ #endif #ifndef SEXP_USE_DL -#ifdef PLAN9 +#if defined(PLAN9) || defined(_WIN32) #define SEXP_USE_DL 0 #else #define SEXP_USE_DL ! SEXP_USE_NO_FEATURES @@ -387,8 +387,12 @@ #endif #ifndef SEXP_USE_STRING_STREAMS +#ifdef _WIN32 +#define SEXP_USE_STRING_STREAMS 0 +#else #define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES #endif +#endif #ifndef SEXP_USE_AUTOCLOSE_PORTS #define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES @@ -434,6 +438,24 @@ #define strncasecmp cistrncmp #define round(x) floor((x)+0.5) #define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#elif defined(_WIN32) +#define snprintf(buf, len, fmt, val) sprintf(buf, fmt, val) +#define strcasecmp lstrcmpi +#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2) +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#define isnan(x) (x!=x) +#define isinf(x) (x > DBL_MAX || x < -DBL_MAX) +#endif + +#ifdef _WIN32 +#define sexp_pos_infinity (DBL_MAX*DBL_MAX) +#define sexp_neg_infinity -sexp_pos_infinity +#define sexp_nan log(-2) +#else +#define sexp_pos_infinity (1.0/0.0) +#define sexp_neg_infinity -sexp_pos_infinity +#define sexp_nan (0.0/0.0) #endif #ifdef __MINGW32__ diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index a197e953..2cb2ebb2 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -40,6 +40,10 @@ typedef unsigned long size_t; #include #include #include +#if SEXP_USE_FLONUMS +#include +#include +#endif #endif #include @@ -115,7 +119,12 @@ enum sexp_types { SEXP_NUM_CORE_TYPES }; -#if SEXP_64_BIT +#ifdef _WIN32 +typedef unsigned short sexp_tag_t; +typedef SIZE_T sexp_uint_t; +typedef SSIZE_T sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#elif SEXP_64_BIT typedef unsigned int sexp_tag_t; typedef unsigned long sexp_uint_t; typedef long sexp_sint_t; diff --git a/sexp.c b/sexp.c index aac5569b..de029797 100644 --- a/sexp.c +++ b/sexp.c @@ -851,9 +851,8 @@ sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt } sexp sexp_list_to_vector_op (sexp ctx sexp_api_params(self, n), sexp ls) { - sexp x, vec = sexp_make_vector(ctx, sexp_length(ctx, ls), SEXP_VOID); - sexp *elts; int i; + sexp x, *elts, vec = sexp_make_vector(ctx, sexp_length(ctx, ls), SEXP_VOID); if (sexp_exceptionp(vec)) return vec; elts = sexp_vector_data(vec); for (i=0, x=ls; sexp_pairp(x); i++, x=sexp_cdr(x)) @@ -1054,7 +1053,8 @@ sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p) { sexp sexp_buffered_flush (sexp ctx, sexp p) { sexp_gc_var1(tmp); - sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, p); + if (! sexp_oportp(p)) + return sexp_type_exception(ctx, NULL, SEXP_OPORT, p); if (! sexp_port_openp(p)) return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p); else { @@ -1722,11 +1722,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_read_symbol(ctx, in, c1, 1); #if SEXP_USE_INFINITIES if (res == sexp_intern(ctx, "+inf.0", -1)) - res = sexp_make_flonum(ctx, 1.0/0.0); + res = sexp_make_flonum(ctx, sexp_pos_infinity); else if (res == sexp_intern(ctx, "-inf.0", -1)) - res = sexp_make_flonum(ctx, -1.0/0.0); + res = sexp_make_flonum(ctx, sexp_neg_infinity); else if (res == sexp_intern(ctx, "+nan.0", -1)) - res = sexp_make_flonum(ctx, 0.0/0.0); + res = sexp_make_flonum(ctx, sexp_nan); #endif } break; diff --git a/vm.c b/vm.c index 50f8e8b8..88f0d728 100644 --- a/vm.c +++ b/vm.c @@ -28,7 +28,7 @@ void sexp_stack_trace (sexp ctx, sexp out) { if (sexp_truep(sexp_bytecode_name(bc))) sexp_write(ctx, sexp_bytecode_name(bc), out); else - sexp_printf(ctx, out, "anon: %p", bc); + sexp_write_string(ctx, "", out); if ((ls=sexp_bytecode_source(bc)) && sexp_pairp(ls)) { if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { sexp_write_string(ctx, " on line ", out); @@ -1071,7 +1071,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { if (tmp2 == SEXP_ZERO) { #if SEXP_USE_FLONUMS if (sexp_flonump(tmp1) && sexp_flonum_value(tmp1) == 0.0) - _ARG1 = sexp_make_flonum(ctx, 0.0/0.0); + _ARG1 = sexp_make_flonum(ctx, 0.0); else #endif sexp_raise("divide by zero", SEXP_NULL); From 28b8f8251bfb04a657f823c0db0dcdc1acd04a65 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 15 Jul 2010 22:50:10 +0900 Subject: [PATCH 457/535] genstubs fixes --- lib/chibi/filesystem.stub | 2 +- lib/chibi/process.stub | 18 +++++++++--------- tools/genstubs.scm | 10 ++++++---- 3 files changed, 16 insertions(+), 14 deletions(-) diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub index 5656fcdc..2aa66e50 100644 --- a/lib/chibi/filesystem.stub +++ b/lib/chibi/filesystem.stub @@ -79,7 +79,7 @@ (define-c errno (delete-directory "rmdir") (string)) (define-c (free DIR) opendir (string)) -(define-c dirent readdir ((link DIR))) +(define-c dirent readdir ((link (pointer DIR)))) (define-c int (duplicate-file-descriptor "dup") (int)) (define-c errno (duplicate-file-descriptor-to "dup2") (int int)) diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub index 17287d30..44f27953 100644 --- a/lib/chibi/process.stub +++ b/lib/chibi/process.stub @@ -44,20 +44,20 @@ (define-c sexp (set-signal-action! "sexp_set_signal_action") ((value ctx sexp) (value self sexp) sexp sexp)) -(define-c errno (make-signal-set "sigemptyset") ((result sigset_t))) -(define-c errno (signal-set-fill! "sigfillset") (sigset_t)) -(define-c errno (signal-set-add! "sigaddset") (sigset_t int)) -(define-c errno (signal-set-delete! "sigaddset") (sigset_t int)) -(define-c boolean (signal-set-contains? "sigismember") (sigset_t int)) +(define-c errno (make-signal-set "sigemptyset") ((pointer result sigset_t))) +(define-c errno (signal-set-fill! "sigfillset") ((pointer sigset_t))) +(define-c errno (signal-set-add! "sigaddset") ((pointer sigset_t) int)) +(define-c errno (signal-set-delete! "sigaddset") ((pointer sigset_t) int)) +(define-c boolean (signal-set-contains? "sigismember") ((pointer sigset_t) int)) (define-c errno (signal-mask-block! "sigprocmask") - ((value SIG_BLOCK int) sigset_t (value NULL sigset_t))) + ((value SIG_BLOCK int) (pointer sigset_t) (pointer value NULL sigset_t))) (define-c errno (signal-mask-unblock! "sigprocmask") - ((value SIG_UNBLOCK int) sigset_t (value NULL sigset_t))) + ((value SIG_UNBLOCK int) (pointer sigset_t) (pointer value NULL sigset_t))) (define-c errno (signal-mask-set! "sigprocmask") - ((value SIG_SETMASK int) sigset_t (value NULL sigset_t))) + ((value SIG_SETMASK int) (pointer sigset_t) (pointer value NULL sigset_t))) (define-c errno (current-signal-mask "sigprocmask") - ((value SIG_BLOCK int) (value NULL sigset_t) (result sigset_t))) + ((value SIG_BLOCK int) (pointer value NULL sigset_t) (pointer result sigset_t))) (define-c unsigned-int alarm (unsigned-int)) (define-c unsigned-int sleep (unsigned-int)) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 77f240fb..cea7e543 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -719,7 +719,7 @@ (lambda (x) (let ((len (get-array-length func x))) (cat " " (type-c-name (type-base x)) " ") - (if (and (type-array x) (not (number? len))) + (if (or (and (type-array x) (not (number? len))) (type-pointer? x)) (cat "*")) (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) (if (number? len) @@ -730,7 +730,9 @@ (if (type-auto-expand? x) (cat " " (type-c-name (type-base x)) " *tmp" (type-index-string x) ";\n")))) - (append (if (type-array ret-type) (list ret-type) '()) + (append (if (or (type-array ret-type) (type-pointer? ret-type)) + (list ret-type) + '()) results (remove type-result? (filter type-array scheme-args)))) (for-each @@ -788,7 +790,7 @@ (if (not (number? (type-array a))) (cat " tmp" (type-index a) "[i] = NULL;\n"))) ((and (type-result? a) (not (basic-type? a)) - (not (type-free? a)) (not (type-pointer? a)) + (not (type-free? a)) ;;(not (type-pointer? a)) (not (type-auto-expand? a)) (or (not (type-array a)) (not (integer? len)))) @@ -820,7 +822,7 @@ => (lambda (y) (cat "len" (type-index y)))) (else (write x))))) ((or (type-result? arg) (type-array arg)) - (cat (if (or (type-pointer? arg) (type-free? arg) (basic-type? arg)) + (cat (if (or (type-free? arg) (basic-type? arg)) ;; (type-pointer? arg) "&" "") "tmp" (type-index arg))) From d9017cc20e94ac8d943d6bdc75262efa5690735f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 15 Jul 2010 23:48:43 +0900 Subject: [PATCH 458/535] removing fcall4 and fcall5 --- eval.c | 4 ++-- include/chibi/eval.h | 2 -- opcodes.c | 2 -- opt/opcode_names.h | 5 ++--- tools/genstubs.scm | 2 -- vm.c | 16 ---------------- 6 files changed, 4 insertions(+), 27 deletions(-) diff --git a/eval.c b/eval.c index 7c45ddf0..3647b5fb 100644 --- a/eval.c +++ b/eval.c @@ -1311,14 +1311,14 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data) { sexp res; #if ! SEXP_USE_EXTENDED_FCALL - if (num_args > 6) + if (num_args > 4) return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", sexp_make_fixnum(num_args)); #endif res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); sexp_opcode_class(res) = SEXP_OPC_FOREIGN; #if SEXP_USE_EXTENDED_FCALL - if (num_args > 6) + if (num_args > 4) sexp_opcode_code(res) = SEXP_OP_FCALLN; else #endif diff --git a/include/chibi/eval.h b/include/chibi/eval.h index b21e3825..e1a82378 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -60,8 +60,6 @@ enum sexp_opcode_names { SEXP_OP_FCALL2, SEXP_OP_FCALL3, SEXP_OP_FCALL4, - SEXP_OP_FCALL5, - SEXP_OP_FCALL6, SEXP_OP_FCALLN, SEXP_OP_JUMP_UNLESS, SEXP_OP_JUMP, diff --git a/opcodes.c b/opcodes.c index 085238f1..cf40794f 100644 --- a/opcodes.c +++ b/opcodes.c @@ -10,8 +10,6 @@ #define _FN2OPTP(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, t, u, s, d, f) #define _FN3(t, u, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, t, u, s, d, f) #define _FN4(t, u, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, t, u, s, d, f) -#define _FN5(t, u, s, d, f) _FN(SEXP_OP_FCALL5, 5, 0, t, u, s, d, f) -#define _FN6(t, u, s, d, f) _FN(SEXP_OP_FCALL6, 6, 0, t, u, s, d, f) #define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, 0, 0, n, a, 0) static struct sexp_opcode_struct opcodes[] = { diff --git a/opt/opcode_names.h b/opt/opcode_names.h index 52c639f9..88bc4387 100644 --- a/opt/opcode_names.h +++ b/opt/opcode_names.h @@ -1,8 +1,7 @@ static const char* reverse_opcode_names[] = - {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", - "TAIL-CALL", "CALL", "FCALL0", "FCALL1", "FCALL2", - "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALLN", + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALLN", "JUMP-UNLESS", "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", diff --git a/tools/genstubs.scm b/tools/genstubs.scm index cea7e543..ed187884 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -272,8 +272,6 @@ (s-args '())) (cond ((null? ls) - ;;(if (> i 6) - ;; (error "FFI currently only supports up to 6 scheme args" func)) (vector scheme-name c-name stub-name ret-type (reverse results) (reverse c-args) (reverse s-args))) (else diff --git a/vm.c b/vm.c index 88f0d728..d292aaab 100644 --- a/vm.c +++ b/vm.c @@ -722,22 +722,6 @@ sexp sexp_vm (sexp ctx, sexp proc) { ip += sizeof(sexp); sexp_check_exception(); break; - case SEXP_OP_FCALL5: - _ALIGN_IP(); - sexp_context_top(ctx) = top; - _ARG5 = ((sexp_proc6)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 5), _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); - top -= 4; - ip += sizeof(sexp); - sexp_check_exception(); - break; - case SEXP_OP_FCALL6: - _ALIGN_IP(); - sexp_context_top(ctx) = top; - _ARG6 = ((sexp_proc7)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 6), _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); - top -= 5; - ip += sizeof(sexp); - sexp_check_exception(); - break; #if SEXP_USE_EXTENDED_FCALL case SEXP_OP_FCALLN: _ALIGN_IP(); From 4588874b96b04044241c750370a40aad32d14f83 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 16 Jul 2010 00:23:33 +0900 Subject: [PATCH 459/535] checking against NULL pointer for source info in print-exception --- sexp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sexp.c b/sexp.c index de029797..59bfdff8 100644 --- a/sexp.c +++ b/sexp.c @@ -414,7 +414,7 @@ sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp if (sexp_procedurep(sexp_exception_procedure(exn))) { ls = sexp_bytecode_name( sexp_procedure_code(sexp_exception_procedure(exn))); - if (sexp_symbolp(ls)) { + if (ls && sexp_symbolp(ls)) { sexp_write_string(ctx, " in ", out); sexp_write(ctx, ls, out); } From 5344e9e2352a398b5fbef3a1c87b8fe74ceefea3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 16 Jul 2010 08:08:15 +0900 Subject: [PATCH 460/535] removing fcall5/6 from disasm --- lib/chibi/disasm.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index d4a7373c..d193e3a7 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -57,8 +57,6 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { case SEXP_OP_FCALL2: case SEXP_OP_FCALL3: case SEXP_OP_FCALL4: - case SEXP_OP_FCALL5: - case SEXP_OP_FCALL6: sexp_printf(ctx, out, "%ld", (long) ((sexp*)ip)[0]); ip += sizeof(sexp); break; From c6c593f277a2f9f5511918f0b97c9c193a62cae8 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 16 Jul 2010 08:22:10 +0900 Subject: [PATCH 461/535] adding 5 and 6 arg variations to generic sexp_fcall --- opt/fcall.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/opt/fcall.c b/opt/fcall.c index 17e7b82f..c38cc3fe 100644 --- a/opt/fcall.c +++ b/opt/fcall.c @@ -16,6 +16,8 @@ sexp sexp_fcall (sexp ctx, sexp self, sexp_sint_t n, sexp f) { sexp *stack = sexp_stack_data(sexp_context_stack(ctx)); sexp_sint_t top = sexp_context_top(ctx); switch (n) { + case 5: return ((sexp_proc6)sexp_opcode_func(f))(ctx, f, 5, _A(1), _A(2), _A(3), _A(4), _A(5)); + case 6: return ((sexp_proc7)sexp_opcode_func(f))(ctx, f, 6, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6)); case 7: return ((sexp_proc8)sexp_opcode_func(f))(ctx, f, 7, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7)); case 8: return ((sexp_proc9)sexp_opcode_func(f))(ctx, f, 8, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8)); case 9: return ((sexp_proc10)sexp_opcode_func(f))(ctx, f, 9, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9)); From 9cf8124a81741928d7407344b6d0e1c1f9805d81 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 17 Jul 2010 14:46:50 +0900 Subject: [PATCH 462/535] records are now generative, match can destructure records with $ patterns --- eval.c | 18 +++++++++++------- include/chibi/eval.h | 3 +++ include/chibi/sexp.h | 2 ++ lib/chibi/match/match.scm | 13 +++++++++++++ lib/srfi/9.module | 19 ++++++++++++------- opcodes.c | 3 +++ opt/opcode_names.h | 7 ++++--- sexp.c | 7 ++++++- vm.c | 27 +++++++++++++++++++++++++++ 9 files changed, 81 insertions(+), 18 deletions(-) diff --git a/eval.c b/eval.c index 3647b5fb..20947d69 100644 --- a/eval.c +++ b/eval.c @@ -397,7 +397,7 @@ static sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), s return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); } -static sexp sexp_strip_synclos (sexp ctx, sexp x) { +static sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) { sexp res; sexp_gc_var2(kar, kdr); sexp_gc_preserve2(ctx, kar, kdr); @@ -406,8 +406,8 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) { x = sexp_synclo_expr(x); goto loop; } else if (sexp_pairp(x)) { - kar = sexp_strip_synclos(ctx, sexp_car(x)); - kdr = sexp_strip_synclos(ctx, sexp_cdr(x)); + kar = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_car(x)); + kdr = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_cdr(x)); res = sexp_cons(ctx, kar, kdr); sexp_immutablep(res) = 1; } else { @@ -641,8 +641,8 @@ static sexp analyze_define (sexp ctx, sexp x) { static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { sexp res = SEXP_VOID, name; - sexp_gc_var3(proc, mac, tmp); - sexp_gc_preserve3(eval_ctx, proc, mac, tmp); + sexp_gc_var2(proc, mac); + sexp_gc_preserve2(eval_ctx, proc, mac); for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls)) && sexp_nullp(sexp_cddar(ls)))) { @@ -662,7 +662,7 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { } } } - sexp_gc_release3(eval_ctx); + sexp_gc_release2(eval_ctx); return res; } @@ -741,7 +741,7 @@ static sexp analyze (sexp ctx, sexp object) { else res = sexp_make_lit(ctx, (sexp_core_code(op) == SEXP_CORE_QUOTE) ? - sexp_strip_synclos(ctx, sexp_cadr(x)) : + sexp_strip_synclos(ctx sexp_api_pass(NULL, 1), sexp_cadr(x)) : sexp_cadr(x)); break; case SEXP_CORE_DEFINE_SYNTAX: @@ -1361,6 +1361,7 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar #if SEXP_USE_TYPE_DEFS sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, @@ -1369,6 +1370,7 @@ sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { sexp_uint_t type_size; + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), @@ -1378,6 +1380,7 @@ sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sex } sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) @@ -1389,6 +1392,7 @@ sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp typ } sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) diff --git a/include/chibi/eval.h b/include/chibi/eval.h index e1a82378..290243ae 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -93,6 +93,9 @@ enum sexp_opcode_names { SEXP_OP_MAKE, SEXP_OP_SLOT_REF, SEXP_OP_SLOT_SET, + SEXP_OP_ISA, + SEXP_OP_SLOTN_REF, + SEXP_OP_SLOTN_SET, SEXP_OP_CAR, SEXP_OP_CDR, SEXP_OP_SET_CAR, diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 2cb2ebb2..7adb008c 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -472,6 +472,8 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) #define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) +#define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b))) + #if SEXP_USE_IMMEDIATE_FLONUMS union sexp_flonum_conv { float flonum; diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm index 963b89ff..f4eb173d 100644 --- a/lib/chibi/match/match.scm +++ b/lib/chibi/match/match.scm @@ -161,6 +161,10 @@ (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) ((match-two v (p *** . q) g+s sk fk i) (match-syntax-error "invalid use of ***" (p *** . q))) + ((match-two v ($ rec p ...) g+s sk fk i) + (if (is-a? v rec) + (match-record-refs v rec 0 (p ...) g+s sk fk i) + fk)) ((match-two v (p . q) g+s sk fk i) (if (pair? v) (let ((w (car v)) (x (cdr v))) @@ -471,6 +475,15 @@ (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) fk i))))))) +(define-syntax match-record-refs + (syntax-rules () + ((_ v rec n (p . q) g+s sk fk i) + (let ((w (slot-ref rec v n))) + (match-one w p ((slot-ref rec v n) (slot-set! rec v n)) + (match-record-refs v rec (+ n 1) q g+s sk fk) fk i))) + ((_ v rec n () g+s (sk ...) fk i) + (sk ... i)))) + ;; Extract all identifiers in a pattern. A little more complicated ;; than just looking for symbols, we need to ignore special keywords ;; and non-pattern forms (such as the predicate expression in ? diff --git a/lib/srfi/9.module b/lib/srfi/9.module index 1c9aad91..58368111 100644 --- a/lib/srfi/9.module +++ b/lib/srfi/9.module @@ -13,17 +13,21 @@ (pred (cadddr expr)) (fields (cddddr expr)) (num-fields (length fields)) - (index (register-simple-type name-str num-fields)) (_define (rename 'define)) (_lambda (rename 'lambda)) - (_let (rename 'let))) + (_let (rename 'let)) + (_register (rename 'register-simple-type))) (define (index-of field ls) (let lp ((ls ls) (i 0)) (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) `(,(rename 'begin) + ;; type + (,_define ,name (,_register ,name-str ,num-fields)) + ;; predicate (,_define ,pred (,(rename 'make-type-predicate) ,(symbol->string (identifier->symbol pred)) - ,index)) + ,name)) + ;; fields ,@(let lp ((ls fields) (i 0) (res '())) (if (null? ls) res @@ -32,7 +36,7 @@ (,(rename 'make-getter) ,(symbol->string (identifier->symbol (cadar ls))) - ,index + ,name ,i)) res))) (lp (cdr ls) @@ -43,17 +47,18 @@ (,(rename 'make-setter) ,(symbol->string (identifier->symbol (caddar ls))) - ,index + ,name ,i)) res) res))))) + ;; constructor (,_define ,make ,(let lp ((ls make-fields) (sets '()) (set-defs '())) (cond ((null? ls) `(,_let ((%make (,(rename 'make-constructor) ,(symbol->string (identifier->symbol make)) - ,index)) + ,name)) ,@set-defs) (,_lambda ,make-fields (,_let ((res (%make))) @@ -79,7 +84,7 @@ (cons (list setter (list (rename 'make-setter) setter-name - index + name (index-of (car ls) fields))) set-defs))))))))))))))))) diff --git a/opcodes.c b/opcodes.c index cf40794f..efc11d50 100644 --- a/opcodes.c +++ b/opcodes.c @@ -36,6 +36,8 @@ _OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string #endif #endif _OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF,3,0, 0, SEXP_FIXNUM, 0,"slot-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET,4,0, 0, SEXP_FIXNUM, 0,"slot-set!", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), @@ -58,6 +60,7 @@ _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA, 2, 0, 0, 0, 0, "is-a?", NULL, 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), diff --git a/opt/opcode_names.h b/opt/opcode_names.h index 88bc4387..a87aeb1c 100644 --- a/opt/opcode_names.h +++ b/opt/opcode_names.h @@ -10,9 +10,10 @@ static const char* reverse_opcode_names[] = "STRING-REF", "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", - "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", - "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", - "MUL", "DIV", "QUOTIENT", "REMAINDER", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", + "ISA?", "SLOTN-REF", "SLOTN-SET", + "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", + "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", diff --git a/sexp.c b/sexp.c index 59bfdff8..910e8523 100644 --- a/sexp.c +++ b/sexp.c @@ -183,7 +183,7 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp_type_size_scale(type) = sexp_unbox_fixnum(sc); sexp_type_name(type) = strdup(sexp_string_data(name)); sexp_type_finalize(type) = f; - res = sexp_make_fixnum(num_types); + res = type; #if SEXP_USE_GLOBAL_TYPES sexp_num_types = num_types + 1; #else @@ -1200,6 +1200,11 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { sexp_write_one(ctx, sexp_synclop(x) ? sexp_synclo_expr(x): x, out); sexp_write_string(ctx, ">", out); break; + case SEXP_SYNCLO: + sexp_write_string(ctx, "#", out); + break; case SEXP_STRING: sexp_write_char(ctx, '"', out); i = sexp_string_length(obj); diff --git a/vm.c b/vm.c index d292aaab..94ef207f 100644 --- a/vm.c +++ b/vm.c @@ -931,6 +931,33 @@ sexp sexp_vm (sexp ctx, sexp proc) { ip += sizeof(sexp)*2; top--; break; + case SEXP_OP_ISA: + _ARG2 = sexp_make_boolean(sexp_isa(_ARG1, _ARG2)); + top--; + break; + case SEXP_OP_SLOTN_REF: + if (! sexp_typep(_ARG1)) + sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + else if (! sexp_isa(_ARG2, _ARG1)) + sexp_raise("slot-ref: bad type", sexp_list1(ctx, _ARG2)); + else if (! sexp_fixnump(_ARG3)) + sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + _ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3)); + top-=2; + break; + case SEXP_OP_SLOTN_SET: + if (! sexp_typep(_ARG1)) + sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + else if (! sexp_isa(_ARG2, _ARG1)) + sexp_raise("slot-set!: bad type", sexp_list1(ctx, _ARG2)); + else if (sexp_immutablep(_ARG2)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG2)); + else if (! sexp_fixnump(_ARG3)) + sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4); + _ARG4 = SEXP_VOID; + top-=3; + break; case SEXP_OP_CAR: if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); From 9cfbfdb31b48f993f4430e1f638848c5a470fcf9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 17 Jul 2010 17:05:20 +0900 Subject: [PATCH 463/535] adding types to ast module --- lib/chibi/ast.c | 15 ++++++++++++++- lib/chibi/ast.module | 1 + 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 2b740f41..323d685e 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -45,7 +45,20 @@ static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { return sexp_intern(ctx, sexp_opcode_name(op), -1); } +static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x) { + return sexp_analyze(ctx, x); +} + +#define sexp_define_type(ctx, name, tag) \ + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag)); + sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_type(ctx, "lam", SEXP_LAMBDA); + sexp_define_type(ctx, "cnd", SEXP_CND); + sexp_define_type(ctx, "set", SEXP_SET); + sexp_define_type(ctx, "ref", SEXP_REF); + sexp_define_type(ctx, "seq", SEXP_SEQ); + sexp_define_type(ctx, "lit", SEXP_LIT); sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); @@ -70,7 +83,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); - sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze); + sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze_op); sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index 497fc5ed..7fdbcd85 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -1,6 +1,7 @@ (define-module (chibi ast) (export analyze env-cell opcode-name + lam cnd set ref seq lit syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? syntactic-closure-expr syntactic-closure-env syntactic-closure-vars lambda-name lambda-params lambda-body lambda-defs From 5308e5b45ba4cb74cedeb05761c34014e6670ceb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 19 Jul 2010 15:01:02 +0900 Subject: [PATCH 464/535] fixing typo --- README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README b/README index 69965ea7..6e5b00a6 100644 --- a/README +++ b/README @@ -239,7 +239,7 @@ Then you can use the following to create and manipulate contexts: is zero. stack and environment may both also be NULL (and _must_ be NULL if context is NULL) and will be given standard defaults. - Thus the to create your first context you generally call: + Thus to create your first context you generally call: sexp_make_eval_context(NULL, NULL, NULL, 0) From d43cf9f6c2ee6ad320045169cbfdf4becc67c051 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 19 Jul 2010 22:31:09 +0900 Subject: [PATCH 465/535] making (config) an importable module self-reference handled with new current-environment --- eval.c | 10 +++++++--- lib/config.scm | 3 ++- opcodes.c | 1 + 3 files changed, 10 insertions(+), 4 deletions(-) diff --git a/eval.c b/eval.c index 20947d69..0c9f6dce 100644 --- a/eval.c +++ b/eval.c @@ -12,8 +12,9 @@ static sexp analyze (sexp ctx, sexp x); static void generate (sexp ctx, sexp x); #if SEXP_USE_MODULES -static sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env); -static sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file); +sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env); +sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file); +sexp sexp_current_environment (sexp ctx sexp_api_params(self, n)); #endif sexp sexp_compile_error (sexp ctx, const char *message, sexp o) { @@ -1511,7 +1512,7 @@ sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { } #if SEXP_USE_MODULES -static sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file) { +sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file) { sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); return sexp_find_module_file(ctx, sexp_string_data(file)); } @@ -1520,6 +1521,9 @@ sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sex sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); return sexp_load_module_file(ctx, sexp_string_data(file), env); } +sexp sexp_current_environment (sexp ctx sexp_api_params(self, n)) { + return sexp_context_env(ctx); +} #endif sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp) { diff --git a/lib/config.scm b/lib/config.scm index be6fb36a..ee35e1dd 100644 --- a/lib/config.scm +++ b/lib/config.scm @@ -1,5 +1,5 @@ ;; config.scm -- configuration module -;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; Copyright (c) 2009-2010 Alex Shinn. All rights reserved. ;; BSD-style license: http://synthcode.com/license.txt ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -168,6 +168,7 @@ (define *modules* (list (cons '(scheme) (make-module #f (interaction-environment) '())) + (cons '(config) (make-module #f (current-environment) '())) (cons '(srfi 0) (make-module (list 'cond-expand) (interaction-environment) (list (list 'export 'cond-expand)))) diff --git a/opcodes.c b/opcodes.c index efc11d50..26622b55 100644 --- a/opcodes.c +++ b/opcodes.c @@ -163,6 +163,7 @@ _FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter_op), #include "opt/plan9-opcodes.c" #endif #if SEXP_USE_MODULES +_FN0("current-environment", 0, sexp_current_environment), _FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports_op), _FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), _FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), From b165a27fcf658fe65599f6377767175ad4f8128e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 19 Jul 2010 23:39:23 +0900 Subject: [PATCH 466/535] adding lambda names in more cases --- eval.c | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/eval.c b/eval.c index 0c9f6dce..a2f07073 100644 --- a/eval.c +++ b/eval.c @@ -440,6 +440,7 @@ static sexp sexp_identifier_eq_op (sexp ctx sexp_api_params(self, n), sexp e1, s /************************* the compiler ***************************/ static sexp analyze_app (sexp ctx, sexp x) { + sexp p; sexp_gc_var2(res, tmp); sexp_gc_preserve2(ctx, res, tmp); for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) { @@ -452,8 +453,22 @@ static sexp analyze_app (sexp ctx, sexp x) { sexp_car(res) = tmp; } } + if (sexp_pairp(res)) { /* fill in lambda names */ + res = sexp_nreverse(ctx, res); + if (sexp_lambdap(sexp_car(res))) { + p=sexp_lambda_params(sexp_car(res)); + for (tmp=sexp_cdr(res); + sexp_pairp(tmp) && sexp_pairp(p); + tmp=sexp_cdr(tmp), p=sexp_cdr(p)) { + if (sexp_lambdap(sexp_car(tmp))) { + sexp_debug(ctx, "setting lambda name: ", sexp_car(p)); + sexp_lambda_name(sexp_car(tmp)) = sexp_car(p); + } + } + } + } sexp_gc_release2(ctx); - return (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); + return res; } static sexp analyze_seq (sexp ctx, sexp ls) { @@ -560,6 +575,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { value = analyze(ctx3, sexp_cadar(tmp)); } if (sexp_exceptionp(value)) sexp_return(res, value); + if (sexp_lambdap(value)) sexp_lambda_name(value) = name; sexp_push(ctx3, defs, sexp_make_set(ctx3, analyze_var_ref(ctx3, name, NULL), value)); } @@ -626,14 +642,16 @@ static sexp analyze_define (sexp ctx, sexp x) { } else value = analyze(ctx, sexp_caddr(x)); ref = analyze_var_ref(ctx, name, &varenv); - if (sexp_exceptionp(ref)) + if (sexp_exceptionp(ref)) { res = ref; - else if (sexp_exceptionp(value)) + } else if (sexp_exceptionp(value)) { res = value; - else if (varenv && sexp_immutablep(varenv)) + } else if (varenv && sexp_immutablep(varenv)) { res = sexp_compile_error(ctx, "immutable binding", name); - else + } else { + if (sexp_lambdap(value)) sexp_lambda_name(value) = name; res = sexp_make_set(ctx, ref, value); + } } } sexp_gc_release4(ctx); From 66bbcefe6a03af474068fbdec36229d071ac5083 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 19 Jul 2010 23:42:18 +0900 Subject: [PATCH 467/535] removing debug line --- eval.c | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/eval.c b/eval.c index a2f07073..7a17155d 100644 --- a/eval.c +++ b/eval.c @@ -457,14 +457,9 @@ static sexp analyze_app (sexp ctx, sexp x) { res = sexp_nreverse(ctx, res); if (sexp_lambdap(sexp_car(res))) { p=sexp_lambda_params(sexp_car(res)); - for (tmp=sexp_cdr(res); - sexp_pairp(tmp) && sexp_pairp(p); - tmp=sexp_cdr(tmp), p=sexp_cdr(p)) { - if (sexp_lambdap(sexp_car(tmp))) { - sexp_debug(ctx, "setting lambda name: ", sexp_car(p)); + for (tmp=sexp_cdr(res); sexp_pairp(tmp)&&sexp_pairp(p); tmp=sexp_cdr(tmp), p=sexp_cdr(p)) + if (sexp_lambdap(sexp_car(tmp))) sexp_lambda_name(sexp_car(tmp)) = sexp_car(p); - } - } } } sexp_gc_release2(ctx); From 3660755f4a18b243d04e5edf4cfcd11df16dd6c4 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 19 Jul 2010 23:55:07 +0900 Subject: [PATCH 468/535] updating macroexpand, exporting ast->sexp --- lib/chibi/macroexpand.module | 2 +- lib/chibi/macroexpand.scm | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/chibi/macroexpand.module b/lib/chibi/macroexpand.module index 47b0e7d4..c9a3fd8c 100644 --- a/lib/chibi/macroexpand.module +++ b/lib/chibi/macroexpand.module @@ -2,5 +2,5 @@ (define-module (chibi macroexpand) (import-immutable (scheme)) (import (chibi ast)) - (export macroexpand) + (export macroexpand ast->sexp) (include "macroexpand.scm")) diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm index a040855a..81cb566f 100644 --- a/lib/chibi/macroexpand.scm +++ b/lib/chibi/macroexpand.scm @@ -68,7 +68,8 @@ (cond ((lambda? x) `(lambda ,(map (lambda (id) (get-rename id x renames)) (lambda-params x)) - ,@(map (lambda (d) `(define ,(identifier->symbol (cadr d)) #f)) (lambda-defs x)) + ,@(map (lambda (d) `(define ,(identifier->symbol (cadar d)) #f)) + (lambda-defs x)) ,@(if (seq? (lambda-body x)) (map a2s (seq-ls (lambda-body x))) (list (a2s (lambda-body x)))))) From 66ae7b1c0317e02e0eaa8cc3e1af0a40c89dc2ec Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 20 Jul 2010 00:19:02 +0900 Subject: [PATCH 469/535] preserving internal define source info --- eval.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/eval.c b/eval.c index 7a17155d..6e567770 100644 --- a/eval.c +++ b/eval.c @@ -564,7 +564,9 @@ static sexp analyze_lambda (sexp ctx, sexp x) { if (sexp_pairp(sexp_caar(tmp))) { name = sexp_caaar(tmp); tmp = sexp_cons(ctx3, sexp_cdaar(tmp), sexp_cdar(tmp)); - value = analyze_lambda(ctx3, sexp_cons(ctx3, SEXP_VOID, tmp)); + tmp = sexp_cons(ctx3, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(sexp_caar(ls)); + value = analyze_lambda(ctx3, tmp); } else { name = sexp_caar(tmp); value = analyze(ctx3, sexp_cadar(tmp)); @@ -624,6 +626,7 @@ 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); tmp = sexp_cons(ctx, sexp_cdr(x), ctx); + sexp_pair_source(sexp_cdr(x)) = sexp_pair_source(x); sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp); res = SEXP_VOID; } else { From 54005c4d668c9b5e18e1f6d48c5b8487cf075115 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 20 Jul 2010 08:21:43 +0900 Subject: [PATCH 470/535] adding source info to all pairs in a list and checking cdr's when analyzing this preserves source info for named lets without any need for source info copying in the macro itself. --- eval.c | 4 ++++ sexp.c | 3 +++ 2 files changed, 7 insertions(+) diff --git a/eval.c b/eval.c index 6e567770..3c108113 100644 --- a/eval.c +++ b/eval.c @@ -550,6 +550,10 @@ static sexp analyze_lambda (sexp ctx, sexp x) { /* build lambda and analyze body */ res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x))); sexp_lambda_source(res) = sexp_pair_source(x); + if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res)))) + sexp_lambda_source(res) = sexp_pair_source(sexp_cdr(x)); + if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res)))) + sexp_lambda_source(res) = sexp_pair_source(sexp_cddr(x)); ctx2 = sexp_make_child_context(ctx, res); tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); diff --git a/sexp.c b/sexp.c index 910e8523..d976a147 100644 --- a/sexp.c +++ b/sexp.c @@ -1549,6 +1549,9 @@ sexp sexp_read_raw (sexp ctx, sexp in) { break; } res = sexp_cons(ctx, tmp, res); + if (sexp_port_sourcep(in) && (line >= 0)) + sexp_pair_source(res) + = sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line)); tmp = sexp_read_raw(ctx, in); } if (! sexp_exceptionp(res)) { From 49cd07dad15692e8b4b6a320bc83ee84aac08a92 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 20 Jul 2010 08:53:43 +0900 Subject: [PATCH 471/535] adding modules introspection lib currently just analyze-module to return all top-level forms of a module analyzed in the internal AST form. --- lib/chibi/modules.module | 5 ++++ lib/chibi/modules.scm | 64 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 69 insertions(+) create mode 100644 lib/chibi/modules.module create mode 100644 lib/chibi/modules.scm diff --git a/lib/chibi/modules.module b/lib/chibi/modules.module new file mode 100644 index 00000000..dd00c3b1 --- /dev/null +++ b/lib/chibi/modules.module @@ -0,0 +1,5 @@ + +(define-module (chibi modules) + (export analyze-module) + (import-immutable (scheme) (config) (chibi ast)) + (include "modules.scm")) diff --git a/lib/chibi/modules.scm b/lib/chibi/modules.scm new file mode 100644 index 00000000..f17f0cd1 --- /dev/null +++ b/lib/chibi/modules.scm @@ -0,0 +1,64 @@ + +(define (file->sexp-list file) + (call-with-input-file file + (lambda (in) + (let lp ((res '())) + (let ((x (read in))) + (if (eof-object? x) + (reverse res) + (lp (cons x res)))))))) + +;; load the module and return it with a list of all top-level forms in +;; the module analyzed +(define (analyze-module name . o) + (let ((recursive? (and (pair? o) (car o))) + (modules `(((scheme) . ,(find-module '(scheme)))))) + (let go ((name name)) + (let ((env (make-environment)) + (dir (module-name-prefix name))) + (define (load-modules files extension) + (for-each + (lambda (f) + (let ((f (string-append dir f extension))) + (cond ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + files)) + (define (include-source file) + (cond ((find-module-file (string-append dir file)) + => (lambda (x) (cons 'body (file->sexp-list x)))) + (else (error "couldn't find include" file)))) + (cond + ((assoc name modules) => cdr) + (else + (let ((mod (find-module name))) + (let lp ((ls (module-meta-data mod)) (res '())) + (cond + ((not (pair? ls)) (reverse res)) + (else + (case (and (pair? (car ls)) (caar ls)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2 (load-module (car mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports) + (eq? (caar ls) 'import-immutable)))) + (cdar ls)) + (lp (cdr ls) res)) + ((include) + (lp (append (map include-source (cdar ls)) (cdr ls)) res)) + ((include-shared) + (cond-expand + (dynamic-loading + (load-modules (cdar ls) *shared-object-extension*)) + (else #f))) + ((body) + (let lp2 ((ls2 (cdar ls)) (res res)) + (cond + ((pair? ls2) + (eval (car ls2) env) + (lp2 (cdr ls2) (cons (analyze (car ls2)) res))) + (else + (lp (cdr ls) res))))) + (else + (lp (cdr ls) res))))))))))))) From b2975ef6236f25f9c7afe5fe929629c57c712754 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 20 Jul 2010 08:55:38 +0900 Subject: [PATCH 472/535] adding scribble module --- lib/chibi/scribble.module | 5 + lib/chibi/scribble.scm | 247 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 252 insertions(+) create mode 100644 lib/chibi/scribble.module create mode 100644 lib/chibi/scribble.scm diff --git a/lib/chibi/scribble.module b/lib/chibi/scribble.module new file mode 100644 index 00000000..b479eb64 --- /dev/null +++ b/lib/chibi/scribble.module @@ -0,0 +1,5 @@ + +(define-module (chibi scribble) + (export scribble-parse scribble-read) + (import-immutable (scheme)) + (include "scribble.scm")) diff --git a/lib/chibi/scribble.scm b/lib/chibi/scribble.scm new file mode 100644 index 00000000..1e4f15cd --- /dev/null +++ b/lib/chibi/scribble.scm @@ -0,0 +1,247 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; general character utils + +(define (char-mirror ch) + (case ch ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else ch))) + +(define (char-delimiter? ch) + (or (eof-object? ch) (char-whitespace? ch) + (memv ch '(#\( #\) #\[ #\] #\{ #\} #\" #\|)))) + +(define (char-punctuation? ch) + (memv ch '(#\- #\+ #\! #\< #\> #\[ #\] #\|))) + +(define (char-digit ch) (- (char->integer ch) (char->integer #\0))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; list utils + +(define (drop ls n) (if (<= n 0) ls (drop (cdr ls) (- n 1)))) + +(define (drop-while pred ls) + (if (or (null? ls) (not (pred (car ls)))) ls (drop-while pred (cdr ls)))) + +(define (list-prefix? prefix ls) + (cond ((null? prefix) #t) + ((null? ls) #f) + ((equal? (car prefix) (car ls)) (list-prefix? (cdr prefix) (cdr ls))) + (else #f))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; scribble reader (standalone, don't use the native reader) + +(define scribble-dot (list ".")) +(define scribble-close (list ")")) + +(define (if-peek-char ch in pass fail) + (cond ((eqv? ch (peek-char in)) (read-char in) pass) (else fail))) + +(define (skip-line in) + (do ((c #f (read-char in))) ((or (eof-object? c) (eqv? c #\newline))))) + +(define (read-float-tail in acc) + (let lp ((res acc) (k 0.1)) + (let ((ch (read-char in))) + (cond ((or (eof-object? ch) (char-delimiter? ch)) res) + ((char-numeric? ch) (lp (+ res (* k (char-digit ch))) (* k 0.1))) + (else (error "invalid numeric syntax")))))) + +(define (read-number in acc base) + (let lp ((acc acc)) + (let ((ch (peek-char in))) + (cond + ((or (eof-object? ch) (char-delimiter? ch)) acc) + ((char-numeric? ch) (read-char in) (lp (+ (* acc base) (char-digit ch)))) + ((eqv? #\. ch) + (read-char in) + (if (= base 10) + (begin (read-char in) (read-float-tail in (exact->inexact acc))) + (error "non-base-10 floating point"))) + (else (error "invalid numeric syntax")))))) + +(define (read-escaped in terminal) + (let lp ((ls '())) + (let ((ch (read-char in))) + (cond + ((or (eof-object? ch) (eqv? ch terminal)) (list->string (reverse ls))) + ((eqv? ch #\\) (lp (cons (read-char in) ls))) + (else (lp (cons ch ls))))))) + +(define (read-symbol in ls) + (do ((ls ls (cons c ls)) (c (peek-char in) (peek-char in))) + ((char-delimiter? c) (string->symbol (list->string (reverse ls)))) + (read-char in))) + +(define (scrib-read in) + (define ch (read-char in)) + (cond + ((eof-object? ch) ch) + ((char-whitespace? ch) (scrib-read in)) + (else + (case ch + ((#\( #\[ #\{) + (let lp ((res '())) + (let ((x (scrib-read in))) + (cond ((eof-object? x) (error "unterminated list" x)) + ((eq? x scribble-close) (reverse res)) + ((eq? x scribble-dot) + (let ((y (scrib-read in))) + (if (or (eof-object? y) (eq? y scribble-close)) + (error "unterminated dotted list") + (let ((z (scrib-read in))) + (if (not (eq? z scribble-close)) + (error "dot in non-terminal position in list" y z) + (append (reverse res) y)))))) + (else (lp (cons x res))))))) + ((#\} #\] #\)) scribble-close) + ((#\.) (if (char-delimiter? (peek-char in)) scribble-dot (read-float-tail in 0.0))) + ((#\') (list 'quote (scrib-read in))) + ((#\`) (list 'quasiquote (scrib-read in))) + ((#\,) (list (if-peek-char #\@ in 'unquote-splicing 'unquote) (scrib-read in))) + ((#\@) (scribble-parse-escape in #\@)) + ((#\;) (skip-line in) (scrib-read in)) + ((#\|) (string->symbol (read-escaped in #\|))) + ((#\") (read-escaped in #\")) + ((#\+ #\-) + (cond ((char-numeric? (peek-char in)) + ((if (eqv? ch #\+) + -) 0 (read-number in 0 10))) + (else (read-symbol in (list ch))))) + ((#\#) + (case (peek-char in) + ((#\t #\f) (eqv? (read-char in) #\t)) + ((#\() (list->vector (scrib-read in))) + ((#\\) + (read-char in) + (if (char-alphabetic? (peek-char in)) + (let ((name (scrib-read in))) + (case name + ((space) #\space) ((newline) #\newline) + (else (string-ref (symbol->string name) 0)))) + (read-char in))) + (else (error "unknown # syntax")))) + (else + (if (char-numeric? ch) + (read-number in (char-digit ch) 10) + (read-symbol in (list ch)))))))) + +(define (scribble-read in) + (let ((res (scrib-read in))) + (cond ((eq? res scribble-dot) (error "invalid . in source")) + ((eq? res scribble-close) (error "too many )'s")) + (else res)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; scribble parser + +(define (read-punctuation in) + (if (not (eqv? #\| (peek-char in))) + '() + (let lp ((ls '())) + (let ((c (peek-char in))) + (cond ((or (eof-object? c) (not(char-punctuation? c))) ls) + (else (lp (cons (char-mirror (read-char in)) ls)))))))) + +(define (read-prefix-wrapper in) + (let lp ((wrap (lambda (x) x))) + (case (peek-char in) + ((#\') (read-char in) (lp (lambda (x) (wrap (list 'quote x))))) + ((#\`) (read-char in) (lp (lambda (x) (wrap (list 'quasiquote x))))) + ((#\,) + (read-char in) + (cond ((eqv? #\@ (peek-char in)) + (read-char in) + (lp (lambda (x) (wrap (list 'unquote-splicing x))))) + (else (lp (lambda (x) (wrap (list 'unquote x))))))) + (else wrap)))) + +(define (scribble-parse-escape in ec) + (define bracket-char #\[) + (define brace-char #\{) + (let* ((wrap (read-prefix-wrapper in)) + (c (peek-char in)) + (cmd (if (or (eqv? c bracket-char) (eqv? c brace-char)) '() (list (scribble-read in)))) + (data? (eqv? (peek-char in) bracket-char)) + (data (if data? (scribble-read in) '())) + (punc (read-punctuation in)) + (body? (eqv? (peek-char in) brace-char)) + (body (cond (body? (read-char in) (scribble-parse in punc ec)) (else '())))) + (wrap (if (or data? body?) (append cmd data body) (car cmd))))) + +(define (scribble-parse in . o) + (define init-punc (if (pair? o) (car o) '())) + (define escape-char (if (and (pair? o) (pair? (cdr o))) (cadr o) #\@)) + (define comment-char #\;) + (define bracket-char #\[) + (define brace-char #\{) + (define close-bracket-char (char-mirror bracket-char)) + (define close-brace-char (char-mirror brace-char)) + (define (collect str res) + (if (pair? str) (cons (list->string (reverse str)) res) res)) + (define (skip-space in) + (let ((ch (peek-char in))) + (cond ((char-whitespace? ch) (read-char in) (skip-space in)) + ((eqv? ch #\;) (skip-line in) (skip-space in))))) + (define (tok str res punc depth) + (let ((c (read-char in))) + (cond + ((eof-object? c) + (if (zero? depth) + (reverse (collect str res)) + (error "unterminated expression" punc))) + ((and (eqv? c escape-char) (list-prefix? punc str)) + (let ((c (peek-char in))) + (cond + ((eof-object? c) + (tok str res punc depth)) + ((char-whitespace? c) + (tok (cons c str) res punc depth)) + ((eqv? c comment-char) + (read-char in) + (cond ((eqv? brace-char (peek-char in)) + (scribble-parse-escape in escape-char)) + (else + (skip-line in) + (let lp () + (cond ((char-whitespace? (peek-char in)) (read-char in) (lp)))))) + (tok str res punc depth)) + ((eqv? c #\|) + (read-char in) + (let lp ((ls (collect str res))) + (skip-space in) + (cond ((eqv? #\| (peek-char in)) (read-char in) (tok '() ls punc depth)) + (else (lp (cons (scribble-read in) ls)))))) + (else + (let ((str (drop str (length punc))) + (x (scribble-parse-escape in escape-char))) + (if (string? x) + (tok (append (reverse (string->list x)) str) res punc depth) + (tok '() (cons x (collect str res)) punc depth))))))) + ((eqv? c brace-char) + (tok (cons c str) res punc (+ depth 1))) + ((eqv? c close-brace-char) + (cond + ((zero? depth) + (let lp ((p punc) (ls '())) + (cond ((null? p) + (reverse (collect str res))) + ((not (eqv? (car p) (peek-char in))) + (tok (append ls (cons c str)) res punc (- depth 1))) + (else + (lp (cdr p) (cons (read-char in) ls)))))) + (else (tok (cons c str) res punc (- depth 1))))) + ((eqv? c #\newline) + (let* ((first? (and (null? res) (null? str))) + (res (collect (drop-while char-whitespace? str) res)) + (res (if (or first? (eqv? #\} (peek-char in))) + res + (cons "\n" res)))) + (let lp ((ls '())) + (let ((c (peek-char in))) + (cond + ((char-whitespace? c) (read-char in) (lp (cons c ls))) + (else (tok (if (eqv? c #\}) ls '()) res punc depth))))))) + (else + (tok (cons c str) res punc depth))))) + ;; begin + (tok '() '() init-punc 0)) From ce6891b1888e5d197a0701c004896c428596ec5d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 25 Jul 2010 21:24:46 +0900 Subject: [PATCH 473/535] adding several utilities to chibi.modules including procedure-analysis --- include/chibi/sexp.h | 4 +- lib/chibi/ast.c | 36 +++++++++- lib/chibi/ast.module | 16 +++-- lib/chibi/macroexpand.module | 6 -- lib/chibi/macroexpand.scm | 86 ------------------------ lib/chibi/modules.module | 7 +- lib/chibi/modules.scm | 126 ++++++++++++++++++++--------------- lib/chibi/repl.module | 3 +- lib/config.scm | 5 +- sexp.c | 2 +- 10 files changed, 133 insertions(+), 158 deletions(-) delete mode 100644 lib/chibi/macroexpand.module delete mode 100644 lib/chibi/macroexpand.scm diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 7adb008c..1012870f 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -301,7 +301,7 @@ struct sexp_struct { struct sexp_core_form_struct core; /* ast types */ struct { - sexp name, params, body, defs, locals, flags, fv, sv, source; + sexp name, params, body, defs, locals, flags, fv, sv, ret, types, source; } lambda; struct { sexp test, pass, fail, source; @@ -704,6 +704,8 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #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_lambda_return_type(x) ((x)->value.lambda.ret) +#define sexp_lambda_param_types(x) ((x)->value.lambda.types) #define sexp_lambda_source(x) ((x)->value.lambda.source) #define sexp_cnd_test(x) ((x)->value.cnd.test) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 323d685e..3a0be629 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -45,8 +45,25 @@ static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { return sexp_intern(ctx, sexp_opcode_name(op), -1); } -static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x) { - return sexp_analyze(ctx, x); +static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { + sexp ctx2 = ctx; + if (sexp_envp(e)) { + ctx2 = sexp_make_child_context(ctx, NULL); + sexp_context_env(ctx2) = e; + } + return sexp_analyze(ctx2, x); +} + +static sexp sexp_optimize (sexp ctx sexp_api_params(self, n), sexp x) { + sexp_gc_var2(ls, res); + sexp_gc_preserve2(ctx, ls, res); + res = x; + ls = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_apply1(ctx, sexp_cdar(ls), res); + sexp_free_vars(ctx, res, SEXP_NULL); + sexp_gc_release2(ctx); + return res; } #define sexp_define_type(ctx, name, tag) \ @@ -67,6 +84,8 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ); sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); + sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE); + sexp_define_accessors(ctx, env, SEXP_PAIR, 2, "pair-source", "pair-source-set!"); sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!"); @@ -74,6 +93,13 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!"); sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 4, "lambda-locals", "lambda-locals-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 5, "lambda-flags", "lambda-flags-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 6, "lambda-free-vars", "lambda-free-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-set-vars", "lambda-set-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 8, "lambda-return-type", "lambda-return-type-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 9, "lambda-param-types", "lambda-param-types-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 10, "lambda-source", "lambda-source-set!"); sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!"); sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!"); sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!"); @@ -83,10 +109,14 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); - sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze_op); + sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 1, "procedure-code", "procedure-code-set!"); + sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 2, "procedure-vars", "procedure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-name", "bytecode-name-set!"); + sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE); sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize); return SEXP_VOID; } diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index 7fdbcd85..53e7e0bb 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -1,16 +1,24 @@ (define-module (chibi ast) - (export analyze env-cell opcode-name + (export analyze optimize env-cell opcode-name ast->sexp macroexpand lam cnd set ref seq lit + pair-source pair-source-set! syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? syntactic-closure-expr syntactic-closure-env syntactic-closure-vars - lambda-name lambda-params lambda-body lambda-defs + lambda-name lambda-params lambda-body lambda-defs lambda-locals + lambda-flags lambda-free-vars lambda-set-vars lambda-return-type + lambda-param-types lambda-source lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + lambda-locals-set! lambda-flags-set! lambda-free-vars-set! + lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set! + lambda-source-set! cnd-test cnd-pass cnd-fail cnd-test-set! cnd-pass-set! cnd-fail-set! set-var set-value set-var-set! set-value-set! ref-name ref-cell ref-name-set! ref-cell-set! - seq-ls seq-ls-set! lit-value lit-value-set!) + seq-ls seq-ls-set! lit-value lit-value-set! + procedure-code procedure-vars procedure-name bytecode-name) (import-immutable (scheme)) - (include-shared "ast")) + (include-shared "ast") + (include "ast.scm")) diff --git a/lib/chibi/macroexpand.module b/lib/chibi/macroexpand.module deleted file mode 100644 index c9a3fd8c..00000000 --- a/lib/chibi/macroexpand.module +++ /dev/null @@ -1,6 +0,0 @@ - -(define-module (chibi macroexpand) - (import-immutable (scheme)) - (import (chibi ast)) - (export macroexpand ast->sexp) - (include "macroexpand.scm")) diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm deleted file mode 100644 index 81cb566f..00000000 --- a/lib/chibi/macroexpand.scm +++ /dev/null @@ -1,86 +0,0 @@ -;; macroexpand.scm -- macro expansion utility -;; Copyright (c) 2009 Alex Shinn. All rights reserved. -;; BSD-style license: http://synthcode.com/license.txt - -;; This actually analyzes the expression then reverse-engineers an -;; sexp from the result, generating a minimal amount of renames. - -(define (macroexpand x) - (ast->sexp (analyze x))) - -(define (ast-renames ast) - (define i 0) - (define renames '()) - (define (rename-symbol id) - (set! i (+ i 1)) - (string->symbol - (string-append (symbol->string (identifier->symbol id)) - "." (number->string i)))) - (define (rename-lambda lam) - (or (assq lam renames) - (let ((res (list lam))) - (set! renames (cons res renames)) - res))) - (define (rename! id lam) - (let ((cell (rename-lambda lam))) - (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell))))) - (define (check-ref id lam env) - (let ((sym (identifier->symbol id))) - (let lp1 ((ls env)) - (cond - ((pair? ls) - (let lp2 ((ls2 (car ls)) (found? #f)) - (cond - ((null? ls2) - (if (not found?) (lp1 (cdr ls)))) - ((and (eq? id (caar ls2)) (eq? lam (cdar ls2))) - (lp2 (cdr ls2) #t)) - ((eq? sym (identifier->symbol (caar ls2))) - (rename! (caar ls2) (cdar ls2)) - (lp2 (cdr ls2) found?)) - (else - (lp2 (cdr ls2) found?))))))))) - (define (flatten-dot x) - (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) - ((null? x) x) - (else (list x)))) - (define (extend-env lam env) - (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env)) - (let lp ((x ast) (env '())) - (cond - ((lambda? x) (lp (lambda-body x) (extend-env x env))) - ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env)) - ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env)) - ((set? x) (lp (set-var x) env) (lp (set-value x) env)) - ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x))) - ((pair? x) (for-each (lambda (x) (lp x env)) x)))) - renames) - -(define (get-rename id lam renames) - (let ((ls (assq lam renames))) - (if (not ls) - (identifier->symbol id) - (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id)))))) - -(define (ast->sexp ast) - (let ((renames (ast-renames ast))) - (let a2s ((x ast)) - (cond - ((lambda? x) - `(lambda ,(map (lambda (id) (get-rename id x renames)) (lambda-params x)) - ,@(map (lambda (d) `(define ,(identifier->symbol (cadar d)) #f)) - (lambda-defs x)) - ,@(if (seq? (lambda-body x)) - (map a2s (seq-ls (lambda-body x))) - (list (a2s (lambda-body x)))))) - ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) - ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) - ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) - ((seq? x) `(begin ,@(map a2s (seq-ls x)))) - ((lit? x) - (let ((v (lit-value x))) - (if (or (pair? v) (null? v) (symbol? v)) `',v v))) - ((pair? x) (cons (a2s (car x)) (a2s (cdr x)))) - ((opcode? x) (or (opcode-name x) x)) - (else x))))) - diff --git a/lib/chibi/modules.module b/lib/chibi/modules.module index dd00c3b1..0d20861e 100644 --- a/lib/chibi/modules.module +++ b/lib/chibi/modules.module @@ -1,5 +1,8 @@ (define-module (chibi modules) - (export analyze-module) - (import-immutable (scheme) (config) (chibi ast)) + (export analyze-module module-ast module-ast-set! + module-ref module-contains? containing-module + procedure-analysis) + (import-immutable (scheme) (config)) + (import (chibi ast)) (include "modules.scm")) diff --git a/lib/chibi/modules.scm b/lib/chibi/modules.scm index f17f0cd1..3e85d40c 100644 --- a/lib/chibi/modules.scm +++ b/lib/chibi/modules.scm @@ -8,57 +8,79 @@ (reverse res) (lp (cons x res)))))))) -;; load the module and return it with a list of all top-level forms in -;; the module analyzed +(define (module? x) (vector? x)) + +(define (module-ast mod) (vector-ref mod 3)) +(define (module-ast-set! mod x) (vector-set! mod 3 x)) + +(define (analyze-module-source name mod recursive?) + (let ((env (module-env mod)) + (dir (if (equal? name '(scheme)) "" (module-name-prefix name)))) + (define (include-source file) + (cond ((find-module-file (string-append dir file)) + => (lambda (x) (cons 'body (file->sexp-list x)))) + (else (error "couldn't find include" file)))) + (let lp ((ls (module-meta-data mod)) (res '())) + (cond + ((not (pair? ls)) + (reverse res)) + (else + (case (and (pair? (car ls)) (caar ls)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2-name (car mod2-name+imports))) + (if recursive? + (analyze-module mod2-name #t)))) + (cdar ls)) + (lp (cdr ls) res)) + ((include) + (lp (append (map include-source (cdar ls)) (cdr ls)) res)) + ((body) + (let lp2 ((ls2 (cdar ls)) (res res)) + (cond + ((pair? ls2) + (lp2 (cdr ls2) (cons (analyze (car ls2) env) res))) + (else + (lp (cdr ls) res))))) + (else + (lp (cdr ls) res)))))))) + (define (analyze-module name . o) (let ((recursive? (and (pair? o) (car o))) - (modules `(((scheme) . ,(find-module '(scheme)))))) - (let go ((name name)) - (let ((env (make-environment)) - (dir (module-name-prefix name))) - (define (load-modules files extension) - (for-each - (lambda (f) - (let ((f (string-append dir f extension))) - (cond ((find-module-file f) => (lambda (x) (load x env))) - (else (error "couldn't find include" f))))) - files)) - (define (include-source file) - (cond ((find-module-file (string-append dir file)) - => (lambda (x) (cons 'body (file->sexp-list x)))) - (else (error "couldn't find include" file)))) - (cond - ((assoc name modules) => cdr) - (else - (let ((mod (find-module name))) - (let lp ((ls (module-meta-data mod)) (res '())) - (cond - ((not (pair? ls)) (reverse res)) - (else - (case (and (pair? (car ls)) (caar ls)) - ((import import-immutable) - (for-each - (lambda (m) - (let* ((mod2-name+imports (resolve-import m)) - (mod2 (load-module (car mod2-name+imports)))) - (%env-copy! env (module-env mod2) (cdr mod2-name+imports) - (eq? (caar ls) 'import-immutable)))) - (cdar ls)) - (lp (cdr ls) res)) - ((include) - (lp (append (map include-source (cdar ls)) (cdr ls)) res)) - ((include-shared) - (cond-expand - (dynamic-loading - (load-modules (cdar ls) *shared-object-extension*)) - (else #f))) - ((body) - (let lp2 ((ls2 (cdar ls)) (res res)) - (cond - ((pair? ls2) - (eval (car ls2) env) - (lp2 (cdr ls2) (cons (analyze (car ls2)) res))) - (else - (lp (cdr ls) res))))) - (else - (lp (cdr ls) res))))))))))))) + (res (load-module name))) + (if (not (module-ast res)) + (module-ast-set! res (analyze-module-source name res recursive?))) + res)) + +(define (module-ref mod var-name . o) + (let ((cell (env-cell (module-env (if (module? mod) mod (load-module mod))) + var-name))) + (if cell + (cdr cell) + (if (pair? o) (car o) (error "no binding in module" mod var-name))))) + +(define (module-contains? mod var-name) + (and (env-cell (module-env (if (module? mod) mod (load-module mod))) var-name) + #t)) + +(define (containing-module x) + (let lp1 ((ls *modules*)) + (and (pair? ls) + (let ((env (module-env (cdar ls)))) + (let lp2 ((e-ls (env-exports env))) + (cond ((null? e-ls) (lp1 (cdr ls))) + ((eq? x (cdr (env-cell env (car e-ls)))) (car ls)) + (else (lp2 (cdr e-ls))))))))) + +(define (procedure-analysis x) + (let ((mod (containing-module x))) + (and mod + (let lp ((ls (module-ast (analyze-module (car mod))))) + (and (pair? ls) + (if (and (set? (car ls)) + (eq? (procedure-name x) (ref-name (set-var (car ls))))) + (set-value (car ls)) + (lp (cdr ls)))))))) + diff --git a/lib/chibi/repl.module b/lib/chibi/repl.module index 4db9a267..5c1035a7 100644 --- a/lib/chibi/repl.module +++ b/lib/chibi/repl.module @@ -1,5 +1,6 @@ (define-module (chibi repl) (export repl) - (import-immutable (scheme) (chibi process)) + (import-immutable (scheme)) + (import (chibi process)) (include "repl.scm")) diff --git a/lib/config.scm b/lib/config.scm index ee35e1dd..55a4e1e0 100644 --- a/lib/config.scm +++ b/lib/config.scm @@ -7,7 +7,7 @@ (define *this-module* '()) -(define (make-module exports env meta) (vector exports env meta)) +(define (make-module exports env meta) (vector exports env meta #f)) (define (%module-exports mod) (vector-ref mod 0)) (define (module-env mod) (vector-ref mod 1)) (define (module-meta-data mod) (vector-ref mod 2)) @@ -167,7 +167,8 @@ (define-config-primitive body) (define *modules* - (list (cons '(scheme) (make-module #f (interaction-environment) '())) + (list (cons '(scheme) (make-module #f (interaction-environment) + '((include "init.scm")))) (cons '(config) (make-module #f (current-environment) '())) (cons '(srfi 0) (make-module (list 'cond-expand) (interaction-environment) diff --git a/sexp.c b/sexp.c index d976a147..3e64553e 100644 --- a/sexp.c +++ b/sexp.c @@ -107,7 +107,7 @@ static struct sexp_type_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode", NULL), _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form", NULL), _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode", NULL), - _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 9, 9, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda", NULL), + _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda", NULL), _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional", NULL), _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, "reference", NULL), _DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, "set!", NULL), From 8d1ed6da27d7ce2b9a671381e890b88966611859 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 25 Jul 2010 21:27:39 +0900 Subject: [PATCH 474/535] adding ast.scm where ast->sexp was moved --- lib/chibi/ast.scm | 91 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 91 insertions(+) create mode 100644 lib/chibi/ast.scm diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm new file mode 100644 index 00000000..020f257a --- /dev/null +++ b/lib/chibi/ast.scm @@ -0,0 +1,91 @@ +;; ast.scm -- ast utilities +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (macroexpand x) + (ast->sexp (analyze x))) + +(define (procedure-name x) + (bytecode-name (procedure-code x))) + +(define (ast-renames ast) + (define i 0) + (define renames '()) + (define (rename-symbol id) + (set! i (+ i 1)) + (string->symbol + (string-append (symbol->string (identifier->symbol id)) + "." (number->string i)))) + (define (rename-lambda lam) + (or (assq lam renames) + (let ((res (list lam))) + (set! renames (cons res renames)) + res))) + (define (rename! id lam) + (let ((cell (rename-lambda lam))) + (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell))))) + (define (check-ref id lam env) + (let ((sym (identifier->symbol id))) + (let lp1 ((ls env)) + (cond + ((pair? ls) + (let lp2 ((ls2 (car ls)) (found? #f)) + (cond + ((null? ls2) + (if (not found?) (lp1 (cdr ls)))) + ((and (eq? id (caar ls2)) (eq? lam (cdar ls2))) + (lp2 (cdr ls2) #t)) + ((eq? sym (identifier->symbol (caar ls2))) + (rename! (caar ls2) (cdar ls2)) + (lp2 (cdr ls2) found?)) + (else + (lp2 (cdr ls2) found?))))))))) + (define (flatten-dot x) + (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) + ((null? x) x) + (else (list x)))) + (define (extend-env lam env) + (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env)) + (let lp ((x ast) (env '())) + (cond + ((lambda? x) (lp (lambda-body x) (extend-env x env))) + ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env)) + ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env)) + ((set? x) (lp (set-var x) env) (lp (set-value x) env)) + ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x))) + ((pair? x) (for-each (lambda (x) (lp x env)) x)))) + renames) + +(define (get-rename id lam renames) + (let ((ls (assq lam renames))) + (if (not ls) + (identifier->symbol id) + (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id)))))) + +(define (map* f ls) + (cond ((pair? ls) (cons (f (car ls)) (map* f (cdr ls)))) + ((null? ls) '()) + (else (f ls)))) + +(define (ast->sexp ast) + (let ((renames (ast-renames ast))) + (let a2s ((x ast)) + (cond + ((lambda? x) + `(lambda ,(map* (lambda (id) (get-rename id x renames)) (lambda-params x)) + ,@(map (lambda (d) `(define ,(identifier->symbol (caar d)) #f)) + (lambda-defs x)) + ,@(if (seq? (lambda-body x)) + (map a2s (seq-ls (lambda-body x))) + (list (a2s (lambda-body x)))))) + ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) + ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) + ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) + ((seq? x) `(begin ,@(map a2s (seq-ls x)))) + ((lit? x) + (let ((v (lit-value x))) + (if (or (pair? v) (null? v) (symbol? v)) `',v v))) + ((pair? x) (cons (a2s (car x)) (a2s (cdr x)))) + ((opcode? x) (or (opcode-name x) x)) + (else x))))) + From fb8e1cf441c9236344e63c776fc083aa32e6138f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 27 Jul 2010 00:07:22 +0900 Subject: [PATCH 475/535] opcode types are now general sexps --- eval.c | 4 +- include/chibi/sexp.h | 11 +- lib/chibi/ast.c | 59 ++++++++++ lib/chibi/ast.module | 5 +- opcodes.c | 268 ++++++++++++++++++++++--------------------- sexp.c | 2 +- 6 files changed, 206 insertions(+), 143 deletions(-) diff --git a/eval.c b/eval.c index 3c108113..1d7dfcbd 100644 --- a/eval.c +++ b/eval.c @@ -1317,8 +1317,8 @@ sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code, sexp_opcode_code(res) = sexp_unbox_fixnum(code); sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); - sexp_opcode_arg1_type(res) = sexp_unbox_fixnum(arg1t); - sexp_opcode_arg2_type(res) = sexp_unbox_fixnum(arg2t); + sexp_opcode_arg1_type(res) = arg1t; + sexp_opcode_arg2_type(res) = arg2t; sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); sexp_opcode_data(res) = data; sexp_opcode_data2(res) = data2; diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 1012870f..e4d806ad 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -204,10 +204,9 @@ struct sexp_type_struct { }; struct sexp_opcode_struct { - unsigned char op_class, code, num_args, flags, - arg1_type, arg2_type, inverse; + unsigned char op_class, code, num_args, flags, inverse; const char *name; - sexp data, data2, proc; + sexp data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type; sexp_proc1 func; }; @@ -683,13 +682,15 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #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_data2(x) ((x)->value.opcode.data2) #define sexp_opcode_proc(x) ((x)->value.opcode.proc) +#define sexp_opcode_return_type(x) ((x)->value.opcode.ret_type) +#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_arg3_type(x) ((x)->value.opcode.arg3_type) #define sexp_opcode_func(x) ((x)->value.opcode.func) #define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 3a0be629..c25c335c 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -45,6 +45,62 @@ static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { return sexp_intern(ctx, sexp_opcode_name(op), -1); } +static sexp sexp_translate_opcode_type (sexp ctx, sexp type) { + sexp_gc_var2(res, tmp); + res = type; + if (sexp_nullp(res)) { /* opcode list types */ + sexp_gc_preserve2(ctx, res, tmp); + tmp = sexp_intern(ctx, "or", -1); + res = sexp_cons(ctx, sexp_make_fixnum(SEXP_PAIR), SEXP_NULL); + res = sexp_cons(ctx, SEXP_NULL, res); + res = sexp_cons(ctx, tmp, res); + sexp_gc_release2(ctx); + } + return res; +} + +static sexp sexp_get_opcode_ret_type (sexp ctx sexp_api_params(self, n), sexp op) { + sexp res; + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + res = sexp_opcode_return_type(op); + if (sexp_fixnump(res)) + res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); + return sexp_translate_opcode_type(ctx, res); +} + +static sexp sexp_get_opcode_param_type (sexp ctx sexp_api_params(self, n), sexp op, sexp k) { + sexp res; + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + else if (! sexp_fixnump(k)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, k); + switch (sexp_unbox_fixnum(k)) { + case 0: + res = sexp_opcode_arg1_type(op); + break; + case 1: + res = sexp_opcode_arg2_type(op); + break; + default: + res = sexp_opcode_arg3_type(op); + if (sexp_vectorp(res)) { + if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2)) + res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO)); + else + res = sexp_type_by_index(ctx, 0); + } + break; + } + return sexp_translate_opcode_type(ctx, res); +} + +static sexp sexp_get_opcode_num_params (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + return sexp_make_fixnum(sexp_opcode_num_args(op)); +} + static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { sexp ctx2 = ctx; if (sexp_envp(e)) { @@ -116,6 +172,9 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + sexp_define_foreign(ctx, env, "opcode-num-params", 1, sexp_get_opcode_num_params); + sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type); + sexp_define_foreign(ctx, env, "opcode-param-type", 1, sexp_get_opcode_param_type); sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize); return SEXP_VOID; } diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index 53e7e0bb..e3bb83ba 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -1,9 +1,9 @@ (define-module (chibi ast) - (export analyze optimize env-cell opcode-name ast->sexp macroexpand + (export analyze optimize env-cell ast->sexp macroexpand lam cnd set ref seq lit pair-source pair-source-set! - syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? syntactic-closure-expr syntactic-closure-env syntactic-closure-vars lambda-name lambda-params lambda-body lambda-defs lambda-locals lambda-flags lambda-free-vars lambda-set-vars lambda-return-type @@ -17,6 +17,7 @@ set-var set-value set-var-set! set-value-set! ref-name ref-cell ref-name-set! ref-cell-set! seq-ls seq-ls-set! lit-value lit-value-set! + opcode-name opcode-num-params opcode-return-type opcode-param-type procedure-code procedure-vars procedure-name bytecode-name) (import-immutable (scheme)) (include-shared "ast") diff --git a/opcodes.c b/opcodes.c index 26622b55..ee549122 100644 --- a/opcodes.c +++ b/opcodes.c @@ -1,5 +1,6 @@ -#define _OP(c,o,n,m,t,u,i,s,d,f) {c, o, n, m, t, u, i, s, d, NULL, NULL, f} +#define _I(n) sexp_make_fixnum(n) +#define _OP(c,o,n,m,a1,a2,i,s,d,f) {c, o, n, m, i, s, d, NULL, NULL, _I(SEXP_OBJECT), a1, a2, SEXP_FALSE, f} #define _FN(o,n,m,t,u,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f) #define _FN0(s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, 0, 0, s, d, f) #define _FN1(t, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, t, 0, s, d, f) @@ -13,164 +14,165 @@ #define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, 0, 0, n, a, 0) static struct sexp_opcode_struct opcodes[] = { -_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), -_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), -_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), -_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF,2,0, SEXP_BYTES, SEXP_FIXNUM, 0,"byte-vector-ref", 0, NULL), -_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET,3,0, SEXP_BYTES, SEXP_FIXNUM, 0,"byte-vector-set!", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH,1,0, SEXP_BYTES, 0, 0,"byte-vector-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, _I(SEXP_PAIR), SEXP_FALSE, 0, "car", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, _I(SEXP_PAIR), _I(SEXP_OBJECT), 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, _I(SEXP_PAIR), SEXP_FALSE, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, _I(SEXP_PAIR), _I(SEXP_OBJECT), 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF, 2, 0, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET, 3, 0, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH, 1, 0, _I(SEXP_VECTOR), SEXP_FALSE, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF, 2, 0, _I(SEXP_BYTES), _I(SEXP_FIXNUM), 0,"byte-vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET, 3, 0, _I(SEXP_BYTES), _I(SEXP_FIXNUM), 0,"byte-vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH, 1, 0, _I(SEXP_BYTES), SEXP_FALSE, 0,"byte-vector-length", 0, NULL), #if SEXP_USE_UTF8_STRINGS -_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-cursor-ref", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_STRING), _I(SEXP_FIXNUM), 0,"string-cursor-ref", 0, NULL), #else -_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_STRING), _I(SEXP_FIXNUM), 0,"string-ref", 0, NULL), #endif #if SEXP_USE_MUTABLE_STRINGS #if SEXP_USE_UTF8_STRINGS -_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-cursor-set!", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, _I(SEXP_STRING), _I(SEXP_FIXNUM), 0,"string-cursor-set!", 0, NULL), #else -_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, _I(SEXP_STRING), _I(SEXP_FIXNUM), 0,"string-set!", 0, NULL), #endif #endif -_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF,3,0, 0, SEXP_FIXNUM, 0,"slot-ref", 0, NULL), -_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET,4,0, 0, SEXP_FIXNUM, 0,"slot-set!", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", SEXP_ZERO, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", SEXP_ONE, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, SEXP_FIXNUM, 0, 1, "-", SEXP_ZERO, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 1, 1, SEXP_FIXNUM, 0, 1, "/", SEXP_ONE, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), -_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), -_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), -_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), -_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), -_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA, 2, 0, 0, 0, 0, "is-a?", NULL, 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0), +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH, 1, 0, _I(SEXP_STRING), SEXP_FALSE, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, _I(SEXP_NUMBER), SEXP_FALSE, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, _I(SEXP_NUMBER), SEXP_FALSE, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_CHAR), SEXP_FALSE, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, _I(SEXP_FIXNUM), SEXP_FALSE, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, _I(SEXP_CHAR), SEXP_FALSE, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, _I(SEXP_CHAR), SEXP_FALSE, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 0, "+", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 0, "*", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 1, "-", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 1, "/", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, _I(SEXP_FIXNUM), _I(SEXP_OBJECT), 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA, 2, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "is-a?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "pair?", _I(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "string?", _I(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "vector?", _I(_I(SEXP_VECTOR)), 0), #if SEXP_USE_IMMEDIATE_FLONUMS -_FN1(0, "flonum?", 0, sexp_flonump_op), +_FN1(_I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op), #else -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "flonum?", _I(SEXP_FLONUM), 0), #endif -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0), -_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "%call/cc", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), -_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), -_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), -_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), -_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), -_FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read_op), -_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write_op), -_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display_op), -_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op), -_FN2(0, 0, "equal?", 0, sexp_equalp_op), -_FN1(0, "list?", 0, sexp_listp_op), -_FN1(0, "identifier?", 0, sexp_identifierp_op), -_FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr_op), -_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq_op), -_FN1(SEXP_PAIR, "length", 0, sexp_length_op), -_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse_op), -_FN1(SEXP_PAIR, "reverse!", 0, sexp_nreverse_op), -_FN2(SEXP_PAIR, SEXP_PAIR, "append2", 0, sexp_append2_op), -_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector_op), -_FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file_op), -_FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file_op), -_FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port_op), -_FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port_op), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "bignum?", _I(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "closure?", _I(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "opcode?", _I(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "input-port?", _I(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "output-port?", _I(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, _I(SEXP_PROCEDURE), SEXP_NULL, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_PROCEDURE), SEXP_FALSE, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, _I(SEXP_CHAR), _I(SEXP_OPORT), 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, _I(SEXP_OPORT), SEXP_FALSE, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_IPORT), SEXP_FALSE, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_IPORT), SEXP_FALSE, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_FN1OPTP(_I(SEXP_IPORT), "read", (sexp)"*current-input-port*", sexp_read_op), +_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"*current-output-port*", sexp_write_op), +_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"*current-output-port*", sexp_display_op), +_FN1OPTP(_I(SEXP_OPORT), "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op), +_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op), +_FN1(_I(SEXP_OBJECT), "list?", 0, sexp_listp_op), +_FN1(_I(SEXP_OBJECT), "identifier?", 0, sexp_identifierp_op), +_FN1(_I(SEXP_OBJECT), "identifier->symbol", 0, sexp_syntactic_closure_expr_op), +_FN4(_I(SEXP_OBJECT), _I(SEXP_ENV), "identifier=?", 0, sexp_identifier_eq_op), +_FN1(SEXP_NULL, "length", 0, sexp_length_op), +_FN1(SEXP_NULL, "reverse", 0, sexp_reverse_op), +_FN1(SEXP_NULL, "reverse!", 0, sexp_nreverse_op), +_FN2(SEXP_NULL, SEXP_NULL, "append2", 0, sexp_append2_op), +_FN1(SEXP_NULL, "list->vector", 0, sexp_list_to_vector_op), +_FN1(_I(SEXP_STRING), "open-input-file", 0, sexp_open_input_file_op), +_FN1(_I(SEXP_STRING), "open-output-file", 0, sexp_open_output_file_op), +_FN1(_I(SEXP_IPORT), "close-input-port", 0, sexp_close_port_op), +_FN1(_I(SEXP_OPORT), "close-output-port", 0, sexp_close_port_op), _FN0("make-environment", 0, sexp_make_env_op), -_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env_op), -_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env_op), -_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval_op), -_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load_op), -_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy_op), -_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception_op), -_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_op), -_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string_op), -_FN2OPT(SEXP_FIXNUM, SEXP_FIXNUM, "make-byte-vector", SEXP_ZERO, sexp_make_bytes_op), -_FN2OPT(SEXP_FIXNUM, SEXP_FIXNUM, "string->number", SEXP_TEN, sexp_string_to_number_op), -_FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp_op), -_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring_op), -_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol_op), -_FN2OPT(SEXP_PAIR, SEXP_STRING, "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op), -_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq_op), -_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq_op), -_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo_op), -_FN1(0, "strip-syntactic-closures", 0, sexp_strip_synclos), -_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), +_FN1(_I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op), +_FN1(_I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op), +_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_ENV), "eval", (sexp)"*interaction-environment*", sexp_eval_op), +_FN2OPTP(_I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"*interaction-environment*", sexp_load_op), +_FN4(_I(SEXP_ENV), _I(SEXP_ENV), "%env-copy!", 0, sexp_env_copy_op), +_FN2(_I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op), +_FN1(_I(SEXP_EXCEPTION), "exception-type", 0, sexp_exception_type_op), +_FN2OPT(_I(SEXP_FIXNUM), _I(SEXP_CHAR), "make-string", sexp_make_character(' '), sexp_make_string_op), +_FN2OPT(_I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-byte-vector", SEXP_ZERO, sexp_make_bytes_op), +_FN2OPT(_I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "string->number", SEXP_TEN, sexp_string_to_number_op), +_FN3(_I(SEXP_STRING), _I(SEXP_STRING), "string-cmp", 0, sexp_string_cmp_op), +_FN3(_I(SEXP_STRING), _I(SEXP_FIXNUM), "substring", 0, sexp_substring_op), +_FN1(_I(SEXP_STRING), "string->symbol", 0, sexp_string_to_symbol_op), +_FN2OPT(SEXP_NULL, _I(SEXP_STRING), "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op), +_FN2(_I(SEXP_OBJECT), SEXP_NULL, "memq", 0, sexp_memq_op), +_FN2(_I(SEXP_OBJECT), SEXP_NULL, "assq", 0, sexp_assq_op), +_FN3(_I(SEXP_ENV), SEXP_NULL, "make-syntactic-closure", 0, sexp_make_synclo_op), +_FN1(_I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip_synclos), +_PARAM("current-input-port", (sexp)"*current-input-port*", _I(SEXP_IPORT)), +_PARAM("current-output-port", (sexp)"*current-output-port*", _I(SEXP_OPORT)), +_PARAM("current-error-port", (sexp)"*current-error-port*", _I(SEXP_OPORT)), +_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", _I(SEXP_PROCEDURE)), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", _I(SEXP_ENV)), _FN0("open-output-string", 0, sexp_make_output_string_port_op), -_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port_op), -_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string_op), +_FN1(_I(SEXP_STRING), "open-input-string", 0, sexp_make_input_string_port_op), +_FN1(_I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op), #if SEXP_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), +_FN1(_I(SEXP_NUMBER), "exp", 0, sexp_exp), +_FN1(_I(SEXP_NUMBER), "log", 0, sexp_log), +_FN1(_I(SEXP_NUMBER), "sin", 0, sexp_sin), +_FN1(_I(SEXP_NUMBER), "cos", 0, sexp_cos), +_FN1(_I(SEXP_NUMBER), "tan", 0, sexp_tan), +_FN1(_I(SEXP_NUMBER), "asin", 0, sexp_asin), +_FN1(_I(SEXP_NUMBER), "acos", 0, sexp_acos), +_FN1(_I(SEXP_NUMBER), "atan1", 0, sexp_atan), +_FN1(_I(SEXP_NUMBER), "sqrt", 0, sexp_sqrt), +_FN1(_I(SEXP_NUMBER), "round", 0, sexp_round), +_FN1(_I(SEXP_NUMBER), "truncate", 0, sexp_trunc), +_FN1(_I(SEXP_NUMBER), "floor", 0, sexp_floor), +_FN1(_I(SEXP_NUMBER), "ceiling", 0, sexp_ceiling), #endif -_FN2(0, 0, "expt", 0, sexp_expt_op), +_FN2(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "expt", 0, sexp_expt_op), #if SEXP_USE_UTF8_STRINGS -_FN2(SEXP_STRING, SEXP_FIXNUM, "string-index->offset", 0, sexp_string_index_to_offset), -_FN2(SEXP_STRING, SEXP_FIXNUM, "string-ref", 0, sexp_string_utf8_index_ref), -_FN3(SEXP_STRING, SEXP_FIXNUM, "string-set!", 0, sexp_string_utf8_index_set), +_FN2(_I(SEXP_STRING), _I(SEXP_FIXNUM), "string-index->offset", 0, sexp_string_index_to_offset), +_FN2(_I(SEXP_STRING), _I(SEXP_FIXNUM), "string-ref", 0, sexp_string_utf8_index_ref), +_FN3(_I(SEXP_STRING), _I(SEXP_FIXNUM), "string-set!", 0, sexp_string_utf8_index_set), #endif #if SEXP_USE_TYPE_DEFS -_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type_op), -_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate_op), -_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor_op), -_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter_op), -_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter_op), +_FN2(_I(SEXP_STRING), _I(SEXP_FIXNUM), "register-simple-type", 0, sexp_register_simple_type_op), +_FN2(_I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0, sexp_make_type_predicate_op), +_FN2(_I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op), +_FN3(_I(SEXP_STRING), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op), +_FN3(_I(SEXP_STRING), _I(SEXP_FIXNUM), "make-setter", 0, sexp_make_setter_op), #endif #if PLAN9 #include "opt/plan9-opcodes.c" #endif #if SEXP_USE_MODULES _FN0("current-environment", 0, sexp_current_environment), -_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports_op), -_FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), -_FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), -_FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory_op), +_FN1(_I(SEXP_ENV), "env-exports", 0, sexp_env_exports_op), +_FN1(_I(SEXP_STRING), "find-module-file", 0, sexp_find_module_file_op), +_FN2(_I(SEXP_STRING), _I(SEXP_ENV), "load-module-file", 0, sexp_load_module_file_op), +_FN2(_I(SEXP_STRING), _I(SEXP_BOOLEAN), "add-module-directory", 0, sexp_add_module_directory_op), #endif #if SEXP_USE_GREEN_THREADS -_OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, 0, 0, 0, "thread-yield!", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, SEXP_FALSE, SEXP_FALSE, 0, "thread-yield!", 0, NULL), #endif }; +#undef _I diff --git a/sexp.c b/sexp.c index 3e64553e..b297cd7e 100644 --- a/sexp.c +++ b/sexp.c @@ -106,7 +106,7 @@ static struct sexp_type_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, "environment", NULL), _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode", NULL), _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form", NULL), - _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode", NULL), + _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 7, 7, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode", NULL), _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda", NULL), _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional", NULL), _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, "reference", NULL), From e0cb8fd076995678fb364556846642d6f1eba8f5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 27 Jul 2010 00:24:37 +0900 Subject: [PATCH 476/535] fixing typo in new opcodes.c --- lib/chibi/ast.c | 6 ++++-- opcodes.c | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index c25c335c..a1ece368 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -48,7 +48,9 @@ static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { static sexp sexp_translate_opcode_type (sexp ctx, sexp type) { sexp_gc_var2(res, tmp); res = type; - if (sexp_nullp(res)) { /* opcode list types */ + if (sexp_fixnump(res)) { + res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); + } else if (sexp_nullp(res)) { /* opcode list types */ sexp_gc_preserve2(ctx, res, tmp); tmp = sexp_intern(ctx, "or", -1); res = sexp_cons(ctx, sexp_make_fixnum(SEXP_PAIR), SEXP_NULL); @@ -174,7 +176,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); sexp_define_foreign(ctx, env, "opcode-num-params", 1, sexp_get_opcode_num_params); sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type); - sexp_define_foreign(ctx, env, "opcode-param-type", 1, sexp_get_opcode_param_type); + sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type); sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize); return SEXP_VOID; } diff --git a/opcodes.c b/opcodes.c index ee549122..6b0e5b40 100644 --- a/opcodes.c +++ b/opcodes.c @@ -69,7 +69,7 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "fixnum?", NULL, 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "pair?", _I(SEXP_PAIR), 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "string?", _I(SEXP_STRING), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "vector?", _I(_I(SEXP_VECTOR)), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "vector?", _I(SEXP_VECTOR), 0), #if SEXP_USE_IMMEDIATE_FLONUMS _FN1(_I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op), #else From 2ed2f865fd227939f53f85bbd138e9809819458f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 27 Jul 2010 08:02:02 +0900 Subject: [PATCH 477/535] adding name to type printed representation --- sexp.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/sexp.c b/sexp.c index b297cd7e..2242f734 100644 --- a/sexp.c +++ b/sexp.c @@ -1195,16 +1195,21 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { break; #endif case SEXP_PROCEDURE: - sexp_write_string(ctx, "#", out); break; case SEXP_SYNCLO: - sexp_write_string(ctx, "#", out); break; + case SEXP_TYPE: + sexp_write_string(ctx, "#", out); + break; case SEXP_STRING: sexp_write_char(ctx, '"', out); i = sexp_string_length(obj); From 68e55705a2839b8a15763d46c0e1773700cfa102 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 27 Jul 2010 11:13:17 +0000 Subject: [PATCH 478/535] adding return types to standard opcodes --- opcodes.c | 286 +++++++++++++++++++++++++++--------------------------- 1 file changed, 143 insertions(+), 143 deletions(-) diff --git a/opcodes.c b/opcodes.c index 6b0e5b40..34505644 100644 --- a/opcodes.c +++ b/opcodes.c @@ -1,178 +1,178 @@ #define _I(n) sexp_make_fixnum(n) -#define _OP(c,o,n,m,a1,a2,i,s,d,f) {c, o, n, m, i, s, d, NULL, NULL, _I(SEXP_OBJECT), a1, a2, SEXP_FALSE, f} -#define _FN(o,n,m,t,u,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f) -#define _FN0(s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, 0, 0, s, d, f) -#define _FN1(t, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, t, 0, s, d, f) -#define _FN1OPT(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, t, u, s, d, f) -#define _FN1OPTP(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, t, 0, s, d, f) -#define _FN2(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, t, u, s, d, f) -#define _FN2OPT(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, t, u, s, d, f) -#define _FN2OPTP(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, t, u, s, d, f) -#define _FN3(t, u, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, t, u, s, d, f) -#define _FN4(t, u, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, t, u, s, d, f) -#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, 0, 0, n, a, 0) +#define _OP(c,o,n,m,rt,a1,a2,a3,i,s,d,f) {c, o, n, m, i, s, d, NULL, NULL, rt, a1, a2, a3, f} +#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, rt, a1, a2, a3, 0, s, d, (sexp_proc1)f) +#define _FN0(rt, s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, rt, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1OPT(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1OPTP(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN2(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN2OPT(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN2OPTP(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN3(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, rt, a1, a2, a3, s, d, f) +#define _FN4(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, rt, a1, a2, a3, s, d, f) +#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, t, SEXP_FALSE, SEXP_FALSE, 0, n, a, 0) static struct sexp_opcode_struct opcodes[] = { -_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, _I(SEXP_PAIR), SEXP_FALSE, 0, "car", 0, NULL), -_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, _I(SEXP_PAIR), _I(SEXP_OBJECT), 0, "set-car!", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, _I(SEXP_PAIR), SEXP_FALSE, 0, "cdr", 0, NULL), -_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, _I(SEXP_PAIR), _I(SEXP_OBJECT), 0, "set-cdr!", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF, 2, 0, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), 0,"vector-ref", 0, NULL), -_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET, 3, 0, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), 0,"vector-set!", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH, 1, 0, _I(SEXP_VECTOR), SEXP_FALSE, 0,"vector-length", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF, 2, 0, _I(SEXP_BYTES), _I(SEXP_FIXNUM), 0,"byte-vector-ref", 0, NULL), -_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET, 3, 0, _I(SEXP_BYTES), _I(SEXP_FIXNUM), 0,"byte-vector-set!", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH, 1, 0, _I(SEXP_BYTES), SEXP_FALSE, 0,"byte-vector-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "car", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF, 2, 0, _I(SEXP_OBJECT), _I(SEXP_VECTOR), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET, 3, 0, SEXP_VOID, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_VECTOR), SEXP_FALSE, SEXP_FALSE, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"byte-vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET, 3, 0, SEXP_VOID, _I(SEXP_BYTES), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0,"byte-vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), SEXP_FALSE, SEXP_FALSE, 0,"byte-vector-length", 0, NULL), #if SEXP_USE_UTF8_STRINGS -_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_STRING), _I(SEXP_FIXNUM), 0,"string-cursor-ref", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-cursor-ref", 0, NULL), #else -_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_STRING), _I(SEXP_FIXNUM), 0,"string-ref", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-ref", 0, NULL), #endif #if SEXP_USE_MUTABLE_STRINGS #if SEXP_USE_UTF8_STRINGS -_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, _I(SEXP_STRING), _I(SEXP_FIXNUM), 0,"string-cursor-set!", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), 0,"string-cursor-set!", 0, NULL), #else -_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, _I(SEXP_STRING), _I(SEXP_FIXNUM), 0,"string-set!", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), 0,"string-set!", 0, NULL), #endif #endif -_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH, 1, 0, _I(SEXP_STRING), SEXP_FALSE, 0,"string-length", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL), -_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, _I(SEXP_NUMBER), SEXP_FALSE, 0, "exact->inexact", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, _I(SEXP_NUMBER), SEXP_FALSE, 0, "inexact->exact", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_CHAR), SEXP_FALSE, 0, "char->integer", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, _I(SEXP_FIXNUM), SEXP_FALSE, 0, "integer->char", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, _I(SEXP_CHAR), SEXP_FALSE, 0, "char-upcase", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, _I(SEXP_CHAR), SEXP_FALSE, 0, "char-downcase", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 0, "+", SEXP_ZERO, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 0, "*", SEXP_ONE, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 1, "-", SEXP_ZERO, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 1, "/", SEXP_ONE, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0, "quotient", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0, "remainder", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 0, "<", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 0, "<=", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 1, ">", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 1, ">=", 0, NULL), -_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), 0, "=", 0, NULL), -_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "eq?", 0, NULL), -_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "cons", 0, NULL), -_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, _I(SEXP_FIXNUM), _I(SEXP_OBJECT), 0, "make-vector", SEXP_VOID, NULL), -_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0, "make-procedure", 0, NULL), -_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "make-exception", 0, NULL), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA, 2, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "is-a?", NULL, 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "null?", NULL, 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "eof-object?", NULL, 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "symbol?", NULL, 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "char?", NULL, 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "fixnum?", NULL, 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "pair?", _I(SEXP_PAIR), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "string?", _I(SEXP_STRING), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "vector?", _I(SEXP_VECTOR), 0), +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), SEXP_FALSE, SEXP_FALSE, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, _I(SEXP_FLONUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, _I(SEXP_CHAR), _I(SEXP_FIXNUM), SEXP_FALSE, SEXP_FALSE, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "+", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "*", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "-", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "/", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, _I(SEXP_PAIR), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), SEXP_FALSE, 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, _I(SEXP_PROCEDURE), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_BYTECODE), 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, _I(SEXP_EXCEPTION), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA, 2, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "is-a?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "pair?", _I(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "string?", _I(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "vector?", _I(SEXP_VECTOR), 0), #if SEXP_USE_IMMEDIATE_FLONUMS -_FN1(_I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op), +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op), #else -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "flonum?", _I(SEXP_FLONUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "flonum?", _I(SEXP_FLONUM), 0), #endif -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "bignum?", _I(SEXP_BIGNUM), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "closure?", _I(SEXP_PROCEDURE), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "opcode?", _I(SEXP_OPCODE), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "input-port?", _I(SEXP_IPORT), 0), -_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "output-port?", _I(SEXP_OPORT), 0), -_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, _I(SEXP_PROCEDURE), SEXP_NULL, 0, "apply1", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_PROCEDURE), SEXP_FALSE, 0, "%call/cc", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), SEXP_FALSE, 0, "raise", 0, NULL), -_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, _I(SEXP_CHAR), _I(SEXP_OPORT), 0, "write-char", (sexp)"*current-output-port*", NULL), -_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, _I(SEXP_OPORT), SEXP_FALSE, 0, "newline", (sexp)"*current-output-port*", NULL), -_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_IPORT), SEXP_FALSE, 0, "read-char", (sexp)"*current-input-port*", NULL), -_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_IPORT), SEXP_FALSE, 0, "peek-char", (sexp)"*current-input-port*", NULL), -_FN1OPTP(_I(SEXP_IPORT), "read", (sexp)"*current-input-port*", sexp_read_op), -_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"*current-output-port*", sexp_write_op), -_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"*current-output-port*", sexp_display_op), -_FN1OPTP(_I(SEXP_OPORT), "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op), -_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op), -_FN1(_I(SEXP_OBJECT), "list?", 0, sexp_listp_op), -_FN1(_I(SEXP_OBJECT), "identifier?", 0, sexp_identifierp_op), -_FN1(_I(SEXP_OBJECT), "identifier->symbol", 0, sexp_syntactic_closure_expr_op), -_FN4(_I(SEXP_OBJECT), _I(SEXP_ENV), "identifier=?", 0, sexp_identifier_eq_op), -_FN1(SEXP_NULL, "length", 0, sexp_length_op), -_FN1(SEXP_NULL, "reverse", 0, sexp_reverse_op), -_FN1(SEXP_NULL, "reverse!", 0, sexp_nreverse_op), -_FN2(SEXP_NULL, SEXP_NULL, "append2", 0, sexp_append2_op), -_FN1(SEXP_NULL, "list->vector", 0, sexp_list_to_vector_op), -_FN1(_I(SEXP_STRING), "open-input-file", 0, sexp_open_input_file_op), -_FN1(_I(SEXP_STRING), "open-output-file", 0, sexp_open_output_file_op), -_FN1(_I(SEXP_IPORT), "close-input-port", 0, sexp_close_port_op), -_FN1(_I(SEXP_OPORT), "close-output-port", 0, sexp_close_port_op), -_FN0("make-environment", 0, sexp_make_env_op), -_FN1(_I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op), -_FN1(_I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op), -_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_ENV), "eval", (sexp)"*interaction-environment*", sexp_eval_op), -_FN2OPTP(_I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"*interaction-environment*", sexp_load_op), -_FN4(_I(SEXP_ENV), _I(SEXP_ENV), "%env-copy!", 0, sexp_env_copy_op), -_FN2(_I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op), -_FN1(_I(SEXP_EXCEPTION), "exception-type", 0, sexp_exception_type_op), -_FN2OPT(_I(SEXP_FIXNUM), _I(SEXP_CHAR), "make-string", sexp_make_character(' '), sexp_make_string_op), -_FN2OPT(_I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-byte-vector", SEXP_ZERO, sexp_make_bytes_op), -_FN2OPT(_I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "string->number", SEXP_TEN, sexp_string_to_number_op), -_FN3(_I(SEXP_STRING), _I(SEXP_STRING), "string-cmp", 0, sexp_string_cmp_op), -_FN3(_I(SEXP_STRING), _I(SEXP_FIXNUM), "substring", 0, sexp_substring_op), -_FN1(_I(SEXP_STRING), "string->symbol", 0, sexp_string_to_symbol_op), -_FN2OPT(SEXP_NULL, _I(SEXP_STRING), "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op), -_FN2(_I(SEXP_OBJECT), SEXP_NULL, "memq", 0, sexp_memq_op), -_FN2(_I(SEXP_OBJECT), SEXP_NULL, "assq", 0, sexp_assq_op), -_FN3(_I(SEXP_ENV), SEXP_NULL, "make-syntactic-closure", 0, sexp_make_synclo_op), -_FN1(_I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip_synclos), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "bignum?", _I(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "closure?", _I(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "opcode?", _I(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "input-port?", _I(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "output-port?", _I(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), SEXP_FALSE, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, SEXP_VOID, _I(SEXP_OPORT), SEXP_FALSE, SEXP_FALSE, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_FN1OPTP(_I(SEXP_OBJECT), _I(SEXP_IPORT), "read", (sexp)"*current-input-port*", sexp_read_op), +_FN2OPTP(SEXP_VOID,_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"*current-output-port*", sexp_write_op), +_FN2OPTP(SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"*current-output-port*", sexp_display_op), +_FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op), +_FN2(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op), +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "list?", 0, sexp_listp_op), +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "identifier?", 0, sexp_identifierp_op), +_FN1(_I(SEXP_SYMBOL), _I(SEXP_OBJECT), "identifier->symbol", 0, sexp_syntactic_closure_expr_op), +_FN4(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_ENV), _I(SEXP_OBJECT), "identifier=?", 0, sexp_identifier_eq_op), +_FN1(_I(SEXP_FIXNUM), SEXP_NULL, "length", 0, sexp_length_op), +_FN1(SEXP_NULL, SEXP_NULL, "reverse", 0, sexp_reverse_op), +_FN1(SEXP_NULL, SEXP_NULL, "reverse!", 0, sexp_nreverse_op), +_FN2(SEXP_NULL, SEXP_NULL, SEXP_NULL, "append2", 0, sexp_append2_op), +_FN1(_I(SEXP_VECTOR), SEXP_NULL, "list->vector", 0, sexp_list_to_vector_op), +_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-file", 0, sexp_open_input_file_op), +_FN1(_I(SEXP_OPORT), _I(SEXP_STRING), "open-output-file", 0, sexp_open_output_file_op), +_FN1(SEXP_VOID, _I(SEXP_IPORT), "close-input-port", 0, sexp_close_port_op), +_FN1(SEXP_VOID, _I(SEXP_OPORT), "close-output-port", 0, sexp_close_port_op), +_FN0(_I(SEXP_ENV), "make-environment", 0, sexp_make_env_op), +_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op), +_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op), +_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "eval", (sexp)"*interaction-environment*", sexp_eval_op), +_FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"*interaction-environment*", sexp_load_op), +_FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%env-copy!", 0, sexp_env_copy_op), +_FN2(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op), +_FN1(_I(SEXP_OBJECT), _I(SEXP_EXCEPTION), "exception-type", 0, sexp_exception_type_op), +_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "make-string", sexp_make_character(' '), sexp_make_string_op), +_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-byte-vector", SEXP_ZERO, sexp_make_bytes_op), +_FN2OPT(_I(SEXP_NUMBER), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string->number", SEXP_TEN, sexp_string_to_number_op), +_FN3(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_BOOLEAN), "string-cmp", 0, sexp_string_cmp_op), +_FN3(_I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "substring", 0, sexp_substring_op), +_FN1(_I(SEXP_SYMBOL), _I(SEXP_STRING), "string->symbol", 0, sexp_string_to_symbol_op), +_FN2OPT(_I(SEXP_STRING), SEXP_NULL, _I(SEXP_STRING), "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op), +_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "memq", 0, sexp_memq_op), +_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "assq", 0, sexp_assq_op), +_FN3(_I(SEXP_SYNCLO), _I(SEXP_ENV), SEXP_NULL, _I(SEXP_OBJECT), "make-syntactic-closure", 0, sexp_make_synclo_op), +_FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip_synclos), _PARAM("current-input-port", (sexp)"*current-input-port*", _I(SEXP_IPORT)), _PARAM("current-output-port", (sexp)"*current-output-port*", _I(SEXP_OPORT)), _PARAM("current-error-port", (sexp)"*current-error-port*", _I(SEXP_OPORT)), _PARAM("current-exception-handler", (sexp)"*current-exception-handler*", _I(SEXP_PROCEDURE)), _PARAM("interaction-environment", (sexp)"*interaction-environment*", _I(SEXP_ENV)), -_FN0("open-output-string", 0, sexp_make_output_string_port_op), -_FN1(_I(SEXP_STRING), "open-input-string", 0, sexp_make_input_string_port_op), -_FN1(_I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op), +_FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_make_output_string_port_op), +_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_make_input_string_port_op), +_FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op), #if SEXP_USE_MATH -_FN1(_I(SEXP_NUMBER), "exp", 0, sexp_exp), -_FN1(_I(SEXP_NUMBER), "log", 0, sexp_log), -_FN1(_I(SEXP_NUMBER), "sin", 0, sexp_sin), -_FN1(_I(SEXP_NUMBER), "cos", 0, sexp_cos), -_FN1(_I(SEXP_NUMBER), "tan", 0, sexp_tan), -_FN1(_I(SEXP_NUMBER), "asin", 0, sexp_asin), -_FN1(_I(SEXP_NUMBER), "acos", 0, sexp_acos), -_FN1(_I(SEXP_NUMBER), "atan1", 0, sexp_atan), -_FN1(_I(SEXP_NUMBER), "sqrt", 0, sexp_sqrt), -_FN1(_I(SEXP_NUMBER), "round", 0, sexp_round), -_FN1(_I(SEXP_NUMBER), "truncate", 0, sexp_trunc), -_FN1(_I(SEXP_NUMBER), "floor", 0, sexp_floor), -_FN1(_I(SEXP_NUMBER), "ceiling", 0, sexp_ceiling), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "exp", 0, sexp_exp), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "log", 0, sexp_log), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sin", 0, sexp_sin), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "cos", 0, sexp_cos), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "tan", 0, sexp_tan), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "asin", 0, sexp_asin), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "acos", 0, sexp_acos), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "atan1", 0, sexp_atan), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sqrt", 0, sexp_sqrt), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "round", 0, sexp_round), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "truncate", 0, sexp_trunc), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "floor", 0, sexp_floor), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "ceiling", 0, sexp_ceiling), #endif -_FN2(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "expt", 0, sexp_expt_op), +_FN2(_I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), "expt", 0, sexp_expt_op), #if SEXP_USE_UTF8_STRINGS -_FN2(_I(SEXP_STRING), _I(SEXP_FIXNUM), "string-index->offset", 0, sexp_string_index_to_offset), -_FN2(_I(SEXP_STRING), _I(SEXP_FIXNUM), "string-ref", 0, sexp_string_utf8_index_ref), -_FN3(_I(SEXP_STRING), _I(SEXP_FIXNUM), "string-set!", 0, sexp_string_utf8_index_set), +_FN2(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-index->offset", 0, sexp_string_index_to_offset), +_FN2(_I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-ref", 0, sexp_string_utf8_index_ref), +_FN3(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "string-set!", 0, sexp_string_utf8_index_set), #endif #if SEXP_USE_TYPE_DEFS -_FN2(_I(SEXP_STRING), _I(SEXP_FIXNUM), "register-simple-type", 0, sexp_register_simple_type_op), -_FN2(_I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0, sexp_make_type_predicate_op), -_FN2(_I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op), -_FN3(_I(SEXP_STRING), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op), -_FN3(_I(SEXP_STRING), _I(SEXP_FIXNUM), "make-setter", 0, sexp_make_setter_op), +_FN2(_I(SEXP_TYPE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "register-simple-type", 0, sexp_register_simple_type_op), +_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0, sexp_make_type_predicate_op), +_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op), +_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op), +_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-setter", 0, sexp_make_setter_op), #endif #if PLAN9 #include "opt/plan9-opcodes.c" #endif #if SEXP_USE_MODULES -_FN0("current-environment", 0, sexp_current_environment), -_FN1(_I(SEXP_ENV), "env-exports", 0, sexp_env_exports_op), -_FN1(_I(SEXP_STRING), "find-module-file", 0, sexp_find_module_file_op), -_FN2(_I(SEXP_STRING), _I(SEXP_ENV), "load-module-file", 0, sexp_load_module_file_op), -_FN2(_I(SEXP_STRING), _I(SEXP_BOOLEAN), "add-module-directory", 0, sexp_add_module_directory_op), +_FN0(_I(SEXP_ENV), "current-environment", 0, sexp_current_environment), +_FN1(SEXP_NULL, _I(SEXP_ENV), "env-exports", 0, sexp_env_exports_op), +_FN1(_I(SEXP_STRING), _I(SEXP_STRING), "find-module-file", 0, sexp_find_module_file_op), +_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load-module-file", 0, sexp_load_module_file_op), +_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_BOOLEAN), "add-module-directory", 0, sexp_add_module_directory_op), #endif #if SEXP_USE_GREEN_THREADS -_OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, SEXP_FALSE, SEXP_FALSE, 0, "thread-yield!", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, SEXP_VOID, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, 0, "thread-yield!", 0, NULL), #endif }; -#undef _I + From 1c8f8a6b3d5624511e549e10b8a1c5856a125e7d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 29 Jul 2010 08:16:06 +0900 Subject: [PATCH 479/535] ast/module updates --- eval.c | 2 ++ include/chibi/sexp.h | 2 +- lib/chibi/ast.c | 1 + lib/chibi/ast.module | 2 +- lib/chibi/modules.scm | 25 +++++++++++++++++++++---- 5 files changed, 26 insertions(+), 6 deletions(-) diff --git a/eval.c b/eval.c index 1d7dfcbd..db81b9b0 100644 --- a/eval.c +++ b/eval.c @@ -269,6 +269,8 @@ static sexp sexp_make_lambda (sexp ctx, sexp params) { sexp_lambda_sv(res) = SEXP_NULL; sexp_lambda_locals(res) = SEXP_NULL; sexp_lambda_defs(res) = SEXP_NULL; + sexp_lambda_return_type(res) = SEXP_FALSE; + sexp_lambda_param_types(res) = SEXP_NULL; return res; } diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index e4d806ad..11d9e0f7 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1046,7 +1046,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) #define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) -#define sexp_make_setter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_make_setter(ctx, a, b, c) sexp_make_setter_op(ctx sexp_api_pass(NULL, 3), a, b, c) #ifdef __cplusplus } /* extern "C" */ diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index a1ece368..c3b5bbe7 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -128,6 +128,7 @@ static sexp sexp_optimize (sexp ctx sexp_api_params(self, n), sexp x) { sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag)); sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_type(ctx, "object", SEXP_OBJECT); sexp_define_type(ctx, "lam", SEXP_LAMBDA); sexp_define_type(ctx, "cnd", SEXP_CND); sexp_define_type(ctx, "set", SEXP_SET); diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index e3bb83ba..e349bff3 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -1,7 +1,7 @@ (define-module (chibi ast) (export analyze optimize env-cell ast->sexp macroexpand - lam cnd set ref seq lit + object lam cnd set ref seq lit pair-source pair-source-set! syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? syntactic-closure-expr syntactic-closure-env syntactic-closure-vars diff --git a/lib/chibi/modules.scm b/lib/chibi/modules.scm index 3e85d40c..b9e40e0d 100644 --- a/lib/chibi/modules.scm +++ b/lib/chibi/modules.scm @@ -65,14 +65,31 @@ (and (env-cell (module-env (if (module? mod) mod (load-module mod))) var-name) #t)) +(define (module-defines? name mod var-name) + (if (not (module-ast mod)) + (module-ast-set! mod (analyze-module-source name mod #f))) + (let lp ((ls (module-ast mod))) + (and (pair? ls) + (or (and (set? (car ls)) + (eq? var-name (ref-name (set-var (car ls)))) + (begin + ;; (write `(found ,var-name in ,name ,(ast->sexp (car ls))) (current-error-port)) + ;; (newline (current-error-port)) + #t)) + (lp (cdr ls)))))) + (define (containing-module x) - (let lp1 ((ls *modules*)) + (let lp1 ((ls (reverse *modules*))) (and (pair? ls) (let ((env (module-env (cdar ls)))) (let lp2 ((e-ls (env-exports env))) - (cond ((null? e-ls) (lp1 (cdr ls))) - ((eq? x (cdr (env-cell env (car e-ls)))) (car ls)) - (else (lp2 (cdr e-ls))))))))) + (if (null? e-ls) + (lp1 (cdr ls)) + (let ((cell (env-cell env (car e-ls)))) + (if (and (eq? x (cdr cell)) + (module-defines? (caar ls) (cdar ls) (car cell))) + (car ls) + (lp2 (cdr e-ls)))))))))) (define (procedure-analysis x) (let ((mod (containing-module x))) From dcb56aa08506d0c3bffa089f700ef0cfb2f9b79e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 29 Jul 2010 12:43:40 +0000 Subject: [PATCH 480/535] adding more types to ast --- lib/chibi/ast.c | 18 +++++++++++++++++- lib/chibi/ast.module | 4 +++- 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index c3b5bbe7..c0830f46 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -48,7 +48,9 @@ static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { static sexp sexp_translate_opcode_type (sexp ctx, sexp type) { sexp_gc_var2(res, tmp); res = type; - if (sexp_fixnump(res)) { + if (! res) { + res = sexp_type_by_index(ctx, SEXP_OBJECT); + } if (sexp_fixnump(res)) { res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); } else if (sexp_nullp(res)) { /* opcode list types */ sexp_gc_preserve2(ctx, res, tmp); @@ -129,12 +131,26 @@ static sexp sexp_optimize (sexp ctx sexp_api_params(self, n), sexp x) { sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_type(ctx, "object", SEXP_OBJECT); + sexp_define_type(ctx, "number", SEXP_NUMBER); + sexp_define_type(ctx, "bignum", SEXP_BIGNUM); + sexp_define_type(ctx, "flonum", SEXP_FLONUM); + sexp_define_type(ctx, "integer", SEXP_FIXNUM); + sexp_define_type(ctx, "opcode", SEXP_OPCODE); + sexp_define_type(ctx, "procedure", SEXP_PROCEDURE); + sexp_define_type(ctx, "bytecode", SEXP_BYTECODE); + sexp_define_type(ctx, "env", SEXP_ENV); + sexp_define_type(ctx, "macro", SEXP_MACRO); sexp_define_type(ctx, "lam", SEXP_LAMBDA); sexp_define_type(ctx, "cnd", SEXP_CND); sexp_define_type(ctx, "set", SEXP_SET); sexp_define_type(ctx, "ref", SEXP_REF); sexp_define_type(ctx, "seq", SEXP_SEQ); sexp_define_type(ctx, "lit", SEXP_LIT); + sexp_define_type(ctx, "sc", SEXP_SYNCLO); + sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV); + sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE); + sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); + sexp_define_type_predicate(ctx, env, "macro?", SEXP_MACRO); sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index e349bff3..0fdb8159 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -1,9 +1,11 @@ (define-module (chibi ast) (export analyze optimize env-cell ast->sexp macroexpand - object lam cnd set ref seq lit + object opcode procedure bytecode macro env number bignum flonum integer + lam cnd set ref seq lit sc pair-source pair-source-set! syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? + environment? bytecode? exception? macro? syntactic-closure-expr syntactic-closure-env syntactic-closure-vars lambda-name lambda-params lambda-body lambda-defs lambda-locals lambda-flags lambda-free-vars lambda-set-vars lambda-return-type From 8b590bd70c4018d1a9221df3bebcd1398f4ad6af Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 29 Jul 2010 13:06:01 +0000 Subject: [PATCH 481/535] adding initial type inference library --- lib/chibi/ast.c | 16 ++- lib/chibi/ast.module | 5 +- lib/chibi/type-inference.module | 7 ++ lib/chibi/type-inference.scm | 198 ++++++++++++++++++++++++++++++++ 4 files changed, 222 insertions(+), 4 deletions(-) create mode 100644 lib/chibi/type-inference.module create mode 100644 lib/chibi/type-inference.scm diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index c0830f46..5f998e7e 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -75,11 +75,14 @@ static sexp sexp_get_opcode_ret_type (sexp ctx sexp_api_params(self, n), sexp op static sexp sexp_get_opcode_param_type (sexp ctx sexp_api_params(self, n), sexp op, sexp k) { sexp res; + int p = sexp_unbox_fixnum(k); if (! sexp_opcodep(op)) return sexp_type_exception(ctx, self, SEXP_OPCODE, op); else if (! sexp_fixnump(k)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, k); - switch (sexp_unbox_fixnum(k)) { + if (p > sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op)) + p = sexp_opcode_num_args(op); + switch (p) { case 0: res = sexp_opcode_arg1_type(op); break; @@ -92,7 +95,7 @@ static sexp sexp_get_opcode_param_type (sexp ctx sexp_api_params(self, n), sexp if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2)) res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO)); else - res = sexp_type_by_index(ctx, 0); + res = sexp_type_by_index(ctx, SEXP_OBJECT); } break; } @@ -105,6 +108,12 @@ static sexp sexp_get_opcode_num_params (sexp ctx sexp_api_params(self, n), sexp return sexp_make_fixnum(sexp_opcode_num_args(op)); } +static sexp sexp_get_opcode_variadic_p (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + return sexp_make_boolean(sexp_opcode_variadic_p(op)); +} + static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { sexp ctx2 = ctx; if (sexp_envp(e)) { @@ -147,6 +156,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_type(ctx, "seq", SEXP_SEQ); sexp_define_type(ctx, "lit", SEXP_LIT); sexp_define_type(ctx, "sc", SEXP_SYNCLO); + sexp_define_type(ctx, "context", SEXP_CONTEXT); sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV); sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE); sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); @@ -160,6 +170,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE); + sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT); sexp_define_accessors(ctx, env, SEXP_PAIR, 2, "pair-source", "pair-source-set!"); sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); @@ -191,6 +202,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + sexp_define_foreign(ctx, env, "opcode-variadic?", 1, sexp_get_opcode_variadic_p); sexp_define_foreign(ctx, env, "opcode-num-params", 1, sexp_get_opcode_num_params); sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type); sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type); diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index 0fdb8159..192b1d7c 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -2,10 +2,10 @@ (define-module (chibi ast) (export analyze optimize env-cell ast->sexp macroexpand object opcode procedure bytecode macro env number bignum flonum integer - lam cnd set ref seq lit sc + context lam cnd set ref seq lit sc pair-source pair-source-set! syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? - environment? bytecode? exception? macro? + environment? bytecode? exception? macro? context? syntactic-closure-expr syntactic-closure-env syntactic-closure-vars lambda-name lambda-params lambda-body lambda-defs lambda-locals lambda-flags lambda-free-vars lambda-set-vars lambda-return-type @@ -20,6 +20,7 @@ ref-name ref-cell ref-name-set! ref-cell-set! seq-ls seq-ls-set! lit-value lit-value-set! opcode-name opcode-num-params opcode-return-type opcode-param-type + opcode-variadic? procedure-code procedure-vars procedure-name bytecode-name) (import-immutable (scheme)) (include-shared "ast") diff --git a/lib/chibi/type-inference.module b/lib/chibi/type-inference.module new file mode 100644 index 00000000..2f9534d2 --- /dev/null +++ b/lib/chibi/type-inference.module @@ -0,0 +1,7 @@ + +(define-module (chibi type-inference) + (export type-analyze-module type-analyze procedure-signature) + (import-immutable (scheme)) + (import (srfi 1) (srfi 69) (chibi modules) (chibi ast) (chibi match)) + (include "type-inference.scm")) + diff --git a/lib/chibi/type-inference.scm b/lib/chibi/type-inference.scm new file mode 100644 index 00000000..515a8cca --- /dev/null +++ b/lib/chibi/type-inference.scm @@ -0,0 +1,198 @@ + +(define (typed? x) + (and (lambda? x) + (lambda-return-type x))) + +(define (union-type? a) + (and (pair? a) (equal? (car a) 'or))) + +(define (intersection-type? a) + (and (pair? a) (equal? (car a) 'and))) + +(define (unfinalized-type? a) + (and (pair? a) (memq (car a) '(return-type param-type)))) + +(define (numeric-type? a) + (or (eq? a number) (eq? a flonum) (eq? a integer))) + +(define (procedure-type? a) + (or (eq? a opcode) (eq? a procedure) (and (pair? a) (eq? (car a) 'lambda)))) + +(define (type-subset? a b) + (or (equal? a b) + (equal? a object) + (equal? b object) + (and (numeric-type? a) (numeric-type? b)) + (and (procedure-type? a) (procedure-type? b)) + (if (union-type? a) + (if (union-type? b) + (lset<= equal? (cdr a) (cdr b)) + (member b (cdr a))) + (and (union-type? b) (member a (cdr b)))))) + +;; XXXX check for type hierarchies +(define (type-union a b) + (cond + ((equal? a b) a) + ((or (equal? a object) (equal? b object)) object) + ((union-type? a) + (if (union-type? b) + (cons (car a) (lset-union equal? (cdr a) (cdr b))) + (cons (car a) (lset-adjoin equal? (cdr a) b)))) + (else (list 'or a b)))) + +;; XXXX check for conflicts +(define (type-intersection a b) + (cond + ((equal? a b) a) + ((or (equal? a object) (unfinalized-type? a)) b) + ((or (equal? b object) (unfinalized-type? b)) a) + ((intersection-type? a) + (if (intersection-type? b) + (lset-intersection equal? (cdr a) (cdr b)) + (cons (car a) (lset-adjoin equal? (cdr a) b)))) + (else (list 'and a b)))) + +(define (lambda-param-types-initialize! f) + (lambda-param-types-set! f (map (lambda (p) (list 'param-type f p)) + (lambda-params f)))) + +(define (lambda-param-type-memq f x) + (let lp ((p (lambda-params f)) + (t (lambda-param-types f))) + (and (pair? p) + (pair? t) + (if (eq? x (car p)) + t + (lp (cdr p) (cdr t)))))) + +(define (lambda-param-type-ref f x) + (cond ((lambda-param-type-memq f x) => car) + (else #f))) + +(define (lambda-param-type-set! f x y) + (if (not (pair? (lambda-param-types f))) + (lambda-param-types-initialize! f)) + (cond ((lambda-param-type-memq f x) + => (lambda (cell) (set-car! cell y))))) + +(define (type-analyze-expr x) + ;;(write `(type-analyze-expr ,x ,(ast->sexp x)) (current-error-port)) (newline (current-error-port)) + (match x + (($ lam name params body defs) + (lambda-return-type-set! x (list 'return-type x)) + (lambda-param-types-initialize! x) + (let ((ret-type (type-analyze-expr body))) + (lambda-return-type-set! x ret-type) + (cons 'lambda (cons ret-type (lambda-param-types x))))) + (($ set ref value) + (type-analyze-expr value) + (if #f #f)) + (($ ref name (_ . loc) source) + (if (lambda? loc) + (lambda-param-type-ref loc name) + object)) + (($ cnd test pass fail) + (type-analyze-expr test) + (type-union (type-analyze-expr pass) (type-analyze-expr fail))) + (($ seq ls) + (let lp ((ls ls)) + (cond ((null? (cdr ls)) + (type-analyze-expr (car ls))) + (else + (type-analyze-expr (car ls)) + (lp (cdr ls)))))) + ((f args ...) + (cond + ((opcode? f) + ;;(write `(opcode app ,(opcode-param-types f) ,args) (current-error-port)) (newline (current-error-port)) + (let lp ((p (opcode-param-types f)) + (a args)) + (cond + ((pair? a) + (cond ((or (pair? p) (opcode-variadic? f)) + (match (car a) + (($ ref name (_ . (and g ($ lam)))) + (let ((t (type-intersection (lambda-param-type-ref g name) + (if (pair? p) + (car p) + (opcode-param-type f (opcode-num-params f)))))) + (lambda-param-type-set! g name t))) + (else + (let ((t (type-analyze-expr (car a)))) + (cond + ((not (type-subset? t (car p))) + (display "WARNING: incompatible type: " (current-error-port)) + (write (list x t (car p)) (current-error-port)) + (newline (current-error-port)))) + t))) + (lp (and (pair? p) (cdr p)) (cdr a))) + (else + (for-each type-analyze-expr a)))))) + (opcode-return-type f)) + (else + (let ((f-type (type-analyze-expr f))) + ;; XXXX apply f-type to params + (for-each type-analyze-expr args) + (if (and (pair? f-type) (eq? 'lambda (car f-type))) + (cadr f-type) + object))))) + (else + ;;(write `(unknown type ,x) (current-error-port)) (newline (current-error-port)) + object))) + +(define (type-resolve-circularities x) + #f) + +;; basic type inference on the body of a module +;; - internal references are to lambdas +;; - external references are to procedures (with completed type info) +;; - for each lambda +;; + add parameter constraints (intersection) from body +;; + add return type constaints (union) from last form(s) +;; - when complete, resolve cycles (e.g. even/odd => boolean) +(define (type-analyze-module-body name ls) + ;;(write `(type-analyze-module-body ,name) (current-error-port)) (newline (current-error-port)) + (for-each type-analyze-expr ls) + (for-each type-resolve-circularities ls)) + +(define (type-analyze-module name) + (let* ((mod (analyze-module name)) + (ls (and (vector? mod) (module-ast mod)))) + ;;(write `(analyzing ,ls) (current-error-port)) (newline (current-error-port)) + (and ls + (let ((x (let lp ((ls ls)) ;; first lambda + (and (pair? ls) + (if (and (set? (car ls)) + (lambda? (set-value (car ls)))) + (set-value (car ls)) + (lp (cdr ls))))))) + (if (and x (not (typed? x))) + (type-analyze-module-body name ls)) + ls)))) + +(define (type-analyze sexp . o) + (type-analyze-expr (apply analyze sexp o))) + +(define (opcode-param-types x) + (let lp ((n (- (opcode-num-params x) 1)) (res '())) + (if (< n 0) + res + (lp (- n 1) (cons (opcode-param-type x n) res))))) + +(define (procedure-signature x) + (if (opcode? x) + (cons (opcode-return-type x) (opcode-param-types x)) + (let lp ((count 0)) + (let ((lam (procedure-analysis x))) + (cond + ((and lam (not (typed? lam)) (zero? count) + (containing-module x)) + => (lambda (mod) + (and (type-analyze-module (car mod)) + (lp (+ count 1))))) + ((lambda? lam) + (cons (lambda-return-type lam) + (lambda-param-types lam))) + (else + #f)))))) From 307f81c315b911067747a37c3ba8b2040da7ca3d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 31 Jul 2010 21:35:46 +0900 Subject: [PATCH 482/535] adding \xNN escapes to string literals --- sexp.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/sexp.c b/sexp.c index 2242f734..5f38669a 100644 --- a/sexp.c +++ b/sexp.c @@ -1371,6 +1371,13 @@ sexp sexp_read_string (sexp ctx, sexp in) { case 'n': c = '\n'; break; case 'r': c = '\r'; break; case 't': c = '\t'; break; + case 'x': + c = sexp_read_char(ctx, in); + if (isxdigit(c)) { + c = digit_value(c)*16 + digit_value(sexp_read_char(ctx, in)); + } else { + sexp_push_char(ctx, c, in); c = 'x'; + } } } if (c == EOF) { From 4a2d9474bcb0406cf408f7c87fdc4b3c5439937b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 31 Jul 2010 22:04:38 +0900 Subject: [PATCH 483/535] forgot to update types lookup for bignums after introducing byte vectors --- opt/bignum.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/opt/bignum.c b/opt/bignum.c index 09c82ded..767d8898 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -487,7 +487,7 @@ enum sexp_number_combs { }; static int sexp_number_types[] = - {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0}; + {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0}; static int sexp_number_type (sexp a) { return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] From db5927abf7747f15dee174c24b9b727aa0f4c6c0 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 31 Jul 2010 22:11:28 +0900 Subject: [PATCH 484/535] fixing type id extraction --- tools/genstubs.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tools/genstubs.scm b/tools/genstubs.scm index ed187884..89900c0d 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -1040,11 +1040,11 @@ (type (cdr type))) (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" " " (type-id-name name) - " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, " + " = sexp_unbox_fixnum(sexp_type_tag(sexp_register_c_type(ctx, name, " (cond ((memq 'finalizer: type) => (lambda (x) (generate-stub-name (cadr x)))) (else "sexp_finalize_c_type")) - "));\n") + ")));\n") (cond ((memq 'predicate: type) => (lambda (x) From f58670b5316d38b6040378073d29060b0522c725 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 31 Jul 2010 22:20:53 +0900 Subject: [PATCH 485/535] no more sexp_symbol_string, accessing sexp_symbol_data directly --- lib/srfi/95/qsort.c | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c index 0f430874..34006c36 100644 --- a/lib/srfi/95/qsort.c +++ b/lib/srfi/95/qsort.c @@ -74,8 +74,7 @@ static int sexp_object_compare (sexp ctx, sexp a, sexp b) { res = strcmp(sexp_string_data(a), sexp_string_data(b)); break; case SEXP_SYMBOL: - res = strcmp(sexp_string_data(sexp_symbol_string(a)), - sexp_string_data(sexp_symbol_string(b))); + res = strcmp(sexp_symbol_data(a), sexp_symbol_data(b)); break; default: res = 0; @@ -84,7 +83,7 @@ static int sexp_object_compare (sexp ctx, sexp a, sexp b) { } #if SEXP_USE_HUFF_SYMS } else if (sexp_lsymbolp(a) && sexp_isymbolp(b)) { - res = strcmp(sexp_string_data(sexp_symbol_string(a)), + res = strcmp(sexp_symbol_data(a), sexp_string_data(sexp_write_to_string(ctx, b))); #endif } else { @@ -94,7 +93,7 @@ static int sexp_object_compare (sexp ctx, sexp a, sexp b) { #if SEXP_USE_HUFF_SYMS if (sexp_isymbolp(a) && sexp_lsymbolp(b)) res = strcmp(sexp_string_data(sexp_write_to_string(ctx, a)), - sexp_string_data(sexp_symbol_string(b))); + sexp_symbol_data(b)); else #endif res = -1; From 566fdee273fa37cd22dbc0d0e4b5e560c546ee35 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 31 Jul 2010 23:00:37 +0900 Subject: [PATCH 486/535] fixing off by one error in quicksort --- lib/srfi/95/qsort.c | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c index 34006c36..14329e37 100644 --- a/lib/srfi/95/qsort.c +++ b/lib/srfi/95/qsort.c @@ -112,6 +112,7 @@ static sexp sexp_object_compare_op (sexp ctx sexp_api_params(self, n), sexp a, s return sexp_make_fixnum(sexp_object_compare(ctx, a, b)); } +/* fast path when using general object-cmp comparator with no key */ static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) { sexp_sint_t mid, i, j; sexp tmp, tmp2; @@ -125,8 +126,8 @@ static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) { swap(tmp, vec[j], vec[hi]); if ((hi-lo) > 2) { sexp_qsort(ctx, vec, lo, j-1); - lo = j+1; - goto loop; + lo = j; + goto loop; /* tail recurse on right side */ } } } @@ -172,8 +173,8 @@ static sexp sexp_qsort_less (sexp ctx, sexp *vec, res = sexp_qsort_less(ctx, vec, lo, j-1, less, key); if (sexp_exceptionp(res)) goto done; - lo = j+1; - goto loop; + lo = j; + goto loop; /* tail recurse on right side */ } } done: From 5975cccd3785874ea875f777fa4afc50523a5037 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 31 Jul 2010 23:08:00 +0900 Subject: [PATCH 487/535] adding (chibi test) module --- lib/chibi/test.module | 14 + lib/chibi/test.scm | 649 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 663 insertions(+) create mode 100644 lib/chibi/test.module create mode 100644 lib/chibi/test.scm diff --git a/lib/chibi/test.module b/lib/chibi/test.module new file mode 100644 index 00000000..032cc93b --- /dev/null +++ b/lib/chibi/test.module @@ -0,0 +1,14 @@ + +(define-module (chibi test) + (export + test test-error test-assert + test-group current-test-group + test-begin test-end test-syntax-error test-info + test-vars test-run ;;test-exit + current-test-verbosity current-test-epsilon current-test-comparator + current-test-applier current-test-handler current-test-skipper + current-test-group-reporter test-failure-count) + (import-immutable (scheme)) + (import (srfi 39) (srfi 98) (chibi time) (chibi ast)) + (include "test.scm")) + diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm new file mode 100644 index 00000000..e5a4d804 --- /dev/null +++ b/lib/chibi/test.scm @@ -0,0 +1,649 @@ +;;;; test.scm -- testing framework +;; +;; Easy to use test suite adapted from the Chicken "test" module. +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exception utilities + +;; from SRFI-12, pending stabilization of an exception library for WG1 +(define-syntax handle-exceptions + (syntax-rules () + ((handle-exceptions exn handler body ...) + (call-with-current-continuation + (lambda (return) + (with-exception-handler + (lambda (exn) handler) + (lambda () body ...))))))) + +(define (warning msg . args) + (display msg (current-error-port)) + (for-each (lambda (x) + (write-char #\space (current-error-port)) + (write x (current-error-port))) + args) + (newline (current-error-port))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utilities + +(define (string-search pat str) + (let* ((pat-len (string-length pat)) + (limit (- (string-length str) pat-len))) + (let lp1 ((i 0)) + (cond + ((>= i limit) #f) + (else + (let lp2 ((j i) (k 0)) + (cond ((>= k pat-len) #t) + ((not (eqv? (string-ref str j) (string-ref pat k))) + (lp1 (+ i 1))) + (else (lp2 (+ j 1) (+ k 1)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; time utilities + +(define (timeval-difference tv1 tv2) + (let ((seconds (- (timeval-seconds tv1) (timeval-seconds tv2))) + (ms (- (timeval-microseconds tv1) (timeval-microseconds tv2)))) + (+ (max seconds 0.0) (/ ms 100000.0)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; test interface + +(define-syntax test + (syntax-rules () + ((test expect expr) + (test #f expect expr)) + ((test name expect (expr ...)) + (test-info name expect (expr ...) ())) + ((test name (expect ...) expr) + (test-syntax-error + 'test + "the test expression should come last " + (test name (expect ...) expr))) + ((test name expect expr) + (test-info name expect expr ())) + ((test a ...) + (test-syntax-error 'test "2 or 3 arguments required" + (test a ...))) + )) + +(define-syntax test-assert + (syntax-rules () + ((_ expr) + (test-assert #f expr)) + ((_ name expr) + (test-info name #f expr ((assertion . #t)))) + ((test a ...) + (test-syntax-error 'test-assert "1 or 2 arguments required" + (test a ...))) + )) + +(define-syntax test-error + (syntax-rules () + ((_ expr) + (test-error #f expr)) + ((_ name expr) + (test-info name #f expr ((expect-error . #t)))) + ((test a ...) + (test-syntax-error 'test-error "1 or 2 arguments required" + (test a ...))) + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; group interface + +(define-syntax test-group + (syntax-rules () + ((_ name-expr body ...) + (let ((name name-expr) + (old-group (current-test-group))) + (if (not (string? name)) + (error "a name is required, got " 'name-expr name)) + (test-begin name) + (handle-exceptions + exn + (begin + (warning "error in group outside of tests") + (print-exception e (current-error-port)) + (test-group-inc! (current-test-group) 'count) + (test-group-inc! (current-test-group) 'ERROR)) + body ...) + (test-end name) + (current-test-group old-group))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define-syntax test-syntax-error + (syntax-rules () + ((_) (syntax-error "invalid use of test-syntax-error")))) + +(define-syntax test-info + (syntax-rules () + ((test-info name expect expr info) + (test-vars () name expect expr ((source . expr) . info))))) + +(define-syntax test-vars + (syntax-rules () + ((_ (vars ...) n expect expr ((key . val) ...)) + (test-run (lambda () expect) + (lambda () expr) + (cons (cons 'name n) + '((source . expr) + ;;(var-names . (vars ...)) + ;;(var-values . ,(list vars)) + (key . val) ...)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; test-group representation + +;; (name (prop value) ...) +(define (make-test-group name) + (list name + (cons 'start-time (get-time-of-day)))) + +(define test-group-name car) + +(define (test-group-ref group field . o) + (apply assq-ref (cdr group) field o)) + +(define (test-group-set! group field value) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x value))) + (else (set-cdr! group (cons (cons field value) (cdr group)))))) + +(define (test-group-inc! group field) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x (+ 1 (cdr x))))) + (else (set-cdr! group (cons (cons field 1) (cdr group)))))) + +(define (test-group-push! group field value) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x (cons value (cdr x))))) + (else (set-cdr! group (cons (cons field (list value)) (cdr group)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (assq-ref ls key . o) + (cond ((assq key ls) => cdr) + ((pair? o) (car o)) + (else #f))) + +(define (approx-equal? a b epsilon) + (< (abs (- 1 (abs (if (zero? b) (+ 1 a) (/ a b))))) + epsilon)) + +;; partial pretty printing to abbreviate `quote' forms and the like +(define (write-to-string x) + (call-with-output-string + (lambda (out) + (let wr ((x x)) + (if (pair? x) + (cond + ((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x)) + (assq (car x) + '((quote . "'") (quasiquote . "`") + (unquote . ",") (unquote-splicing . ",@")))) + => (lambda (s) (display (cdr s) out) (wr (cadr x)))) + (else + (display "(" out) + (wr (car x)) + (let lp ((ls (cdr x))) + (cond ((pair? ls) + (display " " out) + (wr (car ls)) + (lp (cdr ls))) + ((not (null? ls)) + (display " . " out) + (write ls out)))) + (display ")" out))) + (write x out)))))) + +;; if we need to truncate, try first dropping let's to get at the +;; heart of the expression +(define (truncate-source x width . o) + (let* ((str (write-to-string x)) + (len (string-length str))) + (cond + ((<= len width) + str) + ((and (pair? x) (eq? 'let (car x))) + (if (and (pair? o) (car o)) + (truncate-source (car (reverse x)) width #t) + (string-append "..." + (truncate-source (car (reverse x)) (- width 3) #t)))) + ((and (pair? x) (eq? 'call-with-current-continuation (car x))) + (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o)))) + (else + (string-append + (substring str 0 (min (max 0 (- width 3)) (string-length str))) + "..."))))) + +(define (test-get-name! info) + (or + (assq-ref info 'name) + (assq-ref info 'gen-name) + (let ((name + (cond + ((assq-ref info 'source) + => (lambda (src) + (truncate-source src (- (current-column-width) 12)))) + ((current-test-group) + => (lambda (g) + (string-append + "test-" + (number->string (test-group-ref g 'count 0))))) + (else "")))) + (if (pair? info) + (set-cdr! info (cons (cons 'gen-name name) (cdr info)))) + name))) + +(define (test-print-name info . indent) + (let ((width (- (current-column-width) + (or (and (pair? indent) (car indent)) 0))) + (name (test-get-name! info))) + (display name) + (display " ") + (let ((diff (- width 9 (string-length name)))) + (cond + ((positive? diff) + (display (make-string diff #\.))))) + (display " ") + (flush-output))) + +(define (test-group-indent-width group) + (let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0) + (test-first-indentation)))))) + (* 4 (min level (test-max-indentation))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ansi tools + +(define (display-to-string x) + (if (string? x) x (call-with-output-string (lambda (out) (display x out))))) + +(define (red x) (string-append "\x1B[31m" (display-to-string x) "\x1B[0m")) +(define (green x) (string-append "\x1B[32m" (display-to-string x) "\x1B[0m")) +(define (yellow x) (string-append "\x1B[33m" (display-to-string x) "\x1B[0m")) +;; (define (blue x) (string-append "\x1B[34m" (display-to-string x) "\x1B[0m")) +;; (define (magenta x) (string-append "\x1B[35m" (display-to-string x) "\x1B[0m")) +;; (define (cyan x) (string-append "\x1B[36m" (display-to-string x) "\x1B[0m")) +(define (bold x) (string-append "\x1B[1m" (display-to-string x) "\x1B[0m")) +(define (underline x) (string-append "\x1B[4m" (display-to-string x) "\x1B[0m")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (test-run expect expr info) + (if (and (cond ((current-test-group) + => (lambda (g) (not (test-group-ref g 'skip-group?)))) + (else #t)) + (every (lambda (f) (f info)) (current-test-filters))) + ((current-test-applier) expect expr info) + ((current-test-skipper) expect expr info))) + +(define (test-default-applier expect expr info) + (let* ((group (current-test-group)) + (indent (and group (test-group-indent-width group)))) + (cond + ((and group + (equal? 0 (test-group-ref group 'count 0)) + (zero? (test-group-ref group 'subgroups-count 0)) + (test-group-ref group 'verbosity)) + (newline) + (print-header-line + (string-append "testing " (or (test-group-name group) "")) + (or indent 0)))) + (if (and indent (positive? indent)) + (display (make-string indent #\space))) + (test-print-name info indent) + (let ((expect-val + (handle-exceptions + exn + (begin + (warning "bad expect value") + (print-exception exn (current-error-port)) + #f) + (expect)))) + (handle-exceptions + exn + (begin + ((current-test-handler) + (if (assq-ref info 'expect-error) 'PASS 'ERROR) + expect + expr + (append `((exception . ,exn)) info))) + (let ((res (expr))) + (let ((status + (if (and (not (assq-ref info 'expect-error)) + (if (assq-ref info 'assertion) + res + ((current-test-comparator) expect-val res))) + 'PASS + 'FAIL)) + (info `((result . ,res) (expected . ,expect-val) ,@info))) + ((current-test-handler) status expect expr info))))))) + +(define (test-default-skipper expect expr info) + ((current-test-handler) 'SKIP expect expr info)) + +(define (test-default-handler status expect expr info) + (define indent + (make-string + (+ 4 (cond ((current-test-group) + => (lambda (group) (or (test-group-indent-width group) 0))) + (else 0))) + #\space)) + ;; update group info + (cond ((current-test-group) + => (lambda (group) + (if (not (eq? 'SKIP status)) + (test-group-inc! group 'count)) + (test-group-inc! group status)))) + (cond + ((or (eq? status 'FAIL) (eq? status 'ERROR)) + (test-failure-count (+ 1 (test-failure-count))))) + (cond + ((not (eq? status 'SKIP)) + ;; display status + (display "[") + (if (not (eq? status 'ERROR)) (display " ")) ; pad + (display ((if (test-ansi?) + (case status + ((ERROR) (lambda (x) (underline (red x)))) + ((FAIL) red) + ((SKIP) yellow) + (else green)) + (lambda (x) x)) + status)) + (display "]") + (newline) + ;; display status explanation + (cond + ((eq? status 'ERROR) + (display indent) + (cond ((assq 'exception info) + => (lambda (e) + (print-exception (cdr e) (current-output-port)))))) + ((and (eq? status 'FAIL) (assq-ref info 'assertion)) + (display indent) + (display "assertion failed\n")) + ((and (eq? status 'FAIL) (assq-ref info 'expect-error)) + (display indent) + (display "expected an error but got ") + (write (assq-ref info 'result)) (newline)) + ((eq? status 'FAIL) + (display indent) + (display "expected ") (write (assq-ref info 'expected)) + (display " but got ") (write (assq-ref info 'result)) (newline))) + ;; display line, source and values info + (cond + ((or (not (current-test-group)) + (test-group-ref (current-test-group) 'verbosity)) + (case status + ((FAIL ERROR) + (cond + ((assq-ref info 'line-number) + => (lambda (line) + (display " in line ") + (write line) + (cond ((assq-ref info 'file-name) + => (lambda (file) (display " of file ") (write file)))) + (newline)))) + (cond + ((assq-ref info 'source) + => (lambda (s) + (cond + ((or (assq-ref info 'name) + (> (string-length (write-to-string s)) + (current-column-width))) + (display (write-to-string s)) + (newline)))))) + (cond + ((assq-ref info 'values) + => (lambda (v) + (for-each + (lambda (v) + (display " ") (display (car v)) + (display ": ") (write (cdr v)) (newline)) + v)))))))))) + status) + +(define (test-default-group-reporter group) + (define (plural word n) + (if (= n 1) word (string-append word "s"))) + (define (percent n d) + (string-append " (" (number->string (/ (round (* 1000 (/ n d))) 10)) "%)")) + (let* ((end-time (get-time-of-day)) + (start-time (test-group-ref group 'start-time)) + (duration (timeval-difference (car end-time) (car start-time))) + (count (or (test-group-ref group 'count) 0)) + (pass (or (test-group-ref group 'PASS) 0)) + (fail (or (test-group-ref group 'FAIL) 0)) + (err (or (test-group-ref group 'ERROR) 0)) + (skip (or (test-group-ref group 'SKIP) 0)) + (subgroups-count (or (test-group-ref group 'subgroups-count) 0)) + (subgroups-pass (or (test-group-ref group 'subgroups-pass) 0)) + (indent (make-string (or (test-group-indent-width group) 0) #\space))) + (cond + ((or (positive? count) (positive? subgroups-count)) + (if (not (= count (+ pass fail err))) + (warning "inconsistent count:" count pass fail err)) + (display indent) + (cond + ((positive? count) + (write count) (display (plural " test" count)))) + (if (and (positive? count) (positive? subgroups-count)) + (display " and ")) + (cond + ((positive? subgroups-count) + (write subgroups-count) + (display (plural " subgroup" subgroups-count)))) + (display " completed in ") (write duration) (display " seconds") + (cond + ((not (zero? skip)) + (display " (") (write skip) (display (plural " test" skip)) + (display " skipped)"))) + (display ".") (newline) + (cond ((positive? fail) + (display indent) + (display + ((if (test-ansi?) red (lambda (x) x)) + (string-append + (number->string fail) (plural " failure" fail) + (percent fail count) "."))) + (newline))) + (cond ((positive? err) + (display indent) + (display + ((if (test-ansi?) (lambda (x) (underline (red x))) (lambda (x) x)) + (string-append + (number->string err) (plural " error" err) + (percent err count) "."))) + (newline))) + (cond + ((positive? count) + (display indent) + (display + ((if (and (test-ansi?) (= pass count)) green (lambda (x) x)) + (string-append + (number->string pass) " out of " (number->string count) + (percent pass count) (plural " test" pass) " passed."))) + (newline))) + (cond + ((positive? subgroups-count) + (display indent) + (display + ((if (and (test-ansi?) (= subgroups-pass subgroups-count)) + green (lambda (x) x)) + (string-append + (number->string subgroups-pass) " out of " + (number->string subgroups-count) + (percent subgroups-pass subgroups-count) + (plural " subgroup" subgroups-pass) " passed."))) + (newline))) + )) + (print-header-line + (string-append "done testing " (or (test-group-name group) "")) + (or (test-group-indent-width group) 0)) + (newline) + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (test-equal? expect res) + (or (equal? expect res) + (and (number? expect) + (inexact? expect) + (approx-equal? expect res (current-test-epsilon))))) + +(define (print-header-line str . indent) + (let* ((header (string-append + (make-string (if (pair? indent) (car indent) 0) #\space) + "-- " str " ")) + (len (string-length header))) + (display (if (test-ansi?) (bold header) header)) + (display (make-string (max 0 (- (current-column-width) len)) #\-)) + (newline))) + +(define (test-begin . o) + (let* ((name (if (pair? o) (car o) "")) + (group (make-test-group name)) + (parent (current-test-group))) + (cond + ((and parent + (equal? 0 (test-group-ref parent 'count 0)) + (zero? (test-group-ref parent 'subgroups-count 0)) + (test-group-ref parent 'verbosity)) + (newline) + (print-header-line + (string-append "testing " (test-group-name parent)) + (or (test-group-indent-width parent) 0)))) + (test-group-set! group 'parent parent) + (test-group-set! group 'verbosity + (if parent + (test-group-ref parent 'verbosity) + (current-test-verbosity))) + (test-group-set! group 'level + (if parent + (+ 1 (test-group-ref parent 'level 0)) + 0)) + (test-group-set! + group + 'skip-group? + (or (and parent (test-group-ref parent 'skip-group?)) + (not (every (lambda (f) (f group)) (current-test-group-filters))))) + (current-test-group group))) + +(define (test-end . o) + (cond + ((current-test-group) + => (lambda (group) + (if (and (pair? o) (not (equal? (car o) (test-group-name group)))) + (warning "mismatched test-end:" (car o) (test-group-name group))) + (let ((parent (test-group-ref group 'parent))) + (cond + ((not (test-group-ref group 'skip-group?)) + ;; only report if there's something to say + ((current-test-group-reporter) group) + (cond + (parent + (test-group-inc! parent 'subgroups-count) + (cond + ((and (zero? (test-group-ref group 'FAIL 0)) + (zero? (test-group-ref group 'ERROR 0)) + (= (test-group-ref group 'subgroups-pass 0) + (test-group-ref group 'subgroups-count 0))) + (test-group-inc! parent 'subgroups-pass))))))) + (current-test-group parent) + group))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parameters + +(define current-test-group (make-parameter #f)) +(define current-test-verbosity + (make-parameter + (cond ((get-environment-variable "TEST_QUIET") + => (lambda (s) (equal? s "0"))) + (else #t)))) +(define current-test-epsilon (make-parameter 1e-5)) +(define current-test-comparator (make-parameter test-equal?)) +(define current-test-applier (make-parameter test-default-applier)) +(define current-test-handler (make-parameter test-default-handler)) +(define current-test-skipper (make-parameter test-default-skipper)) +(define current-test-group-reporter + (make-parameter test-default-group-reporter)) +(define test-failure-count (make-parameter 0)) + +(define test-first-indentation + (make-parameter + (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION") + => string->number) + (else #f)) + 1))) + +(define test-max-indentation + (make-parameter + (or (cond ((get-environment-variable "TEST_MAX_INDENTATION") + => string->number) + (else #f)) + 5))) + +(define (string->info-matcher str) + (lambda (info) + (cond ((test-get-name! info) + => (lambda (n) (string-search str n))) + (else #f)))) + +(define (string->group-matcher str) + (lambda (group) (string-search str (car group)))) + +(define (getenv-filter-list proc name . o) + (cond + ((get-environment-variable name) + => (lambda (s) + (handle-exceptions + exn + (begin + (warning + (string-append "invalid filter '" s + "' from environment variable: " name)) + (print-exception exn (current-error-port)) + '()) + (let ((f (proc s))) + (list (if (and (pair? o) (car o)) + (lambda (x) (not (f x))) + f)))))) + (else '()))) + +(define current-test-filters + (make-parameter + (append (getenv-filter-list string->info-matcher "TEST_FILTER") + (getenv-filter-list string->info-matcher "TEST_REMOVE" #t)))) + +(define current-test-group-filters + (make-parameter + (append (getenv-filter-list string->group-matcher "TEST_GROUP_FILTER") + (getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE" #t)))) + +(define current-column-width + (make-parameter + (or (cond ((get-environment-variable "TEST_COLUMN_WIDTH") + => string->number) + (else #f)) + 78))) + +(define test-ansi? + (make-parameter + (cond + ((get-environment-variable "TEST_USE_ANSI") + => (lambda (s) (not (equal? s "0")))) + (else + (member (get-environment-variable "TERM") + '("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm" + "linux" "screen" "screen-256color" "vt100")))))) From 9684192ffec71944b91b1d94dd60e90318466d98 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 31 Jul 2010 23:20:50 +0900 Subject: [PATCH 488/535] wrong scale on ms difference --- lib/chibi/test.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm index e5a4d804..58649427 100644 --- a/lib/chibi/test.scm +++ b/lib/chibi/test.scm @@ -48,7 +48,7 @@ (define (timeval-difference tv1 tv2) (let ((seconds (- (timeval-seconds tv1) (timeval-seconds tv2))) (ms (- (timeval-microseconds tv1) (timeval-microseconds tv2)))) - (+ (max seconds 0.0) (/ ms 100000.0)))) + (+ (max seconds 0.0) (/ ms 1000000.0)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; test interface From 1923f54df0843c5d861b0c42b85ef60f4f26827c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 31 Jul 2010 23:30:30 +0900 Subject: [PATCH 489/535] switching tests suites to use (chibi test) --- Makefile | 3 + tests/flonum-tests.scm | 21 ++++ tests/hash-tests.scm | 43 +------ tests/lib-tests.scm | 13 ++ tests/loop-tests.scm | 40 +----- tests/match-tests.scm | 267 ++++++++++++++++------------------------ tests/numeric-tests.scm | 36 +----- tests/sort-tests.scm | 87 ++++++------- tests/thread-tests.scm | 39 +----- 9 files changed, 187 insertions(+), 362 deletions(-) create mode 100644 tests/flonum-tests.scm create mode 100644 tests/lib-tests.scm diff --git a/Makefile b/Makefile index ea3bd2f6..79d6aae4 100644 --- a/Makefile +++ b/Makefile @@ -182,6 +182,9 @@ test-loop: chibi-scheme$(EXE) test-sort: chibi-scheme$(EXE) LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm +test-libs: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/lib-tests.scm + test: chibi-scheme$(EXE) LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/r5rs-tests.scm diff --git a/tests/flonum-tests.scm b/tests/flonum-tests.scm new file mode 100644 index 00000000..5abe4772 --- /dev/null +++ b/tests/flonum-tests.scm @@ -0,0 +1,21 @@ +;;;; these will fail when compiled either without flonums or trig funcs + +(import (chibi test)) + +(test-begin "floating point") + +(test-assert (= -5 (floor -4.3))) +(test-assert (= -4 (ceiling -4.3))) +(test-assert (= -4 (truncate -4.3))) +(test-assert (= -4 (round -4.3))) +(test-assert (= 3 (floor 3.5))) +(test-assert (= 4 (ceiling 3.5))) +(test-assert (= 3 (truncate 3.5))) +(test-assert (= 4 (round 3.5))) + +(test 1124378190243790143.0 (exact->inexact 1124378190243790143)) + +;; (test "1124378190243790143.0" +;; (number->string (exact->inexact 1124378190243790143))) + +(test-end) diff --git a/tests/hash-tests.scm b/tests/hash-tests.scm index 54fb4fc7..09792c5e 100644 --- a/tests/hash-tests.scm +++ b/tests/hash-tests.scm @@ -1,44 +1,7 @@ -(import (srfi 69)) +(import (srfi 69) (chibi test)) -(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) - (write *tests-run* out) - (display ". " 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)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; run tests +(test-begin "hash") (test 'white @@ -70,5 +33,5 @@ (hash-table-set! ht i (* i i))) (hash-table-ref/default ht 25 #f))) -(test-report) +(test-end) diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm new file mode 100644 index 00000000..fbd8ae0a --- /dev/null +++ b/tests/lib-tests.scm @@ -0,0 +1,13 @@ + +(import (chibi test)) + +(test-begin "libraries") + +(load "tests/flonum-tests.scm") +(load "tests/numeric-tests.scm") +(load "tests/hash-tests.scm") +(load "tests/sort-tests.scm") +(load "tests/loop-tests.scm") +(load "tests/match-tests.scm") + +(test-end) diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm index 1c49d48f..f259245c 100644 --- a/tests/loop-tests.scm +++ b/tests/loop-tests.scm @@ -1,40 +1,7 @@ -(import (chibi loop)) +(import (chibi loop) (chibi test)) -(define *tests-run* 0) -(define *tests-passed* 0) - -(define-syntax test - (syntax-rules () - ((test name expr expect) - (begin - (set! *tests-run* (+ *tests-run* 1)) - (let ((str (call-with-output-string (lambda (out) (display name 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)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; run tests +(test-begin "loops") (test "stepping" @@ -198,5 +165,4 @@ (for res (listing i))) => res)) -(test-report) - +(test-end) diff --git a/tests/match-tests.scm b/tests/match-tests.scm index a223e729..911dd831 100644 --- a/tests/match-tests.scm +++ b/tests/match-tests.scm @@ -1,196 +1,135 @@ -(import (chibi match)) +(import (chibi match) (chibi test)) -(define *tests-run* 0) -(define *tests-passed* 0) +(test-begin "match") -(define-syntax test - (syntax-rules () - ((test name expr expect) - (begin - (set! *tests-run* (+ *tests-run* 1)) - (let ((str (call-with-output-string (lambda (out) (display name 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)))))))) +(test "any" 'ok (match 'any (_ 'ok))) +(test "symbol" 'ok (match 'ok (x x))) +(test "number" 'ok (match 28 (28 'ok))) +(test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok))) +(test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok))) +(test "null" 'ok (match '() (() 'ok))) +(test "pair" 'ok (match '(ok) ((x) x))) +(test "vector" 'ok (match '#(ok) (#(x) x))) +(test "any doubled" 'ok (match '(1 2) ((_ _) 'ok))) +(test "and empty" 'ok (match '(o k) ((and) 'ok))) +(test "and single" 'ok (match 'ok ((and x) x))) +(test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok))) +(test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok))) +(test "or single" 'ok (match 'ok ((or x) 'ok))) +(test "or double" 'ok (match 'ok ((or (? symbol? y) y) y))) +(test "not" 'ok (match 28 ((not (a . b)) 'ok))) +(test "pred" 'ok (match 28 ((? number?) 'ok))) +(test "named pred" 29 (match 28 ((? number? x) (+ x 1)))) -(define (test-report) - (write *tests-passed*) - (display " out of ") - (write *tests-run*) - (display " passed (") - (write (* (/ *tests-passed* *tests-run*) 100)) - (display "%)") - (newline)) +(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x))) +(test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok))) +(test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; run tests +(test "ellipses" '((a b c) (1 2 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ___) (list x y)))) -(test "any" (match 'any (_ 'ok)) 'ok) -(test "symbol" (match 'ok (x x)) 'ok) -(test "number" (match 28 (28 'ok)) 'ok) -(test "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok) -(test "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok) -(test "null" (match '() (() 'ok)) 'ok) -(test "pair" (match '(ok) ((x) x)) 'ok) -(test "vector" (match '#(ok) (#(x) x)) 'ok) -(test "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok) -(test "and empty" (match '(o k) ((and) 'ok)) 'ok) -(test "and single" (match 'ok ((and x) x)) 'ok) -(test "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok) -(test "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok) -(test "or single" (match 'ok ((or x) 'ok)) 'ok) -(test "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok) -(test "not" (match 28 ((not (a . b)) 'ok)) 'ok) -(test "pred" (match 28 ((? number?) 'ok)) 'ok) -(test "named pred" (match 28 ((? number? x) (+ x 1))) 29) +(test "real ellipses" '((a b c) (1 2 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ...) (list x y)))) -(test "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok) -(test "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok) -(test "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok) +(test "vector ellipses" '(1 2 3 (a b c) (1 2 3)) + (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) + (#(a b c (hd . tl) ...) (list a b c hd tl)))) -(test "ellipses" - (match '((a . 1) (b . 2) (c . 3)) - (((x . y) ___) (list x y))) - '((a b c) (1 2 3))) +(test "pred ellipses" '(1 2 3) + (match '(1 2 3) + (((? odd? n) ___) n) + (((? number? n) ___) n))) -(test "real ellipses" - (match '((a . 1) (b . 2) (c . 3)) - (((x . y) ...) (list x y))) - '((a b c) (1 2 3))) +(test "failure continuation" 'ok + (match '(1 2) + ((a . b) (=> next) (if (even? a) 'fail (next))) + ((a . b) 'ok))) -(test "vector ellipses" - (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) - (#(a b c (hd . tl) ...) (list a b c hd tl))) - '(1 2 3 (a b c) (1 2 3))) +(test "let" '(o k) + (match-let ((x 'ok) (y '(o k))) y)) -(test "pred ellipses" - (match '(1 2 3) - (((? odd? n) ___) n) - (((? number? n) ___) n)) - '(1 2 3)) +(test "let*" '(f o o f) + (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w))) -(test "failure continuation" - (match '(1 2) - ((a . b) (=> next) (if (even? a) 'fail (next))) - ((a . b) 'ok)) - 'ok) +(test "getter car" '(1 2) + (match '(1 . 2) (((get! a) . b) (list (a) b)))) -(test "let" - (match-let ((x 'ok) (y '(o k))) - y) - '(o k)) +(test "getter cdr" '(1 2) + (match '(1 . 2) ((a . (get! b)) (list a (b))))) -(test "let*" - (match-let* ((x 'f) (y 'o) ((z w) (list y x))) - (list x y z w)) - '(f o o f)) +(test "getter vector" '(1 2 3) + (match '#(1 2 3) (#((get! a) b c) (list (a) b c)))) -(test "getter car" - (match '(1 . 2) (((get! a) . b) (list (a) b))) - '(1 2)) +(test "setter car" '(3 . 2) + (let ((x (cons 1 2))) + (match x (((set! a) . b) (a 3))) + x)) -(test "getter cdr" - (match '(1 . 2) ((a . (get! b)) (list a (b)))) - '(1 2)) +(test "setter cdr" '(1 . 3) + (let ((x (cons 1 2))) + (match x ((a . (set! b)) (b 3))) + x)) -(test "getter vector" - (match '#(1 2 3) (#((get! a) b c) (list (a) b c))) - '(1 2 3)) +(test "setter vector" '#(1 0 3) + (let ((x (vector 1 2 3))) + (match x (#(a (set! b) c) (b 0))) + x)) -(test "setter car" - (let ((x (cons 1 2))) - (match x (((set! a) . b) (a 3))) - x) - '(3 . 2)) +(test "single tail" '((a b) (1 2) (c . 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ... last) (list x y last)))) -(test "setter cdr" - (let ((x (cons 1 2))) - (match x ((a . (set! b)) (b 3))) - x) - '(1 . 3)) +(test "single tail 2" '((a b) (1 2) 3) + (match '((a . 1) (b . 2) 3) + (((x . y) ... last) (list x y last)))) -(test "setter vector" - (let ((x (vector 1 2 3))) - (match x (#(a (set! b) c) (b 0))) - x) - '#(1 0 3)) +(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5)) + (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) + (((x . y) ... u v w) (list x y u v w)))) -(test "single tail" - (match '((a . 1) (b . 2) (c . 3)) - (((x . y) ... last) (list x y last))) - '((a b) (1 2) (c . 3))) +(test "Riastradh quasiquote" '(2 3) + (match '(1 2 3) (`(1 ,b ,c) (list b c)))) -(test "single tail 2" - (match '((a . 1) (b . 2) 3) - (((x . y) ... last) (list x y last))) - '((a b) (1 2) 3)) +(test "trivial tree search" '(1 2 3) + (match '(1 2 3) ((_ *** (a b c)) (list a b c)))) -(test "multiple tail" - (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) - (((x . y) ... u v w) (list x y u v w))) - '((a b) (1 2) (c . 3) (d . 4) (e . 5))) +(test "simple tree search" '(1 2 3) + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c)))) -(test "Riastradh quasiquote" - (match '(1 2 3) (`(1 ,b ,c) (list b c))) - '(2 3)) +(test "deep tree search" '(1 2 3) + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c)))) -(test "trivial tree search" - (match '(1 2 3) ((_ *** (a b c)) (list a b c))) - '(1 2 3)) +(test "non-tail tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c)))) -(test "simple tree search" - (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))) - '(1 2 3)) +(test "restricted tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c)))) -(test "deep tree search" - (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))) - '(1 2 3)) +(test "fail restricted tree search" #f + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f))) -(test "non-tail tree search" - (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))) - '(1 2 3)) +(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) -(test "restricted tree search" - (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))) - '(1 2 3)) - -(test "fail restricted tree search" - (match '(x (y (x a b c (1 2 3) d e f))) - (('x *** (a b c)) (list a b c)) - (else #f)) - #f) - -(test "sxml tree search" - (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) - (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) - (list attrs text)) - (else #f)) - '(((href . "http://synthcode.com/")) ("synthcode"))) - -(test "failed sxml tree search" - (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) - (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) - (list attrs text)) - (else #f)) - #f) +(test "failed sxml tree search" #f + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) (test "collect tree search" - (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) - (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) - (list tag attrs text)) - (else #f)) - '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))) - -(test-report) + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f))) +(test-end) diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm index 76a783f0..43b16cb4 100644 --- a/tests/numeric-tests.scm +++ b/tests/numeric-tests.scm @@ -2,39 +2,9 @@ ;; these tests are only valid if chibi-scheme is compiled with full ;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) -(define *tests-run* 0) -(define *tests-passed* 0) +(import (chibi test)) -(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-begin "numbers") (define (integer-neighborhoods x) (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) @@ -147,4 +117,4 @@ (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1)) (sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) -(test-report) +(test-end) diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm index 5471e648..f506baca 100644 --- a/tests/sort-tests.scm +++ b/tests/sort-tests.scm @@ -1,57 +1,40 @@ -(import (srfi 95)) +(import (srfi 95) (chibi test)) -(define *tests-run* 0) -(define *tests-passed* 0) +(test-begin "sorting") -(define-syntax test - (syntax-rules () - ((test name expr expect) - (begin - (set! *tests-run* (+ *tests-run* 1)) - (let ((str (call-with-output-string (lambda (out) (display name 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)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; run tests - -(test "sort null" (sort '()) '()) -(test "sort null <" (sort '() <) '()) -(test "sort null < car" (sort '() < car) '()) -(test "sort list" (sort '(7 5 2 8 1 6 4 9 3)) '(1 2 3 4 5 6 7 8 9)) -(test "sort list <" (sort '(7 5 2 8 1 6 4 9 3) <) '(1 2 3 4 5 6 7 8 9)) -(test "sort list < car" (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car) - '((1) (2) (3) (4) (5) (6) (7) (8) (9))) +(test "sort null" '() (sort '())) +(test "sort null <" '() (sort '() <)) +(test "sort null < car" '() (sort '() < car)) +(test "sort ordered list" '(1 2 3 4 5 6 7 8 9) (sort '(1 2 3 4 5 6 7 8 9))) +(test "sort reversed list" '(1 2 3 4 5 6 7 8 9) (sort '(9 8 7 6 5 4 3 2 1))) +(test "sort random list 1" '(1 2 3 4 5 6 7 8 9) (sort '(7 5 2 8 1 6 4 9 3))) +(test "sort random list 2" '(1 2 3 4 5 6 7 8) (sort '(5 3 4 1 7 6 8 2))) +(test "sort random list 3" '(1 2 3 4 5 6 7 8 9) (sort '(5 3 4 1 7 9 6 8 2))) +(test "sort numeric list <" '(1 2 3 4 5 6 7 8 9) + (sort '(7 5 2 8 1 6 4 9 3) <)) +(test "sort numeric list < car" '((1) (2) (3) (4) (5) (6) (7) (8) (9)) + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car)) (test "sort list (lambda (a b) (< (car a) (car b)))" - (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) - (lambda (a b) (< (car a) (car b)))) - '((1) (2) (3) (4) (5) (6) (7) (8) (9))) -(test "sort 1-char symbols" (sort '(h b k d a c j i e g f)) - '(a b c d e f g h i j k)) -(test "sort short symbols" (sort '(h b aa k d a ee c j i e g f)) - '(a aa b c d e ee f g h i j k)) -(test "sort long symbols" (sort '(h b aa k d a ee c j i bzzzzzzzzzzzzzzzzzzzzzzz e g f)) - '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz c d e ee f g h i j k)) + '((1) (2) (3) (4) (5) (6) (7) (8) (9)) + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) + (lambda (a b) (< (car a) (car b))))) +(test "sort 1-char symbols" '(a b c d e f g h i j k) + (sort '(h b k d a c j i e g f))) +(test "sort short symbols" '(a aa b c d e ee f g h i j k) + (sort '(h b aa k d a ee c j i e g f))) +(test "sort long symbol" + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz c d e ee f g h i j k) + (sort '(h b aa k d a ee c j i bzzzzzzzzzzzzzzzzzzzzzzz e g f))) +(test "sort long symbols" + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz czzzzzzzzzzzzz dzzzzzzzz e ee f g h i j k) + (sort '(h b aa k dzzzzzzzz a ee czzzzzzzzzzzzz j i bzzzzzzzzzzzzzzzzzzzzzzz e g f))) +(test "sort strings" + '("ape" "bear" "cat" "dog" "elephant" "fox" "goat" "hawk") + (sort '("elephant" "cat" "dog" "ape" "goat" "fox" "hawk" "bear"))) +(test "sort strings string-ci Date: Sun, 1 Aug 2010 15:03:13 +0900 Subject: [PATCH 490/535] changing type names to traditional --- lib/chibi/ast.c | 41 ++++++++++++---------- lib/chibi/ast.module | 47 +++++++++++++------------ lib/chibi/test.scm | 2 +- lib/chibi/type-inference.scm | 66 +++++++++++++++++++----------------- 4 files changed, 84 insertions(+), 72 deletions(-) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 5f998e7e..74fd5fc2 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -139,24 +139,29 @@ static sexp sexp_optimize (sexp ctx sexp_api_params(self, n), sexp x) { sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag)); sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { - sexp_define_type(ctx, "object", SEXP_OBJECT); - sexp_define_type(ctx, "number", SEXP_NUMBER); - sexp_define_type(ctx, "bignum", SEXP_BIGNUM); - sexp_define_type(ctx, "flonum", SEXP_FLONUM); - sexp_define_type(ctx, "integer", SEXP_FIXNUM); - sexp_define_type(ctx, "opcode", SEXP_OPCODE); - sexp_define_type(ctx, "procedure", SEXP_PROCEDURE); - sexp_define_type(ctx, "bytecode", SEXP_BYTECODE); - sexp_define_type(ctx, "env", SEXP_ENV); - sexp_define_type(ctx, "macro", SEXP_MACRO); - sexp_define_type(ctx, "lam", SEXP_LAMBDA); - sexp_define_type(ctx, "cnd", SEXP_CND); - sexp_define_type(ctx, "set", SEXP_SET); - sexp_define_type(ctx, "ref", SEXP_REF); - sexp_define_type(ctx, "seq", SEXP_SEQ); - sexp_define_type(ctx, "lit", SEXP_LIT); - sexp_define_type(ctx, "sc", SEXP_SYNCLO); - sexp_define_type(ctx, "context", SEXP_CONTEXT); + sexp_define_type(ctx, "", SEXP_OBJECT); + sexp_define_type(ctx, "", SEXP_NUMBER); + sexp_define_type(ctx, "", SEXP_BIGNUM); + sexp_define_type(ctx, "", SEXP_FLONUM); + sexp_define_type(ctx, "", SEXP_FIXNUM); + sexp_define_type(ctx, "", SEXP_SYMBOL); + sexp_define_type(ctx, "", SEXP_STRING); + sexp_define_type(ctx, "", SEXP_BYTES); + sexp_define_type(ctx, "", SEXP_PAIR); + sexp_define_type(ctx, "", SEXP_VECTOR); + sexp_define_type(ctx, "", SEXP_OPCODE); + sexp_define_type(ctx, "", SEXP_PROCEDURE); + sexp_define_type(ctx, "", SEXP_BYTECODE); + sexp_define_type(ctx, "", SEXP_ENV); + sexp_define_type(ctx, "", SEXP_MACRO); + sexp_define_type(ctx, "", SEXP_LAMBDA); + sexp_define_type(ctx, "", SEXP_CND); + sexp_define_type(ctx, "", SEXP_SET); + sexp_define_type(ctx, "", SEXP_REF); + sexp_define_type(ctx, "", SEXP_SEQ); + sexp_define_type(ctx, "", SEXP_LIT); + sexp_define_type(ctx, "", SEXP_SYNCLO); + sexp_define_type(ctx, "", SEXP_CONTEXT); sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV); sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE); sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index 192b1d7c..d6ca34d5 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -1,27 +1,30 @@ (define-module (chibi ast) - (export analyze optimize env-cell ast->sexp macroexpand - object opcode procedure bytecode macro env number bignum flonum integer - context lam cnd set ref seq lit sc - pair-source pair-source-set! - syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? - environment? bytecode? exception? macro? context? - syntactic-closure-expr syntactic-closure-env syntactic-closure-vars - lambda-name lambda-params lambda-body lambda-defs lambda-locals - lambda-flags lambda-free-vars lambda-set-vars lambda-return-type - lambda-param-types lambda-source - lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! - lambda-locals-set! lambda-flags-set! lambda-free-vars-set! - lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set! - lambda-source-set! - cnd-test cnd-pass cnd-fail - cnd-test-set! cnd-pass-set! cnd-fail-set! - set-var set-value set-var-set! set-value-set! - ref-name ref-cell ref-name-set! ref-cell-set! - seq-ls seq-ls-set! lit-value lit-value-set! - opcode-name opcode-num-params opcode-return-type opcode-param-type - opcode-variadic? - procedure-code procedure-vars procedure-name bytecode-name) + (export + analyze optimize env-cell ast->sexp macroexpand + + + + + pair-source pair-source-set! + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? + environment? bytecode? exception? macro? context? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + lambda-name lambda-params lambda-body lambda-defs lambda-locals + lambda-flags lambda-free-vars lambda-set-vars lambda-return-type + lambda-param-types lambda-source + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + lambda-locals-set! lambda-flags-set! lambda-free-vars-set! + lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set! + lambda-source-set! + cnd-test cnd-pass cnd-fail + cnd-test-set! cnd-pass-set! cnd-fail-set! + set-var set-value set-var-set! set-value-set! + ref-name ref-cell ref-name-set! ref-cell-set! + seq-ls seq-ls-set! lit-value lit-value-set! + opcode-name opcode-num-params opcode-return-type opcode-param-type + opcode-variadic? + procedure-code procedure-vars procedure-name bytecode-name) (import-immutable (scheme)) (include-shared "ast") (include "ast.scm")) diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm index 58649427..728cb36c 100644 --- a/lib/chibi/test.scm +++ b/lib/chibi/test.scm @@ -15,7 +15,7 @@ (call-with-current-continuation (lambda (return) (with-exception-handler - (lambda (exn) handler) + (lambda (exn) (return handler)) (lambda () body ...))))))) (define (warning msg . args) diff --git a/lib/chibi/type-inference.scm b/lib/chibi/type-inference.scm index 515a8cca..605a442a 100644 --- a/lib/chibi/type-inference.scm +++ b/lib/chibi/type-inference.scm @@ -13,15 +13,17 @@ (and (pair? a) (memq (car a) '(return-type param-type)))) (define (numeric-type? a) - (or (eq? a number) (eq? a flonum) (eq? a integer))) + (or (eq? a ) (eq? a ) (eq? a ))) (define (procedure-type? a) - (or (eq? a opcode) (eq? a procedure) (and (pair? a) (eq? (car a) 'lambda)))) + (or (eq? a ) + (eq? a ) + (and (pair? a) (eq? (car a) 'lambda)))) (define (type-subset? a b) (or (equal? a b) - (equal? a object) - (equal? b object) + (equal? a ) + (equal? b ) (and (numeric-type? a) (numeric-type? b)) (and (procedure-type? a) (procedure-type? b)) (if (union-type? a) @@ -34,7 +36,7 @@ (define (type-union a b) (cond ((equal? a b) a) - ((or (equal? a object) (equal? b object)) object) + ((or (equal? a ) (equal? b )) ) ((union-type? a) (if (union-type? b) (cons (car a) (lset-union equal? (cdr a) (cdr b))) @@ -45,8 +47,8 @@ (define (type-intersection a b) (cond ((equal? a b) a) - ((or (equal? a object) (unfinalized-type? a)) b) - ((or (equal? b object) (unfinalized-type? b)) a) + ((or (equal? a ) (unfinalized-type? a)) b) + ((or (equal? b ) (unfinalized-type? b)) a) ((intersection-type? a) (if (intersection-type? b) (lset-intersection equal? (cdr a) (cdr b)) @@ -79,23 +81,23 @@ (define (type-analyze-expr x) ;;(write `(type-analyze-expr ,x ,(ast->sexp x)) (current-error-port)) (newline (current-error-port)) (match x - (($ lam name params body defs) + (($ name params body defs) (lambda-return-type-set! x (list 'return-type x)) (lambda-param-types-initialize! x) (let ((ret-type (type-analyze-expr body))) (lambda-return-type-set! x ret-type) (cons 'lambda (cons ret-type (lambda-param-types x))))) - (($ set ref value) + (($ ref value) (type-analyze-expr value) (if #f #f)) - (($ ref name (_ . loc) source) + (($ name (_ . loc) source) (if (lambda? loc) (lambda-param-type-ref loc name) - object)) - (($ cnd test pass fail) + )) + (($ test pass fail) (type-analyze-expr test) (type-union (type-analyze-expr pass) (type-analyze-expr fail))) - (($ seq ls) + (($ ls) (let lp ((ls ls)) (cond ((null? (cdr ls)) (type-analyze-expr (car ls))) @@ -105,27 +107,29 @@ ((f args ...) (cond ((opcode? f) - ;;(write `(opcode app ,(opcode-param-types f) ,args) (current-error-port)) (newline (current-error-port)) (let lp ((p (opcode-param-types f)) (a args)) (cond ((pair? a) (cond ((or (pair? p) (opcode-variadic? f)) - (match (car a) - (($ ref name (_ . (and g ($ lam)))) - (let ((t (type-intersection (lambda-param-type-ref g name) - (if (pair? p) - (car p) - (opcode-param-type f (opcode-num-params f)))))) - (lambda-param-type-set! g name t))) - (else - (let ((t (type-analyze-expr (car a)))) - (cond - ((not (type-subset? t (car p))) - (display "WARNING: incompatible type: " (current-error-port)) - (write (list x t (car p)) (current-error-port)) - (newline (current-error-port)))) - t))) + (let ((p-type + (if (pair? p) + (car p) + (opcode-param-type f (opcode-num-params f))))) + (match (car a) + (($ name (_ . (and g ($ )))) + (let ((t (type-intersection (lambda-param-type-ref g name) + p-type))) + (lambda-param-type-set! g name t))) + (else + (let ((t (type-analyze-expr (car a)))) + (cond + ((not (type-subset? t p-type)) + (display "WARNING: incompatible type: " + (current-error-port)) + (write (list x t p-type) (current-error-port)) + (newline (current-error-port)))) + t)))) (lp (and (pair? p) (cdr p)) (cdr a))) (else (for-each type-analyze-expr a)))))) @@ -136,10 +140,10 @@ (for-each type-analyze-expr args) (if (and (pair? f-type) (eq? 'lambda (car f-type))) (cadr f-type) - object))))) + ))))) (else ;;(write `(unknown type ,x) (current-error-port)) (newline (current-error-port)) - object))) + ))) (define (type-resolve-circularities x) #f) From e4b65f83d5df95c59461e53aebafc364b546afa9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Aug 2010 15:04:00 +0900 Subject: [PATCH 491/535] adding srfi-38 --- lib/srfi/38.module | 6 ++ lib/srfi/38.scm | 255 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 261 insertions(+) create mode 100644 lib/srfi/38.module create mode 100644 lib/srfi/38.scm diff --git a/lib/srfi/38.module b/lib/srfi/38.module new file mode 100644 index 00000000..45769029 --- /dev/null +++ b/lib/srfi/38.module @@ -0,0 +1,6 @@ + +(define-module (srfi 38) + (import-immutable (scheme)) + (export write-with-shared-structure write/ss + read-with-shared-structure read/ss) + (include "38.scm")) diff --git a/lib/srfi/38.scm b/lib/srfi/38.scm new file mode 100644 index 00000000..62650ddb --- /dev/null +++ b/lib/srfi/38.scm @@ -0,0 +1,255 @@ +;;;; srfi-38.scm - reading and writing shared structures +;; +;; This code was written by Alex Shinn in 2009 and placed in the +;; Public Domain. All warranties are disclaimed. + +(define (extract-shared-objects x) + (let ((seen '())) + (let find ((x x)) + (cond + ((assq x seen) + => (lambda (cell) (set-cdr! cell (+ (cdr cell) 1)))) + ((pair? x) + (set! seen (cons (cons x 1) seen)) + (find (car x)) + (find (cdr x))) + ((vector? x) + (set! seen (cons (cons x 1) seen)) + (do ((i 0 (+ i 1))) + ((= i (vector-length x))) + (find (vector-ref x i)))))) + (let extract ((ls seen) (res '())) + (cond + ((null? ls) res) + ((> (cdar ls) 1) (extract (cdr ls) (cons (cons (caar ls) #f) res))) + (else (extract (cdr ls) res)))))) + +(define (write-with-shared-structure x . o) + (let ((out (if (pair? o) (car o) (current-output-port))) + (shared (extract-shared-objects x)) + (count 0)) + (define (check-shared x prefix cont) + (let ((cell (assq x shared))) + (cond ((and cell (cdr cell)) + (display prefix out) + (display "#" out) + (write (cdr cell)) + (display "#" out)) + (else + (cond (cell + (display prefix out) + (display "#=" out) + (write count out) + (set-cdr! cell count) + (set! count (+ count 1)))) + (cont x))))) + (cond + ((null? shared) + (write x out)) + (else + (let wr ((x x)) + (check-shared + x + "" + (lambda (x) + (cond + ((pair? x) + (display "(" out) + (wr (car x)) + (let lp ((ls (cdr x))) + (check-shared + ls + " . " + (lambda (ls) + (cond ((null? ls)) + ((pair? ls) + (display " " out) + (wr (car ls)) + (lp (cdr ls))) + (else + (display " . " out) + (wr ls)))))) + (display ")" out)) + ((vector? x) + (display "#(" out) + (let ((len (vector-length x))) + (cond ((> len 0) + (wr (vector-ref x 0)) + (do ((i 1 (+ i 1))) + ((= i len)) + (display " " out) + (wr (vector-ref x i)))))) + (display ")" out)) + (else + (write x out)))))))))) + +(define write/ss write-with-shared-structure) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (skip-line in) + (let ((c (read-char in))) + (if (not (or (eof-object? c) (eqv? c #\newline))) + (skip-line in)))) + +(define (skip-whitespace in) + (case (peek-char in) + ((#\space #\tab #\newline #\return) + (read-char in) + (skip-whitespace in)) + ((#\;) + (skip-line in) + (skip-whitespace in)))) + +(define (skip-comment in depth) + (case (read-char in) + ((#\#) (skip-comment in (if (eqv? #\| (peek-char in)) (+ depth 1) depth))) + ((#\|) (if (eqv? #\# (peek-char in)) + (if (zero? depth) (read-char in) (skip-comment in (- depth 1))) + (skip-comment in depth))) + (else (if (eof-object? (peek-char in)) + (error "unterminated #| comment") + (skip-comment in depth))))) + +(define delimiters + '(#\( #\) #\[ #\] #\space #\tab #\newline #\return)) + +(define read-with-shared-structure + (let ((read read)) + (lambda o + (let ((in (if (pair? o) (car o) (current-input-port))) + (shared '())) + (define (read-label res) + (let ((c (char-downcase (peek-char in)))) + (if (if (char-numeric? c) #t (memv c '(#\a #\b #\c #\d #\e))) + (read-label (cons (read-char in) res)) + (list->string (reverse res))))) + (define (read-number base) + (let* ((str (read-label '())) + (n (string->number str base))) + (if (or (not n) (not (memv (peek-char in) delimiters))) + (error "read error: invalid number syntax" str (peek-char in)) + n))) + (define (read-float-tail in) ;; called only after a leading period + (let lp ((res 0.0) (k 0.1)) + (let ((c (peek-char in))) + (cond + ((char-numeric? c) (lp (+ res (* (read-char in) k)) (* k 0.1))) + ((memv c delimiters) res) + (else (error "invalid char in float syntax" c)))))) + (define (read-name c in) + (let lp ((ls (if (char? c) (list c) '()))) + (let ((c (peek-char in))) + (cond ((memv c delimiters) (list->string (reverse ls))) + (else (lp (cons (read-char in) ls))))))) + (define (read-named-char c in) + (let ((name (read-name c in))) + (cond ((string-ci=? name "space") #\space) + ((string-ci=? name "newline") #\newline) + (else (error "unknown char name"))))) + (define (read-one) + (skip-whitespace in) + (case (peek-char in) + ((#\#) + (read-char in) + (case (char-downcase (peek-char in)) + ((#\=) + (read-char in) + (let* ((str (read-label '())) + (n (string->number str)) + (cell (list #f)) + (thunk (lambda () (car cell)))) + (if (not n) (error "read error: invalid reference" str)) + (set! shared (cons (cons n thunk) shared)) + (let ((x (read-one))) + (set-car! cell x) + x))) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let ((n (string->number (read-label '())))) + (cond + ((not (eqv? #\# (peek-char in))) + (error "read error: expected # after #n" (read-char in))) + (else + (read-char in) + (cond ((assv n shared) => cdr) + (else (error "read error: unknown reference" n))))))) + ((#\;) + (read-char in) + (read-one) ;; discard + (read-one)) + ((#\|) + (skip-comment in 0)) + ((#\!) (skip-line in) (read-one in)) + ((#\() (list->vector (read-one))) + ((#\') (read-char in) (list 'syntax (read-one))) + ((#\`) (read-char in) (list 'quasisyntax (read-one))) + ((#\t) (read-char in) #t) + ((#\f) (read-char in) #t) ; support SRFI-4 f32/64 vectors + ((#\d) (read-char in) (read in)) + ((#\x) (read-char in) (read-number 16)) + ((#\o) (read-char in) (read-number 8)) + ((#\b) (read-char in) (read-number 2)) + ((#\i) (read-char in) (exact->inexact (read-one))) + ((#\e) (read-char in) (inexact->exact (read-one))) + ((#\\) + (read-char in) + (let ((c (read-char in))) + (if (memv (peek-char in) delimiters) + c + (read-named-char c in)))) + (else ; last resort + (error "unknown # syntax: " (peek-char in))))) + ((#\() + (read-char in) + (let lp ((res '())) + (skip-whitespace in) + (case (peek-char in) + ((#\)) + (read-char in) + (reverse res)) + ((#\.) + (read-char in) + (cond + ((memv (peek-char in) delimiters) + (let ((tail (read-one))) + (skip-whitespace in) + (if (eqv? #\) (peek-char in)) + (begin (read-char in) (append (reverse res) tail)) + (error "expected end of list after dot")))) + ((char-numeric? (peek-char in)) (read-float-tail in)) + (else (string->symbol (read-name #\. in))))) + (else + (lp (cons (read-one) res)))))) + ((#\') (read-char in) (list 'quote (read-one))) + ((#\`) (read-char in) (list 'quasiquote (read-one))) + ((#\,) + (read-char in) + (list (if (eqv? #\@ (peek-char in)) + (begin (read-char in) 'unquote-splicing) + 'unquote) + (read-one))) + (else + (read in)))) + ;; body + (let ((res (read-one))) + (if (pair? shared) + (patch res)) + res))))) + +(define (hole? x) (procedure? x)) +(define (fill-hole x) (if (hole? x) (fill-hole (x)) x)) + +(define (patch x) + (cond + ((pair? x) + (if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch (car x))) + (if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch (cdr x)))) + ((vector? x) + (do ((i (- (vector-length x) 1) (- i 1))) + ((< i 0)) + (let ((elt (vector-ref x i))) + (if (hole? elt) + (vector-set! x i (fill-hole elt)) + (patch elt))))))) + +(define read/ss read-with-shared-structure) From e656c6e7e25827c392d5fdeab4dcffb32a77335f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Aug 2010 16:20:31 +0900 Subject: [PATCH 492/535] don't error when passing dotted lists to n-ary map --- lib/init.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/init.scm b/lib/init.scm index d5191caf..62d044ec 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -73,11 +73,11 @@ (map1 proc (cdr ls) (cons (proc (car ls)) res)) (reverse res))) (define (mapn proc lol res) - (if (null? (car lol)) - (reverse res) + (if (pair? (car lol)) (mapn proc (map1 cdr lol '()) - (cons (apply1 proc (map1 car lol '())) res)))) + (cons (apply1 proc (map1 car lol '())) res)) + (reverse res))) (if (null? lol) (map1 proc ls '()) (mapn proc (cons ls lol) '()))) From f61e3ac415b717e1cd5f821a3ecaf7229f6533d9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Aug 2010 16:20:43 +0900 Subject: [PATCH 493/535] fixing bug in delete --- lib/srfi/1/deletion.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm index 70ee5cc5..2d44275a 100644 --- a/lib/srfi/1/deletion.scm +++ b/lib/srfi/1/deletion.scm @@ -10,7 +10,7 @@ (if tail (lp (cdr tail) (take-up-to-reverse ls tail rev)) (if (pair? rev) (append-reverse! rev ls) ls)))) - (filter (lambda (y) (eq x y)) ls)))) + (remove (lambda (y) (eq x y)) ls)))) (define delete! delete) From da5d9c677b5540a334efa48f92487fc94628121a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Aug 2010 17:47:10 +0900 Subject: [PATCH 494/535] adding error types, fixing the return value of primitive list types. also adding and types. --- lib/chibi/ast.c | 8 ++++++-- lib/chibi/ast.module | 2 +- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 74fd5fc2..c3c58feb 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -55,8 +55,8 @@ static sexp sexp_translate_opcode_type (sexp ctx, sexp type) { } else if (sexp_nullp(res)) { /* opcode list types */ sexp_gc_preserve2(ctx, res, tmp); tmp = sexp_intern(ctx, "or", -1); - res = sexp_cons(ctx, sexp_make_fixnum(SEXP_PAIR), SEXP_NULL); - res = sexp_cons(ctx, SEXP_NULL, res); + res = sexp_cons(ctx, SEXP_NULL, SEXP_NULL); + res = sexp_cons(ctx, sexp_type_by_index(ctx, SEXP_PAIR), res); res = sexp_cons(ctx, tmp, res); sexp_gc_release2(ctx); } @@ -67,6 +67,8 @@ static sexp sexp_get_opcode_ret_type (sexp ctx sexp_api_params(self, n), sexp op sexp res; if (! sexp_opcodep(op)) return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + if (sexp_opcode_code(op) == SEXP_OP_RAISE) + return sexp_list1(ctx, sexp_intern(ctx, "error", -1)); res = sexp_opcode_return_type(op); if (sexp_fixnump(res)) res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); @@ -145,6 +147,8 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_type(ctx, "", SEXP_FLONUM); sexp_define_type(ctx, "", SEXP_FIXNUM); sexp_define_type(ctx, "", SEXP_SYMBOL); + sexp_define_type(ctx, "", SEXP_CHAR); + sexp_define_type(ctx, "", SEXP_BOOLEAN); sexp_define_type(ctx, "", SEXP_STRING); sexp_define_type(ctx, "", SEXP_BYTES); sexp_define_type(ctx, "", SEXP_PAIR); diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index d6ca34d5..ee10d2cc 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -3,7 +3,7 @@ (export analyze optimize env-cell ast->sexp macroexpand - + pair-source pair-source-set! From 2fe2e9f00274054dfca46b25639a4dc70a5d3de9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Aug 2010 17:55:30 +0900 Subject: [PATCH 495/535] adding test-values --- lib/chibi/test.module | 2 +- lib/chibi/test.scm | 25 +++++++++++++++++++------ 2 files changed, 20 insertions(+), 7 deletions(-) diff --git a/lib/chibi/test.module b/lib/chibi/test.module index 032cc93b..d8b405f1 100644 --- a/lib/chibi/test.module +++ b/lib/chibi/test.module @@ -1,7 +1,7 @@ (define-module (chibi test) (export - test test-error test-assert + test test-error test-assert test-values test-group current-test-group test-begin test-end test-syntax-error test-info test-vars test-run ;;test-exit diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm index 728cb36c..bfa7429e 100644 --- a/lib/chibi/test.scm +++ b/lib/chibi/test.scm @@ -68,8 +68,7 @@ (test-info name expect expr ())) ((test a ...) (test-syntax-error 'test "2 or 3 arguments required" - (test a ...))) - )) + (test a ...))))) (define-syntax test-assert (syntax-rules () @@ -79,8 +78,15 @@ (test-info name #f expr ((assertion . #t)))) ((test a ...) (test-syntax-error 'test-assert "1 or 2 arguments required" - (test a ...))) - )) + (test a ...))))) + +(define-syntax test-values + (syntax-rules () + ((_ expect expr) + (test-values #f expect expr)) + ((_ name expect expr) + (test name (call-with-values (lambda () expect) (lambda results results)) + (call-with-values (lambda () expr) (lambda results results)))))) (define-syntax test-error (syntax-rules () @@ -90,8 +96,7 @@ (test-info name #f expr ((expect-error . #t)))) ((test a ...) (test-syntax-error 'test-error "1 or 2 arguments required" - (test a ...))) - )) + (test a ...))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; group interface @@ -219,6 +224,14 @@ (truncate-source (car (reverse x)) (- width 3) #t)))) ((and (pair? x) (eq? 'call-with-current-continuation (car x))) (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o)))) + ((and (pair? x) (eq? 'call-with-values (car x))) + (string-append + "..." + (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (caadr x))) + (car (reverse (cadr x))) + (cadr x)) + (- width 3) + #t))) (else (string-append (substring str 0 (min (max 0 (- width 3)) (string-length str))) From fbf7319a30663a404d1b005d055731d5ffe251e9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Aug 2010 18:12:49 +0900 Subject: [PATCH 496/535] various type inference fixes, mutually recursive functions now resolve correctly --- lib/chibi/type-inference.scm | 145 +++++++++++++++++++++++++++-------- 1 file changed, 113 insertions(+), 32 deletions(-) diff --git a/lib/chibi/type-inference.scm b/lib/chibi/type-inference.scm index 605a442a..137cc251 100644 --- a/lib/chibi/type-inference.scm +++ b/lib/chibi/type-inference.scm @@ -1,3 +1,7 @@ +;; type-inference.scm -- general type-inference for Scheme +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define (typed? x) (and (lambda? x) @@ -10,7 +14,13 @@ (and (pair? a) (equal? (car a) 'and))) (define (unfinalized-type? a) - (and (pair? a) (memq (car a) '(return-type param-type)))) + (and (pair? a) + (or (memq (car a) '(return-type param-type)) + (and (memq (car a) '(and or)) + (any unfinalized-type? (cdr a)))))) + +(define (finalized-type? a) + (not (unfinalized-type? a))) (define (numeric-type? a) (or (eq? a ) (eq? a ) (eq? a ))) @@ -55,6 +65,17 @@ (cons (car a) (lset-adjoin equal? (cdr a) b)))) (else (list 'and a b)))) +(define (type-of x) + (cond ((boolean? x) ) + ((char? x) ) + ((symbol? x) ) + ((string? x) ) + ((and (integer? x) (exact? x)) ) + ((flonum? x) ) + ((pair? x) ) + ((vector? x) ) + (else ))) + (define (lambda-param-types-initialize! f) (lambda-param-types-set! f (map (lambda (p) (list 'param-type f p)) (lambda-params f)))) @@ -79,24 +100,32 @@ => (lambda (cell) (set-car! cell y))))) (define (type-analyze-expr x) - ;;(write `(type-analyze-expr ,x ,(ast->sexp x)) (current-error-port)) (newline (current-error-port)) (match x (($ name params body defs) - (lambda-return-type-set! x (list 'return-type x)) - (lambda-param-types-initialize! x) - (let ((ret-type (type-analyze-expr body))) - (lambda-return-type-set! x ret-type) - (cons 'lambda (cons ret-type (lambda-param-types x))))) + (cond + ((not (lambda-return-type x)) + (lambda-return-type-set! x (list 'return-type x)) + (lambda-param-types-initialize! x) + (let ((ret-type (type-analyze-expr body))) + (lambda-return-type-set! x ret-type) + (cons 'lambda (cons ret-type (lambda-param-types x))))))) (($ ref value) (type-analyze-expr value) (if #f #f)) - (($ name (_ . loc) source) - (if (lambda? loc) - (lambda-param-type-ref loc name) - )) + (($ name (value . loc) source) + (cond + ((lambda? loc) (lambda-param-type-ref loc name)) + ((procedure? loc) + (let ((sig (procedure-signature loc))) + (if (and (pair? sig) (car sig)) + (cons 'lambda sig) + (list 'return-type (procedure-analysis loc))))) + (else ))) (($ test pass fail) - (type-analyze-expr test) - (type-union (type-analyze-expr pass) (type-analyze-expr fail))) + (let ((test-type (type-analyze-expr test)) + (pass-type (type-analyze-expr pass)) + (fail-type (type-analyze-expr fail))) + (type-union pass-type fail-type))) (($ ls) (let lp ((ls ls)) (cond ((null? (cdr ls)) @@ -124,7 +153,10 @@ (else (let ((t (type-analyze-expr (car a)))) (cond - ((not (type-subset? t p-type)) + ((and t p-type + (finalized-type? t) + (finalized-type? p-type) + (not (type-subset? t p-type))) (display "WARNING: incompatible type: " (current-error-port)) (write (list x t p-type) (current-error-port)) @@ -138,32 +170,76 @@ (let ((f-type (type-analyze-expr f))) ;; XXXX apply f-type to params (for-each type-analyze-expr args) - (if (and (pair? f-type) (eq? 'lambda (car f-type))) - (cadr f-type) - ))))) + (cond + ((and (pair? f-type) (eq? (car f-type) 'lambda)) + (cadr f-type)) + ((and (pair? f-type) (memq (car f-type) '(return-type param-type))) + f-type) + (else + )))))) (else - ;;(write `(unknown type ,x) (current-error-port)) (newline (current-error-port)) - ))) + (type-of x)))) + +(define (resolve-delayed-type x) + (let lp ((x x) (seen '()) (default )) + (match x + (('return-type f) + (if (memq f seen) + default + (lp (lambda-return-type f) (cons f seen) default))) + (('param-type f p) + (if (member x seen) + default + (lp (lambda-param-type-ref f p) (cons x seen) default))) + (('or y ...) + (let ((z (find finalized-type? y))) + (if z + (let ((default (if (eq? default ) + (lp z seen default) + (type-union (lp z seen default) default)))) + (fold type-union + default + (map (lambda (y1) (lp y1 seen default)) (delete z y)))) + (fold type-union default (map (lambda (y1) (lp y1 seen default)) y))))) + (('and y ...) + (fold type-intersection default (map (lambda (y1) (lp y1 seen default)) y))) + (('not y) + (list 'not (lp y seen default))) + (else + x)))) (define (type-resolve-circularities x) - #f) + (match x + (($ name params body defs) + (if (unfinalized-type? (lambda-return-type x)) + (lambda-return-type-set! x (resolve-delayed-type + (lambda-return-type x)))) + (for-each + (lambda (p t) + (if (unfinalized-type? t) + (lambda-param-type-set! x p (resolve-delayed-type t)))) + params + (lambda-param-types x)) + (type-resolve-circularities (lambda-body x))) + (($ ref value) + (type-resolve-circularities value)) + (($ test pass fail) + (type-resolve-circularities test) + (type-resolve-circularities pass) + (type-resolve-circularities fail)) + (($ ls) + (for-each type-resolve-circularities ls)) + ((app ...) + (for-each type-resolve-circularities app)) + (else #f))) -;; basic type inference on the body of a module -;; - internal references are to lambdas -;; - external references are to procedures (with completed type info) -;; - for each lambda -;; + add parameter constraints (intersection) from body -;; + add return type constaints (union) from last form(s) -;; - when complete, resolve cycles (e.g. even/odd => boolean) (define (type-analyze-module-body name ls) - ;;(write `(type-analyze-module-body ,name) (current-error-port)) (newline (current-error-port)) (for-each type-analyze-expr ls) (for-each type-resolve-circularities ls)) (define (type-analyze-module name) (let* ((mod (analyze-module name)) (ls (and (vector? mod) (module-ast mod)))) - ;;(write `(analyzing ,ls) (current-error-port)) (newline (current-error-port)) (and ls (let ((x (let lp ((ls ls)) ;; first lambda (and (pair? ls) @@ -184,9 +260,15 @@ res (lp (- n 1) (cons (opcode-param-type x n) res))))) +(define (opcode-type x) + (cons 'lambda (cons (opcode-return-type x) (opcode-param-types x)))) + +(define (lambda-type x) + (cons 'lambda (cons (lambda-return-type x) (lambda-param-types x)))) + (define (procedure-signature x) (if (opcode? x) - (cons (opcode-return-type x) (opcode-param-types x)) + (cdr (opcode-type x)) (let lp ((count 0)) (let ((lam (procedure-analysis x))) (cond @@ -196,7 +278,6 @@ (and (type-analyze-module (car mod)) (lp (+ count 1))))) ((lambda? lam) - (cons (lambda-return-type lam) - (lambda-param-types lam))) + (cdr (lambda-type lam))) (else #f)))))) From 1d1130d4c3f77b07dc8f24c34b2865833bf15b8f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 2 Aug 2010 00:52:22 +0900 Subject: [PATCH 497/535] adding efficient type-of operator --- lib/chibi/ast.c | 22 ++++++++++++++++++++++ lib/chibi/ast.module | 2 +- 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index c3c58feb..32cbc1e7 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -116,6 +116,27 @@ static sexp sexp_get_opcode_variadic_p (sexp ctx sexp_api_params(self, n), sexp return sexp_make_boolean(sexp_opcode_variadic_p(op)); } +static sexp sexp_type_of (sexp ctx sexp_api_params(self, n), sexp x) { + if (sexp_pointerp(x)) + return sexp_object_type(ctx, x); + else if (sexp_fixnump(x)) + return sexp_type_by_index(ctx, SEXP_FIXNUM); + else if (sexp_booleanp(x)) + return sexp_type_by_index(ctx, SEXP_BOOLEAN); + else if (sexp_charp(x)) + return sexp_type_by_index(ctx, SEXP_CHAR); +#if SEXP_USE_HUFF_SYMS + else if (sexp_symbolp(x)) + return sexp_type_by_index(ctx, SEXP_SYMBOL); +#endif +#if SEXP_USE_IMMEDIATE_FLONUMS + else if (sexp_flonump(x)) + return sexp_type_by_index(ctx, SEXP_FLONUM); +#endif + else + return sexp_type_by_index(ctx, SEXP_OBJECT); +} + static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { sexp ctx2 = ctx; if (sexp_envp(e)) { @@ -216,6 +237,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type); sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type); sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize); + sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of); return SEXP_VOID; } diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index ee10d2cc..711da431 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -1,7 +1,7 @@ (define-module (chibi ast) (export - analyze optimize env-cell ast->sexp macroexpand + analyze optimize env-cell ast->sexp macroexpand type-of From 678a82f266c930957787cabbd8ddd9f6d7d4d55e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 2 Aug 2010 08:49:13 +0900 Subject: [PATCH 498/535] removing type-of from type-inference module --- lib/chibi/type-inference.scm | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/lib/chibi/type-inference.scm b/lib/chibi/type-inference.scm index 137cc251..6b21a230 100644 --- a/lib/chibi/type-inference.scm +++ b/lib/chibi/type-inference.scm @@ -65,17 +65,6 @@ (cons (car a) (lset-adjoin equal? (cdr a) b)))) (else (list 'and a b)))) -(define (type-of x) - (cond ((boolean? x) ) - ((char? x) ) - ((symbol? x) ) - ((string? x) ) - ((and (integer? x) (exact? x)) ) - ((flonum? x) ) - ((pair? x) ) - ((vector? x) ) - (else ))) - (define (lambda-param-types-initialize! f) (lambda-param-types-set! f (map (lambda (p) (list 'param-type f p)) (lambda-params f)))) From e5c3c7a4134ae5ec4f1c0d5f043d665c02f8050f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 11 Aug 2010 22:33:21 +0900 Subject: [PATCH 499/535] adding join-timeout-exception? --- lib/chibi/ast.c | 5 +++++ lib/chibi/ast.module | 6 ++++-- lib/srfi/18.module | 1 + lib/srfi/18/interface.scm | 10 ++++++++++ 4 files changed, 20 insertions(+), 2 deletions(-) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 32cbc1e7..8d946273 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -187,6 +187,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_type(ctx, "", SEXP_LIT); sexp_define_type(ctx, "", SEXP_SYNCLO); sexp_define_type(ctx, "", SEXP_CONTEXT); + sexp_define_type(ctx, "", SEXP_EXCEPTION); sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV); sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE); sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); @@ -201,6 +202,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE); sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT); + sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); sexp_define_accessors(ctx, env, SEXP_PAIR, 2, "pair-source", "pair-source-set!"); sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); @@ -228,6 +230,9 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 1, "procedure-code", "procedure-code-set!"); sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 2, "procedure-vars", "procedure-vars-set!"); sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-name", "bytecode-name-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", "exception-kind-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", "exception-message-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 2, "exception-irritants", "exception-irritants-set!"); sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE); sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index 711da431..a439bd57 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -5,10 +5,10 @@ - + pair-source pair-source-set! syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? - environment? bytecode? exception? macro? context? + environment? bytecode? exception? macro? context? exception? syntactic-closure-expr syntactic-closure-env syntactic-closure-vars lambda-name lambda-params lambda-body lambda-defs lambda-locals lambda-flags lambda-free-vars lambda-set-vars lambda-return-type @@ -22,6 +22,8 @@ set-var set-value set-var-set! set-value-set! ref-name ref-cell ref-name-set! ref-cell-set! seq-ls seq-ls-set! lit-value lit-value-set! + exception-kind exception-kind-set! exception-message exception-message-set! + exception-irritants exception-irritants-set! opcode-name opcode-num-params opcode-return-type opcode-param-type opcode-variadic? procedure-code procedure-vars procedure-name bytecode-name) diff --git a/lib/srfi/18.module b/lib/srfi/18.module index 930e800e..3ed564f8 100644 --- a/lib/srfi/18.module +++ b/lib/srfi/18.module @@ -17,6 +17,7 @@ uncaught-exception-reason) (import-immutable (scheme) (srfi 9) + (chibi ast) (chibi time)) (include-shared "18/threads") (include "18/types.scm" "18/interface.scm")) diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm index 7dde92aa..3757c0b5 100644 --- a/lib/srfi/18/interface.scm +++ b/lib/srfi/18/interface.scm @@ -37,3 +37,13 @@ (define current-time get-time-of-day) (define time? timeval?) + +(define (join-timeout-exception? x) + (and (exception? x) + (equal? (exception-message x) "timed out waiting for thread"))) + +;; flush out exception types +(define (abandoned-mutex-exception? x) #f) +(define (terminated-thread-exception? x) #f) +(define (uncaught-exception? x) #f) +(define (uncaught-exception-reason x) #f) From 9f69f1b4258254d49c02c389fc40011043da9d36 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 12 Aug 2010 08:53:26 +0900 Subject: [PATCH 500/535] working on handling signals via threads --- eval.c | 6 +++++- include/chibi/sexp.h | 1 + lib/chibi/process.module | 1 + lib/chibi/process.stub | 1 + lib/chibi/signal.c | 44 ++++++++++++++++++++++++++-------------- lib/srfi/18/threads.c | 32 ++++++++++++++++++++++++++++- tools/genstubs.scm | 5 +++++ 7 files changed, 73 insertions(+), 17 deletions(-) diff --git a/eval.c b/eval.c index db81b9b0..272a7cd1 100644 --- a/eval.c +++ b/eval.c @@ -349,6 +349,7 @@ void sexp_init_eval_context_globals (sexp ctx) { #if SEXP_USE_GREEN_THREADS sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL; sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO; #endif sexp_gc_release3(ctx); } @@ -1599,7 +1600,10 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); #endif #if SEXP_USE_UTF8_STRINGS - sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "utf-8", -1)); +#endif +#if SEXP_USE_GREEN_THREADS + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "threads", -1)); #endif sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 11d9e0f7..dd3de98d 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -879,6 +879,7 @@ enum sexp_context_globals { SEXP_G_THREADS_BACK, SEXP_G_THREADS_PAUSED, SEXP_G_THREADS_LOCAL, + SEXP_G_THREADS_SIGNALS, #endif SEXP_G_NUM_GLOBALS }; diff --git a/lib/chibi/process.module b/lib/chibi/process.module index fe03c2e5..372b56e4 100644 --- a/lib/chibi/process.module +++ b/lib/chibi/process.module @@ -13,5 +13,6 @@ signal/stop signal/tty-stop signal/tty-input signal/tty-output) (import-immutable (scheme)) + (cond-expand (threads (import (srfi 18))) (else #f)) (include-shared "process")) diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub index 44f27953..93b08d95 100644 --- a/lib/chibi/process.stub +++ b/lib/chibi/process.stub @@ -70,3 +70,4 @@ (define-c void exit (int)) (define-c int (execute execvp) (string (array string))) +(c-init "sexp_init_signals(ctx, env);") diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c index ea23929f..ee82bb6c 100644 --- a/lib/chibi/signal.c +++ b/lib/chibi/signal.c @@ -1,40 +1,42 @@ -/* signal.c -- process signals interface */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #define SEXP_MAX_SIGNUM 32 static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM]; +static struct sigaction call_sigaction, call_sigdefault, call_sigignore; + static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { - sexp ctx, sigctx, handler; + sexp ctx; +#if ! SEXP_USE_GREEN_THREADS + sexp sigctx, handler; sexp_gc_var1(args); +#endif ctx = sexp_signal_contexts[signum]; if (ctx) { +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = + (sexp) ((sexp_uint_t)sexp_global(ctx, SEXP_G_THREADS_SIGNALS) + | (sexp_uint_t)sexp_make_fixnum(signum)); +#else handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), sexp_make_fixnum(signum)); - if (sexp_truep(handler)) { + if (sexp_applicablep(handler)) { sigctx = sexp_make_child_context(ctx, NULL); sexp_gc_preserve1(sigctx, args); args = sexp_cons(sigctx, SEXP_FALSE, SEXP_NULL); sexp_car(args) = sexp_make_cpointer(sigctx, sexp_siginfo_t_type_id, info, SEXP_FALSE, 0); - args = sexp_cons(sigctx, SEXP_FALSE, args); - sexp_car(args) = sexp_make_fixnum(signum); + args = sexp_cons(sigctx, sexp_make_fixnum(signum), args); sexp_apply(sigctx, handler, args); sexp_gc_release1(sigctx); } +#endif } } -static struct sigaction call_sigaction = { - .sa_sigaction = sexp_call_sigaction, - .sa_flags = SA_SIGINFO | SA_NODEFER -}; - -static struct sigaction call_sigdefault = {.sa_handler = SIG_DFL}; -static struct sigaction call_sigignore = {.sa_handler = SIG_IGN}; - static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newaction) { int res; sexp oldaction; @@ -60,3 +62,15 @@ static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newac return oldaction; } +static void sexp_init_signals (sexp ctx, sexp env) { + call_sigaction.sa_sigaction = sexp_call_sigaction; +#if SEXP_USE_GREEN_THREADS + call_sigaction.sa_flags = SA_SIGINFO /* | SA_NODEFER */; + sigfillset(&call_sigaction.sa_mask); +#else + call_sigaction.sa_flags = SA_SIGINFO | SA_NODEFER; +#endif + call_sigdefault.sa_handler = SIG_DFL; + call_sigignore.sa_handler = SIG_IGN; + memset(sexp_signal_contexts, 0, sizeof(sexp_signal_contexts)); +} diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index 046d8bf4..b638b1d9 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -264,12 +264,41 @@ void sexp_wait_on_single_thread (sexp ctx) { usleep(usecs); } +static const sexp_uint_t sexp_log2_lookup[32] = { + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 +}; + +/* only works on powers of two */ +static sexp_uint_t sexp_log2_of_pow2 (sexp_uint_t n) { + return sexp_log2_lookup[(n * 0x077CB531U) >> 27]; +} + sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { struct timeval tval; - sexp res, ls1, ls2, tmp, paused, front=sexp_global(ctx, SEXP_G_THREADS_FRONT); + int allsigs, restsigs, signum; + sexp res, ls1, ls2, handler, paused, front; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + front = sexp_global(ctx, SEXP_G_THREADS_FRONT); paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); + /* run signal handlers */ + while (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) { + allsigs = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS)); + restsigs = allsigs & (allsigs-1); + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = sexp_make_fixnum(restsigs); + signum = sexp_log2_of_pow2(allsigs-restsigs); + handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), + sexp_make_fixnum(signum)); + if (sexp_applicablep(handler)) { + tmp = sexp_cons(ctx, SEXP_FALSE, SEXP_NULL); + tmp = sexp_cons(ctx, sexp_make_fixnum(signum), tmp); + sexp_apply(ctx, handler, tmp); + } + } + /* if we've terminated, check threads joining us */ if (sexp_context_refuel(ctx) <= 0) { for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { @@ -351,6 +380,7 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { sexp_context_waitp(res) = 0; } + sexp_gc_release1(ctx); return res; } diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 89900c0d..e75d9a92 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -141,6 +141,7 @@ (define *types* '()) (define *funcs* '()) (define *consts* '()) +(define *inits* '()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; type objects @@ -392,6 +393,9 @@ (define (c-system-include header) (cat "\n#include <" header ">\n")) +(define (c-init x) + (set! *inits* (cons x *inits*))) + (define (parse-struct-like ls) (let lp ((ls ls) (res '())) (cond @@ -1249,6 +1253,7 @@ (for-each write-const *consts*) (for-each write-type *types*) (for-each write-func-binding *funcs*) + (for-each (lambda (x) (cat " " x "\n")) (reverse *inits*)) (cat " sexp_gc_release2(ctx);\n" " return SEXP_VOID;\n" "}\n\n")) From 9d4203f6132245a960a0886ff4ba022daaeb9adc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Aug 2010 16:08:34 +0900 Subject: [PATCH 501/535] incorporating cygwin patches from john cowan: * makefile rules for cygwin * forcing function versions of tolower/isalpha/etc. --- Makefile | 14 ++++++++++++++ include/chibi/sexp.h | 5 +++++ lib/srfi/69/hash.c | 2 +- main.c | 4 ++-- sexp.c | 2 +- 5 files changed, 23 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 79d6aae4..ac5e7c9b 100644 --- a/Makefile +++ b/Makefile @@ -36,10 +36,16 @@ PLATFORM=mingw SOLIBDIR = $(BINDIR) DIFFOPTS = -b else +ifeq ($(shell uname -o),Cygwin) +PLATFORM=cygwin +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else PLATFORM=unix endif endif endif +endif ifeq ($(PLATFORM),macosx) SO = .dylib @@ -57,12 +63,20 @@ LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a STATICFLAGS = -DSEXP_USE_DL=0 LIBDL = else +ifeq ($(PLATFORM),cygwin) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +else SO = .so EXE = CLIBFLAGS = -fPIC -shared STATICFLAGS = -static -DSEXP_USE_DL=0 endif endif +endif ifeq ($(USE_BOEHM),1) SEXP_USE_BOEHM = 1 diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index dd3de98d..39a3ea58 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -129,6 +129,11 @@ typedef unsigned int sexp_tag_t; typedef unsigned long sexp_uint_t; typedef long sexp_sint_t; #define sexp_heap_align(n) sexp_align(n, 5) +#elif __CYGWIN__ +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) #else typedef unsigned short sexp_tag_t; typedef unsigned int sexp_uint_t; diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c index e739ff1c..42d1e864 100644 --- a/lib/srfi/69/hash.c +++ b/lib/srfi/69/hash.c @@ -34,7 +34,7 @@ static sexp sexp_string_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { sexp_uint_t acc = FNV_OFFSET_BASIS; - while (*str) {acc *= FNV_PRIME; acc ^= tolower(*str++);} + while (*str) {acc *= FNV_PRIME; acc ^= (tolower)(*str++);} return acc % bound; } diff --git a/main.c b/main.c index 03caf762..d07a9767 100644 --- a/main.c +++ b/main.c @@ -163,8 +163,8 @@ void run_main (int argc, char **argv) { check_nonull_arg('h', arg); heap_size = atol(arg); len = strlen(arg); - if (heap_size && isalpha(arg[len-1])) { - switch (tolower(arg[len-1])) { + if (heap_size && (isalpha)(arg[len-1])) { + switch ((tolower)(arg[len-1])) { case 'k': heap_size *= 1024; break; case 'm': heap_size *= (1024*1024); break; } diff --git a/sexp.c b/sexp.c index 5f38669a..8a6f0079 100644 --- a/sexp.c +++ b/sexp.c @@ -1659,7 +1659,7 @@ 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[1]) && isxdigit(str[2]) && str[3] == '\0') { + (isxdigit)(str[1]) && (isxdigit)(str[2]) && str[3] == '\0') { res = sexp_make_character(16 * digit_value(str[1]) + digit_value(str[2])); } else { From f401156d280cfa759cadd6e6dfec70e1f091948b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Aug 2010 16:13:40 +0900 Subject: [PATCH 502/535] adding dist-clean target which removes .stub generated .c files --- Makefile | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index ac5e7c9b..11cb4d03 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ # -*- makefile-gmake -*- -.PHONY: all libs doc dist clean cleaner test install uninstall +.PHONY: all libs doc dist clean cleaner dist-clean test install uninstall .PRECIOUS: %.c # install configuration @@ -162,6 +162,9 @@ cleaner: clean rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h rm -rf *.dSYM +dist-clean: cleaner + for f in `find lib -name \*.stub`; do rm -f $${f%.stub}.c; done + test-basic: chibi-scheme$(EXE) @for f in tests/basic/*.scm; do \ LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ @@ -227,14 +230,14 @@ uninstall: cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h rm -rf $(DESTDIR)$(MODDIR) -dist: cleaner +dist: dist-clean 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` -mips-dist: cleaner +mips-dist: dist-clean rm -f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz mkdir chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` for f in `hg manifest`; do mkdir -p chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/$$f; done From f49b4ccfc0bbebf7af8448e90758e78d77cef2ef Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Aug 2010 16:49:31 +0900 Subject: [PATCH 503/535] specifying -DSEXP_USE_STRING_STREAMS=0 for cygwin --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 11cb4d03..8cfdb266 100644 --- a/Makefile +++ b/Makefile @@ -68,7 +68,7 @@ SO = .dll EXE = .exe CC = gcc CLIBFLAGS = -shared -LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +LDFLAGS += -DSEXP_USE_STRING_STREAMS=0 -Wl,--out-implib,libchibi-scheme$(SO).a else SO = .so EXE = From 32f835e5f2358411ed4a2f5514ad1d541febb615 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Aug 2010 16:51:33 +0900 Subject: [PATCH 504/535] previous setting was in wrong place --- Makefile | 5 +++-- lib/chibi/repl.module | 3 ++- lib/chibi/term/edit-line.scm | 4 ++++ lib/srfi/38.scm | 2 +- 4 files changed, 10 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 8cfdb266..131a73d2 100644 --- a/Makefile +++ b/Makefile @@ -58,7 +58,7 @@ SO = .dll EXE = .exe CC = gcc CLIBFLAGS = -shared -CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL -DSEXP_USE_DEBUG=0 +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a STATICFLAGS = -DSEXP_USE_DL=0 LIBDL = @@ -68,7 +68,8 @@ SO = .dll EXE = .exe CC = gcc CLIBFLAGS = -shared -LDFLAGS += -DSEXP_USE_STRING_STREAMS=0 -Wl,--out-implib,libchibi-scheme$(SO).a +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a else SO = .so EXE = diff --git a/lib/chibi/repl.module b/lib/chibi/repl.module index 5c1035a7..405d9a0e 100644 --- a/lib/chibi/repl.module +++ b/lib/chibi/repl.module @@ -2,5 +2,6 @@ (define-module (chibi repl) (export repl) (import-immutable (scheme)) - (import (chibi process)) + (import (chibi process) + (chibi term edit-line)) (include "repl.scm")) diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm index cd8fd376..c3b022ea 100644 --- a/lib/chibi/term/edit-line.scm +++ b/lib/chibi/term/edit-line.scm @@ -1,3 +1,7 @@ +;;;; edit-line.scm - pure scheme line editing tool +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; vt100 terminal utilities diff --git a/lib/srfi/38.scm b/lib/srfi/38.scm index 62650ddb..a5149b4d 100644 --- a/lib/srfi/38.scm +++ b/lib/srfi/38.scm @@ -197,7 +197,7 @@ (if (memv (peek-char in) delimiters) c (read-named-char c in)))) - (else ; last resort + (else (error "unknown # syntax: " (peek-char in))))) ((#\() (read-char in) From 4bd9c0a3a7729d0016d14f31a370856307ec64ef Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Aug 2010 17:03:46 +0900 Subject: [PATCH 505/535] fixing srfi-27 build for cygwin --- include/chibi/sexp.h | 2 +- lib/srfi/27/rand.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 39a3ea58..d13c2c64 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -129,7 +129,7 @@ typedef unsigned int sexp_tag_t; typedef unsigned long sexp_uint_t; typedef long sexp_sint_t; #define sexp_heap_align(n) sexp_align(n, 5) -#elif __CYGWIN__ +#elif defined(__CYGWIN__) typedef unsigned short sexp_tag_t; typedef unsigned int sexp_uint_t; typedef int sexp_sint_t; diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index d70f8726..6e971df8 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -19,7 +19,7 @@ SEXP_RANDOM_STATE_SIZE, \ sexp_random_data(x)) -#if SEXP_BSD +#if SEXP_BSD || defined(__CYGWIN__) typedef unsigned int sexp_random_t; #define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs))) #define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n) @@ -85,7 +85,7 @@ static sexp sexp_random_real (sexp ctx sexp_api_params(self, n)) { return sexp_rs_random_real(ctx sexp_api_pass(self, n), default_random_source); } -#if SEXP_BSD +#if SEXP_BSD || defined(__CYGWIN__) static sexp sexp_make_random_source (sexp ctx sexp_api_params(self, n)) { sexp res; From ec8b97656470f5b5a62e4eb9bd5d2f995e417342 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Aug 2010 17:28:21 +0900 Subject: [PATCH 506/535] simplifying sexp_check_exception in vm --- vm.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/vm.c b/vm.c index 94ef207f..afd18f7f 100644 --- a/vm.c +++ b/vm.c @@ -486,8 +486,6 @@ static sexp_uint_t sexp_restore_stack (sexp saved, sexp *current) { #define sexp_check_exception() \ do {if (sexp_exceptionp(_ARG1)) { \ - if (! sexp_exception_procedure(_ARG1)) \ - sexp_exception_procedure(_ARG1) = self; \ goto call_error_handler;}} \ while (0) @@ -550,8 +548,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { switch (*ip++) { case SEXP_OP_NOOP: break; - case SEXP_OP_RAISE: call_error_handler: + if (! sexp_exception_procedure(_ARG1)) + sexp_exception_procedure(_ARG1) = self; + case SEXP_OP_RAISE: tmp1 = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); sexp_context_last_fp(ctx) = fp; if (! sexp_procedurep(tmp1)) goto end_loop; From 710a6b48aa9c03575355b44d32976a50c1fbc324 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Aug 2010 19:09:07 +0900 Subject: [PATCH 507/535] signal handlers now run in a separate thread --- eval.c | 1 + include/chibi/sexp.h | 2 ++ lib/chibi/signal.c | 2 +- lib/srfi/18/interface.scm | 16 ++++++++++- lib/srfi/18/threads.c | 59 ++++++++++++++++++++++++++++----------- sexp.c | 5 +++- 6 files changed, 66 insertions(+), 19 deletions(-) diff --git a/eval.c b/eval.c index 272a7cd1..5fe9e2bc 100644 --- a/eval.c +++ b/eval.c @@ -350,6 +350,7 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL; sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO; + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = SEXP_FALSE; #endif sexp_gc_release3(ctx); } diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index d13c2c64..a8e67513 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -885,6 +885,7 @@ enum sexp_context_globals { SEXP_G_THREADS_PAUSED, SEXP_G_THREADS_LOCAL, SEXP_G_THREADS_SIGNALS, + SEXP_G_THREADS_SIGNAL_RUNNER, #endif SEXP_G_NUM_GLOBALS }; @@ -942,6 +943,7 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); #endif #define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) +#define sexp_at_eofp(p) (feof(sexp_port_stream(p))) SEXP_API sexp sexp_make_context(sexp ctx, size_t size); SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c index ee82bb6c..37fce4c2 100644 --- a/lib/chibi/signal.c +++ b/lib/chibi/signal.c @@ -19,7 +19,7 @@ static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { #if SEXP_USE_GREEN_THREADS sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = (sexp) ((sexp_uint_t)sexp_global(ctx, SEXP_G_THREADS_SIGNALS) - | (sexp_uint_t)sexp_make_fixnum(signum)); + | (sexp_uint_t)sexp_make_fixnum(1UL<> 27]; } +static sexp sexp_pop_signal (sexp ctx sexp_api_params(self, n)) { + int allsigs, restsigs, signum; + if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) == SEXP_ZERO) { + return SEXP_FALSE; + } else { + allsigs = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS)); + restsigs = allsigs & (allsigs-1); + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = sexp_make_fixnum(restsigs); + signum = sexp_log2_of_pow2(allsigs-restsigs); + return sexp_make_fixnum(signum); + } +} + +static sexp sexp_get_signal_handler (sexp ctx sexp_api_params(self, n), sexp signum) { + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, signum); + return sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); +} + sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { struct timeval tval; - int allsigs, restsigs, signum; - sexp res, ls1, ls2, handler, paused, front; + sexp res, ls1, ls2, runner, paused, front; sexp_gc_var1(tmp); sexp_gc_preserve1(ctx, tmp); front = sexp_global(ctx, SEXP_G_THREADS_FRONT); paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); - /* run signal handlers */ - while (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) { - allsigs = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS)); - restsigs = allsigs & (allsigs-1); - sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = sexp_make_fixnum(restsigs); - signum = sexp_log2_of_pow2(allsigs-restsigs); - handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), - sexp_make_fixnum(signum)); - if (sexp_applicablep(handler)) { - tmp = sexp_cons(ctx, SEXP_FALSE, SEXP_NULL); - tmp = sexp_cons(ctx, sexp_make_fixnum(signum), tmp); - sexp_apply(ctx, handler, tmp); + /* check for signals */ + if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) { + runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER); + if (! sexp_contextp(runner)) { /* ensure the runner exists */ + if (sexp_envp(runner)) { + tmp = sexp_env_cell(runner, (tmp=sexp_intern(ctx, "signal-runner", -1))); + if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) { + runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE); + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner; + sexp_thread_start(ctx, self, 1, runner); + } + } + } else if (sexp_context_waitp(runner)) { /* wake it if it's sleeping */ + sexp_context_waitp(runner) = 0; + sexp_thread_start(ctx, self, 1, runner); } } @@ -404,10 +426,15 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "%mutex-unlock!", 3, sexp_mutex_unlock); sexp_define_foreign(ctx, env, "condition-variable-signal!", 1, sexp_condition_variable_signal); sexp_define_foreign(ctx, env, "condition-variable-broadcast!", 1, sexp_condition_variable_broadcast); + sexp_define_foreign(ctx, env, "pop-signal!", 0, sexp_pop_signal); + sexp_define_foreign(ctx, env, "get-signal-handler", 1, sexp_get_signal_handler); sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) = sexp_make_foreign(ctx, "scheduler", 0, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); + /* remember the env to lookup the runner later */ + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env; + return SEXP_VOID; } diff --git a/sexp.c b/sexp.c index 8a6f0079..c7ae13ec 100644 --- a/sexp.c +++ b/sexp.c @@ -1512,7 +1512,10 @@ sexp sexp_read_raw (sexp ctx, sexp in) { scan_loop: switch (c1 = sexp_read_char(ctx, in)) { case EOF: - res = SEXP_EOF; + if (sexp_at_eofp(in)) + res = SEXP_EOF; + else + goto scan_loop; break; case ';': while ((c1 = sexp_read_char(ctx, in)) != EOF) From 98681871c4dca481d65552c499dda969b5c0d4d8 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 16 Aug 2010 15:14:00 +0000 Subject: [PATCH 508/535] fixing scheduling of threads generated by eval --- eval.c | 2 ++ include/chibi/sexp.h | 3 ++- lib/chibi/signal.c | 4 ++-- lib/srfi/18/threads.c | 27 ++++----------------------- sexp.c | 2 +- vm.c | 13 ++++++++++--- 6 files changed, 21 insertions(+), 30 deletions(-) diff --git a/eval.c b/eval.c index 5fe9e2bc..c0c7e166 100644 --- a/eval.c +++ b/eval.c @@ -1728,9 +1728,11 @@ sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = SEXP_FALSE; ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0); + sexp_context_child(ctx) = ctx2; res = sexp_compile(ctx2, obj); if (! sexp_exceptionp(res)) res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_context_child(ctx) = SEXP_FALSE; sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; sexp_context_top(ctx) = top; sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index a8e67513..7484d9c6 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -337,7 +337,7 @@ struct sexp_struct { #endif char tailp, tracep, timeoutp, waitp; sexp_uint_t pos, depth, last_fp; - sexp bc, lambda, stack, env, fv, parent, globals, + sexp bc, lambda, stack, env, fv, parent, child, globals, proc, name, specific, event; } context; } value; @@ -746,6 +746,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #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_child(x) ((x)->value.context.child) #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.tracep) diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c index 37fce4c2..7202d96e 100644 --- a/lib/chibi/signal.c +++ b/lib/chibi/signal.c @@ -65,10 +65,10 @@ static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newac static void sexp_init_signals (sexp ctx, sexp env) { call_sigaction.sa_sigaction = sexp_call_sigaction; #if SEXP_USE_GREEN_THREADS - call_sigaction.sa_flags = SA_SIGINFO /* | SA_NODEFER */; + call_sigaction.sa_flags = SA_SIGINFO | SA_RESTART /* | SA_NODEFER */; sigfillset(&call_sigaction.sa_mask); #else - call_sigaction.sa_flags = SA_SIGINFO | SA_NODEFER; + call_sigaction.sa_flags = SA_SIGINFO | SA_RESTART | SA_NODEFER; #endif call_sigdefault.sa_handler = SIG_DFL; call_sigignore.sa_handler = SIG_IGN; diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index 970af517..b84d59f4 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -84,30 +84,11 @@ sexp sexp_thread_start (sexp ctx sexp_api_params(self, n), sexp thread) { } sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) { - sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_FRONT); - sexp_context_refuel(thread) = 0; - for ( ; sexp_pairp(ls2) && (sexp_car(ls2) != thread); ls2=sexp_cdr(ls2)) - ls1 = ls2; - if (sexp_pairp(ls2)) { - if (ls1 == SEXP_NULL) - sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(ls2); - else /* splice */ - sexp_cdr(ls1) = sexp_cdr(ls2); - if (ls2 == sexp_global(ctx, SEXP_G_THREADS_BACK)) - sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1; - } else { /* check for paused threads */ - ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); - for ( ; sexp_pairp(ls2) && (sexp_car(ls2) != thread); ls2=sexp_cdr(ls2)) - ls1 = ls2; - if (sexp_pairp(ls2)) { - if (ls1 == SEXP_NULL) - sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); - else /* splice */ - sexp_cdr(ls1) = sexp_cdr(ls2); - } - } + sexp res = sexp_make_boolean(ctx == thread); + for ( ; thread && sexp_contextp(thread); thread=sexp_context_child(thread)) + sexp_context_refuel(thread) = 0; /* return true if terminating self */ - return sexp_make_boolean(ctx == thread); + return res; } static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { diff --git a/sexp.c b/sexp.c index c7ae13ec..db4c91fe 100644 --- a/sexp.c +++ b/sexp.c @@ -114,7 +114,7 @@ static struct sexp_type_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, "sequence", NULL), _DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, "literal", NULL), _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack", NULL), - _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 11, 11, 0, 0, sexp_sizeof(context), 0, 0, "context", NULL), + _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 12, 12, 0, 0, sexp_sizeof(context), 0, 0, "context", NULL), }; #undef _DEF_TYPE diff --git a/vm.c b/vm.c index afd18f7f..acbea8b2 100644 --- a/vm.c +++ b/vm.c @@ -536,6 +536,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { cp = sexp_procedure_vars(self); } fuel = sexp_context_refuel(ctx); + if (fuel <= 0) goto end_loop; } #endif #if SEXP_USE_DEBUG_VM @@ -1334,9 +1335,15 @@ sexp sexp_vm (sexp ctx, sexp proc) { end_loop: #if SEXP_USE_GREEN_THREADS - if (ctx != root_thread) { /* don't return from child threads */ - sexp_context_refuel(ctx) = fuel = 0; - goto loop; + if (ctx != root_thread) { + if (sexp_context_refuel(root_thread) <= 0) { + /* the root already terminated */ + _ARG1 = SEXP_VOID; + } else { + /* don't return from child threads */ + sexp_context_refuel(ctx) = fuel = 0; + goto loop; + } } #endif sexp_gc_release3(ctx); From 02b888b438d1efaba7620fcc4b2e8e2d3feaf917 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 16 Aug 2010 15:14:30 +0000 Subject: [PATCH 509/535] chibi.repl uses edit-line, catches interrupts --- lib/chibi/repl.module | 6 ++- lib/chibi/repl.scm | 89 +++++++++++++++--------------------- lib/chibi/term/edit-line.scm | 16 +++++-- 3 files changed, 52 insertions(+), 59 deletions(-) diff --git a/lib/chibi/repl.module b/lib/chibi/repl.module index 405d9a0e..742b9581 100644 --- a/lib/chibi/repl.module +++ b/lib/chibi/repl.module @@ -2,6 +2,8 @@ (define-module (chibi repl) (export repl) (import-immutable (scheme)) - (import (chibi process) - (chibi term edit-line)) + (import (chibi ast) + (chibi process) + (chibi term edit-line) + (srfi 18)) (include "repl.scm")) diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm index 307b0253..b7ff79bc 100644 --- a/lib/chibi/repl.scm +++ b/lib/chibi/repl.scm @@ -1,58 +1,41 @@ +;;;; repl.scm - friendlier repl with line editing and signal handling +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-syntax handle-exceptions + (syntax-rules () + ((handle-exceptions exn handler expr) + (call-with-current-continuation + (lambda (return) + (with-exception-handler (lambda (exn) (return handler)) + (lambda () expr))))))) + +(define (with-signal-handler sig handler thunk) + (let ((old-handler #f)) + (dynamic-wind + (lambda () (set! old-handler (set-signal-action! sig handler))) + thunk + (lambda () (set-signal-action! sig old-handler))))) (define (run-repl module env) - (if module (display module)) - (display "> ") - (flush-output) - (let lp () - (let ((ch (peek-char))) - (cond ((eof-object? ch) - (exit 0)) - ((and (char? ch) (char-whitespace? ch)) - (read-char) - (lp))))) - (cond - ((eq? #\@ (peek-char)) - (read-char) - (let ((sym (read))) - (if (not (symbol? sym)) - (error "repl: invalid @ syntax: @" sym) - (case sym - ((config) - (let ((res (eval (read) *config-env*))) - (cond - ((not (eq? res (if #f #f))) - (write res) - (newline))) - (run-repl module env))) - ((in) - (let ((mod (read))) - (if (or (not mod) (equal? mod '(scheme))) - (run-repl #f (interaction-environment)) - (let ((env (eval `(module-env (load-module ',mod)) - *config-env*))) - (run-repl mod env))))) - (else - (error "repl: unknown @ escape" sym)))))) - (else - (let ((expr (read))) - (cond - ((eof-object? expr) - (exit 0)) - (else - (let ((res (eval expr env))) - (cond - ((not (eq? res (if #f #f))) - (write res) - (newline))) - (run-repl module env)))))))) + (let ((line (edit-line (if module (string-append (symbol->string module) "> ") "> ")))) + (cond + ((or (not line) (eof-object? line))) + ((equal? line "") (run-repl module env)) + (else + (handle-exceptions exn (print-exception exn (current-error-port)) + (let* ((expr (call-with-input-string line read)) + (thread (make-thread (lambda () + (let ((res (eval expr env))) + (if (not (eq? res (if #f #f))) + (write res))))))) + (with-signal-handler + signal/interrupt + (lambda (n) (thread-terminate! thread)) + (lambda () (thread-start! thread) (thread-join! thread))))) + (newline) + (run-repl module env))))) (define (repl) - (set-signal-action! signal/interrupt - (lambda (n info) - (newline) - (run-repl #f (interaction-environment)))) - (current-exception-handler - (lambda (exn) - (print-exception exn (current-error-port)) - (run-repl #f (interaction-environment)))) (run-repl #f (interaction-environment))) diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm index c3b022ea..1c985919 100644 --- a/lib/chibi/term/edit-line.scm +++ b/lib/chibi/term/edit-line.scm @@ -367,7 +367,12 @@ (buffer-goto! buf out (- (buffer-pos buf) 1))) (define (command/forward-delete-char ch buf out return) - (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1))) + (cond + ((zero? (- (buffer-length buf) (buffer-min buf))) + (newline out) + (return 'eof)) + (else + (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1))))) (define (command/backward-delete-char ch buf out return) (buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf))) @@ -443,7 +448,7 @@ (let* ((width (or terminal-width (get-terminal-width out))) (buf (make-buffer)) (done? #f) - (return (lambda o (set! done? #t)))) + (return (lambda o (set! done? (if (pair? o) (car o) #t))))) (buffer-refresh?-set! buf #t) (buffer-width-set! buf width) (buffer-insert! buf out prompt) @@ -457,7 +462,8 @@ (let lp ((kmap keymap)) (let ((ch (read-char in))) (if (eof-object? ch) - (buffer->string buf) + (let ((res (buffer->string buf))) + (if (equal? res "") ch res)) (let ((x (keymap-lookup kmap (char->integer ch)))) (cond ((keymap? x) @@ -465,7 +471,9 @@ ((procedure? x) (x ch buf out return) (buffer-refresh buf out) - (if done? (buffer->string buf) (lp keymap))) + (if done? + (and (not (eq? done? 'eof)) (buffer->string buf)) + (lp keymap))) (else ;;(command/beep ch buf out return) (lp keymap))))))))))))) From 2449b97341dc44ba63d134b553ad3001b6dc7667 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 17 Aug 2010 00:17:50 +0900 Subject: [PATCH 510/535] defining off64_t as off_t for cygwin --- lib/chibi/io/port.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c index 947f3400..6aa6403a 100644 --- a/lib/chibi/io/port.c +++ b/lib/chibi/io/port.c @@ -86,6 +86,11 @@ static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size } #if ! SEXP_BSD + +#ifdef __CYGWIN__ +#define off64_t off_t +#endif + static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) { sexp vec = (sexp)cookie, ctx, res; if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1; From bddaed32955b7f841c3bb93ee1a1f2f2bb1bc546 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 17 Aug 2010 20:46:12 +0900 Subject: [PATCH 511/535] removing redundant sexp_heap_align definition --- .hgignore | 30 + AUTHORS | 29 + COPYING | 24 + Makefile | 246 ++++ README | 440 ++++++ RELEASE | 1 + TODO | 165 +++ VERSION | 1 + chibi-scheme.vcproj | 206 +++ doc/chibi-scheme.1 | 133 ++ eval.c | 1758 ++++++++++++++++++++++ gc.c | 346 +++++ include/chibi/bignum.h | 43 + include/chibi/eval.h | 203 +++ include/chibi/features.h | 469 ++++++ include/chibi/sexp.h | 1065 ++++++++++++++ lib/chibi/ast.c | 248 ++++ lib/chibi/ast.module | 33 + lib/chibi/ast.scm | 91 ++ lib/chibi/base64.module | 7 + lib/chibi/base64.scm | 351 +++++ lib/chibi/disasm.c | 99 ++ lib/chibi/disasm.module | 5 + lib/chibi/filesystem.module | 27 + lib/chibi/filesystem.scm | 43 + lib/chibi/filesystem.stub | 118 ++ lib/chibi/heap-stats.c | 120 ++ lib/chibi/heap-stats.module | 6 + lib/chibi/io.module | 13 + lib/chibi/io/io.scm | 170 +++ lib/chibi/io/io.stub | 27 + lib/chibi/io/port.c | 201 +++ lib/chibi/loop.module | 9 + lib/chibi/loop/loop.scm | 365 +++++ lib/chibi/match.module | 6 + lib/chibi/match/match.scm | 683 +++++++++ lib/chibi/mime.module | 7 + lib/chibi/mime.scm | 410 ++++++ lib/chibi/modules.module | 8 + lib/chibi/modules.scm | 103 ++ lib/chibi/net.module | 11 + lib/chibi/net.scm | 32 + lib/chibi/net.stub | 25 + lib/chibi/net/http.module | 7 + lib/chibi/net/http.scm | 180 +++ lib/chibi/pathname.module | 7 + lib/chibi/pathname.scm | 180 +++ lib/chibi/process.module | 18 + lib/chibi/process.stub | 73 + lib/chibi/quoted-printable.module | 7 + lib/chibi/quoted-printable.scm | 157 ++ lib/chibi/repl.module | 9 + lib/chibi/repl.scm | 41 + lib/chibi/scribble.module | 5 + lib/chibi/scribble.scm | 247 ++++ lib/chibi/signal.c | 76 + lib/chibi/stty.module | 11 + lib/chibi/stty.scm | 235 +++ lib/chibi/stty.stub | 106 ++ lib/chibi/system.module | 15 + lib/chibi/system.stub | 34 + lib/chibi/term/edit-line.module | 5 + lib/chibi/term/edit-line.scm | 505 +++++++ lib/chibi/test.module | 14 + lib/chibi/test.scm | 662 +++++++++ lib/chibi/time.module | 12 + lib/chibi/time.stub | 46 + lib/chibi/type-inference.module | 7 + lib/chibi/type-inference.scm | 272 ++++ lib/chibi/uri.module | 10 + lib/chibi/uri.scm | 306 ++++ lib/config.scm | 179 +++ lib/init.scm | 875 +++++++++++ lib/srfi/1.module | 31 + lib/srfi/1/alists.scm | 14 + lib/srfi/1/constructors.scm | 36 + lib/srfi/1/deletion.scm | 25 + lib/srfi/1/fold.scm | 115 ++ lib/srfi/1/lset.scm | 51 + lib/srfi/1/misc.scm | 54 + lib/srfi/1/predicates.scm | 42 + lib/srfi/1/search.scm | 54 + lib/srfi/1/selectors.scm | 59 + lib/srfi/11.module | 28 + lib/srfi/16.module | 24 + lib/srfi/18.module | 24 + lib/srfi/18/interface.scm | 63 + lib/srfi/18/threads.c | 421 ++++++ lib/srfi/18/types.scm | 24 + lib/srfi/2.module | 16 + lib/srfi/26.module | 24 + lib/srfi/27.module | 11 + lib/srfi/27/constructors.scm | 10 + lib/srfi/27/rand.c | 204 +++ lib/srfi/33.module | 17 + lib/srfi/33/bit.c | 303 ++++ lib/srfi/33/bitwise.scm | 61 + lib/srfi/38.module | 6 + lib/srfi/38.scm | 255 ++++ lib/srfi/39.module | 25 + lib/srfi/6.module | 5 + lib/srfi/69.module | 17 + lib/srfi/69/hash.c | 242 ++++ lib/srfi/69/interface.scm | 115 ++ lib/srfi/69/type.scm | 12 + lib/srfi/8.module | 10 + lib/srfi/9.module | 90 ++ lib/srfi/95.module | 7 + lib/srfi/95/qsort.c | 228 +++ lib/srfi/95/sort.scm | 70 + lib/srfi/98.module | 5 + lib/srfi/98/env.c | 48 + main.c | 219 +++ mkfile | 28 + opcodes.c | 178 +++ opt/bignum.c | 775 ++++++++++ opt/fcall.c | 33 + opt/opcode_names.h | 21 + opt/plan9-opcodes.c | 19 + opt/plan9.c | 351 +++++ opt/sexp-huff.c | 128 ++ opt/sexp-hufftabs.c | 92 ++ opt/sexp-unhuff.c | 71 + opt/simplify.c | 143 ++ sexp.c | 1842 ++++++++++++++++++++++++ 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 | 48 + tests/basic/test10-unhygiene.res | 6 + tests/basic/test10-unhygiene.scm | 49 + tests/build/build-opts.txt | 21 + tests/build/build-tests.sh | 37 + tests/flonum-tests.scm | 21 + tests/hash-tests.scm | 37 + tests/install/install-tests.pl | 57 + tests/install/run-install-test.sh | 12 + tests/lib-tests.scm | 13 + tests/loop-tests.scm | 168 +++ tests/match-tests.scm | 135 ++ tests/numeric-tests.scm | 120 ++ tests/r5rs-tests.scm | 465 ++++++ tests/sort-tests.scm | 40 + tests/thread-tests.scm | 25 + tools/genstatic.scm | 135 ++ tools/genstubs.scm | 1280 ++++++++++++++++ vm.c | 1391 ++++++++++++++++++ 163 files changed, 23646 insertions(+) create mode 100644 .hgignore create mode 100644 AUTHORS create mode 100644 COPYING create mode 100644 Makefile create mode 100644 README create mode 100644 RELEASE create mode 100644 TODO create mode 100644 VERSION create mode 100644 chibi-scheme.vcproj create mode 100644 doc/chibi-scheme.1 create mode 100644 eval.c create mode 100644 gc.c create mode 100644 include/chibi/bignum.h create mode 100644 include/chibi/eval.h create mode 100644 include/chibi/features.h create mode 100644 include/chibi/sexp.h create mode 100644 lib/chibi/ast.c create mode 100644 lib/chibi/ast.module create mode 100644 lib/chibi/ast.scm create mode 100644 lib/chibi/base64.module create mode 100644 lib/chibi/base64.scm create mode 100644 lib/chibi/disasm.c create mode 100644 lib/chibi/disasm.module create mode 100644 lib/chibi/filesystem.module create mode 100644 lib/chibi/filesystem.scm create mode 100644 lib/chibi/filesystem.stub create mode 100644 lib/chibi/heap-stats.c create mode 100644 lib/chibi/heap-stats.module create mode 100644 lib/chibi/io.module create mode 100644 lib/chibi/io/io.scm create mode 100644 lib/chibi/io/io.stub create mode 100644 lib/chibi/io/port.c create mode 100644 lib/chibi/loop.module create mode 100644 lib/chibi/loop/loop.scm create mode 100644 lib/chibi/match.module create mode 100644 lib/chibi/match/match.scm create mode 100644 lib/chibi/mime.module create mode 100644 lib/chibi/mime.scm create mode 100644 lib/chibi/modules.module create mode 100644 lib/chibi/modules.scm create mode 100644 lib/chibi/net.module create mode 100644 lib/chibi/net.scm create mode 100644 lib/chibi/net.stub create mode 100644 lib/chibi/net/http.module create mode 100644 lib/chibi/net/http.scm create mode 100644 lib/chibi/pathname.module create mode 100644 lib/chibi/pathname.scm create mode 100644 lib/chibi/process.module create mode 100644 lib/chibi/process.stub create mode 100644 lib/chibi/quoted-printable.module create mode 100644 lib/chibi/quoted-printable.scm create mode 100644 lib/chibi/repl.module create mode 100644 lib/chibi/repl.scm create mode 100644 lib/chibi/scribble.module create mode 100644 lib/chibi/scribble.scm create mode 100644 lib/chibi/signal.c create mode 100644 lib/chibi/stty.module create mode 100644 lib/chibi/stty.scm create mode 100644 lib/chibi/stty.stub create mode 100644 lib/chibi/system.module create mode 100644 lib/chibi/system.stub create mode 100644 lib/chibi/term/edit-line.module create mode 100644 lib/chibi/term/edit-line.scm create mode 100644 lib/chibi/test.module create mode 100644 lib/chibi/test.scm create mode 100644 lib/chibi/time.module create mode 100644 lib/chibi/time.stub create mode 100644 lib/chibi/type-inference.module create mode 100644 lib/chibi/type-inference.scm create mode 100644 lib/chibi/uri.module create mode 100644 lib/chibi/uri.scm create mode 100644 lib/config.scm create mode 100644 lib/init.scm create mode 100644 lib/srfi/1.module create mode 100644 lib/srfi/1/alists.scm create mode 100644 lib/srfi/1/constructors.scm create mode 100644 lib/srfi/1/deletion.scm create mode 100644 lib/srfi/1/fold.scm create mode 100644 lib/srfi/1/lset.scm create mode 100644 lib/srfi/1/misc.scm create mode 100644 lib/srfi/1/predicates.scm create mode 100644 lib/srfi/1/search.scm create mode 100644 lib/srfi/1/selectors.scm create mode 100644 lib/srfi/11.module create mode 100644 lib/srfi/16.module create mode 100644 lib/srfi/18.module create mode 100644 lib/srfi/18/interface.scm create mode 100644 lib/srfi/18/threads.c create mode 100644 lib/srfi/18/types.scm create mode 100644 lib/srfi/2.module create mode 100644 lib/srfi/26.module create mode 100644 lib/srfi/27.module create mode 100644 lib/srfi/27/constructors.scm create mode 100644 lib/srfi/27/rand.c create mode 100644 lib/srfi/33.module create mode 100644 lib/srfi/33/bit.c create mode 100644 lib/srfi/33/bitwise.scm create mode 100644 lib/srfi/38.module create mode 100644 lib/srfi/38.scm create mode 100644 lib/srfi/39.module create mode 100644 lib/srfi/6.module create mode 100644 lib/srfi/69.module create mode 100644 lib/srfi/69/hash.c create mode 100644 lib/srfi/69/interface.scm create mode 100644 lib/srfi/69/type.scm create mode 100644 lib/srfi/8.module create mode 100644 lib/srfi/9.module create mode 100644 lib/srfi/95.module create mode 100644 lib/srfi/95/qsort.c create mode 100644 lib/srfi/95/sort.scm create mode 100644 lib/srfi/98.module create mode 100644 lib/srfi/98/env.c create mode 100644 main.c create mode 100644 mkfile create mode 100644 opcodes.c create mode 100644 opt/bignum.c create mode 100644 opt/fcall.c create mode 100644 opt/opcode_names.h create mode 100644 opt/plan9-opcodes.c create mode 100644 opt/plan9.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 opt/simplify.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/build/build-opts.txt create mode 100755 tests/build/build-tests.sh create mode 100644 tests/flonum-tests.scm create mode 100644 tests/hash-tests.scm create mode 100755 tests/install/install-tests.pl create mode 100755 tests/install/run-install-test.sh create mode 100644 tests/lib-tests.scm create mode 100644 tests/loop-tests.scm create mode 100644 tests/match-tests.scm create mode 100644 tests/numeric-tests.scm create mode 100644 tests/r5rs-tests.scm create mode 100644 tests/sort-tests.scm create mode 100644 tests/thread-tests.scm create mode 100755 tools/genstatic.scm create mode 100755 tools/genstubs.scm create mode 100644 vm.c diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..e8b8b309 --- /dev/null +++ b/.hgignore @@ -0,0 +1,30 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dylib +*.class +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +clibs.c +chibi-scheme +chibi-scheme-static +include/chibi/install.h +lib/chibi/filesystem.c +lib/chibi/io/io.c +lib/chibi/net.c +lib/chibi/process.c +lib/chibi/system.c +lib/chibi/time.c +lib/chibi/stty.c diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 00000000..fc0b8224 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,29 @@ +Alex Shinn wrote the initial version of chibi-scheme and all +distributed modules. + +The `dynamic-wind' implementation is adapted from the implementation +in the appendix to the Scheme48 reference manual, reportedly first +written by Chris Hanson and John Lamping. + +Thanks to the following people for patches and bug reports: + + * Alexander Shendi + * Andreas Rottman + * Bruno Deferrari + * Derrick Eddington + * Eduardo Cavazos + * Felix Winkelmann + * Gregor Klinke + * Jeremy Wolff + * Jeronimo Pellegrini + * John Cowan + * John Samsa + * Lars J Aas + * Lorenzo Campedelli + * Michal Kowalski (sladegen) + * Taylor Venable + +If you would prefer not to be listed, or are one of the users listed +without a full name, please contact me. If you've made a contribution +and are not listed, please accept my apologies and contact me +immediately! diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..1fcee28e --- /dev/null +++ b/COPYING @@ -0,0 +1,24 @@ +Copyright (c) 2009 Alex Shinn +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..131a73d2 --- /dev/null +++ b/Makefile @@ -0,0 +1,246 @@ +# -*- makefile-gmake -*- + +.PHONY: all libs doc dist clean cleaner dist-clean test install uninstall +.PRECIOUS: %.c + +# install configuration + +CC ?= cc +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +SOLIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi +LIBDIR ?= $(PREFIX)/lib/chibi +MANDIR ?= $(PREFIX)/share/man/man1 + +DESTDIR ?= + +GENSTUBS ?= ./tools/genstubs.scm +GENSTATIC ?= ./tools/genstatic.scm + +######################################################################## +# system configuration - if not using GNU make, set PLATFORM and the +# following flags as necessary. + +# +LIBDL = -ldl + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +ifeq ($(shell uname -o),Cygwin) +PLATFORM=cygwin +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +PLATFORM=unix +endif +endif +endif +endif + +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0 +else +ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +STATICFLAGS = -DSEXP_USE_DL=0 +LIBDL = +else +ifeq ($(PLATFORM),cygwin) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static -DSEXP_USE_DL=0 +endif +endif +endif + +ifeq ($(USE_BOEHM),1) +SEXP_USE_BOEHM = 1 +endif + +ifeq ($(SEXP_USE_BOEHM),1) +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DSEXP_USE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude +endif + +ifeq ($(SEXP_USE_DL),0) +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS) +else +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm +XCFLAGS := -Wall -g3 $(CFLAGS) +endif + +######################################################################## + +all: chibi-scheme$(EXE) libs + +COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \ + lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \ + lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/net$(SO) \ + lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \ + lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \ + lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + +libs: $(COMPILED_LIBS) + +INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h + +include/chibi/install.h: Makefile + echo '#define sexp_so_extension "'$(SO)'"' > $@ + echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@ + echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ + echo '#define sexp_version "'`cat VERSION`'"' >> $@ + echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@ + +sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< + +libchibi-sexp$(SO): sexp.o + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) + +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 $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm + +clibs.c: $(GENSTATIC) lib lib/chibi lib/srfi + make chibi-scheme$(EXE) + make libs + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTATIC) $< > $@ + +%.c: %.stub $(GENSTUBS) + make chibi-scheme$(EXE) + -LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTUBS) $< + +lib/%$(SO): lib/%.c $(INCLUDES) + -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +clean: + rm -f *.o *.i *.s *.8 + find lib -name \*$(SO) -exec rm -f '{}' \; + rm -f tests/basic/*.out tests/basic/*.err + +cleaner: clean + rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h + rm -rf *.dSYM + +dist-clean: cleaner + for f in `find lib -name \*.stub`; do rm -f $${f%.stub}.c; done + +test-basic: chibi-scheme$(EXE) + @for f in tests/basic/*.scm; do \ + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + +test-build: + ./tests/build/build-tests.sh + +test-threads: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/thread-tests.scm + +test-numbers: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/numeric-tests.scm + +test-flonums: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/flonum-tests.scm + +test-hash: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/hash-tests.scm + +test-match: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/match-tests.scm + +test-loop: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/loop-tests.scm + +test-sort: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm + +test-libs: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/lib-tests.scm + +test: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/r5rs-tests.scm + +install: chibi-scheme$(EXE) + mkdir -p $(DESTDIR)$(BINDIR) + cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ + cp tools/genstubs.scm $(DESTDIR)$(BINDIR)/ + mkdir -p $(DESTDIR)$(MODDIR) + cp -r lib/* $(DESTDIR)$(MODDIR)/ + mkdir -p $(DESTDIR)$(INCDIR) + cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ + mkdir -p $(DESTDIR)$(LIBDIR) + mkdir -p $(DESTDIR)$(SOLIBDIR) + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ + mkdir -p $(DESTDIR)$(MANDIR) + cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/ + -if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + +uninstall: + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE) + rm -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO) + rm -f $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a + cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -rf $(DESTDIR)$(MODDIR) + +dist: dist-clean + 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` + +mips-dist: dist-clean + rm -f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz + mkdir chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + for f in `hg manifest`; do mkdir -p chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/$$f; done + tar cphzvf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + rm -rf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` diff --git a/README b/README new file mode 100644 index 00000000..6e5b00a6 --- /dev/null +++ b/README @@ -0,0 +1,440 @@ + + 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. + +------------------------------------------------------------------------ +INSTALLING + +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 chibi/features.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 CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 + +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 features.h file, or +directly from make with: + + make SEXP_USE_BOEHM=1 + +To compile a static executable, use + + make chibi-scheme-static SEXP_USE_DL=0 + +To compile a static executable with all C libraries statically +included, first you need to create a clibs.c file, which can be done +with: + + make clibs.c + +or edited manually. Be sure to run this with a non-static +chibi-scheme. Then you can make the static executable with: + + make cleaner + make chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS + +------------------------------------------------------------------------ +CHIBI-SCHEME LANGUAGE + +The default language is mostly compatible with the R5RS, with all +differences made by design, not through difficulty of implementation. +The following procedures are omitted: + + transcript-on and transcript-off (because they're silly) + rationalize (pending the addition of rational numbers) + +Apart from this, chibi-scheme is case-sensitive, unlike the R5RS. +The default configuration includes fixnums, flonums and bignums +but no exact rationals or complex numbers. + +Full continuations are supported, but currently continuations don't +take C code into account. The only higher-order C functions in the +standard environment are LOAD and EVAL. + +LOAD is extended to accept an optional environment argument, like +EVAL. You can also LOAD shared libraries in addition to Scheme source +files - in this case the function sexp_init_library is automatically +called with the following signature: + + sexp_init_library(sexp context, sexp environment) + +SYNTAX-RULES macros are provided by default, with the extensions from +SRFI-46. In addition, low-level hygienic macros are provided with +a syntactic-closures interface, including SC-MACRO-TRANSFORMER, +RSC-MACRO-TRANSFORMER, and ER-MACRO-TRANSFORMER. A good introduction +to syntactic-closures can be found at: + + http://community.schemewiki.org/?syntactic-closures + +IDENTIFIER?, IDENTIFIER->SYMBOL, IDENTIFIER=?, and +MAKE-SYNTACTIC-CLOSURE and STRIP-SYNTACTIC-CLOSURES are provided. + +SRFI-0's COND-EXPAND is provided, with the feature `chibi'. + +STRING-CONCATENATE concatenates a list of strings. + +------------------------------------------------------------------------ +TYPES + +You can define new data types with SRFI-9. This is just syntactic +sugar for the following more primitive type constructors: + +(register-simple-type ) + => ; a fixnum + +(make-type-predicate ) + => ; takes 1 arg, returns #t iff that arg is of the type + +(make-constructor ) + => ; takes 0 args, returns a newly allocated instance of type + +(make-getter ) + => ; takes 1 args, retrieves the field located at the index + +(make-setter ) + => ; takes 2 args, sets the field located at the index + +------------------------------------------------------------------------ +MODULE SYSTEM + +A configurable module system, in the style of the Scheme48 module +system, is provided by default. + +Modules names are hierarchical lists of symbols or numbers. The +definition of the module (foo bar baz) is searched for in the file +foo/bar/baz.module. This file should contain an expression of the +form: + + (define-module (foo bar baz) + ...) + +where can be any of + + (export ...) - specify an export list + (import ...) - specify one or more imports + (import-immutable ...) - specify an immutable import + (body ...) - inline Scheme code + (include ...) - load one or more files + (include-shared ...) - dynamic load a library + + can either be a module name or any of + + (only ...) + (except ...) + (rename ( ) ...) + (prefix ) + +The can be composed and perform basic selection and renaming of +individual identifiers from the given module. + +Files are loaded relative to the .module file, and are written with +their extension (so you can use whatever suffix you prefer - .scm, +.ss, .sls, etc.). + +Shared modules, on the other hand, should be specified _without_ the +extension - the correct suffix will be added portably (e.g. .so for +Unix and .dylib for OS X). + +You may also use COND-EXPAND and arbitrary macro expansions in a +module definition to generate . + +------------------------------------------------------------------------ +MODULES + +The default environment is (scheme) - you almost always want to import +this. + +Currently you can load the following SRFIs with (import (srfi N)): + + (srfi 0) - cond-expand + (srfi 1) - list library + (srfi 2) - and-let* + (srfi 6) - basic string ports + (srfi 8) - receive + (srfi 9) - define-record-type + (srfi 11) - let-values/let*-values + (srfi 16) - case-lambda + (srfi 22) - running scheme scripts on Unix + (srfi 23) - error reporting mechanism + (srfi 26) - cut/cute partial application + (srfi 27) - sources of random bits + (srfi 33) - bitwise operators + (srfi 39) - prameter objects + (srfi 46) - basic syntax-rules extensions + (srfi 62) - s-expression comments + (srfi 69) - basic hash tables + (srfi 95) - sorting and merging + (srfi 98) - environment access + +although 0, 22, 23, 46 and 62 are built into the default environment +so there's no need to import them. + +Included non-standard modules are put in the (chibi) module namespace. +The following additional modules are available: + + (chibi net) - networking interface + (chibi filesystem) - local filesystem and file descriptor interface + (chibi process) - processes and signals + (chibi system) - host system and user information + (chibi time) - time and date library + (chibi match) - pattern-matching library + (chibi loop) - extensible loop syntax + (chibi pathname) - pathname manipulation utilities + (chibi uri) - URI parsing and construction utilities + (chibi macroexpand) - macro expansion utility + (chibi ast) - interface to the internal Abstract Syntax Tree + (chibi disasm) - disassembly utility for the chibi VM + (chibi heap-stats) - debugging tool to analyze or dump the heap + +------------------------------------------------------------------------ +C INTERFACE + +See the file main.c for an example of using chibi-scheme as a library. + +The basic usage involves creating a context for evaluation and loading +or evaluating Scheme source with it. Begin by including the eval.h +header file: + + #include + +then call + + sexp_scheme_init(); + +with no parameters to initialize any globals (this actually does +nothing in the standard configuration but is a good idea to call +anyway). + +Then you can use the following to create and manipulate contexts: + + sexp_make_eval_context(context, stack, environment, heap_size) + Creates a new context with the given stack and environment. + If context is non-NULL, this will be the "parent" context and + the two contexts will share a heap. Otherwise, a new heap + will be allocated with heap_size, or a default size if heap_size + is zero. stack and environment may both also be NULL (and _must_ + be NULL if context is NULL) and will be given standard defaults. + + Thus to create your first context you generally call: + + sexp_make_eval_context(NULL, NULL, NULL, 0) + + You can create as many contexts as you want, and other than those + sharing a heap they are all independent and thread-safe. + + sexp_load_standard_env(context, env, version) + Loads the init.scm file in the environment env. Version refers + to the RnRS version number and should always be SEXP_FIVE. The + environment created with sexp_make_eval_context only contains + core syntactic forms and C primitives (thus for example it has + CAR but not CADR or LIST), so to get a full featured + environment, plus a module system with which to load additional + modules, you want to use this. + + sexp_destroy_context(context) + Signals that you no longer need context, or any other context + sharing the heap. It will thus free() the context and heap and + all associated memory. Does nothing if using the Boehm GC. + +Environments can be handled with the following: + + sexp_context_env(context) + A macro returning the default environment associated with context. + + sexp_env_define(context, env, symbol, value) + Define a variable in an environment. + + sexp_env_ref(env, symbol, dflt) + Fetch the binding for symbol from the environment env, + returning the default dflt if the symbol is unbound. + +You can evaluate code with the following utility: + + sexp_eval(context, expr, env) + Evaluates an s-expression in an environment. + env can be NULL to use the context's default env. + + sexp_eval_string(context, str, env) + Reads an s-expression from str and evaluates it in env. + + sexp_load(context, file, env) + Read and eval all top-level forms from file in environment env. + As described in LOAD above, file may be a shared library. + +To define new primitive functions from C, use sexp_define_foreign, +which takes a Scheme environment, a name, a number of arguments the C +function takes (not counting the context argument), and a C function. + + /* sexp_define_foreign(context, env, name, num_args, f) */ + + sexp add (sexp context, sexp x, sexp y) { + return sexp_fx_add(x, y); + } + + sexp_define_foreign(context, env, "add", 2, add); + +You can also define functions with a single optional argument: + + sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); + +See the SRFI-69 implementation for more detailed examples of this. + +------------------------------------------------------------------------ +FFI + +Simple C FFI. "genstubs.scm file.stub" will read in the C function +FFI definitions from file.stub and output the appropriate C +wrappers into file.c. You can then compile that file with: + + cc -fPIC -shared file.c -lchibi-scheme + +(or using whatever flags are appropriate to generate shared libs on +your platform) and then the generated .so file can be loaded +directly with LOAD, or portably using (include-shared "file") in a +module definition (note that include-shared uses no suffix). + +The goal of this interface is to make access to C types and +functions easy, without requiring the user to write any C code. +That means the stubber needs to be intelligent about various C +calling conventions and idioms, such as return values passed in +actual parameters. Writing C by hand is still possible, and +several of the core modules provide C interfaces directly without +using the stubber. + +================================ + +Struct Interface + +(define-c-struct struct-name + [predicate: predicate-name] + [constructor: constructor-name] + [finalizer: c_finalizer_name] + (type c_field_name getter-name setter-name) ...) + + +================================ + + +Function Interface + +(define-c return-type name-spec (arg-type ...)) + +where name-space is either a symbol name, or a list of +(scheme-name c_name). If just a symbol, the C name is taken +to be the same with -'s replaced by _'s. + +arg-type is a type suitable for input validation and conversion. + +================================ + + +Types + +Types + +Basic Types + void + boolean + char + sexp (no conversions) + +Integer Types: + signed-char short int long + unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t + time_t (in seconds, but using the chibi epoch of 2010/01/01) + errno (as a return type returns #f on error) + +Float Types: + float double long-double + +String Types: + string - a null-terminated char* + env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme + in addition you can use (array char) as a string + +Port Types: + input-port output-port + +Struct Types: + +Struct types are by default just referred to by the bare +struct-name from define-c-struct, and it is assumed you want a +pointer to that type. To refer to the full struct, use the struct +modifier, as in (struct struct-name). + +Type modifiers + +Any type may also be written as a list of modifiers followed by the +type itself. The supported modifiers are: + +const: prepends the "const" C type modifier + * as a return or result parameter, makes non-immediates immutable + +free: it's Scheme's responsibility to "free" this resource + * as a return or result parameter, registers the freep flag + this causes the type finalizer to be run when GCed + +maybe-null: this pointer type may be NULL + * as a result parameter, NULL is translated to #f + normally this would just return a wrapped NULL pointer + * as an input parameter, #f is translated to NULL + normally this would be a type error + +pointer: create a pointer to this type + * as a return parameter, wraps the result in a vanilla cpointer + * as a result parameter, boxes then unboxes the value + +struct: treat this struct type as a struct, not a pointer + * as an input parameter, dereferences the pointer + * as a type field, indicates a nested struct + +link: add a gc link + * as a field getter, link to the parent object, so the + parent won't be GCed so long as we have a reference + to the child. this behavior is automatic for nested + structs. + +result: return a result in this parameter + * if there are multiple results (including the return type), + they are all returned in a list + * if there are any result parameters, a return type + of errno returns #f on failure, and as eliminated + from the list of results otherwise + +(value ): specify a fixed value + * as an input parameter, this parameter is not provided + in the Scheme API but always passed as + +(default ): specify a default value + * as the final input parameter, makes the Scheme parameter + optional, defaulting to + +(array []) an array type + * length must be specified for return and result parameters + * if specified, length can be any of + ** an integer, for a fixed size + ** the symbol null, indicating a NULL-terminated array diff --git a/RELEASE b/RELEASE new file mode 100644 index 00000000..35f6fb33 --- /dev/null +++ b/RELEASE @@ -0,0 +1 @@ +lithium diff --git a/TODO b/TODO new file mode 100644 index 00000000..161ca82c --- /dev/null +++ b/TODO @@ -0,0 +1,165 @@ +-*- org -*- + +* compiler +** DONE ast rewrite + - State "DONE" [2009-04-09 Thu 14:32] +** DONE call/cc support + - State "DONE" [2009-04-09 Thu 14:36] +** DONE exceptions + - State "DONE" [2009-04-09 Thu 14:45] +** TODO native x86 backend + API redesign in preparation complete, initial + tests on native factorial and closures working. +** TODO fasl/image files + sexp_copy_context() can form the basis for images, + FASL for arbitrary modules will need additional + help with resolving external references. +** DONE shared stack on EVAL + - State "DONE" [2009-12-26 Sat 08:22] + +* compiler optimizations +** DONE constant folding + - State "DONE" [2009-12-16 Wed 23:25] +** DONE simplification pass, dead-code elimination + - State "DONE" [2009-12-18 Fri 14:14] + This is important in particular for the output generated by + syntax-rules. +** TODO lambda lift + The current closure representation is not very efficient, so this + would help a lot. +** TODO inlining (and disabling primitive inlining) + Being able to redefine procedures is important though. +** TODO unsafe operations + Possibly, don't want to make things too complicated or unstable. +** TODO plugin infrastructure +** TODO type inference with warnings + +* macros +** DONE hygiene + - State "DONE" [2009-04-09 Thu 14:41] +** DONE hygienic nested let-syntax + - State "DONE" [2009-12-08 Tue 14:41] +** DONE macroexpand utility + - State "DONE" [2009-12-08 Tue 14:41] +** DONE SRFI-46 basic syntax-rules extensions + - State "DONE" [2009-12-26 Sat 07:59] +** DONE (... ...) support + - State "DONE" [2009-12-26 Sat 02:06] +** TODO compiler macros +** TODO syntax-rules common pattern reduction +** TODO syntax-rules loop optimization + +* garbage collection +** DONE precise gc rewrite + - State "DONE" [2009-06-22 Mon 14:27] +** DONE fix heap growing + - State "DONE" [2009-06-22 Mon 14:29] +** DONE separate gc heaps + - State "DONE" [2009-12-08 Tue 14:29] +** DONE add finalizers + - State "DONE" [2009-12-08 Tue 14:29] +** TODO support weak references + +* runtime +** DONE bignums + - State "DONE" [2009-07-07 Tue 14:42] +** DONE unicode + - State "DONE" from "TODO" [2010-07-11 Sun 23:58] + Supported with UTF-8 strings, string-ref is O(n) and + string-set! may need to reallocate the whole string. + string-cursor-ref can be used for O(1) string access. +** DONE threads + - State "DONE" from "TODO" [2010-07-11 Sun 15:31] + VM now supports an optional hook for green threads, + and a SRFI-18 interface is provided as a separate module. + I/O operations will currently block all threads though, + this needs to be addressed. +** DONE virtual ports + - State "DONE" [2010-01-02 Sat 20:12] +** DONE dynamic-wind + - State "DONE" [2009-12-26 Sat 01:51] + Adapted a version from Scheme48. +** DONE recursive disasm + - State "DONE" [2009-12-18 Fri 14:15] + +* FFI +** DONE libdl support + - State "DONE" [2009-12-08 Tue 14:45] +** DONE opcode generation interface + - State "DONE" [2009-11-15 Sun 14:45] +** DONE stub generator + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE define-c-struct + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE define-c + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE array return types + - State "DONE" [2009-12-26 Sat 01:49] +*** DONE pre-buffered string types (like getcwd) + - State "DONE" [2009-12-26 Sat 01:49] + +* module system +** DONE scheme48-like config language + - State "DONE" [2009-10-13 Tue 14:38] +** DONE shared library includes + - State "DONE" [2009-12-08 Tue 14:39] +** DONE only/except/rename/prefix modifiers + - State "DONE" [2009-12-16 Wed 18:57] +** TODO scheme-complete.el support +** DONE access individual modules from repl + - State "DONE" [2009-12-26 Sat 01:49] + +* core modules +** DONE SRFI-0 cond-expand + - State "DONE" [2009-12-16 Wed 20:12] +** DONE SRFI-9 define-record-type + - State "DONE" [2009-12-08 Tue 14:50] +** DONE SRFI-69 hash-tables + - State "DONE" [2009-11-15 Sun 14:50] +** DONE match library + - State "DONE" [2009-12-08 Tue 14:54] +** DONE loop library + - State "DONE" [2009-12-08 Tue 14:54] +** TODO network interface +** DONE posix interface + - State "DONE" from "TODO" [2010-07-11 Sun 15:36] + Splitting this into several parts. +*** DONE filesystem interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE process interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE time interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE host system interface + - State "DONE" [2010-01-02 Sat 20:12] +** DONE pathname library + - State "DONE" [2009-12-16 Wed 18:58] +** DONE uri library + - State "DONE" [2009-12-16 Wed 18:58] +** TODO http library +** TODO show (formatting) library +** TODO zip library +** TODO tar library +** TODO md5sum library + +* ports +** DONE basic mingw support + - State "DONE" [2009-06-22 Mon 14:36] +** DONE Plan 9 support + - State "DONE" [2009-08-10 Mon 14:37] +** DONE 64-bit support + - State "DONE" [2009-11-01 Sun 14:37] +** TODO iPhone support +** TODO bare-metal support + +* miscellaneous +** TODO overall cleanup +** TODO user documentation +** TODO thorough source documentation +** TODO full test suite for libraries + +* distribution +** TODO packaging format +** TODO code repository with fetch+install tool +** TODO translator to/from other implementations + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..be586341 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.3 diff --git a/chibi-scheme.vcproj b/chibi-scheme.vcproj new file mode 100644 index 00000000..86bd69e9 --- /dev/null +++ b/chibi-scheme.vcproj @@ -0,0 +1,206 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1 new file mode 100644 index 00000000..b84620d5 --- /dev/null +++ b/doc/chibi-scheme.1 @@ -0,0 +1,133 @@ +.TH "chibi-scheme" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-scheme \- a tiny Scheme interpreter + +.SH SYNOPSIS +.B chibi-scheme +[-qV] +[-I +.I path +] +[-A +.I path +] +[-m +.I module +] +[-l +.I file +] +[-e +.I expr +] +[-p +.I expr +] +[--] +[ +.I script argument ... +] +.br +.sp 0.3 + +.SH DESCRIPTION +.I chibi-scheme +is a sample interactive Scheme interpreter for the +.I chibi-scheme +library. It serves as an example of how to embed +.I chibi-scheme +in applications, and can be useful on its own for writing +scripts and interactive development. + +When +.I script +is given, the script will be loaded with SRFI-22 semantics, +calling the procedure +.I main +(if defined) with a single parameter as a list of the +command-line arguments beginning with the script name. + +Otherwise, if no script is given and no -e or -p options +are given an interactive repl is entered, reading, evaluating, +then printing expressions until EOF is reached. The repl +provided is very minimal - if you want readline +completion you may want to wrap it with the +.I rlwrap(1) +program. Signals aren't caught either - to enable handling keyboard +interrupts you can use the (chibi process) module. + +.SH OPTIONS +.TP 5 +.BI -V +Prints the version information and exits. +.TP +.BI -q +Don't load the initialization file. The resulting +environment will only contain the core syntactic forms +and primitives coded in C. +.TP +.BI -h size +Specifies the initial size of the heap, in bytes. +.I size +can be any integer value, optionally suffixed by +"K" for kilobytes, or "M" for megabytes. +.I -h +must be specified before any options which load or +evaluate Scheme code. +.TP +.BI -I path +Inserts +.I path +on front of the load path list. +.TP +.BI -A path +Appends +.I path +to the load path list. +.TP +.BI -m module +Imports +.I module +as though "(import +.I module +)" were evaluated. However, to reduce the need for shell +escapes, modules are written in a dot notation, so that the module +.I (foo bar) +is written as +.I foo.bar +.TP +.BI -l file +Loads the Scheme source from the file +.I file +searched for in the default load path. +.TP +.BI -e expr +Evaluates the Scheme expression +.I expr. +.TP +.BI -p expr +Evaluates the Scheme expression +.I expr +then prints the result to stdout. + +.SH ENVIRONMENT +.TP +.B CHIBI_MODULE_PATH +.TQ +A colon separated list of directories to search for module +files, inserted before the system default load paths. + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +More detailed information can be found in the README file +included in the distribution. + +The chibi-scheme home-page: +.br +http://code.google.com/p/chibi-scheme/ diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..c0c7e166 --- /dev/null +++ b/eval.c @@ -0,0 +1,1758 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +static sexp analyze (sexp ctx, sexp x); +static void generate (sexp ctx, sexp x); + +#if SEXP_USE_MODULES +sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env); +sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file); +sexp sexp_current_environment (sexp ctx sexp_api_params(self, n)); +#endif + +sexp sexp_compile_error (sexp ctx, const char *message, sexp o) { + sexp exn; + sexp_gc_var3(sym, irritants, msg); + sexp_gc_preserve3(ctx, sym, irritants, msg); + irritants = sexp_list1(ctx, o); + msg = sexp_c_string(ctx, message, -1); + exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile", -1), + msg, irritants, SEXP_FALSE, + (sexp_pairp(o)?sexp_pair_source(o):SEXP_FALSE)); + sexp_gc_release3(ctx); + return exn; +} + +static void sexp_warn (sexp ctx, char *msg, sexp x) { + sexp out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) { + sexp_write_string(ctx, "WARNING: ", out); + sexp_write_string(ctx, msg, out); + sexp_write(ctx, x, out); + sexp_write_char(ctx, '\n', out); + } +} + +void sexp_warn_undefs (sexp ctx, sexp from, sexp to) { + sexp x; + for (x=from; sexp_pairp(x) && x!=to; x=sexp_env_next_cell(x)) + if (sexp_cdr(x) == SEXP_UNDEF) + sexp_warn(ctx, "reference to undefined variable: ", sexp_car(x)); +} + + +/********************** environment utilities ***************************/ + +static sexp sexp_env_cell_loc (sexp env, sexp key, sexp *varenv) { + sexp ls; + + do { + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + if (sexp_car(ls) == key) { + if (varenv) *varenv = env; + return ls; + } + env = sexp_env_parent(env); + } while (env); + + return NULL; +} + +sexp sexp_env_cell (sexp env, sexp key) { + return sexp_env_cell_loc(env, key, NULL); +} + +static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, + sexp value, sexp *varenv) { + sexp_gc_var1(cell); + cell = sexp_env_cell_loc(env, key, varenv); + if (! cell) { + sexp_gc_preserve1(ctx, cell); + while (sexp_env_lambda(env) || sexp_env_syntactic_p(env)) + env = sexp_env_parent(env); + sexp_env_push(ctx, env, cell, key, value); + if (varenv) *varenv = env; + sexp_gc_release1(ctx); + } + return cell; +} + +sexp sexp_env_ref (sexp env, sexp key, sexp dflt) { + sexp cell = sexp_env_cell(env, key); + return (cell ? sexp_cdr(cell) : dflt); +} + +sexp sexp_env_global_ref (sexp env, sexp key, sexp dflt) { + while (sexp_env_lambda(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); + return sexp_env_ref(env, key, dflt); +} + +sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { + sexp cell=SEXP_FALSE, res=SEXP_VOID; + sexp_gc_var1(tmp); + for (tmp=sexp_env_bindings(env); sexp_pairp(tmp); tmp=sexp_env_next_cell(tmp)) + if (sexp_car(tmp) == key) { + cell = tmp; + break; + } + if (sexp_immutablep(env)) { + res = sexp_user_exception(ctx, NULL, "immutable binding", key); + } else { + sexp_gc_preserve1(ctx, tmp); + if (sexp_truep(cell)) { + if (sexp_immutablep(cell)) + res = sexp_user_exception(ctx, NULL, "immutable binding", key); + else + sexp_cdr(cell) = value; + } else { + sexp_env_push(ctx, env, tmp, key, value); + } + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_env_exports_op (sexp ctx sexp_api_params(self, n), sexp env) { + sexp ls; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_push(ctx, res, sexp_car(ls)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { + sexp_gc_var2(e, tmp); + sexp_gc_preserve2(ctx, e, 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_env_push(ctx, e, tmp, sexp_car(vars), value); + sexp_gc_release2(ctx); + return e; +} + +static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(ctx, res, sexp_car(ls)); + sexp_gc_release1(ctx); + return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res)); +} + +static sexp sexp_flatten_dot (sexp ctx, sexp ls) { + return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls)); +} + +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 ctx, sexp_uint_t i) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) { + tmp = sexp_alloc_bytecode(ctx, i); + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); + sexp_bytecode_length(tmp) = i; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(ctx)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(ctx)), + i); + sexp_context_bc(ctx) = tmp; + } +} + +static void expand_bcode (sexp ctx, sexp_uint_t size) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(ctx)) + < (sexp_context_pos(ctx))+size) { + tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2); + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); + sexp_bytecode_length(tmp) + = sexp_bytecode_length(sexp_context_bc(ctx))*2; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(ctx)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(ctx)), + sexp_bytecode_length(sexp_context_bc(ctx))); + sexp_context_bc(ctx) = tmp; + } +} + +static void emit_enter (sexp ctx); +static void emit_return (sexp ctx); +static void bless_bytecode (sexp ctx, sexp bc); + +static sexp finalize_bytecode (sexp ctx) { + sexp bc; + emit_return(ctx); + shrink_bcode(ctx, sexp_context_pos(ctx)); + bc = sexp_context_bc(ctx); + if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */ + if (sexp_nullp(sexp_cdr(sexp_bytecode_literals(bc)))) + sexp_bytecode_literals(bc) = sexp_car(sexp_bytecode_literals(bc)); + else if (sexp_nullp(sexp_cddr(sexp_bytecode_literals(bc)))) + sexp_cdr(sexp_bytecode_literals(bc)) = sexp_cadr(sexp_bytecode_literals(bc)); + else + sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc)); + } + bless_bytecode(ctx, bc); + return bc; +} + +static void emit (sexp ctx, unsigned char c) { + expand_bcode(ctx, 1); + sexp_bytecode_data(sexp_context_bc(ctx))[sexp_context_pos(ctx)++] = c; +} + +sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp flags, + sexp num_args, sexp bc, sexp vars) { + 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; + sexp_procedure_vars(proc) = vars; + return proc; +} + +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_op (sexp ctx sexp_api_params(self, n), sexp env, sexp fv, sexp expr) { + sexp res; + if (! (sexp_symbolp(expr) || sexp_pairp(expr))) + return expr; + res = sexp_alloc_type(ctx, 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 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; + sexp_lambda_sv(res) = SEXP_NULL; + sexp_lambda_locals(res) = SEXP_NULL; + sexp_lambda_defs(res) = SEXP_NULL; + sexp_lambda_return_type(res) = SEXP_FALSE; + sexp_lambda_param_types(res) = SEXP_NULL; + return res; +} + +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 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 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 ctx, sexp value) { + sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT); + sexp_lit_value(res) = value; + return res; +} + +/****************************** contexts ******************************/ + +#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) + +static void sexp_add_path (sexp ctx, const char *str) { + const char *colon; + if (str && *str) { + colon = strchr(str, ':'); + if (colon) + sexp_add_path(ctx, colon+1); + else + colon = str + strlen(str); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), SEXP_VOID); + sexp_car(sexp_global(ctx, SEXP_G_MODULE_PATH)) + = sexp_c_string(ctx, str, colon-str); + } +} + +void sexp_init_eval_context_globals (sexp ctx) { + sexp_gc_var3(tmp, vec, ctx2); + ctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve3(ctx, tmp, vec, ctx2); + vec = sexp_intern(ctx, "*current-exception-handler*", -1); + sexp_global(ctx, SEXP_G_ERR_HANDLER) + = sexp_env_cell_create(ctx, sexp_context_env(ctx), vec, SEXP_FALSE, NULL); +#if ! SEXP_USE_NATIVE_X86 + emit(ctx, SEXP_OP_RESUMECC); + sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); + ctx2 = sexp_make_child_context(ctx, NULL); + emit(ctx2, SEXP_OP_DONE); + tmp = finalize_bytecode(ctx2); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + sexp_global(ctx, SEXP_G_FINAL_RESUMER) + = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); + sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) + = sexp_intern(ctx, "final-resumer", -1); +#endif + sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL; + sexp_add_path(ctx, sexp_default_module_dir); + sexp_add_path(ctx, getenv(SEXP_MODULE_PATH_VAR)); + tmp = sexp_c_string(ctx, "./lib", 5); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); + tmp = sexp_c_string(ctx, ".", 1); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO; + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = SEXP_FALSE; +#endif + sexp_gc_release3(ctx); +} + +sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size) { + sexp_gc_var1(res); + if (ctx) sexp_gc_preserve1(ctx, res); + res = sexp_make_context(ctx, size); + sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE); + sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; + sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE; + sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; + if ((! stack) || (stack == SEXP_FALSE)) { + stack = sexp_alloc_tagged(res, SEXP_STACK_SIZE, SEXP_STACK); + sexp_stack_length(stack) = SEXP_INIT_STACK_SIZE; + sexp_stack_top(stack) = 0; + } + sexp_context_stack(res) = stack; + sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_FIVE)); + if (! ctx) sexp_init_eval_context_globals(res); + if (ctx) { + sexp_context_tracep(res) = sexp_context_tracep(ctx); + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_make_child_context (sexp ctx, sexp lambda) { + sexp res = sexp_make_eval_context(ctx, + sexp_context_stack(ctx), + sexp_context_env(ctx), + 0); + if (! sexp_exceptionp(res)) { + sexp_context_lambda(res) = lambda; + sexp_context_top(res) = sexp_context_top(ctx); + sexp_context_fv(res) = sexp_context_fv(ctx); + sexp_context_tracep(res) = sexp_context_tracep(ctx); + } + return res; +} + +/**************************** identifiers *****************************/ + +static sexp sexp_identifierp_op (sexp ctx sexp_api_params(self, n), sexp x) { + return sexp_make_boolean(sexp_idp(x)); +} + +static sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), sexp x) { + return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); +} + +static sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) { + sexp res; + sexp_gc_var2(kar, kdr); + sexp_gc_preserve2(ctx, kar, kdr); + loop: + if (sexp_synclop(x)) { + x = sexp_synclo_expr(x); + goto loop; + } else if (sexp_pairp(x)) { + kar = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_car(x)); + kdr = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_cdr(x)); + res = sexp_cons(ctx, kar, kdr); + sexp_immutablep(res) = 1; + } else { + res = x; + } + sexp_gc_release2(ctx); + return res; +} + +static sexp sexp_identifier_eq_op (sexp ctx sexp_api_params(self, n), 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 = sexp_env_cell(e1, id1); + if (cell && sexp_lambdap(sexp_cdr(cell))) + lam1 = sexp_cdr(cell); + cell = sexp_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 analyze_app (sexp ctx, sexp x) { + sexp p; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, 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 { + sexp_car(res) = tmp; + } + } + if (sexp_pairp(res)) { /* fill in lambda names */ + res = sexp_nreverse(ctx, res); + if (sexp_lambdap(sexp_car(res))) { + p=sexp_lambda_params(sexp_car(res)); + for (tmp=sexp_cdr(res); sexp_pairp(tmp)&&sexp_pairp(p); tmp=sexp_cdr(tmp), p=sexp_cdr(p)) + if (sexp_lambdap(sexp_car(tmp))) + sexp_lambda_name(sexp_car(tmp)) = sexp_car(p); + } + } + sexp_gc_release2(ctx); + return res; +} + +static sexp analyze_seq (sexp ctx, sexp ls) { + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + if (sexp_nullp(ls)) + res = SEXP_VOID; + else if (sexp_nullp(sexp_cdr(ls))) + res = analyze(ctx, sexp_car(ls)); + else { + 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_release2(ctx); + return res; +} + +static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) { + sexp env = sexp_context_env(ctx), res; + sexp_gc_var1(cell); + sexp_gc_preserve1(ctx, cell); + cell = sexp_env_cell_loc(env, x, varenv); + if (! cell) { + if (sexp_synclop(x)) { + if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_context_fv(ctx))) + && sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_synclo_free_vars(x)))) + env = sexp_synclo_env(x); + x = sexp_synclo_expr(x); + } + cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF, varenv); + } + if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) + res = sexp_compile_error(ctx, "invalid use of syntax as value", x); + else + res = sexp_make_ref(ctx, x, cell); + sexp_gc_release1(ctx); + return res; +} + +static sexp analyze_set (sexp ctx, sexp x) { + sexp res, varenv; + sexp_gc_var2(ref, value); + sexp_gc_preserve2(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), &varenv); + 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 if (sexp_immutablep(sexp_ref_cell(ref)) + || (varenv && sexp_immutablep(varenv))) + res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x)); + else + res = sexp_make_set(ctx, ref, value); + } + sexp_gc_release2(ctx); + 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, ctx3; + sexp_gc_var6(res, body, tmp, value, defs, ctx2); + sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2); + /* verify syntax */ + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(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))) + sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x)); + 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, tmp=sexp_copy_list(ctx, sexp_cadr(x))); + sexp_lambda_source(res) = sexp_pair_source(x); + if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res)))) + sexp_lambda_source(res) = sexp_pair_source(sexp_cdr(x)); + if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res)))) + sexp_lambda_source(res) = sexp_pair_source(sexp_cddr(x)); + ctx2 = sexp_make_child_context(ctx, res); + tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); + sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); + sexp_env_lambda(sexp_context_env(ctx2)) = res; + body = analyze_seq(ctx2, sexp_cddr(x)); + 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)) { + tmp = sexp_car(ls); + ctx3 = sexp_cdr(tmp); + if (sexp_pairp(sexp_caar(tmp))) { + name = sexp_caaar(tmp); + tmp = sexp_cons(ctx3, sexp_cdaar(tmp), sexp_cdar(tmp)); + tmp = sexp_cons(ctx3, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(sexp_caar(ls)); + value = analyze_lambda(ctx3, tmp); + } else { + name = sexp_caar(tmp); + value = analyze(ctx3, sexp_cadar(tmp)); + } + if (sexp_exceptionp(value)) sexp_return(res, value); + if (sexp_lambdap(value)) sexp_lambda_name(value) = name; + sexp_push(ctx3, defs, + sexp_make_set(ctx3, analyze_var_ref(ctx3, name, NULL), value)); + } + if (sexp_pairp(defs)) { + if (! sexp_seqp(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(ctx2, defs, sexp_seq_ls(body)); + } + sexp_lambda_body(res) = body; + cleanup: + sexp_gc_release6(ctx); + return res; +} + +static sexp analyze_if (sexp ctx, sexp x) { + sexp res, fail_expr; + sexp_gc_var3(test, pass, fail); + sexp_gc_preserve3(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_release3(ctx); + return res; +} + +static sexp analyze_define (sexp ctx, sexp x) { + sexp name, res, varenv; + sexp_gc_var4(ref, value, tmp, env); + sexp_gc_preserve4(ctx, ref, value, tmp, env); + env = sexp_context_env(ctx); + while (sexp_env_syntactic_p(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(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_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))) { + sexp_env_push(ctx, env, tmp, 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); + tmp = sexp_cons(ctx, sexp_cdr(x), ctx); + sexp_pair_source(sexp_cdr(x)) = sexp_pair_source(x); + sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp); + res = SEXP_VOID; + } else { + if (sexp_synclop(name)) name = sexp_synclo_expr(name); + sexp_env_cell_create(ctx, env, name, SEXP_VOID, NULL); + if (sexp_pairp(sexp_cadr(x))) { + tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); + tmp = sexp_cons(ctx, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(x); + value = analyze_lambda(ctx, tmp); + } else + value = analyze(ctx, sexp_caddr(x)); + ref = analyze_var_ref(ctx, name, &varenv); + if (sexp_exceptionp(ref)) { + res = ref; + } else if (sexp_exceptionp(value)) { + res = value; + } else if (varenv && sexp_immutablep(varenv)) { + res = sexp_compile_error(ctx, "immutable binding", name); + } else { + if (sexp_lambdap(value)) sexp_lambda_name(value) = name; + res = sexp_make_set(ctx, ref, value); + } + } + } + sexp_gc_release4(ctx); + return res; +} + +static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { + sexp res = SEXP_VOID, name; + sexp_gc_var2(proc, mac); + sexp_gc_preserve2(eval_ctx, proc, mac); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + 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 = sexp_eval(eval_ctx, sexp_cadar(ls), NULL); + if (sexp_procedurep(proc)) { + name = sexp_caar(ls); + if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) + name = sexp_synclo_expr(name); + mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(bind_ctx)); + sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac); + } else { + res = (sexp_exceptionp(proc) ? proc + : sexp_compile_error(eval_ctx, "non-procedure macro:", proc)); + break; + } + } + } + sexp_gc_release2(eval_ctx); + return res; +} + +static sexp analyze_define_syntax (sexp ctx, sexp x) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_list1(ctx, sexp_cdr(x)); + res = analyze_bind_syntax(tmp, ctx, ctx); + sexp_gc_release1(ctx); + return res; +} + +static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp) { + sexp res; + sexp_gc_var3(env, ctx2, tmp); + sexp_gc_preserve3(ctx, env, ctx2, tmp); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad let(rec)-syntax", x); + } else { + env = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_syntactic_p(env) = 1; + 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), (recp ? ctx2 : ctx), ctx2); + res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x))); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp analyze_let_syntax (sexp ctx, sexp x) { + return analyze_let_syntax_aux(ctx, x, 0); +} + +static sexp analyze_letrec_syntax (sexp ctx, sexp x) { + return analyze_let_syntax_aux(ctx, x, 1); +} + +static sexp analyze (sexp ctx, sexp object) { + sexp op; + sexp_gc_var4(res, tmp, x, cell); + sexp_gc_preserve4(ctx, res, tmp, x, cell); + x = object; + loop: + if (sexp_pairp(x)) { + 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 = sexp_env_cell(sexp_context_env(ctx), sexp_car(x)); + if (! cell && sexp_synclop(sexp_car(x))) + cell = sexp_env_cell(sexp_synclo_env(sexp_car(x)), + sexp_synclo_expr(sexp_car(x))); + if (! cell) { + res = analyze_app(ctx, x); + } else { + op = sexp_cdr(cell); + if (sexp_corep(op)) { + switch (sexp_core_code(op)) { + case SEXP_CORE_DEFINE: + res = analyze_define(ctx, x); break; + case SEXP_CORE_SET: + res = analyze_set(ctx, x); break; + case SEXP_CORE_LAMBDA: + res = analyze_lambda(ctx, x); break; + case SEXP_CORE_IF: + res = analyze_if(ctx, x); break; + case SEXP_CORE_BEGIN: + res = analyze_seq(ctx, sexp_cdr(x)); break; + case SEXP_CORE_QUOTE: + case SEXP_CORE_SYNTAX_QUOTE: + if (! (sexp_pairp(sexp_cdr(x)) && sexp_nullp(sexp_cddr(x)))) + res = sexp_compile_error(ctx, "bad quote form", x); + else + res = sexp_make_lit(ctx, + (sexp_core_code(op) == SEXP_CORE_QUOTE) ? + sexp_strip_synclos(ctx sexp_api_pass(NULL, 1), sexp_cadr(x)) : + sexp_cadr(x)); + break; + case SEXP_CORE_DEFINE_SYNTAX: + res = analyze_define_syntax(ctx, x); break; + case SEXP_CORE_LET_SYNTAX: + res = analyze_let_syntax(ctx, x); break; + case SEXP_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)) { + 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_make_child_context(ctx, sexp_context_lambda(ctx)); + x = sexp_apply(x, sexp_macro_proc(op), tmp); + if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x))) + sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp)); + goto loop; + } else if (sexp_opcodep(op)) { + res = sexp_length(ctx, sexp_cdr(x)); + if (sexp_unbox_fixnum(res) < sexp_opcode_num_args(op)) { + res = sexp_compile_error(ctx, "not enough args for opcode", x); + } else if ((sexp_unbox_fixnum(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)); + 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))))))) + sexp_warn(ctx, "invalid operand in application: ", x); + res = analyze_app(ctx, x); + } + } else if (sexp_idp(x)) { + res = analyze_var_ref(ctx, x, NULL); + } else if (sexp_synclop(x)) { + tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(tmp) = sexp_synclo_env(x); + sexp_context_fv(tmp) = sexp_append2(tmp, + sexp_synclo_free_vars(x), + sexp_context_fv(tmp)); + x = sexp_synclo_expr(x); + res = analyze(tmp, x); + } else { + res = x; + } + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res)) + && sexp_pairp(x)) + sexp_exception_source(res) = sexp_pair_source(x); + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} + +/********************** free varable analysis *************************/ + +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_var1(res); + if (sexp_nullp(fv2)) + return fv1; + sexp_gc_preserve1(ctx, res); + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, 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_release1(ctx); + return res; +} + +sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) { + sexp_gc_var2(fv1, fv2); + sexp_gc_preserve2(ctx, fv1, fv2); + fv1 = fv; + if (sexp_lambdap(x)) { + fv1 = sexp_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 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_cndp(x)) { + fv1 = sexp_free_vars(ctx, sexp_cnd_test(x), fv); + fv1 = sexp_free_vars(ctx, sexp_cnd_pass(x), fv1); + fv1 = sexp_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 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_setp(x)) { + fv1 = sexp_free_vars(ctx, sexp_set_value(x), fv); + fv1 = sexp_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 = sexp_free_vars(ctx, sexp_synclo_expr(x), fv); + } + sexp_gc_release2(ctx); + return fv1; +} + +/************************ library procedures **************************/ + +static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) { + sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn); + return sexp_exception_kind(exn); +} + +static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) { + FILE *in; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + in = fopen(sexp_string_data(path), "r"); + if (! in) + return sexp_user_exception(ctx, self, "couldn't open input file", path); + return sexp_make_input_port(ctx, in, path); +} + +static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) { + FILE *out; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + out = fopen(sexp_string_data(path), "w"); + if (! out) + return sexp_user_exception(ctx, self, "couldn't open output file", path); + return sexp_make_output_port(ctx, out, path); +} + +static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) { + sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port); + if (! sexp_port_openp(port)) + return sexp_user_exception(ctx, self, "port already closed", port); + return sexp_finalize_port(ctx sexp_api_pass(self, n), port); +} + +#if SEXP_USE_DL +#ifdef __MINGW32__ +#include +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + HINSTANCE handle = LoadLibraryA(sexp_string_data(file)); + if(!handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = (sexp_proc2) GetProcAddress(handle, "sexp_init_library"); + if(!init) { + FreeLibrary(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx sexp_api_pass(NULL, 1), env); +} +#else +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); + if (! handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = dlsym(handle, "sexp_init_library"); + if (! init) { + dlclose(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx sexp_api_pass(NULL, 1), env); +} +#endif +#endif + +sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { +#if SEXP_USE_DL + char *suffix; +#endif + sexp tmp, out=SEXP_FALSE; + sexp_gc_var4(ctx2, x, in, res); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); +#if SEXP_USE_DL + suffix = sexp_string_data(source) + + sexp_string_length(source) - strlen(sexp_so_extension); + if (strcmp(suffix, sexp_so_extension) == 0) { + res = sexp_load_dl(ctx, source, env); + } else { +#endif + sexp_gc_preserve4(ctx, ctx2, x, in, res); + res = SEXP_VOID; + in = sexp_open_input_file(ctx, source); + out = sexp_current_error_port(ctx); + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0); + sexp_context_parent(ctx2) = ctx; + tmp = sexp_env_bindings(env); + sexp_context_tailp(ctx2) = 0; + if (sexp_exceptionp(in)) { + if (sexp_not(out)) out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) + 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, env); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); + } +#if SEXP_USE_WARN_UNDEFS + if (! sexp_exceptionp(res)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + sexp_gc_release4(ctx); +#if SEXP_USE_DL + } +#endif + return res; +} + +#if SEXP_USE_MATH + +#if SEXP_USE_BIGNUMS +#define maybe_convert_bignum(z) \ + else if (sexp_bignump(z)) d = sexp_bignum_to_double(z); +#else +#define maybe_convert_bignum(z) +#endif + +#define define_math_op(name, cname) \ + static sexp name (sexp ctx sexp_api_params(self, n), sexp z) { \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_fixnump(z)) \ + d = (double)sexp_unbox_fixnum(z); \ + maybe_convert_bignum(z) \ + else \ + return sexp_type_exception(ctx, self, SEXP_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_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) { + double d, r; + if (sexp_flonump(z)) + d = sexp_flonum_value(z); + else if (sexp_fixnump(z)) + d = (double)sexp_unbox_fixnum(z); + maybe_convert_bignum(z) /* XXXX add bignum sqrt */ + else + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); + r = sqrt(d); + if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) + return sexp_make_fixnum(round(r)); + else + return sexp_make_flonum(ctx, r); +} + +#endif + +static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { + long double f, x1, e1; + sexp res; +#if SEXP_USE_BIGNUMS + if (sexp_bignump(e)) { /* bignum exponent needs special handling */ + if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) + res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ + else if (x == SEXP_ONE) + res = SEXP_ONE; /* 1.0 */ + else if (sexp_flonump(x)) + res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); + else + res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */ + } else if (sexp_bignump(x)) { + res = sexp_bignum_expt(ctx, x, e); + } else { +#endif + if (sexp_fixnump(x)) + x1 = sexp_unbox_fixnum(x); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + if (sexp_fixnump(e)) + e1 = sexp_unbox_fixnum(e); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, e); + f = pow(x1, e1); + if ((f > SEXP_MAX_FIXNUM) || (f < SEXP_MIN_FIXNUM) +#if SEXP_USE_FLONUMS + || (! sexp_fixnump(x)) || (! sexp_fixnump(e)) +#endif + ) { +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(x) && sexp_fixnump(e)) + res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); + else +#endif +#if SEXP_USE_FLONUMS + res = sexp_make_flonum(ctx, f); +#else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#endif + } else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#if SEXP_USE_BIGNUMS + } +#endif + return res; +} + +static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, sexp str2, sexp ci) { + sexp_sint_t len1, len2, len, diff; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2); + len1 = sexp_string_length(str1); + len2 = sexp_string_length(str2); + len = ((len1>4)&1)+3; +} + +static int sexp_utf8_char_byte_count(int c) { + if (c < 0x80) return 1; + if (c < 0x800) return 2; + if (c < 0x10000) return 3; + return 4; +} + +static int sexp_string_utf8_length (unsigned char *p, int len) { + unsigned char *q = p+len; + int i; + for (i=0; p0 && j0) + return sexp_user_exception(ctx, self, "string-index->offset: index out of range", index); + return sexp_make_fixnum(j); +} + +sexp sexp_string_utf8_ref (sexp ctx, sexp str, sexp i) { + unsigned char *p=(unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(i); + if (*p < 0x80) + return sexp_make_character(*p); + else if ((*p < 0xC0) || (*p > 0xF7)) + return sexp_user_exception(ctx, NULL, "string-ref: invalid utf8 byte", i); + else if (*p < 0xE0) + return sexp_make_character(((p[0]&0x3F)<<6) + (p[1]&0x3F)); + else if (*p < 0xF0) + return sexp_make_character(((p[0]&0x1F)<<12) + ((p[1]&0x3F)<<6) + (p[2]&0x3F)); + else + return sexp_make_character(((p[0]&0x0F)<<16) + ((p[1]&0x3F)<<6) + ((p[2]&0x3F)<<6) + (p[2]&0x3F)); +} + +sexp sexp_string_utf8_index_ref (sexp ctx sexp_api_params(self, n), sexp str, sexp i) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + off = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, i); + if (sexp_exceptionp(off)) return off; + return sexp_string_utf8_ref(ctx, str, off); +} + +void sexp_utf8_encode_char (unsigned char* p, int len, int c) { + switch (len) { + case 4: *p++ = (0xF0 + ((c)>>18)); *p++ = (0x80 + ((c>>12)&0x3F)); + *p++ = (0x80 + ((c>>6)&0x3F)); *p = (0x80 + (c&0x3F)); break; + case 3: *p++ = (0xE0 + ((c)>>12)); *p++ = (0x80 + ((c>>6)&0x3F)); + *p = (0x80 + (c&0x3F)); break; + case 2: *p++ = (0xC0 + ((c)>>6)); *p = (0x80 + (c&0x3F)); break; + default: *p = c; break; + } +} + +void sexp_write_utf8_char (sexp ctx, int c, sexp out) { + unsigned char buf[8]; + int len = sexp_utf8_char_byte_count(c); + sexp_utf8_encode_char(buf, len, c); + buf[len+1] = 0; + sexp_write_string(ctx, (char*)buf, out); +} + +sexp sexp_read_utf8_char (sexp ctx, sexp port, int i) { + if (i >= 0x80) { + if ((i < 0xC0) || (i > 0xF7)) { + return sexp_user_exception(ctx, NULL, "read-char: invalid utf8 byte", sexp_make_fixnum(i)); + } else if (i < 0xE0) { + i = ((i&0x3F)<<6) + (sexp_read_char(ctx, port)&0x3F); + } else if (i < 0xF0) { + i = ((i&0x1F)<<12) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += sexp_read_char(ctx, port)&0x3F; + } else { + i = ((i&0x0F)<<16) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += (sexp_read_char(ctx, port)&0x3F)<<6; + i += sexp_read_char(ctx, port)&0x3F; + } + } + return sexp_make_character(i); +} + +#if SEXP_USE_MUTABLE_STRINGS + +void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) { + sexp b; + unsigned char *p, *q; + int i = sexp_unbox_fixnum(index), c = sexp_unbox_character(ch), + old_len, new_len, len; + p = (unsigned char*)sexp_string_data(str) + i; + old_len = sexp_utf8_initial_byte_count(*p); + new_len = sexp_utf8_char_byte_count(c); + if (old_len != new_len) { /* resize bytes if needed */ + len = sexp_string_length(str)+(new_len-old_len); + b = sexp_make_bytes(ctx, sexp_make_fixnum(len), SEXP_VOID); + if (! sexp_exceptionp(b)) { + q = (unsigned char*)sexp_bytes_data(b); + memcpy(q, sexp_string_data(str), i); + memcpy(q+i+new_len, p+old_len, len-i-new_len+1); + sexp_string_bytes(str) = b; + p = q + i; + } + sexp_string_length(str) += new_len - old_len; + } + sexp_utf8_encode_char(p, new_len, c); +} + +sexp sexp_string_utf8_index_set (sexp ctx sexp_api_params(self, n), sexp str, sexp i, sexp ch) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch); + off = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, i); + if (sexp_exceptionp(off)) return off; + sexp_string_utf8_set(ctx, str, off, ch); + return SEXP_VOID; +} + +#endif +#endif + +#ifdef PLAN9 +#include "opt/plan9.c" +#endif + +/************************** optimizations *****************************/ + +#if SEXP_USE_SIMPLIFY +#include "opt/simplify.c" +#endif + +/***************************** opcodes ********************************/ + +#include "opcodes.c" + +static sexp sexp_copy_core (sexp ctx, struct sexp_core_form_struct *core) { + sexp res = sexp_alloc_type(ctx, core, SEXP_CORE); + memcpy(&(res->value), core, sizeof(core[0])); + return res; +} + +static sexp sexp_copy_opcode (sexp ctx, struct sexp_opcode_struct *op) { + sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + memcpy(&(res->value), op, sizeof(op[0])); + return res; +} + +sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code, + sexp num_args, sexp flags, sexp arg1t, sexp arg2t, + sexp invp, sexp data, sexp data2, sexp_proc1 func) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, num_args); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, flags); + if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0) + || (sexp_unbox_fixnum(op_class) >= SEXP_OPC_NUM_OP_CLASSES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode class", op_class); + else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) + || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code); + else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_arg1_type(res) = arg1t; + sexp_opcode_arg2_type(res) = arg2t; + sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_data(res) = data; + sexp_opcode_data2(res) = data2; + sexp_opcode_func(res) = func; + sexp_opcode_name(res) = strdup(sexp_string_data(name)); + } + return res; +} + +sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res; +#if ! SEXP_USE_EXTENDED_FCALL + if (num_args > 4) + return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); +#endif + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; +#if SEXP_USE_EXTENDED_FCALL + if (num_args > 4) + sexp_opcode_code(res) = SEXP_OP_FCALLN; + else +#endif + sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1; + if (flags & 1) num_args--; + sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; + sexp_opcode_name(res) = name; + sexp_opcode_data(res) = data; + sexp_opcode_func(res) = f; + return res; +} + +sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res = SEXP_VOID; + sexp_gc_var1(op); + sexp_gc_preserve1(ctx, op); + op = sexp_make_foreign(ctx, name, num_args, flags, f, data); + if (sexp_exceptionp(op)) + res = op; + else + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), op); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, + sexp_proc1 f, const char *param) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_intern(ctx, param, -1); + tmp = sexp_env_cell(env, tmp); + res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_TYPE_DEFS + +sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), + sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); +} + +sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + sexp_uint_t type_size; + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); + type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), + sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, + sexp_make_fixnum(type_size), NULL); +} + +sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); + return + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER), + sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); + return + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER), + sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +#endif + +#if SEXP_USE_STATIC_LIBS +#include "clibs.c" +#endif + +/*********************** standard environment *************************/ + +static struct sexp_core_form_struct core_forms[] = { + {SEXP_CORE_DEFINE, "define"}, + {SEXP_CORE_SET, "set!"}, + {SEXP_CORE_LAMBDA, "lambda"}, + {SEXP_CORE_IF, "if"}, + {SEXP_CORE_BEGIN, "begin"}, + {SEXP_CORE_QUOTE, "quote"}, + {SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}, + {SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}, + {SEXP_CORE_LET_SYNTAX, "let-syntax"}, + {SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}, +}; + +sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) { + 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; + return e; +} + +sexp sexp_make_null_env_op (sexp ctx sexp_api_params(self, n), sexp version) { + sexp_uint_t i; + sexp e = sexp_make_env(ctx), core; + for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) { + core = sexp_copy_core(ctx, &core_forms[i]); + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(core), -1), core); + } + return e; +} + +sexp sexp_make_primitive_env (sexp ctx, sexp version) { + int i; + sexp_gc_var3(e, op, sym); + sexp_gc_preserve3(ctx, e, op, sym); + e = sexp_make_null_env(ctx, version); + for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { + op = sexp_copy_opcode(ctx, &opcodes[i]); + if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1); + sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); + } + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op), -1), op); + } + sexp_gc_release3(ctx); + return e; +} + +sexp sexp_find_module_file (sexp ctx, const char *file) { + sexp res=SEXP_FALSE, ls; + char *dir, *path; + sexp_uint_t slash, dirlen, filelen, len; +#ifdef PLAN9 +#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0) + unsigned char buf[128]; +#else +#define file_exists_p(path, buf) (! stat(path, buf)) + struct stat buf_str; + struct stat *buf = &buf_str; +#endif + + filelen = strlen(file); + + ls = sexp_global(ctx, SEXP_G_MODULE_PATH); + for ( ; sexp_pairp(ls) && sexp_not(res); ls=sexp_cdr(ls)) { + dir = sexp_string_data(sexp_car(ls)); + dirlen = sexp_string_length(sexp_car(ls)); + slash = dir[dirlen-1] == '/'; + len = dirlen+filelen+2-slash; + path = (char*) malloc(len); + memcpy(path, dir, dirlen); + if (! slash) path[dirlen] = '/'; + memcpy(path+len-filelen-1, file, filelen); + path[len-1] = '\0'; + if (file_exists_p(path, buf)) + res = sexp_c_string(ctx, path, len-1); + free(path); + } + + return res; +} + +#define sexp_file_not_found "couldn't find file in module path" + +sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { + sexp res; + sexp_gc_var1(path); + sexp_gc_preserve1(ctx, path); + path = sexp_find_module_file(ctx, file); + if (sexp_stringp(path)) { + res = sexp_load(ctx, path, env); + } else { + path = sexp_c_string(ctx, file, -1); + res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path); + } + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_MODULES +sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + return sexp_find_module_file(ctx, sexp_string_data(file)); +} +sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + return sexp_load_module_file(ctx, sexp_string_data(file), env); +} +sexp sexp_current_environment (sexp ctx sexp_api_params(self, n)) { + return sexp_context_env(ctx); +} +#endif + +sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp) { + sexp ls; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dir); + if (sexp_truep(appendp)) { + if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { + for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) + ; + sexp_cdr(ls) = sexp_list1(ctx, dir); + } else { + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir); + } + } else { + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir); + } + return SEXP_VOID; +} + +sexp sexp_load_standard_parameters (sexp ctx, sexp e) { + /* add io port and interaction env parameters */ + sexp p = sexp_make_input_port(ctx, stdin, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p); + p = sexp_make_output_port(ctx, stdout, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p); + p = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); + return SEXP_VOID; +} + +sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { + sexp_gc_var3(op, tmp, sym); + sexp_gc_preserve3(ctx, op, tmp, sym); + sexp_load_standard_parameters(ctx, e); +#if SEXP_USE_DL + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1), + tmp=sexp_c_string(ctx, sexp_so_extension, -1)); +#endif + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform, -1)); +#if SEXP_USE_DL + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading", -1)); +#endif +#if SEXP_USE_MODULES + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules", -1)); +#endif +#if SEXP_USE_BOEHM + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); +#endif +#if SEXP_USE_UTF8_STRINGS + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "utf-8", -1)); +#endif +#if SEXP_USE_GREEN_THREADS + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "threads", -1)); +#endif + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); + sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; +#if SEXP_USE_SIMPLIFY + op = sexp_make_foreign(ctx, "simplify", 1, 0, + (sexp_proc1)sexp_simplify, SEXP_VOID); + tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); +#endif + /* load init.scm */ + tmp = sexp_load_module_file(ctx, sexp_init_file, e); + /* load and bind config env */ +#if SEXP_USE_MODULES + if (! sexp_exceptionp(tmp)) { + sym = sexp_intern(ctx, "*config-env*", -1); + if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { + tmp = sexp_make_env(ctx); + if (! sexp_exceptionp(tmp)) { + sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; + sexp_env_parent(tmp) = e; + op = sexp_load_module_file(ctx, sexp_config_file, tmp); + if (sexp_exceptionp(op)) + sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); + sexp_env_define(ctx, tmp, sym, tmp); + } + } + sexp_env_define(ctx, e, sym, tmp); + } +#endif +#if SEXP_USE_STATIC_LIBS + sexp_init_all_libraries(ctx, e); +#endif + sexp_gc_release3(ctx); + return sexp_exceptionp(tmp) ? tmp : e; +} + +sexp sexp_make_standard_env_op (sexp ctx sexp_api_params(self, n), sexp version) { + sexp_gc_var1(env); + sexp_gc_preserve1(ctx, env); + env = sexp_make_primitive_env(ctx, version); + if (! sexp_exceptionp(env)) sexp_load_standard_env(ctx, env, version); + sexp_gc_release1(ctx); + return env; +} + +sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) { + sexp oldname, newname, value; + if (! sexp_envp(to)) to = sexp_context_env(ctx); + if (! sexp_envp(from)) from = sexp_context_env(ctx); + if (sexp_not(ls)) { + if (sexp_truep(immutp)) { + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_parent(to) = value; + sexp_immutablep(value) = 1; + sexp_env_bindings(value) = sexp_env_bindings(from); + } else { + for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_env_define(ctx, to, sexp_car(ls), sexp_cdr(ls)); + } + } else { + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (sexp_pairp(sexp_car(ls))) { + newname = sexp_caar(ls); oldname = sexp_cdar(ls); + } else { + newname = oldname = sexp_car(ls); + } + value = sexp_env_ref(from, oldname, SEXP_UNDEF); + if (value != SEXP_UNDEF) { + sexp_env_define(ctx, to, newname, value); +#if SEXP_USE_WARN_UNDEFS + } else { + sexp_warn(ctx, "importing undefined variable: ", oldname); +#endif + } + } + } + return SEXP_VOID; +} + +/************************* backend ***************************/ + +#if SEXP_USE_NATIVE_X86 +#include "opt/x86.c" +#else +#include "vm.c" +#endif + +/************************** eval interface ****************************/ + +sexp sexp_compile (sexp ctx, sexp x) { + sexp_gc_var3(ast, vec, res); + sexp_gc_preserve3(ctx, ast, vec, res); + ast = sexp_analyze(ctx, x); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(res); res=sexp_cdr(res)) + ast = sexp_apply1(ctx, sexp_cdar(res), ast); + sexp_free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + emit_enter(ctx); + generate(ctx, ast); + res = finalize_bytecode(ctx); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec); + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { + sexp_sint_t top; + sexp ctx2; + sexp_gc_var2(res, err_handler); + if (! env) env = sexp_context_env(ctx); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_gc_preserve2(ctx, res, err_handler); + top = sexp_context_top(ctx); + err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = SEXP_FALSE; + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0); + sexp_context_child(ctx) = ctx2; + res = sexp_compile(ctx2, obj); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_context_child(ctx) = SEXP_FALSE; + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; + sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_eval_string (sexp ctx, const char *str, sexp_sint_t len, sexp env) { + sexp res; + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); + obj = sexp_read_from_string(ctx, str, len); + res = sexp_eval(ctx, obj, env); + sexp_gc_release1(ctx); + return res; +} + +void sexp_scheme_init (void) { + if (! scheme_initialized_p) { + scheme_initialized_p = 1; + sexp_init(); + } +} diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..af7b3986 --- /dev/null +++ b/gc.c @@ -0,0 +1,346 @@ +/* gc.c -- simple mark&sweep garbage collector */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +#if SEXP_USE_MMAP_GC +#include +#endif + +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(sexp_sizeof(pair))) + +#if SEXP_USE_GLOBAL_HEAP +sexp_heap sexp_global_heap; +#endif + +#if SEXP_USE_CONSERVATIVE_GC +static sexp* stack_base; +#endif + +static sexp_heap sexp_heap_last (sexp_heap h) { + while (h->next) h = h->next; + return h; +} + +sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) { + sexp_uint_t res; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) + return sexp_heap_align(1); + t = sexp_object_type(ctx, x); + res = sexp_type_size_of_object(t, x); + return res; +} + +#if SEXP_USE_SAFE_GC_MARK +static int sexp_in_heap(sexp ctx, sexp_uint_t x) { + sexp_heap h; + if (x & (sexp_heap_align(1)-1)) { + fprintf(stderr, "invalid heap alignment: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; + } + for (h=sexp_context_heap(ctx); h; h=h->next) + if (((sexp_uint_t)h < x) && (x < (sexp_uint_t)(h->data + h->size))) + return 1; + fprintf(stderr, "invalid object outside heap: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; +} +#endif + +#if SEXP_USE_DEBUG_GC +#include "opt/gc_debug.c" +#endif + +void sexp_mark (sexp ctx, sexp x) { + 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; +#if SEXP_USE_SAFE_GC_MARK + if (! sexp_in_heap(ctx, (sexp_uint_t)x)) + return; +#endif +#if SEXP_USE_HEADER_MAGIC + if (sexp_pointer_magic(x) != SEXP_POINTER_MAGIC && sexp_pointer_tag(x) != SEXP_TYPE + && sexp_pointer_tag(x) != SEXP_OPCODE && sexp_pointer_tag(x) != SEXP_CORE + && sexp_pointer_tag(x) != SEXP_STACK) + return; +#endif + sexp_gc_mark(x) = 1; + if (sexp_contextp(x)) + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) sexp_mark(ctx, *(saves->var)); + t = sexp_object_type(ctx, x); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len = sexp_type_num_slots_of_object(t, x) - 1; + if (len >= 0) { + for (i=0; inext) { + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); + q = h->free_list; + end = (sexp) ((char*)h->data + h->size - sexp_heap_align(sexp_sizeof(pair))); + while (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) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + r->size); + continue; + } + size = sexp_heap_align(sexp_allocated_bytes(ctx, p)); + if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + /* free p */ + finalizer = sexp_type_finalize(sexp_object_type(ctx, p)); + if (finalizer) finalizer(ctx sexp_api_pass(NULL, 1), 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); + } + } + } + if (sum_freed_ptr) *sum_freed_ptr = sum_freed; + return sexp_make_fixnum(max_freed); +} + +sexp sexp_gc (sexp ctx, size_t *sum_freed) { + sexp res; +#if SEXP_USE_GLOBAL_SYMBOLS + int i; + 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(sexp_context_heap(ctx)); + 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=sexp_context_heap(ctx); 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, total_size; + sexp_heap h; + size = sexp_heap_align(size); + res = sexp_try_alloc(ctx, size); + if (! res) { + max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed)); + for (total_size=0, h=sexp_context_heap(ctx); h->next; h=h->next) + total_size += h->size; + total_size += h->size; + if (((max_freed < size) + || ((total_size > sum_freed) + && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO))) + && ((!SEXP_MAXIMUM_HEAP_SIZE) || (total_size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); + if (! res) + res = sexp_global(ctx, SEXP_G_OOM_ERROR); + } + return res; +} + +#if ! SEXP_USE_GLOBAL_HEAP + +sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { + sexp_sint_t i, off, len, freep; + sexp_heap to, from = sexp_context_heap(ctx); + sexp_free_list q; + sexp p, p2, t, end, *v; + freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP); + + /* validate input, creating a new heap if needed */ + if (from->next) { + return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx); + } else if (! dst || sexp_not(dst)) { + to = sexp_make_heap(from->size); + dst = (sexp) ((char*)ctx + ((char*)to - (char*)from)); + } else if (! sexp_contextp(dst)) { + return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst); + } else if (sexp_context_heap(dst)->size < from->size) { + return sexp_user_exception(ctx, NULL, "destination context too small", dst); + } else { + to = sexp_context_heap(dst); + } + + /* copy the raw data */ + off = (char*)to - (char*)from; + memcpy(to, from, sexp_heap_pad_size(from->size)); + to->free_list = (sexp_free_list) ((char*)to->free_list + off); + to->data += off; + end = (sexp) (from->data + from->size); + + /* adjust the free list */ + for (q=to->free_list; q->next; q=q->next) + q->next = (sexp_free_list) ((char*)q->next + off); + + /* adjust if the destination is larger */ + if (from->size < to->size) { + if (((char*)q + q->size - off) >= (char*)end) { + q->size += (to->size - from->size); + } else { + q->next = (sexp_free_list) ((char*)end + off); + q->next->next = NULL; + q->next->size = (to->size - from->size); + } + } + + /* adjust data by traversing over the _original_ heap */ + p = (sexp) (from->data + sexp_heap_align(sexp_sizeof(pair))); + q = from->free_list; + while (p < end) { + /* find the next free list pointer */ + for ( ; q && ((char*)q < (char*)p); q=q->next) + ; + if ((char*)q == (char*)p) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + q->size); + } else { + t = sexp_object_type(ctx, p); + len = sexp_type_num_slots_of_object(t, p); + p2 = (sexp)((char*)p + off); + v = (sexp*) ((char*)p2 + sexp_type_field_base(t)); + /* offset any pointers in the _destination_ heap */ + for (i=0; i 6 args */ +/* #define SEXP_USE_EXTENDED_FCALL 0 */ + +/* uncomment this if you don't need flonum support */ +/* This is only for EVAL - you'll still be able to read */ +/* and write flonums directly through the sexp API. */ +/* #define SEXP_USE_FLONUMS 0 */ + +/* uncomment this to disable reading/writing IEEE infinities */ +/* By default you can read/write +inf.0, -inf.0 and +nan.0 */ +/* #define SEXP_USE_INFINITIES 0 */ + +/* uncomment this if you want immediate flonums */ +/* This is experimental, enable at your own risk. */ +/* #define SEXP_USE_IMMEDIATE_FLONUMS 1 */ + +/* uncomment this if you don't want bignum support */ +/* Bignums are implemented with a small, custom library */ +/* in opt/bignum.c. */ +/* #define SEXP_USE_BIGNUMS 0 */ + +/* uncomment this if you don't need extended math operations */ +/* This includes the trigonometric and expt functions. */ +/* Automatically disabled if you've disabled flonums. */ +/* #define SEXP_USE_MATH 0 */ + +/* uncomment this to disable the self and n parameters to primitives */ +/* This is the old style API. */ +/* #define SEXP_USE_SELF_PARAMETER 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* This is something of a hack, but can be quite useful. */ +/* It's very fast and doesn't involve any separate analysis */ +/* passes. */ +/* #define SEXP_USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* By default (this may change) small symbols are represented */ +/* as immediates using a simple huffman encoding. This keeps */ +/* the symbol table small, and minimizes hashing when doing a */ +/* lot of reading. */ +/* #define SEXP_USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* You can trade off some space in exchange for longer read */ +/* times by disabling hashing and just putting all */ +/* non-immediate symbols in a single list. */ +/* #define SEXP_USE_HASH_SYMS 0 */ + +/* uncomment this to disable UTF-8 string support */ +/* The default settings store strings in memory as UTF-8, */ +/* and assumes strings passed to/from the C FFI are UTF-8. */ +/* #define SEXP_USE_UTF8_STRINGS 0 */ + +/* uncomment this to disable the string-set! opcode */ +/* By default (non-literal) strings are mutable. */ +/* Making them immutable allows for packed UTF-8 strings. */ +/* #define SEXP_USE_MUTABLE_STRINGS 0 */ + +/* uncomment this to disable string ports */ +/* If disabled some basic functionality such as number->string */ +/* will not be available by default. */ +/* #define SEXP_USE_STRING_STREAMS 0 */ + +/* uncomment this to disable automatic closing of ports */ +/* If enabled, the underlying FILE* for file ports will be */ +/* automatically closed when they're garbage collected. Doesn't */ +/* apply to stdin/stdout/stderr. */ +/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */ + +/* uncomment this to use the normal 1970 unix epoch */ +/* By default chibi uses an datetime epoch starting at */ +/* 2010/01/01 00:00:00 in order to be able to represent */ +/* more common times as fixnums. */ +/* #define SEXP_USE_2010_EPOCH 0 */ + +/* uncomment this to disable stack overflow checks */ +/* By default stacks are fairly small, so it's good to leave */ +/* this enabled. */ +/* #define SEXP_USE_CHECK_STACK 0 */ + +/* #define SEXP_USE_DEBUG_VM 0 */ +/* Experts only. */ +/* For *very* verbose output on every VM operation. */ + +/* uncomment this to make the VM adhere to alignment rules */ +/* This is required on some platforms, e.g. ARM */ +/* #define SEXP_USE_ALIGNED_BYTECODE */ + +/************************************************************************/ +/* These settings are configurable but only recommended for */ +/* experienced users, and only apply when using the native GC. */ +/************************************************************************/ + +/* the initial heap size in bytes */ +#ifndef SEXP_INITIAL_HEAP_SIZE +#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) +#endif + +/* the maximum heap size in bytes - if 0 there is no limit */ +#ifndef SEXP_MAXIMUM_HEAP_SIZE +#define SEXP_MAXIMUM_HEAP_SIZE 0 +#endif +#ifndef SEXP_MINIMUM_HEAP_SIZE +#define SEXP_MINIMUM_HEAP_SIZE 8*1024 +#endif + +/* if after GC more than this percentage of memory is still in use, */ +/* and we've not exceeded the maximum size, grow the heap */ +#ifndef SEXP_GROW_HEAP_RATIO +#define SEXP_GROW_HEAP_RATIO 0.75 +#endif + +/* the default number of opcodes to run each thread for */ +#ifndef SEXP_DEFAULT_QUANTUM +#define SEXP_DEFAULT_QUANTUM 500 +#endif + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#ifndef SEXP_64_BIT +#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) +#define SEXP_64_BIT 1 +#else +#define SEXP_64_BIT 0 +#endif +#endif + +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 +#if ! defined(_GNU_SOURCE) && ! defined(_WIN32) && ! defined(PLAN9) +#define _GNU_SOURCE +#endif +#endif + +#ifndef SEXP_USE_NO_FEATURES +#define SEXP_USE_NO_FEATURES 0 +#endif + +#ifndef SEXP_USE_GREEN_THREADS +#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_NATIVE_X86 +#define SEXP_USE_NATIVE_X86 0 +#endif + +#ifndef SEXP_USE_MODULES +#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_TYPE_DEFS +#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_MAXIMUM_TYPES +#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1) +#endif + +#ifndef SEXP_USE_DL +#if defined(PLAN9) || defined(_WIN32) +#define SEXP_USE_DL 0 +#else +#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_STATIC_LIBS +#define SEXP_USE_STATIC_LIBS 0 +#endif + +#ifndef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 0 +#endif + +#ifndef SEXP_USE_MALLOC +#define SEXP_USE_MALLOC 0 +#endif + +#ifndef SEXP_USE_MMAP_GC +#define SEXP_USE_MMAP_GC 0 +#endif + +#ifndef SEXP_USE_DEBUG_GC +#define SEXP_USE_DEBUG_GC 0 +#endif + +#ifndef SEXP_USE_SAFE_GC_MARK +#define SEXP_USE_SAFE_GC_MARK 0 +#endif + +#ifndef SEXP_USE_CONSERVATIVE_GC +#define SEXP_USE_CONSERVATIVE_GC 0 +#endif + +#ifndef SEXP_USE_HEADER_MAGIC +#define SEXP_USE_HEADER_MAGIC 0 +#endif + +#ifndef SEXP_USE_GLOBAL_HEAP +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_HEAP 1 +#else +#define SEXP_USE_GLOBAL_HEAP 0 +#endif +#endif + +#ifndef SEXP_USE_GLOBAL_TYPES +#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS) +#endif + +#ifndef SEXP_USE_GLOBAL_SYMBOLS +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_SYMBOLS 1 +#else +#define SEXP_USE_GLOBAL_SYMBOLS 0 +#endif +#endif + +#ifndef SEXP_USE_EXTENDED_FCALL +#define SEXP_USE_EXTENDED_FCALL ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_INFINITIES +#if defined(PLAN9) || ! SEXP_USE_FLONUMS +#define SEXP_USE_INFINITIES 0 +#else +#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_IMMEDIATE_FLONUMS +#define SEXP_USE_IMMEDIATE_FLONUMS 0 +#endif + +#ifndef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MATH +#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_SELF_PARAMETER +#define SEXP_USE_SELF_PARAMETER 1 +#endif + +#ifndef SEXP_USE_WARN_UNDEFS +#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HUFF_SYMS +#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HASH_SYMS +#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_DEBUG_VM +#define SEXP_USE_DEBUG_VM 0 +#endif + +#ifndef SEXP_USE_UTF8_STRINGS +#define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MUTABLE_STRINGS +#define SEXP_USE_MUTABLE_STRINGS 1 +#endif + +#if (SEXP_USE_UTF8_STRINGS && SEXP_USE_MUTABLE_STRINGS) +#define SEXP_USE_PACKED_STRINGS 0 +#endif +#ifndef SEXP_USE_PACKED_STRINGS +#define SEXP_USE_PACKED_STRINGS 1 +#endif + +#ifndef SEXP_USE_STRING_STREAMS +#ifdef _WIN32 +#define SEXP_USE_STRING_STREAMS 0 +#else +#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_AUTOCLOSE_PORTS +#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_2010_EPOCH +#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_EPOCH_OFFSET +#if SEXP_USE_2010_EPOCH +#define SEXP_EPOCH_OFFSET 1262271600 +#else +#define SEXP_EPOCH_OFFSET 0 +#endif +#endif + +#ifndef SEXP_USE_CHECK_STACK +#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES +#endif + +#if SEXP_USE_NATIVE_X86 +#undef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 1 +#undef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS 0 +#undef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS 0 +#undef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY 0 +#endif + +#ifndef SEXP_USE_ALIGNED_BYTECODE +#if defined(__arm__) +#define SEXP_USE_ALIGNED_BYTECODE 1 +#else +#define SEXP_USE_ALIGNED_BYTECODE 0 +#endif +#endif + +#ifdef PLAN9 +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#elif defined(_WIN32) +#define snprintf(buf, len, fmt, val) sprintf(buf, fmt, val) +#define strcasecmp lstrcmpi +#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2) +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#define isnan(x) (x!=x) +#define isinf(x) (x > DBL_MAX || x < -DBL_MAX) +#endif + +#ifdef _WIN32 +#define sexp_pos_infinity (DBL_MAX*DBL_MAX) +#define sexp_neg_infinity -sexp_pos_infinity +#define sexp_nan log(-2) +#else +#define sexp_pos_infinity (1.0/0.0) +#define sexp_neg_infinity -sexp_pos_infinity +#define sexp_nan (0.0/0.0) +#endif + +#ifdef __MINGW32__ +#ifdef BUILDING_DLL +#define SEXP_API __declspec(dllexport) +#else +#define SEXP_API __declspec(dllimport) +#endif +#else +#define SEXP_API +#endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h new file mode 100644 index 00000000..7484d9c6 --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,1065 @@ +/* sexp.h -- header for sexp library */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_H +#define SEXP_H + +#ifdef __cplusplus +extern "C" { +#endif + +#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" + +#include "chibi/features.h" +#include "chibi/install.h" + +#if defined(_WIN32) || defined(__MINGW32__) +#include +#else +#if SEXP_USE_DL +#include +#endif +#if SEXP_USE_GREEN_THREADS +#include +#endif +#endif + +#ifdef PLAN9 +#include +#include +#include +#include +#include <9p.h> +typedef unsigned long size_t; +#else +#include +#include +#include +#include +#include +#include +#include +#if SEXP_USE_FLONUMS +#include +#include +#endif +#endif + +#include +#include + +/* tagging system + * bits end in 00: pointer + * 01: fixnum + * 011: immediate flonum (optional) + * 111: immediate symbol (optional) + * 000110: char + * 001110: unique immediate (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 6 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 63 + +#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 + +#ifndef SEXP_POINTER_MAGIC +#define SEXP_POINTER_MAGIC 0xFDCA9764uL /* arbitrary */ +#endif + +#if SEXP_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_NUMBER, + SEXP_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_BYTES, + SEXP_STRING, + SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, + SEXP_CPOINTER, + 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_CORE_TYPES +}; + +#ifdef _WIN32 +typedef unsigned short sexp_tag_t; +typedef SIZE_T sexp_uint_t; +typedef SSIZE_T sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#elif SEXP_64_BIT +typedef unsigned int sexp_tag_t; +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#elif defined(__CYGWIN__) +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#else +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +typedef struct sexp_struct *sexp; + +#define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1)) + +#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2)) +#define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type)) +#define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type)) + +#define SEXP_UINT_T_MAX ((sexp_uint_t)-1) +#define SEXP_UINT_T_MIN (0) +#define SEXP_SINT_T_MAX __MAX_SIGNED(sexp_sint_t) +#define SEXP_SINT_T_MIN __MIN_SIGNED(sexp_sint_t) + +#define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1) +#define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1) + +#if SEXP_USE_SELF_PARAMETER +#define sexp_api_params(self, n) , sexp self, long n +#define sexp_api_pass(self, n) , self, n +#else +#define sexp_api_params(self, n) +#define sexp_api_pass(self, n) +#endif + +/* procedure types */ +typedef sexp (*sexp_proc1) (sexp sexp_api_params(self, n)); +typedef sexp (*sexp_proc2) (sexp sexp_api_params(self, n), sexp); +typedef sexp (*sexp_proc3) (sexp sexp_api_params(self, n), sexp, sexp); +typedef sexp (*sexp_proc4) (sexp sexp_api_params(self, n), sexp, sexp, sexp); +typedef sexp (*sexp_proc5) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc6) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc7) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp); + +typedef struct sexp_free_list_t *sexp_free_list; +struct sexp_free_list_t { + sexp_uint_t size; + sexp_free_list next; +}; + +typedef struct sexp_heap_t *sexp_heap; +struct sexp_heap_t { + sexp_uint_t size; + sexp_free_list free_list; + sexp_heap next; + /* note this must be aligned on a proper heap boundary, */ + /* so we can't just use char data[] */ + char *data; +}; + +struct sexp_gc_var_t { + sexp *var; +#if SEXP_USE_DEBUG_GC + char *name; +#endif + struct sexp_gc_var_t *next; +}; + +struct sexp_type_struct { + sexp_tag_t tag; + short field_base, field_eq_len_base, field_len_base, field_len_off; + unsigned short field_len_scale; + short size_base, size_off; + unsigned short size_scale; + char *name; + sexp_proc2 finalize; +}; + +struct sexp_opcode_struct { + unsigned char op_class, code, num_args, flags, inverse; + const char *name; + sexp data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type; + sexp_proc1 func; +}; + +struct sexp_core_form_struct { + char code; + const char *name; +}; + +struct sexp_struct { + sexp_tag_t tag; + char gc_mark; + unsigned int immutablep:1; + unsigned int freep:1; + unsigned int syntacticp:1; +#if SEXP_USE_HEADER_MAGIC + unsigned int magic; +#endif + union { + /* basic types */ + double flonum; + struct sexp_type_struct type; + struct { + sexp car, cdr; + sexp source; + } pair; + struct { + sexp_uint_t length; + sexp data[]; + } vector; + struct { + sexp_uint_t length; + char data[]; + } bytes; + struct { +#if SEXP_USE_PACKED_STRINGS + sexp_uint_t length; + char data[]; +#else + sexp_uint_t offset, length; + sexp bytes; +#endif + } string; + struct { + sexp_uint_t length; + char data[]; + } symbol; + struct { + FILE *stream; + char *buf; + char openp, no_closep, sourcep; + sexp_uint_t offset, line; + size_t size; + sexp name; + sexp cookie; + } port; + struct { + sexp kind, message, irritants, procedure, source; + } exception; + struct { + signed char sign; + sexp_uint_t length; + sexp_uint_t data[]; + } bignum; + struct { + sexp_uint_t length; + void *value; + sexp parent; + char body[]; + } cpointer; + /* runtime types */ + struct { + sexp parent, lambda, bindings; + } env; + struct { + sexp_uint_t length; + sexp name, literals, source; + 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 sexp_opcode_struct opcode; + struct sexp_core_form_struct core; + /* ast types */ + struct { + sexp name, params, body, defs, locals, flags, fv, sv, ret, types, source; + } lambda; + struct { + sexp test, pass, fail, source; + } cnd; + struct { + sexp var, value, source; + } set; + struct { + sexp name, cell, source; + } ref; + struct { + sexp ls, source; + } seq; + struct { + sexp value, source; + } lit; + /* compiler state */ + struct { + sexp_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp_heap heap; + struct sexp_gc_var_t *saves; +#if SEXP_USE_GREEN_THREADS + sexp_sint_t refuel; + unsigned char* ip; + struct timeval tval; +#endif + char tailp, tracep, timeoutp, waitp; + sexp_uint_t pos, depth, last_fp; + sexp bc, lambda, stack, env, fv, parent, child, globals, + proc, name, specific, event; + } 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_offsetof_slot0 (offsetof(struct sexp_struct, value)) + +#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double)) + +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) +#define sexp_alloc_bytecode(ctx, i) sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE) + +#if SEXP_USE_BIGNUMS +#include "chibi/bignum.h" +#endif + +/***************************** 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_fixnump(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_flags(x) ((x)->flags) +#define sexp_immutablep(x) ((x)->immutablep) +#define sexp_freep(x) ((x)->freep) +#define sexp_pointer_magic(x) ((x)->magic) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) +#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) + +#define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b))) + +#if SEXP_USE_IMMEDIATE_FLONUMS +union sexp_flonum_conv { + float flonum; + unsigned int bits; +}; +#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x); +#if SEXP_64_BIT +SEXP_API float sexp_flonum_value (sexp x); +SEXP_API sexp sexp_make_flonum(sexp ctx, float f); +#else +#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)(((unsigned int)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) +#endif +#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_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) +#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER)) +#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_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x)) + +#if SEXP_USE_HUFF_SYMS +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +#else +#define sexp_symbolp(x) (sexp_lsymbolp(x)) +#endif + +#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_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) + +#define SEXP_NEG_ONE sexp_make_fixnum(-1) +#define SEXP_ZERO sexp_make_fixnum(0) +#define SEXP_ONE sexp_make_fixnum(1) +#define SEXP_TWO sexp_make_fixnum(2) +#define SEXP_THREE sexp_make_fixnum(3) +#define SEXP_FOUR sexp_make_fixnum(4) +#define SEXP_FIVE sexp_make_fixnum(5) +#define SEXP_SIX sexp_make_fixnum(6) +#define SEXP_SEVEN sexp_make_fixnum(7) +#define SEXP_EIGHT sexp_make_fixnum(8) +#define SEXP_NINE sexp_make_fixnum(9) +#define SEXP_TEN sexp_make_fixnum(10) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) + +#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x))) +#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x)) +#else +#define _or_integer_flonump(x) +#endif + +#if SEXP_USE_BIGNUMS +SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x); +SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); +#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) +#else +#define sexp_make_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_make_unsigned_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_exact_integerp(x) sexp_fixnump(x) +#endif + +#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) +#define sexp_numberp(x) (sexp_exact_integerp(x) || sexp_flonump(x)) +#else +#define sexp_fixnum_to_flonum(ctx, x) (x) +#define sexp_numberp(x) sexp_exact_integerp(x) +#endif + +#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS +#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0])) +#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0])) +#else +#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x)) +#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x)) +#endif + +#define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET) +#define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET) + +/*************************** 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_fixnum(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_fixnum(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_fixnum(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_bytes_length(x) ((x)->value.bytes.length) +#define sexp_bytes_data(x) ((x)->value.bytes.data) + +#define sexp_string_length(x) ((x)->value.string.length) +#if SEXP_USE_PACKED_STRINGS +#define sexp_string_data(x) ((x)->value.string.data) +#else +#define sexp_string_bytes(x) ((x)->value.string.bytes) +#define sexp_string_offset(x) ((x)->value.string.offset) +#define sexp_string_data(x) (sexp_bytes_data(sexp_string_bytes(x))+sexp_string_offset(x)) +#endif + +#define sexp_bytes_ref(x, i) (sexp_make_fixnum((unsigned char)sexp_bytes_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_bytes_set(x, i, v) (sexp_bytes_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_fixnum(v)) + +#define sexp_string_ref(x, i) (sexp_make_character((unsigned char)sexp_string_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_character(v)) + +#define sexp_symbol_data(x) ((x)->value.symbol.data) +#define sexp_symbol_length(x) ((x)->value.symbol.length) +#define sexp_symbol_string(x) (x) + +#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_no_closep(p) ((p)->value.port.no_closep) +#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_cpointer_freep(p) (sexp_freep(p)) +#define sexp_cpointer_length(p) ((p)->value.cpointer.length) +#define sexp_cpointer_body(p) ((p)->value.cpointer.body) +#define sexp_cpointer_parent(p) ((p)->value.cpointer.parent) +#define sexp_cpointer_value(p) ((p)->value.cpointer.value) +#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p)) + +#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_source(x) ((x)->value.bytecode.source) +#define sexp_bytecode_data(x) ((x)->value.bytecode.data) + +#define sexp_env_syntactic_p(x) ((x)->syntacticp) +#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_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_data2(x) ((x)->value.opcode.data2) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) +#define sexp_opcode_return_type(x) ((x)->value.opcode.ret_type) +#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_arg3_type(x) ((x)->value.opcode.arg3_type) +#define sexp_opcode_func(x) ((x)->value.opcode.func) + +#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_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) + +#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_lambda_return_type(x) ((x)->value.lambda.ret) +#define sexp_lambda_param_types(x) ((x)->value.lambda.types) +#define sexp_lambda_source(x) ((x)->value.lambda.source) + +#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_cnd_source(x) ((x)->value.cnd.source) + +#define sexp_set_var(x) ((x)->value.set.var) +#define sexp_set_value(x) ((x)->value.set.value) +#define sexp_set_source(x) ((x)->value.set.source) + +#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_ref_source(x) ((x)->value.ref.source) + +#define sexp_seq_ls(x) ((x)->value.seq.ls) +#define sexp_seq_source(x) ((x)->value.seq.source) + +#define sexp_lit_value(x) ((x)->value.lit.value) +#define sexp_lit_source(x) ((x)->value.lit.source) + +#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_lambda(x) ((x)->value.context.lambda) +#define sexp_context_parent(x) ((x)->value.context.parent) +#define sexp_context_child(x) ((x)->value.context.child) +#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.tracep) +#define sexp_context_globals(x) ((x)->value.context.globals) +#define sexp_context_last_fp(x) ((x)->value.context.last_fp) +#define sexp_context_refuel(x) ((x)->value.context.refuel) +#define sexp_context_ip(x) ((x)->value.context.ip) +#define sexp_context_proc(x) ((x)->value.context.proc) +#define sexp_context_timeval(x) ((x)->value.context.tval) +#define sexp_context_name(x) ((x)->value.context.name) +#define sexp_context_specific(x) ((x)->value.context.specific) +#define sexp_context_event(x) ((x)->value.context.event) +#define sexp_context_timeoutp(x) ((x)->value.context.timeoutp) +#define sexp_context_waitp(x) ((x)->value.context.waitp) + +#if SEXP_USE_ALIGNED_BYTECODE +#define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx)) +#else +#define sexp_context_align_pos(ctx) +#endif + +#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) + +#if SEXP_USE_GLOBAL_HEAP +#if ! SEXP_USE_BOEHM +SEXP_API sexp_heap sexp_global_heap; +#endif +#define sexp_context_heap(ctx) sexp_global_heap +#else +#define sexp_context_heap(ctx) ((ctx)->value.context.heap) +#endif + +#if SEXP_USE_GLOBAL_SYMBOLS +#define sexp_context_symbols(ctx) sexp_symbol_table +#else +#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) +#endif + +#if SEXP_USE_GLOBAL_TYPES +SEXP_API struct sexp_struct *sexp_type_specs; +#define sexp_context_types(ctx) sexp_type_specs +#define sexp_type_by_index(ctx,i) (&(sexp_context_types(ctx)[i])) +#define sexp_context_num_types(ctx) sexp_num_types +#define sexp_context_type_array_size(ctx) sexp_type_array_size +#else +#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#define sexp_type_by_index(ctx,i) (sexp_context_types(ctx)[i]) +#define sexp_context_num_types(ctx) \ + sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES)) +#define sexp_context_type_array_size(ctx) \ + sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES)) +#endif + +#define sexp_object_type(ctx,x) (sexp_type_by_index(ctx, ((x)->tag))) +#define sexp_object_type_name(ctx,x) (sexp_type_name(sexp_object_type(ctx, x))) +#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i))) + +#define sexp_type_size_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \ + * sexp_type_size_scale(t) \ + + sexp_type_size_base(t)) +#define sexp_type_num_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_len_base(t)) +#define sexp_type_num_eq_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_eq_len_base(t)) + +#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_eq_len_base(x) ((x)->value.type.field_eq_len_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_type_finalize(x) ((x)->value.type.finalize) + +#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_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b))) +#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b))) +#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1))) +#define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a)))) +#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) + +#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 *****************************/ + +enum sexp_context_globals { +#if ! SEXP_USE_GLOBAL_SYMBOLS + SEXP_G_SYMBOLS, +#endif +#if ! SEXP_USE_GLOBAL_TYPES + SEXP_G_TYPES, + SEXP_G_NUM_TYPES, +#endif + SEXP_G_OOM_ERROR, /* out of memory exception object */ + SEXP_G_OOS_ERROR, /* out of stack exception object */ + SEXP_G_OPTIMIZATIONS, + SEXP_G_SIGNAL_HANDLERS, + SEXP_G_CONFIG_ENV, + SEXP_G_MODULE_PATH, + SEXP_G_QUOTE_SYMBOL, + SEXP_G_QUASIQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SPLICING_SYMBOL, + SEXP_G_EMPTY_VECTOR, + SEXP_G_CUR_IN_SYMBOL, + SEXP_G_CUR_OUT_SYMBOL, + SEXP_G_CUR_ERR_SYMBOL, + SEXP_G_INTERACTION_ENV_SYMBOL, + SEXP_G_ERR_HANDLER, + SEXP_G_RESUMECC_BYTECODE, + SEXP_G_FINAL_RESUMER, +#if SEXP_USE_GREEN_THREADS + SEXP_G_THREADS_SCHEDULER, + SEXP_G_THREADS_FRONT, + SEXP_G_THREADS_BACK, + SEXP_G_THREADS_PAUSED, + SEXP_G_THREADS_LOCAL, + SEXP_G_THREADS_SIGNALS, + SEXP_G_THREADS_SIGNAL_RUNNER, +#endif + SEXP_G_NUM_GLOBALS +}; + +#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(ctx, (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 SEXP_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)) + +SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); +SEXP_API sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, const char *str, sexp_uint_t len, sexp p); +SEXP_API sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p); +SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) +#define sexp_at_eofp(p) (feof(sexp_port_stream(p))) + +SEXP_API sexp sexp_make_context(sexp ctx, size_t size); +SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +SEXP_API sexp sexp_cons_op(sexp ctx sexp_api_params(self, n), sexp head, sexp tail); +SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_listp_op(sexp ctx sexp_api_params(self, n), sexp obj); +SEXP_API sexp sexp_reverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_nreverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_copy_list_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_append2_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_memq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_assq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_length_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen); +SEXP_API sexp sexp_make_bytes_op(sexp ctx sexp_api_params(self, n), sexp len, sexp i); +SEXP_API sexp sexp_make_string_op(sexp ctx sexp_api_params(self, n), sexp len, sexp ch); +SEXP_API sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end); +SEXP_API sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep); +SEXP_API sexp sexp_intern (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b); +SEXP_API sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt); +SEXP_API sexp sexp_list_to_vector_op (sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); +SEXP_API sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp in); +SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_write_to_string (sexp ctx, sexp obj); +SEXP_API sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port); +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_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)); +SEXP_API sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port); +SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); +SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x); +SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +SEXP_API sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out); +SEXP_API void sexp_init(void); + +#define sexp_assert_type(ctx, pred, type_id, obj) if (! pred(obj)) return sexp_type_exception(ctx, self, type_id, obj) + +#define SEXP_COPY_DEFAULT SEXP_ZERO +#define SEXP_COPY_FREEP SEXP_ONE + +#if SEXP_USE_GLOBAL_HEAP +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_destroy_context (sexp ctx); +SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags); +#endif + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots); +SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); +SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj); +#define sexp_register_c_type(ctx, name, finalizer) \ + sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ + SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer) +#endif + +#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) +#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))) + +/* simplify primitive API interface */ + +#define sexp_read(ctx, in) sexp_read_op(ctx sexp_api_pass(NULL, 1), in) +#define sexp_write(ctx, obj, out) sexp_write_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_display(ctx, obj, out) sexp_display_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx sexp_api_pass(NULL, 2), e, out) +#define sexp_flush_output(ctx, obj, out) sexp_flush_output_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_listp(ctx, x) sexp_listp_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_length(ctx, x) sexp_length_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_reverse(ctx, x) sexp_reverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_copy_list(ctx, x) sexp_copy_list_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_cons(ctx, a, b) sexp_cons_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_append2(ctx, a, b) sexp_append2_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx sexp_api_pass(NULL, 2), a, b); +#define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_string_to_number(ctx, s, b) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), s, b) +#define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx sexp_api_pass(NULL, 2), l, i) +#define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), l, c) +#define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_substring(ctx, a, b, c) sexp_substring_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx sexp_api_pass(NULL, 2), ls, s) +#define sexp_memq(ctx, a, b) sexp_memq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_assq(ctx, a, b) sexp_assq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_output_string_port(ctx) sexp_make_output_string_port_op(ctx sexp_api_pass(NULL, 0)) +#define sexp_make_input_string_port(ctx, s) sexp_make_input_string_port_op(ctx sexp_api_pass(NULL, 1), s) +#define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_expt(ctx, a, b) sexp_expt_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_simple_type(ctx, a, b) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j) sexp_register_type_op(ctx sexp_api_pass(NULL, 10), a, b, c, d, e, f, g, h, i, j) +#define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_make_setter(ctx, a, b, c) sexp_make_setter_op(ctx sexp_api_pass(NULL, 3), a, b, c) + +#ifdef __cplusplus +} /* extern "C" */ +#endif + +#endif /* ! SEXP_H */ + diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c new file mode 100644 index 00000000..8d946273 --- /dev/null +++ b/lib/chibi/ast.c @@ -0,0 +1,248 @@ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); + sexp_gc_release2(ctx); +} + +static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, + sexp_uint_t cindex, char* get, char *set) { + sexp type, index; + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + type = sexp_make_fixnum(ctype); + index = sexp_make_fixnum(cindex); + op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, get, -1), op); + op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, set, -1), op); + sexp_gc_release2(ctx); +} + +static sexp sexp_get_env_cell (sexp ctx sexp_api_params(self, n), sexp env, sexp id) { + sexp cell = sexp_env_cell(env, id); + while ((! cell) && sexp_synclop(id)) { + env = sexp_synclo_env(id); + id = sexp_synclo_expr(id); + } + return cell ? cell : SEXP_FALSE; +} + +static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + else if (! sexp_opcode_name(op)) + return SEXP_FALSE; + else + return sexp_intern(ctx, sexp_opcode_name(op), -1); +} + +static sexp sexp_translate_opcode_type (sexp ctx, sexp type) { + sexp_gc_var2(res, tmp); + res = type; + if (! res) { + res = sexp_type_by_index(ctx, SEXP_OBJECT); + } if (sexp_fixnump(res)) { + res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); + } else if (sexp_nullp(res)) { /* opcode list types */ + sexp_gc_preserve2(ctx, res, tmp); + tmp = sexp_intern(ctx, "or", -1); + res = sexp_cons(ctx, SEXP_NULL, SEXP_NULL); + res = sexp_cons(ctx, sexp_type_by_index(ctx, SEXP_PAIR), res); + res = sexp_cons(ctx, tmp, res); + sexp_gc_release2(ctx); + } + return res; +} + +static sexp sexp_get_opcode_ret_type (sexp ctx sexp_api_params(self, n), sexp op) { + sexp res; + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + if (sexp_opcode_code(op) == SEXP_OP_RAISE) + return sexp_list1(ctx, sexp_intern(ctx, "error", -1)); + res = sexp_opcode_return_type(op); + if (sexp_fixnump(res)) + res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); + return sexp_translate_opcode_type(ctx, res); +} + +static sexp sexp_get_opcode_param_type (sexp ctx sexp_api_params(self, n), sexp op, sexp k) { + sexp res; + int p = sexp_unbox_fixnum(k); + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + else if (! sexp_fixnump(k)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, k); + if (p > sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op)) + p = sexp_opcode_num_args(op); + switch (p) { + case 0: + res = sexp_opcode_arg1_type(op); + break; + case 1: + res = sexp_opcode_arg2_type(op); + break; + default: + res = sexp_opcode_arg3_type(op); + if (sexp_vectorp(res)) { + if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2)) + res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO)); + else + res = sexp_type_by_index(ctx, SEXP_OBJECT); + } + break; + } + return sexp_translate_opcode_type(ctx, res); +} + +static sexp sexp_get_opcode_num_params (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + return sexp_make_fixnum(sexp_opcode_num_args(op)); +} + +static sexp sexp_get_opcode_variadic_p (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + return sexp_make_boolean(sexp_opcode_variadic_p(op)); +} + +static sexp sexp_type_of (sexp ctx sexp_api_params(self, n), sexp x) { + if (sexp_pointerp(x)) + return sexp_object_type(ctx, x); + else if (sexp_fixnump(x)) + return sexp_type_by_index(ctx, SEXP_FIXNUM); + else if (sexp_booleanp(x)) + return sexp_type_by_index(ctx, SEXP_BOOLEAN); + else if (sexp_charp(x)) + return sexp_type_by_index(ctx, SEXP_CHAR); +#if SEXP_USE_HUFF_SYMS + else if (sexp_symbolp(x)) + return sexp_type_by_index(ctx, SEXP_SYMBOL); +#endif +#if SEXP_USE_IMMEDIATE_FLONUMS + else if (sexp_flonump(x)) + return sexp_type_by_index(ctx, SEXP_FLONUM); +#endif + else + return sexp_type_by_index(ctx, SEXP_OBJECT); +} + +static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { + sexp ctx2 = ctx; + if (sexp_envp(e)) { + ctx2 = sexp_make_child_context(ctx, NULL); + sexp_context_env(ctx2) = e; + } + return sexp_analyze(ctx2, x); +} + +static sexp sexp_optimize (sexp ctx sexp_api_params(self, n), sexp x) { + sexp_gc_var2(ls, res); + sexp_gc_preserve2(ctx, ls, res); + res = x; + ls = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_apply1(ctx, sexp_cdar(ls), res); + sexp_free_vars(ctx, res, SEXP_NULL); + sexp_gc_release2(ctx); + return res; +} + +#define sexp_define_type(ctx, name, tag) \ + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag)); + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_type(ctx, "", SEXP_OBJECT); + sexp_define_type(ctx, "", SEXP_NUMBER); + sexp_define_type(ctx, "", SEXP_BIGNUM); + sexp_define_type(ctx, "", SEXP_FLONUM); + sexp_define_type(ctx, "", SEXP_FIXNUM); + sexp_define_type(ctx, "", SEXP_SYMBOL); + sexp_define_type(ctx, "", SEXP_CHAR); + sexp_define_type(ctx, "", SEXP_BOOLEAN); + sexp_define_type(ctx, "", SEXP_STRING); + sexp_define_type(ctx, "", SEXP_BYTES); + sexp_define_type(ctx, "", SEXP_PAIR); + sexp_define_type(ctx, "", SEXP_VECTOR); + sexp_define_type(ctx, "", SEXP_OPCODE); + sexp_define_type(ctx, "", SEXP_PROCEDURE); + sexp_define_type(ctx, "", SEXP_BYTECODE); + sexp_define_type(ctx, "", SEXP_ENV); + sexp_define_type(ctx, "", SEXP_MACRO); + sexp_define_type(ctx, "", SEXP_LAMBDA); + sexp_define_type(ctx, "", SEXP_CND); + sexp_define_type(ctx, "", SEXP_SET); + sexp_define_type(ctx, "", SEXP_REF); + sexp_define_type(ctx, "", SEXP_SEQ); + sexp_define_type(ctx, "", SEXP_LIT); + sexp_define_type(ctx, "", SEXP_SYNCLO); + sexp_define_type(ctx, "", SEXP_CONTEXT); + sexp_define_type(ctx, "", SEXP_EXCEPTION); + sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV); + sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE); + sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); + sexp_define_type_predicate(ctx, env, "macro?", SEXP_MACRO); + sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); + sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); + sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); + sexp_define_type_predicate(ctx, env, "set?", SEXP_SET); + sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF); + sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ); + sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); + sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); + sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE); + sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT); + sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); + sexp_define_accessors(ctx, env, SEXP_PAIR, 2, "pair-source", "pair-source-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 4, "lambda-locals", "lambda-locals-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 5, "lambda-flags", "lambda-flags-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 6, "lambda-free-vars", "lambda-free-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-set-vars", "lambda-set-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 8, "lambda-return-type", "lambda-return-type-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 9, "lambda-param-types", "lambda-param-types-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 10, "lambda-source", "lambda-source-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); + sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); + sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); + sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 1, "procedure-code", "procedure-code-set!"); + sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 2, "procedure-vars", "procedure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-name", "bytecode-name-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", "exception-kind-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", "exception-message-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 2, "exception-irritants", "exception-irritants-set!"); + sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE); + sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); + sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); + sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + sexp_define_foreign(ctx, env, "opcode-variadic?", 1, sexp_get_opcode_variadic_p); + sexp_define_foreign(ctx, env, "opcode-num-params", 1, sexp_get_opcode_num_params); + sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type); + sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type); + sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize); + sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of); + return SEXP_VOID; +} + diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module new file mode 100644 index 00000000..a439bd57 --- /dev/null +++ b/lib/chibi/ast.module @@ -0,0 +1,33 @@ + +(define-module (chibi ast) + (export + analyze optimize env-cell ast->sexp macroexpand type-of + + + + + pair-source pair-source-set! + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? + environment? bytecode? exception? macro? context? exception? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + lambda-name lambda-params lambda-body lambda-defs lambda-locals + lambda-flags lambda-free-vars lambda-set-vars lambda-return-type + lambda-param-types lambda-source + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + lambda-locals-set! lambda-flags-set! lambda-free-vars-set! + lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set! + lambda-source-set! + cnd-test cnd-pass cnd-fail + cnd-test-set! cnd-pass-set! cnd-fail-set! + set-var set-value set-var-set! set-value-set! + ref-name ref-cell ref-name-set! ref-cell-set! + seq-ls seq-ls-set! lit-value lit-value-set! + exception-kind exception-kind-set! exception-message exception-message-set! + exception-irritants exception-irritants-set! + opcode-name opcode-num-params opcode-return-type opcode-param-type + opcode-variadic? + procedure-code procedure-vars procedure-name bytecode-name) + (import-immutable (scheme)) + (include-shared "ast") + (include "ast.scm")) + diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm new file mode 100644 index 00000000..020f257a --- /dev/null +++ b/lib/chibi/ast.scm @@ -0,0 +1,91 @@ +;; ast.scm -- ast utilities +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (macroexpand x) + (ast->sexp (analyze x))) + +(define (procedure-name x) + (bytecode-name (procedure-code x))) + +(define (ast-renames ast) + (define i 0) + (define renames '()) + (define (rename-symbol id) + (set! i (+ i 1)) + (string->symbol + (string-append (symbol->string (identifier->symbol id)) + "." (number->string i)))) + (define (rename-lambda lam) + (or (assq lam renames) + (let ((res (list lam))) + (set! renames (cons res renames)) + res))) + (define (rename! id lam) + (let ((cell (rename-lambda lam))) + (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell))))) + (define (check-ref id lam env) + (let ((sym (identifier->symbol id))) + (let lp1 ((ls env)) + (cond + ((pair? ls) + (let lp2 ((ls2 (car ls)) (found? #f)) + (cond + ((null? ls2) + (if (not found?) (lp1 (cdr ls)))) + ((and (eq? id (caar ls2)) (eq? lam (cdar ls2))) + (lp2 (cdr ls2) #t)) + ((eq? sym (identifier->symbol (caar ls2))) + (rename! (caar ls2) (cdar ls2)) + (lp2 (cdr ls2) found?)) + (else + (lp2 (cdr ls2) found?))))))))) + (define (flatten-dot x) + (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) + ((null? x) x) + (else (list x)))) + (define (extend-env lam env) + (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env)) + (let lp ((x ast) (env '())) + (cond + ((lambda? x) (lp (lambda-body x) (extend-env x env))) + ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env)) + ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env)) + ((set? x) (lp (set-var x) env) (lp (set-value x) env)) + ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x))) + ((pair? x) (for-each (lambda (x) (lp x env)) x)))) + renames) + +(define (get-rename id lam renames) + (let ((ls (assq lam renames))) + (if (not ls) + (identifier->symbol id) + (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id)))))) + +(define (map* f ls) + (cond ((pair? ls) (cons (f (car ls)) (map* f (cdr ls)))) + ((null? ls) '()) + (else (f ls)))) + +(define (ast->sexp ast) + (let ((renames (ast-renames ast))) + (let a2s ((x ast)) + (cond + ((lambda? x) + `(lambda ,(map* (lambda (id) (get-rename id x renames)) (lambda-params x)) + ,@(map (lambda (d) `(define ,(identifier->symbol (caar d)) #f)) + (lambda-defs x)) + ,@(if (seq? (lambda-body x)) + (map a2s (seq-ls (lambda-body x))) + (list (a2s (lambda-body x)))))) + ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) + ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) + ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) + ((seq? x) `(begin ,@(map a2s (seq-ls x)))) + ((lit? x) + (let ((v (lit-value x))) + (if (or (pair? v) (null? v) (symbol? v)) `',v v))) + ((pair? x) (cons (a2s (car x)) (a2s (cdr x)))) + ((opcode? x) (or (opcode-name x) x)) + (else x))))) + diff --git a/lib/chibi/base64.module b/lib/chibi/base64.module new file mode 100644 index 00000000..12324e1d --- /dev/null +++ b/lib/chibi/base64.module @@ -0,0 +1,7 @@ + +(define-module (chibi base64) + (export base64-encode base64-encode-string + base64-decode base64-decode-string + base64-encode-header) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "base64.scm")) diff --git a/lib/chibi/base64.scm b/lib/chibi/base64.scm new file mode 100644 index 00000000..3d95ad71 --- /dev/null +++ b/lib/chibi/base64.scm @@ -0,0 +1,351 @@ +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: base64-encode-string str +;; Return a base64 encoded representation of string according to the +;; official base64 standard as described in RFC3548. + +;; Procedure: base64-decode-string str +;; Return a base64 decoded representation of string, also interpreting +;; the alternate 62 & 63 valued characters as described in RFC3548. +;; Other out-of-band characters are silently stripped, and = signals +;; the end of the encoded string. No errors will be raised. + +;; Procedure: base64-encode [port] +;; Procedure: base64-decode [port] +;; Variations of the above which read and write to ports. + +;; Procedure: base64-encode-header enc str [start-col max-col nl] +;; Return a base64 encoded representation of string as above, +;; wrapped in =?ENC?B?...?= as per RFC1522, split across multiple +;; MIME-header lines as needed to keep each lines length less than +;; MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring +;; STR is already encoded according to ENC. The optional argument +;; NL is the newline separator, defaulting to CRLF. + +;; This API is compatible with the Gauche library rfc.base64. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-chop str n) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (+ i n))) + (if (>= j len) + (reverse (cons (substring str i len) res)) + (lp j (cons (substring str i j) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; constants and tables + +(define *default-max-col* 76) + +(define *outside-char* 99) ; luft-balloons +(define *pad-char* 101) ; dalmations + +(define *base64-decode-table* + (let ((res (make-vector #x100 *outside-char*))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res (+ i 65) i) + (vector-set! res (+ i 97) (+ i 26)) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 48) (+ i 52)) + (lp (+ i 1))))) + ;; extras (be liberal for different common base64 formats) + (vector-set! res (char->integer #\+) 62) + (vector-set! res (char->integer #\-) 62) + (vector-set! res (char->integer #\/) 63) + (vector-set! res (char->integer #\_) 63) + (vector-set! res (char->integer #\~) 63) + (vector-set! res (char->integer #\=) *pad-char*) + res)) + +(define (base64-decode-char c) + (vector-ref *base64-decode-table* (char->integer c))) + +(define *base64-encode-table* + (let ((res (make-vector 64))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res i (integer->char (+ i 65))) + (vector-set! res (+ i 26) (integer->char (+ i 97))) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 52) (integer->char (+ i 48))) + (lp (+ i 1))))) + (vector-set! res 62 #\+) + (vector-set! res 63 #\/) + res)) + +(define (enc i) + (vector-ref *base64-encode-table* i)) + +;; try to match common boundaries +(define decode-src-length + (lcm 76 78)) + +(define decode-dst-length + (* 3 (arithmetic-shift (+ 3 decode-src-length) -2))) + +(define encode-src-length + (* 3 1024)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; decoding + +;; Create a result buffer with the maximum possible length for the +;; input, and pass it to the internal base64-decode-string! utility. +;; If the resulting length used is exact, we can return that buffer, +;; otherwise we return the appropriate substring. +(define (base64-decode-string src) + (let* ((len (string-length src)) + (dst-len (* 3 (arithmetic-shift (+ 3 len) -2))) + (dst (make-string dst-len))) + (base64-decode-string! + src 0 len dst + (lambda (src-offset res-len b1 b2 b3) + (let ((res-len (base64-decode-finish dst res-len b1 b2 b3))) + (if (= res-len dst-len) + dst + (substring dst 0 res-len))))))) + +;; This is a little funky. +;; +;; We want to skip over "outside" characters (e.g. newlines inside +;; base64-encoded data, as would be passed in mail clients and most +;; large base64 data). This would normally mean two nested loops - +;; one for overall processing the input, and one for looping until +;; we get to a valid character. However, many Scheme compilers are +;; really bad about optimizing nested loops of primitives, so we +;; flatten this into a single loop, using conditionals to determine +;; which character is currently being read. +(define (base64-decode-string! src start end dst kont) + (let lp ((i start) + (j 0) + (b1 *outside-char*) + (b2 *outside-char*) + (b3 *outside-char*)) + (if (>= i end) + (kont i j b1 b2 b3) + (let ((c (base64-decode-char (string-ref src i)))) + (cond + ((eqv? c *pad-char*) + (kont i j b1 b2 b3)) + ((eqv? c *outside-char*) + (lp (+ i 1) j b1 b2 b3)) + ((eqv? b1 *outside-char*) + (lp (+ i 1) j c b2 b3)) + ((eqv? b2 *outside-char*) + (lp (+ i 1) j b1 c b3)) + ((eqv? b3 *outside-char*) + (lp (+ i 1) j b1 b2 c)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (string-set! dst + (+ j 2) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 2 0 b3) 6) + c))) + (lp (+ i 1) (+ j 3) + *outside-char* *outside-char* *outside-char*))))))) + +;; If requested, account for any "partial" results (i.e. trailing 2 or +;; 3 chars) by writing them into the destination (additional 1 or 2 +;; bytes) and returning the adjusted offset for how much data we've +;; written. +(define (base64-decode-finish dst j b1 b2 b3) + (cond + ((eqv? b1 *outside-char*) + j) + ((eqv? b2 *outside-char*) + (string-set! dst j (integer->char (arithmetic-shift b1 2))) + (+ j 1)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (cond + ((eqv? b3 *outside-char*) + (+ j 1)) + (else + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (+ j 2)))))) + +;; General port decoder: work in single blocks at a time to avoid +;; allocating memory (crucial for Scheme implementations that don't +;; allow large strings). +(define (base64-decode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string decode-src-length)) + (dst (make-string decode-dst-length))) + (let lp ((offset 0)) + (let ((src-len (+ offset + (read-string! decode-src-length src in offset)))) + (cond + ((= src-len decode-src-length) + ;; read a full chunk: decode, write and loop + (base64-decode-string! + src 0 decode-src-length dst + (lambda (src-offset dst-len b1 b2 b3) + (cond + ((and (< src-offset src-len) + (eqv? #\= (string-ref src src-offset))) + ;; done + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))) + ((eqv? b1 *outside-char*) + (write-string dst dst-len out) + (lp 0)) + (else + (write-string dst dst-len out) + ;; one to three chars left in buffer + (string-set! src 0 (enc b1)) + (cond + ((eqv? b2 *outside-char*) + (lp 1)) + (else + (string-set! src 1 (enc b2)) + (cond + ((eqv? b3 *outside-char*) + (lp 2)) + (else + (string-set! src 2 (enc b3)) + (lp 3)))))))))) + (else + ;; end of source - just decode and write once + (base64-decode-string! + src 0 src-len dst + (lambda (src-offset dst-len b1 b2 b3) + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; encoding + +(define (base64-encode-string str) + (let* ((len (string-length str)) + (quot (quotient len 3)) + (rem (- len (* quot 3))) + (res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2)) + (res (make-string res-len))) + (base64-encode-string! str 0 len res) + res)) + +(define (base64-encode-string! str start end res) + (let* ((res-len (string-length res)) + (limit (- end 2))) + (let lp ((i start) (j 0)) + (if (>= i limit) + (case (- end i) + ((1) + (let ((b1 (char->integer (string-ref str i)))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (arithmetic-shift (bitwise-and #b11 b1) 4))) + (string-set! res (+ j 2) #\=) + (string-set! res (+ j 3) #\=))) + ((2) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (arithmetic-shift (extract-bit-field 4 0 b2) + 2))) + (string-set! res (+ j 3) #\=)))) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1)))) + (b3 (char->integer (string-ref str (+ i 2))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 2) + (extract-bit-field 2 6 b3)))) + (string-set! res (+ j 3) (enc (bitwise-and #b111111 b3))) + (lp (+ i 3) (+ j 4))))))) + +(define (base64-encode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string encode-src-length)) + (dst (make-string + (arithmetic-shift (quotient encode-src-length 3) 2)))) + (let lp () + (let ((n (read-string! 2048 src in))) + (base64-encode-string! src 0 n dst) + (write-string dst (* 3 (quotient (+ n 3) 4)) out) + (if (= n 2048) + (lp))))))) + +(define (base64-encode-header encoding str . o) + (define (round4 i) (arithmetic-shift (arithmetic-shift i -2) 2)) + (let ((start-col (if (pair? o) (car o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?B?")) + (prefix-length (+ 2 (string-length prefix))) + (effective-max-col (round4 (- max-col prefix-length))) + (first-max-col (round4 (- effective-max-col start-col))) + (str (base64-encode-string str)) + (len (string-length str))) + (if (<= len first-max-col) + (string-append prefix str "?=") + (string-append + (if (positive? first-max-col) + (string-append + prefix (substring str 0 first-max-col) "?=" nl "\t" prefix) + "") + (string-concatenate (string-chop (substring str first-max-col len) + effective-max-col) + (string-append "?=" nl "\t" prefix)) + "?="))))) + diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c new file mode 100644 index 00000000..d193e3a7 --- /dev/null +++ b/lib/chibi/disasm.c @@ -0,0 +1,99 @@ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" +#include "../../opt/opcode_names.h" + +#define SEXP_DISASM_MAX_DEPTH 8 +#define SEXP_DISASM_PAD_WIDTH 4 + +static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { + sexp tmp; + unsigned char *ip, opcode, i; + + if (sexp_procedurep(bc)) { + bc = sexp_procedure_code(bc); + } else if (sexp_opcodep(bc)) { + sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); + return SEXP_VOID; + } else if (! sexp_bytecodep(bc)) { + return sexp_type_exception(ctx, self, SEXP_BYTECODE, bc); + } + if (! sexp_oportp(out)) { + return sexp_type_exception(ctx, self, SEXP_OPORT, out); + } + + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + sexp_write_string(ctx, "-------------- ", out); + if (sexp_truep(sexp_bytecode_name(bc))) { + sexp_write(ctx, sexp_bytecode_name(bc), out); + sexp_write_char(ctx, ' ', out); + } + sexp_printf(ctx, out, "%p\n", bc); + + ip = sexp_bytecode_data(bc); + + loop: + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + 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 SEXP_OP_STACK_REF: + case SEXP_OP_LOCAL_REF: + case SEXP_OP_LOCAL_SET: + case SEXP_OP_CLOSURE_REF: + case SEXP_OP_JUMP: + case SEXP_OP_JUMP_UNLESS: + case SEXP_OP_TYPEP: + case SEXP_OP_FCALL0: + case SEXP_OP_FCALL1: + case SEXP_OP_FCALL2: + case SEXP_OP_FCALL3: + case SEXP_OP_FCALL4: + sexp_printf(ctx, out, "%ld", (long) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case SEXP_OP_SLOT_REF: + case SEXP_OP_SLOT_SET: + case SEXP_OP_MAKE: + ip += sizeof(sexp)*2; + break; + case SEXP_OP_GLOBAL_REF: + case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_TAIL_CALL: + case SEXP_OP_CALL: + case SEXP_OP_PUSH: + tmp = ((sexp*)ip)[0]; + if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF)) + && sexp_pairp(tmp)) + tmp = sexp_car(tmp); + else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) + sexp_write_char(ctx, '\'', out); + sexp_write(ctx, tmp, out); + ip += sizeof(sexp); + break; + } + sexp_write_char(ctx, '\n', out); + if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) + && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) + disasm(ctx, self, tmp, out, depth+1); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +static sexp sexp_disasm (sexp ctx sexp_api_params(self, n), sexp bc, sexp out) { + return disasm(ctx, self, bc, out, 0); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "*current-output-port*"); + return SEXP_VOID; +} diff --git a/lib/chibi/disasm.module b/lib/chibi/disasm.module new file mode 100644 index 00000000..9017a4bc --- /dev/null +++ b/lib/chibi/disasm.module @@ -0,0 +1,5 @@ + +(define-module (chibi disasm) + (export disasm) + (import-immutable (scheme)) + (include-shared "disasm")) diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module new file mode 100644 index 00000000..ecd4af32 --- /dev/null +++ b/lib/chibi/filesystem.module @@ -0,0 +1,27 @@ + +(define-module (chibi filesystem) + (export open-input-file-descriptor open-output-file-descriptor + duplicate-file-descriptor duplicate-file-descriptor-to + close-file-descriptor renumber-file-descriptor + delete-file link-file symbolic-link-file rename-file + directory-files directory-fold create-directory delete-directory + file-status + file-device file-inode + file-mode file-num-links + file-owner file-group + file-represented-device file-size + file-block-size file-num-blocks + file-access-time file-modification-time file-change-time + file-regular? file-directory? file-character? + file-block? file-fifo? file-link? + file-socket? file-exists? + get-file-descriptor-flags set-file-descriptor-flags! + get-file-descriptor-status set-file-descriptor-status! + open/read open/write open/read-write + open/create open/exclusive open/truncate + open/append open/non-block + is-a-tty?) + (import-immutable (scheme)) + (include-shared "filesystem") + (include "filesystem.scm")) + diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm new file mode 100644 index 00000000..aa3fc69f --- /dev/null +++ b/lib/chibi/filesystem.scm @@ -0,0 +1,43 @@ +;; filesystem.scm -- additional filesystem utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (let lp ((res knil)) + (let ((file (readdir dir))) + (if file (lp (kons (dirent-name file) res)) res))))) + +(define (directory-files dir) + (directory-fold dir cons '())) + +(define (renumber-file-descriptor old new) + (and (duplicate-file-descriptor-to old new) + (close-file-descriptor old))) + +(define (file-status file) + (if (string? file) (stat file) (fstat file))) + +(define (file-device x) (stat-dev (if (stat? x) x (file-status x)))) +(define (file-inode x) (stat-ino (if (stat? x) x (file-status x)))) +(define (file-mode x) (stat-mode (if (stat? x) x (file-status x)))) +(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x)))) +(define (file-owner x) (stat-uid (if (stat? x) x (file-status x)))) +(define (file-group x) (stat-gid (if (stat? x) x (file-status x)))) +(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x)))) +(define (file-size x) (stat-size (if (stat? x) x (file-status x)))) +(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x)))) +(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x)))) +(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x)))) +(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x)))) +(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x)))) + +(define (file-regular? x) (S_ISREG (file-mode x))) +(define (file-directory? x) (S_ISDIR (file-mode x))) +(define (file-character? x) (S_ISCHR (file-mode x))) +(define (file-block? x) (S_ISBLK (file-mode x))) +(define (file-fifo? x) (S_ISFIFO (file-mode x))) +(define (file-link? x) (S_ISLNK (file-mode x))) +(define (file-socket? x) (S_ISSOCK (file-mode x))) + +(define (file-exists? x) (and (file-status x) #t)) diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub new file mode 100644 index 00000000..2aa66e50 --- /dev/null +++ b/lib/chibi/filesystem.stub @@ -0,0 +1,118 @@ + +(c-system-include "sys/types.h") +(c-system-include "unistd.h") +(c-system-include "dirent.h") +(c-system-include "fcntl.h") + +(define-c-type DIR + finalizer: closedir) + +(define-c-struct dirent + (string d_name dirent-name)) + +(define-c-struct stat + predicate: stat? + (dev_t st_dev stat-dev) + (ino_t st_ino stat-ino) + (mode_t st_mode stat-mode) + (nlink_t st_nlink stat-nlinks) + (uid_t st_uid stat-uid) + (gid_t st_gid stat-gid) + (dev_t st_rdev stat-rdev) + (off_t st_size stat-size) + (blksize_t st_blksize stat-blksize) + (blkcnt_t st_blocks stat-blocks) + (time_t st_atime stat-atime) + (time_t st_mtime stat-mtime) + (time_t st_ctime stat-ctime)) + +(define-c boolean S_ISREG (mode_t)) +(define-c boolean S_ISDIR (mode_t)) +(define-c boolean S_ISCHR (mode_t)) +(define-c boolean S_ISBLK (mode_t)) +(define-c boolean S_ISFIFO (mode_t)) +(define-c boolean S_ISLNK (mode_t)) +(define-c boolean S_ISSOCK (mode_t)) + +;;(define-c-const int ("S_IFMT")) +(define-c-const int (file/socket "S_IFSOCK")) +(define-c-const int (file/link "S_IFLNK")) +(define-c-const int (file/regular "S_IFREG")) +(define-c-const int (file/block "S_IFBLK")) +(define-c-const int (file/directory "S_IFDIR")) +(define-c-const int (file/character "S_IFCHR")) +(define-c-const int (file/fifo "S_IFIFO")) +(define-c-const int (file/suid "S_ISUID")) +(define-c-const int (file/sgid "S_ISGID")) +(define-c-const int (file/sticky "S_ISVTX")) +;;(define-c-const int ("S_IRWXU")) +(define-c-const int (perm/user-read "S_IRUSR")) +(define-c-const int (perm/user-write "S_IWUSR")) +(define-c-const int (perm/user-execute "S_IXUSR")) +;;(define-c-const int ("S_IRWXG")) +(define-c-const int (perm/group-read "S_IRGRP")) +(define-c-const int (perm/group-write "S_IWGRP")) +(define-c-const int (perm/group-execute "S_IXGRP")) +;;(define-c-const int ("S_IRWXO")) +(define-c-const int (perm/others-read "S_IROTH")) +(define-c-const int (perm/others-write "S_IWOTH")) +(define-c-const int (perm/others-execute "S_IXOTH")) + +(define-c errno stat (string (result stat))) +(define-c errno fstat (int (result stat))) +(define-c errno (file-link-status "lstat") (string (result stat))) + +(define-c input-port (open-input-file-descriptor "fdopen") + (int (value "r" string))) +(define-c output-port (open-output-file-descriptor "fdopen") + (int (value "w" string))) + +(define-c errno (delete-file "unlink") (string)) +(define-c errno (link-file "link") (string string)) +(define-c errno (symbolic-link-file "symlink") (string string)) +(define-c errno (rename-file "rename") (string string)) + +(define-c non-null-string (current-directory "getcwd") + ((result (array char (auto-expand arg1))) (value 256 int))) + +(define-c errno (create-directory "mkdir") (string int)) +(define-c errno (delete-directory "rmdir") (string)) + +(define-c (free DIR) opendir (string)) +(define-c dirent readdir ((link (pointer DIR)))) + +(define-c int (duplicate-file-descriptor "dup") (int)) +(define-c errno (duplicate-file-descriptor-to "dup2") (int int)) +(define-c errno (close-file-descriptor "close") (int)) + +(define-c errno (open-pipe "pipe") ((result (array int 2)))) +(define-c errno (make-fifo "mkfifo") (string (default #o644 int))) + +(define-c int (get-file-descriptor-flags "fcntl") + (int (value F_GETFD int))) +(define-c errno (set-file-descriptor-flags! "fcntl") + (int (value F_SETFD int) long)) + +(define-c int (get-file-descriptor-status "fcntl") + (int (value F_GETFL int))) +(define-c errno (set-file-descriptor-status! "fcntl") + (int (value F_SETFL int) long)) + +;; (define-c int (get-file-descriptor-lock "fcntl") +;; (int (value F_GETLK int) flock)) +;; (define-c errno (set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLK int) flock)) +;; (define-c errno (try-set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLKW int) flock)) + +(define-c-const int (open/read "O_RDONLY")) +(define-c-const int (open/write "O_WRONLY")) +(define-c-const int (open/read-write "O_RDWR")) +(define-c-const int (open/create "O_CREAT")) +(define-c-const int (open/exclusive "O_EXCL")) +(define-c-const int (open/truncate "O_TRUNC")) +(define-c-const int (open/append "O_APPEND")) +(define-c-const int (open/non-block "O_NONBLOCK")) + +(define-c boolean (is-a-tty? "isatty") (port-or-fd)) + diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c new file mode 100644 index 00000000..8b977f1a --- /dev/null +++ b/lib/chibi/heap-stats.c @@ -0,0 +1,120 @@ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define SEXP_HEAP_VECTOR_DEPTH 1 + +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); + +static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { + int i; + if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x) + || sexp_flonump(x) || sexp_bignump(x)) { + sexp_write(ctx, x, out); + } else if (depth <= 0) { + goto print_name; + } else if (sexp_synclop(x)) { + sexp_write_string(ctx, "#", out); + } else if (sexp_pairp(x)) { + sexp_write_char(ctx, '(', out); + sexp_print_simple(ctx, sexp_car(x), out, depth-1); + sexp_write_string(ctx, " . ", out); + sexp_print_simple(ctx, sexp_cdr(x), out, depth-1); + sexp_write_char(ctx, ')', out); + } else if (sexp_vectorp(x)) { + sexp_write_string(ctx, "#(", out); + for (i=0; i0) + sexp_write_char(ctx, ' ', out); + sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); + } + if (i", out); + } +} + +static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { + size_t freed; + sexp_uint_t stats[256], hi_type=0, i; + sexp_heap h = sexp_context_heap(ctx); + sexp p, out=SEXP_FALSE; + sexp_free_list q, r; + char *end; + sexp_gc_var3(res, tmp, name); + + if (printp) + out = sexp_env_global_ref(sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + SEXP_FALSE); + + /* run gc once to remove unused variables */ + sexp_gc(ctx, &freed); + + /* initialize stats */ + for (i=0; i<256; i++) stats[i]=0; + + /* loop over each heap chunk */ + for ( ; h; h=h->next) { + 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) { /* this is a free block, skip */ + p = (sexp) (((char*)p) + r->size); + continue; + } + /* otherwise maybe print, then increment the stat and continue */ + if (sexp_oportp(out)) { + sexp_print_simple(ctx, p, out, depth); + sexp_write_char(ctx, '\n', out); + } + stats[sexp_pointer_tag(p)]++; + if (sexp_pointer_tag(p) > hi_type) + hi_type = sexp_pointer_tag(p); + p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p))); + } + } + + /* build and return results */ + sexp_gc_preserve3(ctx, res, tmp, name); + res = SEXP_NULL; + for (i=hi_type; i>0; i--) + if (stats[i]) { + name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i), -1); + tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); + res = sexp_cons(ctx, tmp, res); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_heap_stats (sexp ctx sexp_api_params(self, n)) { + return sexp_heap_walk(ctx, 0, 0); +} + +static sexp sexp_heap_dump (sexp ctx sexp_api_params(self, n), sexp depth) { + if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) + return sexp_xtype_exception(ctx, self, "bad heap-dump depth", depth); + return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats); + sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE); + return SEXP_VOID; +} + diff --git a/lib/chibi/heap-stats.module b/lib/chibi/heap-stats.module new file mode 100644 index 00000000..c1599c35 --- /dev/null +++ b/lib/chibi/heap-stats.module @@ -0,0 +1,6 @@ + +(define-module (chibi heap-stats) + (export heap-stats heap-dump) + (import-immutable (scheme)) + (include-shared "heap-stats")) + diff --git a/lib/chibi/io.module b/lib/chibi/io.module new file mode 100644 index 00000000..ec765c04 --- /dev/null +++ b/lib/chibi/io.module @@ -0,0 +1,13 @@ + +(define-module (chibi io) + (export read-string read-string! write-string read-line write-line + port-fold port-fold-right port-map + port->list port->string-list port->sexp-list port->string + file-position set-file-position! seek/set seek/cur seek/end + make-custom-input-port make-custom-output-port + make-null-output-port make-broadcast-port make-concatenated-port + make-generated-input-port make-filtered-output-port + make-filtered-input-port) + (import-immutable (scheme)) + (include-shared "io/io") + (include "io/io.scm")) diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm new file mode 100644 index 00000000..2d4da555 --- /dev/null +++ b/lib/chibi/io/io.scm @@ -0,0 +1,170 @@ +;; io.scm -- various input/output utilities +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define eof + (call-with-input-string " " + (lambda (in) (read-char in) (read-char in)))) + +(define (string-copy! dst start src from to) + (do ((i from (+ i 1)) (j start (+ j 1))) + ((>= i to)) + (string-set! dst j (string-ref src i)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; reading and writing + +(define (write-line str . o) + (let ((out (if (pair? o) (car o) (current-output-port)))) + (display str out) + (newline out))) + +(define (read-line . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192))) + (let ((res (%read-line n in))) + (if (not res) + eof + (let ((len (string-length res))) + (if (and (> len 0) (eqv? #\newline (string-ref res (- len 1)))) + (if (and (> len 1) (eqv? #\return (string-ref res (- len 2)))) + (substring res 0 (- len 2)) + (substring res 0 (- len 1))) + res)))))) + +(define (read-string n . o) + (let ((in (if (pair? o) (car o) (current-input-port)))) + (let ((res (%read-string n in))) + (if (if (pair? res) (= 0 (car res)) #t) + eof + (cadr res))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; higher order port operations + +(define (port-fold kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp ((acc knil)) + (let ((x (read in))) + (if (eof-object? x) acc (lp (kons x acc))))))) + +(define (port-fold-right kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp () + (let ((x (read in))) + (if (eof-object? x) knil (kons x (lp))))))) + +(define (port-map fn . o) + (reverse (apply port-fold (lambda (x ls) (cons (fn x) ls)) '() o))) + +(define (port->list read in) + (port-map (lambda (x) x) read in)) + +(define (port->sexp-list in) + (port->list read in)) + +(define (port->string-list in) + (port->list read-line in)) + +(define (port->string in) + (string-concatenate (port->list (lambda (in) (read-string 1024 in)) in))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; custom port utilities + +(define (make-custom-input-port read . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-input-port read seek close))) + +(define (make-custom-output-port write . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-output-port write seek close))) + +(define (make-null-output-port) + (make-custom-output-port (lambda (str n) 0))) + +(define (make-broadcast-port . ports) + (make-custom-output-port + (lambda (str n) + (for-each (lambda (p) (write-string str n p)) ports) + n))) + +(define (make-filtered-output-port filter out) + (make-custom-output-port + (lambda (str n) + (let* ((len (string-length str)) + (s1 (if (= n len) str (substring str 0 n))) + (s2 (filter s1))) + (if (string? s2) + (write-string s2 (string-length s2) out)))))) + +(define (make-concatenated-port . ports) + (make-custom-input-port + (lambda (str n) + (if (null? ports) + 0 + (let lp ((i (read-string! str n (car ports)))) + (cond + ((>= i n) + i) + (else + (set! ports (cdr ports)) + (cond + ((null? ports) + i) + (else + (let* ((s (read-string (- n i) (car ports))) + (len (if (string? s) (string-length s) 0))) + (if (and (string? str) (> len 0)) + (string-copy! str i s 0 len)) + (lp (+ i len)))))))))))) + +(define (make-generated-input-port generator) + (let ((buf "") + (len 0) + (offset 0)) + (make-custom-input-port + (lambda (str n) + (cond + ((>= (- len offset) n) + (string-copy! str 0 buf offset (+ offset n)) + (set! offset (+ offset n)) + n) + (else + (string-copy! str 0 buf offset len) + (let lp ((i (- len offset))) + (set! buf (generator)) + (cond + ((not (string? buf)) + (set! buf "") + (set! len 0) + (set! offset 0) + (- n i)) + (else + (set! len (string-length buf)) + (set! offset 0) + (cond + ((>= (- len offset) (- n i)) + (string-copy! str i buf offset (+ offset (- n i))) + (set! offset (+ offset (- n i))) + n) + (else + (string-copy! str i buf offset len) + (lp (+ i (- len offset)))))))))))))) + +(define (make-filtered-input-port filter in) + (make-generated-input-port + (lambda () + (let ((res (read-string 1024 in))) + (if (string? res) (filter res) res))))) diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub new file mode 100644 index 00000000..07450dc0 --- /dev/null +++ b/lib/chibi/io/io.stub @@ -0,0 +1,27 @@ + +(define-c non-null-string (%read-line "fgets") + ((result (array char arg1)) int (default (current-input-port) input-port))) + +(define-c size_t (%read-string "fread") + ((result (array char arg2)) (value 1 size_t) size_t (default (current-input-port) input-port))) + +(define-c size_t (read-string! "fread") + (string (value 1 size_t) size_t (default (current-input-port) input-port))) + +(define-c size_t (write-string "fwrite") + (string (value 1 size_t) size_t (default (current-output-port) output-port))) + +(define-c-const int (seek/set "SEEK_SET")) +(define-c-const int (seek/cur "SEEK_CUR")) +(define-c-const int (seek/end "SEEK_END")) + +(define-c long (file-position "ftell") (port)) +(define-c long (set-file-position! "fseek") (port long int)) + +(c-include "port.c") + +(define-c sexp (%make-custom-input-port "sexp_make_custom_input_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) + +(define-c sexp (%make-custom-output-port "sexp_make_custom_output_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c new file mode 100644 index 00000000..6aa6403a --- /dev/null +++ b/lib/chibi/io/port.c @@ -0,0 +1,201 @@ + +#include +#include + +#define SEXP_PORT_BUFFER_SIZE 1024 +#define SEXP_LAST_CONTEXT_CHECK_LIMIT 256 + +#define sexp_cookie_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO) +#define sexp_cookie_buffer(vec) sexp_vector_ref((sexp)vec, SEXP_ONE) +#define sexp_cookie_read(vec) sexp_vector_ref((sexp)vec, SEXP_TWO) +#define sexp_cookie_write(vec) sexp_vector_ref((sexp)vec, SEXP_THREE) +#define sexp_cookie_seek(vec) sexp_vector_ref((sexp)vec, SEXP_FOUR) +#define sexp_cookie_close(vec) sexp_vector_ref((sexp)vec, SEXP_FIVE) + +#if ! SEXP_USE_BOEHM +static int sexp_in_heap_p (sexp_heap h, sexp p) { + for ( ; h; h = h->next) + if (((sexp)h < p) && (p < (sexp)((char*)h + h->size))) + return 1; + return 0; +} +#endif + +static sexp sexp_last_context (sexp ctx, sexp *cstack) { + sexp res=SEXP_FALSE, p; +#if ! SEXP_USE_BOEHM + sexp_sint_t i; + sexp_heap h = sexp_context_heap(ctx); + for (i=0; i sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_read(vec), args); + sexp_gc_release2(ctx); + if (sexp_fixnump(res)) { + memcpy(buffer, sexp_string_data(sexp_cookie_buffer(vec)), sexp_unbox_fixnum(res)); + return sexp_unbox_fixnum(res); + } else { + return -1; + } +} + +#if SEXP_BSD +static int sexp_cookie_writer (void *cookie, const char *buffer, int size) +#else +static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size) +#endif +{ + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_write(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + if (size > sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_write(vec), args); + sexp_gc_release2(ctx); + return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1); +} + +#if ! SEXP_BSD + +#ifdef __CYGWIN__ +#define off64_t off_t +#endif + +static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + args = sexp_make_integer(ctx, *position); + args = sexp_list2(ctx, args, sexp_make_fixnum(whence)); + res = sexp_apply(ctx, sexp_cookie_seek(vec), args); + if (sexp_fixnump(res)) + *position = sexp_unbox_fixnum(res); + sexp_gc_release2(ctx); + return sexp_fixnump(res); +} +#endif + +static int sexp_cookie_cleaner (void *cookie) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_close(vec))) return 0; + ctx = sexp_cookie_ctx(vec); + res = sexp_apply(ctx, sexp_cookie_close(vec), SEXP_NULL); + return (sexp_exceptionp(res) ? -1 : sexp_truep(res)); +} + +#if ! SEXP_BSD + +static cookie_io_functions_t sexp_cookie = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = (cookie_seek_function_t*)sexp_cookie_seeker, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +static cookie_io_functions_t sexp_cookie_no_seek = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = NULL, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +#endif + +#if SEXP_USE_STRING_STREAMS + +static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode, + sexp read, sexp write, + sexp seek, sexp close) { + FILE *in; + sexp res; + sexp_gc_var1(vec); + if (sexp_truep(read) && ! sexp_procedurep(read)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read); + if (sexp_truep(write) && ! sexp_procedurep(write)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write); + if (sexp_truep(seek) && ! sexp_procedurep(seek)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek); + if (sexp_truep(close) && ! sexp_procedurep(close)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close); + sexp_gc_preserve1(ctx, vec); + vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID); + sexp_cookie_ctx(vec) = ctx; + sexp_cookie_buffer(vec) + = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID); + sexp_cookie_read(vec) = read; + sexp_cookie_write(vec) = write; + sexp_cookie_seek(vec) = seek; + sexp_cookie_close(vec) = close; +#if SEXP_BSD + in = funopen(vec, + (sexp_procedurep(read) ? sexp_cookie_reader : NULL), + (sexp_procedurep(write) ? sexp_cookie_writer : NULL), + NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */ + (sexp_procedurep(close) ? sexp_cookie_cleaner : NULL)); +#else + in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek)); +#endif + if (! in) { + res = sexp_user_exception(ctx, self, "couldn't make custom port", read); + } else { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = vec; /* for gc preserving */ + } + sexp_gc_release1(ctx); + return res; +} + +#else + +static sexp sexp_make_custom_port (sexp ctx, sexp self, + char *mode, sexp read, sexp write, + sexp seek, sexp close) { + return sexp_user_exception(ctx, self, "custom ports not supported in this configuration", SEXP_NULL); +} + +#endif + +static sexp sexp_make_custom_input_port (sexp ctx, sexp self, + sexp read, sexp seek, sexp close) { + return sexp_make_custom_port(ctx, self, "r", read, SEXP_FALSE, seek, close); +} + +static sexp sexp_make_custom_output_port (sexp ctx, sexp self, + sexp write, sexp seek, sexp close) { + sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close); + sexp_pointer_tag(res) = SEXP_OPORT; + return res; +} diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module new file mode 100644 index 00000000..5b76daf8 --- /dev/null +++ b/lib/chibi/loop.module @@ -0,0 +1,9 @@ + +(define-module (chibi loop) + (export loop in-list in-lists in-port in-file up-from down-from + listing listing-reverse appending appending-reverse + summing multiplying in-string in-string-reverse + in-vector in-vector-reverse) + (import-immutable (scheme)) + (include "loop/loop.scm")) + diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm new file mode 100644 index 00000000..09e12856 --- /dev/null +++ b/lib/chibi/loop/loop.scm @@ -0,0 +1,365 @@ +;;;; loop.scm - the chibi loop (aka foof-loop) +;; +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; The loop API is compatible with Taylor Campbell's foof-loop, but +;; the iterator API is different and subject to change. All loop +;; variables may be implicitly destructured with MATCH semantics. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (assoc-pred equal elt ls) + (and (pair? ls) + (if (equal elt (car (car ls))) + (car ls) + (assoc-pred equal elt (cdr ls))))) + +(define-syntax let-keyword-form + (syntax-rules () + ((let-keyword-form + ((labeled-arg-macro-name (positional-name . params))) + . body) + (let-syntax + ((labeled-arg-macro-name + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (named '()) (posns '())) + (cond + ((pair? ls) + (if (and (list? (car ls)) (compare (caar ls) (rename '=>))) + (lp (cdr ls) (cons (cdar ls) named) posns) + (lp (cdr ls) named (cons (car ls) posns)))) + (else + (let lp ((ls (syntax-quote params)) + (posns (reverse posns)) + (args '())) + (cond + ((null? ls) + (if (pair? posns) + (error "let-keyword-form: too many args" expr) + (cons (syntax-quote positional-name) (reverse args)))) + ((assoc-pred compare (caar ls) named) + => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args)))) + ((pair? posns) + (lp (cdr ls) (cdr posns) (cons (car posns) args))) + (else + (lp (cdr ls) posns (cons (cadar ls) args)))))))))))) + . body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax loop + (syntax-rules () + ;; unnamed, implicit recursion + ((loop (vars ...) body ...) + (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop))) + ;; named, explicit recursion + ((loop name (vars ...) body ...) + (%loop name () () () () () (vars ...) body ...)))) + +;; Main LOOP macro. Separate the variables from the iterator and +;; parameters, then walk through each parameter expanding the +;; bindings, and build the final form. + +(define-syntax %loop + (syntax-rules (=> for with let while until) + ;; automatic iteration + ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body) + (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ;; do equivalents, with optional guards + ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body) + (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init step) rest ...) . body) + (%loop name l (vars ... (var init step)) c r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init) rest ...) . body) + (%loop name l (vars ... (var init var)) c r f (rest ...) . body)) + ;; user-specified terminators + ((_ name l vars (checks ...) r f ((until expr) rest ...) . body) + (%loop name l vars (checks ... expr) r f (rest ...) . body)) + ((_ name l vars (checks ...) r f ((while expr) rest ...) . body) + (%loop name l vars (checks ... (not expr)) r f (rest ...) . body)) + ;; specify a default done? + ((_ name l v c r f ()) + (%loop name l v c r f () (#f #f))) + ((_ name l v c r f () () . body) + (%loop name l v c r f () (#f #f) . body)) + ;; final expansion + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => result + . body) + (let* (lets ...) + (letrec ((tmp (lambda (var ...) + (if (or checks ...) + (let-keyword-form ((name (tmp (var step) ...))) + (let (finals ...) result)) + (let (refs ...) + (let-keyword-form ((name (tmp (var step) ...))) + (if #f #f) + . body)))))) + (tmp init ...)))) + ;; unspecified return value case + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + . body) + (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => (if #f #f) . body)) + )) + +(define-syntax %loop-next + (syntax-rules () + ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...) + name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...) + . rest) + (%loop name (lets ... new-lets ...) (vars ... new-vars ...) + (checks ... new-checks ...) (refs ... new-refs ...) + (finals ... new-finals ...) + . rest)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Iterators + +;; Each gets passed two lists, those items left of the <- and those to +;; the right, followed by a NEXT and REST continuation. + +;; Should finish with +;; +;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...) +;; (loop-vars ...) (final-vars ...) . rest) +;; +;; OUTER-VARS: bound once outside the loop in a LET* +;; CURSOR-VARS: DO-style bindings of the form (name init update) +;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t +;; LOOP-VARS: inner variables, updated in parallel after the cursors +;; FINAL-VARS: final variables, bound only in the => result + +(define-syntax in-list ; called just "IN" in ITER + (syntax-rules () + ((in-list ((var) source) next . rest) + (in-list ((var cursor) source) next . rest)) + ((in-list ((var cursor) source) next . rest) + (in-list ((var cursor succ) source) next . rest)) + ((in-list ((var cursor succ) (source)) next . rest) + (next () ; outer let bindings + ((cursor source succ)) ; iterator, init, step + ((not (pair? cursor))) ; finish tests for iterator vars + ;; step variables and values + ((var (car cursor)) + (succ (cdr cursor))) + () ; final result bindings + . rest)) + ((in-list ((var cursor succ) (source step)) next . rest) + (next () + ((cursor source succ)) + ((not (pair? cursor))) + ((var (car cursor)) + (succ (step cursor))) + () + . rest)))) + +;; Iterator from Taylor R. Campbell. If you know the number of lists +;; ahead of time it's much more efficient to iterate over each one +;; separately. +(define-syntax in-lists + (syntax-rules () + ((in-lists ((elts) lol) next . rest) + (in-lists ((elts pairs) lol) next . rest)) + ((in-lists ((elts pairs) lol) next . rest) + (in-lists ((elts pairs succ) lol) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol step)) next . rest) + (in-lists ((elts pairs succ) (lol step null?)) next . rest)) + ((in-lists ((elts pairs succ) (lol step done?)) next . rest) + (next () + ((pairs lol succ)) + ((let lp ((ls pairs)) ; an in-lined ANY + (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls)))))) + ((elts (map car pairs)) + (succ (map step pairs))) + () + . rest)) + )) + +(define-syntax define-in-indexed + (syntax-rules () + ((define-in-indexed in-type in-type-reverse length ref) + (begin + (define-syntax in-type + (syntax-rules () + ((in-type ls next . rest) + (%in-idx >= + 0 (length tmp) ref tmp ls next . rest)))) + (define-syntax in-type-reverse + (syntax-rules () + ((in-type-reverse ls next . rest) + (%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest)))) + )))) + +(define-in-indexed in-string in-string-reverse string-length string-ref) +(define-in-indexed in-vector in-vector-reverse vector-length vector-ref) + +;; helper for the above string and vector iterators +(define-syntax %in-idx + (syntax-rules () + ;; cmp inc start end ref + ((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest) + (%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest) + (next ((tmp-vec vec) (end to)) + ((index from (+ index step))) + ((ge index end)) + ((var (r tmp-vec index))) + () + . rest)) + )) + +(define-syntax in-port + (syntax-rules () + ((in-port ((var) source) next . rest) + (in-port ((var p) source) next . rest)) + ((in-port ((var p) ()) next . rest) + (in-port ((var p) ((current-input-port))) next . rest)) + ((in-port ((var p) (port)) next . rest) + (in-port ((var p) (port read-char)) next . rest)) + ((in-port ((var p) (port read-char)) next . rest) + (in-port ((var p) (port read-char eof-object?)) next . rest)) + ((in-port ((var p) (port reader eof?)) next . rest) + (next ((p port) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + () + . rest)))) + +(define-syntax in-file + (syntax-rules () + ((in-file ((var) source) next . rest) + (in-file ((var p) source) next . rest)) + ((in-file ((var p) (file)) next . rest) + (in-file ((var p) (file read-char)) next . rest)) + ((in-file ((var p) (file reader)) next . rest) + (in-file ((var p) (file reader eof-object?)) next . rest)) + ((in-file ((var p) (file reader eof?)) next . rest) + (next ((p (open-input-file file)) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + ((dummy (close-input-port p))) + . rest)))) + +(define-syntax up-from + (syntax-rules (to by) + ((up-from (() . args) next . rest) + (up-from ((var) . args) next . rest)) + ((up-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var s (+ var e))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var s (+ var 1))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var s (+ var e))) () () () . rest)) + ((up-from ((var) (start)) next . rest) + (next ((s start)) ((var s (+ var 1))) () () () . rest)) + )) + +(define-syntax down-from + (syntax-rules (to by) + ((down-from (() . args) next . rest) + (down-from ((var) . args) next . rest)) + ((down-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var (- s e) (- var e))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var (- s 1) (- var 1))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var (- s e) (- var e))) () () () + . rest)) + ((down-from ((var) (start)) next . rest) + (next ((s start)) ((var (- s 1) (- var 1))) () () () + . rest)) + )) + +(define-syntax accumulating + (syntax-rules (initial if) + ((accumulating (kons final init) ((var) . x) next . rest) + (accumulating (kons final init) ((var cursor) . x) next . rest)) + ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest) + (accumulating (kons final i) ((var cursor) x) n . rest)) + ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (if check (tmp-kons expr cursor) cursor))) + () + () + ((var (final cursor))) + . rest)) + ((accumulating (kons final init) ((var cursor) (expr)) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (tmp-kons expr cursor))) + () + () + ((var (final cursor))) + . rest)))) + +(define-syntax listing + (syntax-rules () + ((listing args next . rest) + (accumulating (cons reverse '()) args next . rest)))) + +(define-syntax listing-reverse + (syntax-rules () + ((listing-reverse args next . rest) + (accumulating (cons (lambda (x) x) '()) args next . rest)))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define-syntax appending + (syntax-rules () + ((appending args next . rest) + (accumulating (append-reverse reverse '()) args next . rest)))) + +(define-syntax appending-reverse + (syntax-rules () + ((appending-reverse args next . rest) + (accumulating (append-reverse (lambda (x) x) '()) args next . rest)))) + +(define-syntax summing + (syntax-rules () + ((summing args next . rest) + (accumulating (+ (lambda (x) x) 0) args next . rest)))) + +(define-syntax multiplying + (syntax-rules () + ((multiplying args next . rest) + (accumulating (* (lambda (x) x) 1) args next . rest)))) diff --git a/lib/chibi/match.module b/lib/chibi/match.module new file mode 100644 index 00000000..1366176a --- /dev/null +++ b/lib/chibi/match.module @@ -0,0 +1,6 @@ + +(define-module (chibi match) + (export match match-lambda match-lambda* match-let match-letrec match-let*) + (import-immutable (scheme)) + (include "match/match.scm")) + diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm new file mode 100644 index 00000000..f4eb173d --- /dev/null +++ b/lib/chibi/match/match.scm @@ -0,0 +1,683 @@ +;;;; match.scm -- portable hygienic pattern matcher +;; +;; This code is written by Alex Shinn and placed in the +;; Public Domain. All warranties are disclaimed. + +;; This is a full superset of the popular MATCH package by Andrew +;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks +;; in R6RS SYNTAX-RULES), and thus preserving hygiene. + +;; This is a simple generative pattern matcher - each pattern is +;; expanded into the required tests, calling a failure continuation if +;; the tests fail. This makes the logic easy to follow and extend, +;; but produces sub-optimal code in cases where you have many similar +;; clauses due to repeating the same tests. Nonetheless a smart +;; compiler should be able to remove the redundant tests. For +;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance +;; hit. + +;; The original version was written on 2006/11/29 and described in the +;; following Usenet post: +;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd +;; and is still available at +;; http://synthcode.com/scheme/match-simple.scm +;; It's just 80 lines for the core MATCH, and an extra 40 lines for +;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar. +;; +;; A variant of this file which uses COND-EXPAND in a few places for +;; performance can be found at +;; http://synthcode.com/scheme/match-cond-expand.scm +;; +;; 2009/11/25 - adding `***' tree search patterns +;; 2008/03/20 - fixing bug where (a ...) matched non-lists +;; 2008/03/15 - removing redundant check in vector patterns +;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) +;; 2007/09/04 - fixing quasiquote patterns +;; 2007/07/21 - allowing ellipse patterns in non-final list positions +;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse +;; (thanks to Taylor Campbell) +;; 2007/04/08 - clean up, commenting +;; 2006/12/24 - bugfixes +;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; force compile-time syntax errors with useful messages + +(define-syntax match-syntax-error + (syntax-rules () + ((_) (match-syntax-error "invalid match-syntax-error usage")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The basic interface. MATCH just performs some basic syntax +;; validation, binds the match expression to a temporary variable `v', +;; and passes it on to MATCH-NEXT. It's a constant throughout the +;; code below that the binding `v' is a direct variable reference, not +;; an expression. + +(define-syntax match + (syntax-rules () + ((match) + (match-syntax-error "missing match expression")) + ((match atom) + (match-syntax-error "no match clauses")) + ((match (app ...) (pat . body) ...) + (let ((v (app ...))) + (match-next v ((app ...) (set! (app ...))) (pat . body) ...))) + ((match #(vec ...) (pat . body) ...) + (let ((v #(vec ...))) + (match-next v (v (set! v)) (pat . body) ...))) + ((match atom (pat . body) ...) + (match-next atom (atom (set! atom)) (pat . body) ...)) + )) + +;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure +;; thunk, which is expanded by recursing MATCH-NEXT on the remaining +;; clauses. `g+s' is a list of two elements, the get! and set! +;; expressions respectively. + +(define-syntax match-next + (syntax-rules (=>) + ;; no more clauses, the match failed + ((match-next v g+s) + (error 'match "no matching pattern")) + ;; named failure continuation + ((match-next v g+s (pat (=> failure) . body) . rest) + (let ((failure (lambda () (match-next v g+s . rest)))) + ;; match-one analyzes the pattern for us + (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ()))) + ;; anonymous failure continuation, give it a dummy name + ((match-next v g+s (pat . body) . rest) + (match-next v g+s (pat (=> failure) . body) . rest)))) + +;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to +;; MATCH-TWO. + +(define-syntax match-one + (syntax-rules () + ;; If it's a list of two or more values, check to see if the + ;; second one is an ellipse and handle accordingly, otherwise go + ;; to MATCH-TWO. + ((match-one v (p q . r) g+s sk fk i) + (match-check-ellipse + q + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()) + (match-two v (p q . r) g+s sk fk i))) + ;; Go directly to MATCH-TWO. + ((match-one . x) + (match-two . x)))) + +;; This is the guts of the pattern matcher. We are passed a lot of +;; information in the form: +;; +;; (match-two var pattern getter setter success-k fail-k (ids ...)) +;; +;; usually abbreviated +;; +;; (match-two v p g+s sk fk i) +;; +;; where VAR is the symbol name of the current variable we are +;; matching, PATTERN is the current pattern, getter and setter are the +;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding +;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure +;; continuation (which is just a thunk call and is thus safe to expand +;; multiple times) and IDS are the list of identifiers bound in the +;; pattern so far. + +(define-syntax match-two + (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!) + ((match-two v () g+s (sk ...) fk i) + (if (null? v) (sk ... i) fk)) + ((match-two v (quote p) g+s (sk ...) fk i) + (if (equal? v 'p) (sk ... i) fk)) + ((match-two v (quasiquote p) . x) + (match-quasiquote v p . x)) + ((match-two v (and) g+s (sk ...) fk i) (sk ... i)) + ((match-two v (and p q ...) g+s sk fk i) + (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i)) + ((match-two v (or) g+s sk fk i) fk) + ((match-two v (or p) . x) + (match-one v p . x)) + ((match-two v (or p ...) g+s sk fk i) + (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ())) + ((match-two v (not p) g+s (sk ...) fk i) + (match-one v p g+s (match-drop-ids fk) (sk ... i) i)) + ((match-two v (get! getter) (g s) (sk ...) fk i) + (let ((getter (lambda () g))) (sk ... i))) + ((match-two v (set! setter) (g (s ...)) (sk ...) fk i) + (let ((setter (lambda (x) (s ... x)))) (sk ... i))) + ((match-two v (? pred . p) g+s sk fk i) + (if (pred v) (match-one v (and . p) g+s sk fk i) fk)) + ((match-two v (= proc p) . x) + (let ((w (proc v))) (match-one w p . x))) + ((match-two v (p ___ . r) g+s sk fk i) + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())) + ((match-two v (p) g+s sk fk i) + (if (and (pair? v) (null? (cdr v))) + (let ((w (car v))) + (match-one w p ((car v) (set-car! v)) sk fk i)) + fk)) + ((match-two v (p *** q) g+s sk fk i) + (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) + ((match-two v (p *** . q) g+s sk fk i) + (match-syntax-error "invalid use of ***" (p *** . q))) + ((match-two v ($ rec p ...) g+s sk fk i) + (if (is-a? v rec) + (match-record-refs v rec 0 (p ...) g+s sk fk i) + fk)) + ((match-two v (p . q) g+s sk fk i) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-one w p ((car v) (set-car! v)) + (match-one x q ((cdr v) (set-cdr! v)) sk fk) + fk + i)) + fk)) + ((match-two v #(p ...) g+s . x) + (match-vector v 0 () (p ...) . x)) + ((match-two v _ g+s (sk ...) fk i) (sk ... i)) + ;; Not a pair or vector or special literal, test to see if it's a + ;; new symbol, in which case we just bind it, or if it's an + ;; already bound symbol or some other literal, in which case we + ;; compare it with EQUAL?. + ((match-two v x g+s (sk ...) fk (id ...)) + (let-syntax + ((new-sym? + (syntax-rules (id ...) + ((new-sym? x sk2 fk2) sk2) + ((new-sym? y sk2 fk2) fk2)))) + (new-sym? random-sym-to-match + (let ((x v)) (sk ... (id ... x))) + (if (equal? v x) (sk ... (id ...)) fk)))) + )) + +;; QUASIQUOTE patterns + +(define-syntax match-quasiquote + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ v (unquote p) g+s sk fk i) + (match-one v p g+s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g+s sk fk i) + (if (pair? v) + (match-one v + (p . tmp) + (match-quasiquote tmp rest g+s sk fk) + fk + i) + fk)) + ((_ v (quasiquote p) g+s sk fk i . depth) + (match-quasiquote v p g+s sk fk i #f . depth)) + ((_ v (unquote p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (unquote-splicing p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (p . q) g+s sk fk i . depth) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-quasiquote + w p g+s + (match-quasiquote-step x q g+s sk fk depth) + fk i . depth)) + fk)) + ((_ v #(elt ...) g+s sk fk i . depth) + (if (vector? v) + (let ((ls (vector->list v))) + (match-quasiquote ls (elt ...) g+s sk fk i . depth)) + fk)) + ((_ v x g+s sk fk i . depth) + (match-one v 'x g+s sk fk i)))) + +(define-syntax match-quasiquote-step + (syntax-rules () + ((match-quasiquote-step x q g+s sk fk depth i) + (match-quasiquote x q g+s sk fk i . depth)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities + +;; Takes two values and just expands into the first. +(define-syntax match-drop-ids + (syntax-rules () + ((_ expr ids ...) expr))) + +(define-syntax match-drop-first-arg + (syntax-rules () + ((_ arg expr) expr))) + +;; To expand an OR group we try each clause in succession, passing the +;; first that succeeds to the success continuation. On failure for +;; any clause, we just try the next clause, finally resorting to the +;; failure continuation fk if all clauses fail. The only trick is +;; that we want to unify the identifiers, so that the success +;; continuation can refer to a variable from any of the OR clauses. + +(define-syntax match-gen-or + (syntax-rules () + ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...)) + (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) + (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...)))))) + +(define-syntax match-gen-or-step + (syntax-rules () + ((_ v () g+s sk fk . x) + ;; no OR clauses, call the failure continuation + fk) + ((_ v (p) . x) + ;; last (or only) OR clause, just expand normally + (match-one v p . x)) + ((_ v (p . q) g+s sk fk i) + ;; match one and try the remaining on failure + (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) + )) + +;; We match a pattern (p ...) by matching the pattern p in a loop on +;; each element of the variable, accumulating the bound ids into lists. + +;; Look at the body of the simple case - it's just a named let loop, +;; matching each element in turn to the same pattern. The only trick +;; is that we want to keep track of the lists of each extracted id, so +;; when the loop recurses we cons the ids onto their respective list +;; variables, and on success we bind the ids (what the user input and +;; expects to see in the success body) to the reversed accumulated +;; list IDs. + +(define-syntax match-gen-ellipses + (syntax-rules () + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to (p ...), just bind the list + (let ((p v)) + (if (list? p) + (sk ... i) + fk)) + ;; simple case, match all elements of the list + (let loop ((ls v) (id-ls '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) + fk i))) + (else + fk))))) + ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking + (match-verify-no-ellipses + r + (let* ((tail-len (length 'r)) + (ls v) + (len (length ls))) + (if (< len tail-len) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond + ((= n tail-len) + (let ((id (reverse id-ls)) ...) + (match-one ls r (#f #f) (sk ... i) fk i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids + (loop (cdr ls) (- n 1) (cons id id-ls) ...)) + fk + i))) + (else + fk))))))))) + +;; This is just a safety check. Although unlike syntax-rules we allow +;; trailing patterns after an ellipses, we explicitly disable multiple +;; ellipses at the same level. This is because in the general case +;; such patterns are exponential in the number of ellipses, and we +;; don't want to make it easy to construct very expensive operations +;; with simple looking patterns. For example, it would be O(n^2) for +;; patterns like (a ... b ...) because we must consider every trailing +;; element for every possible break for the leading "a ...". + +(define-syntax match-verify-no-ellipses + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipse + x + (match-syntax-error + "multiple ellipse patterns not allowed at same level") + (match-verify-no-ellipses y sk))) + ((_ () sk) + sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipse" x)))) + +;; Matching a tree search pattern is only slightly more complicated. +;; Here we allow patterns of the form +;; +;; (x *** y) +;; +;; to represent the pattern y located somewhere in a tree where the +;; path from the current object to y can be seen as a list of the form +;; (X ...). Y can immediately match the current object in which case +;; the path is the empty list. In a sense it's a 2-dimensional +;; version of the ... pattern. +;; +;; As a common case the pattern (_ *** y) can be used to search for Y +;; anywhere in a tree, regardless of the path used. +;; +;; To implement the search, we use two recursive procedures. TRY +;; attempts to match Y once, and on success it calls the normal SK on +;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we +;; call NEXT which first checks if the current value is a list +;; beginning with X, then calls TRY on each remaining element of the +;; list. Since TRY will recursively call NEXT again on failure, this +;; effects a full depth-first search. +;; +;; The failure continuation throughout is a jump to the next step in +;; the tree search, initialized with the original failure continuation +;; FK. + +(define-syntax match-gen-search + (syntax-rules () + ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) + (letrec ((try (lambda (w fail id-ls ...) + (match-one w q g+s + (match-drop-ids + (let ((id (reverse id-ls)) ...) + sk)) + (next w fail id-ls ...) i))) + (next (lambda (w fail id-ls ...) + (if (not (pair? w)) + (fail) + (let ((u (car w))) + (match-one + u p ((car w) (set-car! w)) + (match-drop-ids + ;; accumulate the head variables from + ;; the p pattern, and loop over the tail + (let ((id-ls (cons id id-ls)) ...) + (let lp ((ls (cdr w))) + (if (pair? ls) + (try (car ls) + (lambda () (lp (cdr ls))) + id-ls ...) + (fail))))) + (fail) i)))))) + ;; the initial id-ls binding here is a dummy to get the right + ;; number of '()s + (let ((id-ls '()) ...) + (try v (lambda () fk) id-ls ...)))))) + +;; Vector patterns are just more of the same, with the slight +;; exception that we pass around the current vector index being +;; matched. + +(define-syntax match-vector + (syntax-rules (___) + ((_ v n pats (p q) . x) + (match-check-ellipse q + (match-gen-vector-ellipses v n pats p . x) + (match-vector-two v n pats (p q) . x))) + ((_ v n pats (p ___) sk fk i) + (match-gen-vector-ellipses v n pats p sk fk i)) + ((_ . x) + (match-vector-two . x)))) + +;; Check the exact vector length, then check each element in turn. + +(define-syntax match-vector-two + (syntax-rules () + ((_ v n ((pat index) ...) () sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (= len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) . x) + (match-vector v (+ n 1) (pats ... (p n)) q . x)))) + +(define-syntax match-vector-step + (syntax-rules () + ((_ v () (sk ...) fk i) (sk ... i)) + ((_ v ((pat index) . rest) sk fk i) + (let ((w (vector-ref v index))) + (match-one w pat ((vector-ref v index) (vector-set! v index)) + (match-vector-step v rest sk fk) + fk i))))) + +;; With a vector ellipse pattern we first check to see if the vector +;; length is at least the required length. + +(define-syntax match-gen-vector-ellipses + (syntax-rules () + ((_ v n ((pat index) ...) p sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (>= len n) + (match-vector-step v ((pat index) ...) + (match-vector-tail v p n len sk fk) + fk i) + fk)) + fk)))) + +(define-syntax match-vector-tail + (syntax-rules () + ((_ v p n len sk fk i) + (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())))) + +(define-syntax match-vector-tail-two + (syntax-rules () + ((_ v p n len (sk ...) fk i ((id id-ls) ...)) + (let loop ((j n) (id-ls '()) ...) + (if (>= j len) + (let ((id (reverse id-ls)) ...) (sk ... i)) + (let ((w (vector-ref v j))) + (match-one w p ((vector-ref v j) (vetor-set! v j)) + (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) + fk i))))))) + +(define-syntax match-record-refs + (syntax-rules () + ((_ v rec n (p . q) g+s sk fk i) + (let ((w (slot-ref rec v n))) + (match-one w p ((slot-ref rec v n) (slot-set! rec v n)) + (match-record-refs v rec (+ n 1) q g+s sk fk) fk i))) + ((_ v rec n () g+s (sk ...) fk i) + (sk ... i)))) + +;; Extract all identifiers in a pattern. A little more complicated +;; than just looking for symbols, we need to ignore special keywords +;; and non-pattern forms (such as the predicate expression in ? +;; patterns), and also ignore previously bound identifiers. +;; +;; Calls the continuation with all new vars as a list of the form +;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely +;; pair with the original variable (e.g. it's used in the ellipse +;; generation for list variables). +;; +;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) + +(define-syntax match-extract-vars + (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!) + ((match-extract-vars (? pred . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars ($ rec . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (= proc p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (quote x) (k ...) i v) + (k ... v)) + ((match-extract-vars (quasiquote x) k i v) + (match-extract-quasiquote-vars x k i v (#t))) + ((match-extract-vars (and . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (or . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (not . p) . x) + (match-extract-vars p . x)) + ;; A non-keyword pair, expand the CAR with a continuation to + ;; expand the CDR. + ((match-extract-vars (p q . r) k i v) + (match-check-ellipse + q + (match-extract-vars (p . r) k i v) + (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) + ((match-extract-vars (p . q) k i v) + (match-extract-vars p (match-extract-vars-step q k i v) i ())) + ((match-extract-vars #(p ...) . x) + (match-extract-vars (p ...) . x)) + ((match-extract-vars _ (k ...) i v) (k ... v)) + ((match-extract-vars ___ (k ...) i v) (k ... v)) + ((match-extract-vars *** (k ...) i v) (k ... v)) + ;; This is the main part, the only place where we might add a new + ;; var if it's an unbound symbol. + ((match-extract-vars p (k ...) (i ...) v) + (let-syntax + ((new-sym? + (syntax-rules (i ...) + ((new-sym? p sk fk) sk) + ((new-sym? x sk fk) fk)))) + (new-sym? random-sym-to-match + (k ... ((p p-ls) . v)) + (k ... v)))) + )) + +;; Stepper used in the above so it can expand the CAR and CDR +;; separately. + +(define-syntax match-extract-vars-step + (syntax-rules () + ((_ p k i v ((v2 v2-ls) ...)) + (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) + )) + +(define-syntax match-extract-quasiquote-vars + (syntax-rules (quasiquote unquote unquote-splicing) + ((match-extract-quasiquote-vars (quasiquote x) k i v d) + (match-extract-quasiquote-vars x k i v (#t . d))) + ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) + (match-extract-quasiquote-vars (unquote x) k i v d)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t)) + (match-extract-vars x k i v)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) + (match-extract-quasiquote-vars x k i v d)) + ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) + (match-extract-quasiquote-vars + x + (match-extract-quasiquote-vars-step y k i v d) i ())) + ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) + (match-extract-quasiquote-vars (x ...) k i v d)) + ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) + (k ... v)) + )) + +(define-syntax match-extract-quasiquote-vars-step + (syntax-rules () + ((_ x k i v d ((v2 v2-ls) ...)) + (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d)) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gimme some sugar baby. + +(define-syntax match-lambda + (syntax-rules () + ((_ clause ...) (lambda (expr) (match expr clause ...))))) + +(define-syntax match-lambda* + (syntax-rules () + ((_ clause ...) (lambda expr (match expr clause ...))))) + +(define-syntax match-let + (syntax-rules () + ((_ (vars ...) . body) + (match-let/helper let () () (vars ...) . body)) + ((_ loop . rest) + (match-named-let loop () . rest)))) + +(define-syntax match-letrec + (syntax-rules () + ((_ vars . body) (match-let/helper letrec () () vars . body)))) + +(define-syntax match-let/helper + (syntax-rules () + ((_ let ((var expr) ...) () () . body) + (let ((var expr) ...) . body)) + ((_ let ((var expr) ...) ((pat tmp) ...) () . body) + (let ((var expr) ...) + (match-let* ((pat tmp) ...) + . body))) + ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((a expr) . rest) . body) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)))) + +(define-syntax match-named-let + (syntax-rules () + ((_ loop ((pat expr var) ...) () . body) + (let loop ((var expr) ...) + (match-let ((pat var) ...) + . body))) + ((_ loop (v ...) ((pat expr) . rest) . body) + (match-named-let loop (v ... (pat expr tmp)) rest . body)))) + +(define-syntax match-let* + (syntax-rules () + ((_ () . body) + (begin . body)) + ((_ ((pat expr) . rest) . body) + (match expr (pat (match-let* rest . body)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Otherwise COND-EXPANDed bits. + +;; This *should* work, but doesn't :( +;; (define-syntax match-check-ellipse +;; (syntax-rules (...) +;; ((_ ... sk fk) sk) +;; ((_ x sk fk) fk))) + +;; This is a little more complicated, and introduces a new let-syntax, +;; but should work portably in any R[56]RS Scheme. Taylor Campbell +;; originally came up with the idea. +(define-syntax match-check-ellipse + (syntax-rules () + ;; these two aren't necessary but provide fast-case failures + ((match-check-ellipse (a . b) success-k failure-k) failure-k) + ((match-check-ellipse #(a ...) success-k failure-k) failure-k) + ;; matching an atom + ((match-check-ellipse id success-k failure-k) + (let-syntax ((ellipse? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipse? (foo id) sk fk) sk) + ((ellipse? other sk fk) fk)))) + ;; this list of three elements will only many the (foo id) list + ;; above if `id' is `...' + (ellipse? (a b c) success-k failure-k))))) + + +;; This is portable but can be more efficient with non-portable +;; extensions. This trick was originally discovered by Oleg Kiselyov. + +(define-syntax match-check-identifier + (syntax-rules () + ;; fast-case failures, lists and vectors are not identifiers + ((_ (x . y) success-k failure-k) failure-k) + ((_ #(x ...) success-k failure-k) failure-k) + ;; x is an atom + ((_ x success-k failure-k) + (let-syntax + ((sym? + (syntax-rules () + ;; if the symbol `abracadabra' matches x, then x is a + ;; symbol + ((sym? x sk fk) sk) + ;; otherwise x is a non-symbol datum + ((sym? y sk fk) fk)))) + (sym? abracadabra success-k failure-k))))) diff --git a/lib/chibi/mime.module b/lib/chibi/mime.module new file mode 100644 index 00000000..2c10dbd1 --- /dev/null +++ b/lib/chibi/mime.module @@ -0,0 +1,7 @@ + +(define-module (chibi mime) + (export mime-ref assoc-ref mime-header-fold mime-headers->list + mime-parse-content-type mime-decode-header + mime-message-fold mime-message->sxml) + (import-immutable (scheme) (chibi base64) (chibi quoted-printable) (chibi io)) + (include "mime.scm")) diff --git a/lib/chibi/mime.scm b/lib/chibi/mime.scm new file mode 100644 index 00000000..e712d7fa --- /dev/null +++ b/lib/chibi/mime.scm @@ -0,0 +1,410 @@ +;; mime.scm -- RFC2045 MIME library +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2822 headers + +;; Procedure: mime-header-fold kons knil [source [limit [kons-from]]] +;; +;; Performs a fold operation on the MIME headers of source which can be +;; either a string or port, and defaults to current-input-port. kons +;; is called on the three values: +;; kons header value accumulator +;; where accumulator begins with knil. Neither the header nor the +;; value are modified, except wrapped lines are handled for the value. +;; +;; The optional procedure KONS-FROM is a procedure to be called when +;; the first line of the headers is an "From
" line, to +;; enable this procedure to be used as-is on mbox files and the like. +;; It defaults to KONS, and if such a line is found the fold will begin +;; with (KONS-FROM "%from"
(KONS-FROM "%date" KNIL)). +;; +;; The optional LIMIT gives a limit on the number of headers to read. + +;; Procedure: mime-headers->list [source] +;; Return an alist of the MIME headers from source with headers all +;; downcased. + +;; Procedure: mime-parse-content-type str +;; Parses STR as a Content-Type style-value returning the list +;; (type (attr . val) ...) +;; For example: +;; (mime-parse-content-type +;; "text/html; CHARSET=US-ASCII; filename=index.html") +;; => ("text/html" ("charset" . "US-ASCII") ("filename" . "index.html")) + +;; Procedure: mime-decode-header str +;; Replace all occurrences of RFC1522 =?ENC?...?= escapes in STR with +;; the appropriate decoded and charset converted value. + +;; Procedure: mime-ref headers str [default] +;; A case-insensitive assoc-ref. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2045 MIME encoding + +;; Procedure: mime-message-fold src headers kons knil +;; Performs a fold operation on the given string or port SRC as a MIME +;; body corresponding to the headers give in HEADERS. KONS is called +;; on the successive values: +;; +;; KONS part-headers part-body accumulator +;; +;; where part-headers are the headers for the given MIME part (the +;; original headers for single-part MIME), part-body is the +;; appropriately decoded and charset-converted body of the message, +;; and the accumulator begins with KNIL. +;; +;; TODO: Extend mime-message-fold to (optionally?) pass KONS an +;; input-port instead of string for the body to handle very large bodies +;; (this is not much of an issue for SMTP since the messages are in +;; practice limited, but it could be problematic for large HTTP bodies). +;; +;; This does a depth-first search, folding in sequence. It should +;; probably be doing a tree-fold as in html-parser. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define mime-line-length-limit 4096) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; association lists + +(define (assoc* key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (cond + ((null? ls) #f) + ((eq key (caar ls)) (car ls)) + (else (lp (cdr ls))))))) + +(define (assoc-ref ls key . o) + (let ((default (and (pair? o) (car o))) + (eq (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) equal?))) + (cond ((assoc* key ls eq) => cdr) + (else default)))) + +(define (mime-ref ls key . o) + (assoc-ref ls key (and (pair? o) (car o)) string-ci=?)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; simple matching instead of regexps + +(define (match-mbox-from-line line) + (let ((len (string-length line))) + (and (> len 5) + (string=? (substring line 0 5) "From ") + (let lp ((i 6)) + (cond + ((= i len) (list (substring line 5 len) "")) + ((memq (string-ref line i) '(#\space #\tab)) + (list (substring line 5 i) (substring line (+ i 1) len))) + (else (lp (+ i 1)))))))) + +(define (string-scan-colon-or-maybe-equal str) + (let ((len (string-length str))) + (let lp ((i 0) (best #f)) + (if (= i len) + best + (let ((c (string-ref str i))) + (cond ((or (char-alphabetic? c) + (char-numeric? c) + (memv c '(#\- #\_))) + (lp (+ i 1) best)) + ((eq? c #\:) + (if (= i 0) #f i)) + ((eqv? c #\=) + (lp (+ i 1) (or best i))) + (else + best))))))) + +(define (string-skip-white-space str i) + (let ((lim (string-length str))) + (let lp ((i i)) + (cond ((>= i lim) lim) + ((char-whitespace? (string-ref str i)) (lp (+ i 1))) + (else i))))) + +(define (match-mime-header-line line) + (let ((i (string-scan-colon-or-maybe-equal line))) + (and i + (let ((j (string-skip-white-space line (+ i 1)))) + (list (substring line 0 i) + (substring line j (string-length line))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dummy encoder + +(define (ces-convert str . x) + str) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; some srfi-13 & string utils + +(define (string-copy! to tstart from . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length from)))) + (let lp ((i start) (j tstart)) + (cond + ((< i end) + (string-set! to j (string-ref from i)) + (lp (+ i 1) (+ j 1))))))) + +(define (string-concatenate-reverse ls) + (let lp ((ls ls) (rev '()) (len 0)) + (if (null? ls) + (let ((res (make-string len))) + (let lp ((ls rev) (i 0)) + (cond + ((null? ls) + res) + (else + (string-copy! res i (car ls)) + (lp (cdr ls) (+ i (string-length (car ls)))))))) + (lp (cdr ls) (cons (car ls) rev) (+ len (string-length (car ls))))))) + +(define (string-downcase s . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length s)))) + (let* ((len (- end start)) (s2 (make-string len))) + (let lp ((i start) (j 0)) + (cond + ((>= i end) + s2) + (else + (string-set! s2 j (char-downcase (string-ref s i))) + (lp (+ i 1) (+ j 1)))))))) + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-trim-white-space s) + (let ((len (string-length s))) + (let lp ((i 0)) + (cond ((= i len) "") + ((char-whitespace? (string-ref s i)) (lp (+ i 1))) + (else + (let lp ((j (- len 1))) + (cond ((<= j i) "") + ((char-whitespace? (string-ref s j)) (lp (- j 1))) + (else (substring s i (+ j 1)))))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; header parsing + +(define (mime-header-fold kons knil . o) + (let ((src (and (pair? o) (car o))) + (limit (and (pair? o) (pair? (cdr o)) (car (cdr o)))) + (kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (caddr o) kons))) + ((if (string? src) mime-header-fold-string mime-header-fold-port) + kons knil (or src (current-input-port)) limit kons-from))) + +(define (mime-header-fold-string kons knil str limit kons-from) + (call-with-input-string str + (lambda (in) (mime-header-fold-port kons knil in limit kons-from)))) + +(define (mime-header-fold-port kons knil port limit kons-from) + (define (out line acc count) + (cond + ((or (and limit (> count limit)) (eof-object? line) (string=? line "")) + acc) + ((match-mime-header-line line) + => (lambda (m) (in (car m) (list (cadr m)) acc (+ count 1)))) + (else + ;;(warn "invalid header line: ~S\n" line) + (out (read-line port mime-line-length-limit) acc (+ count 1))))) + (define (in header value acc count) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((and limit (> count limit)) + acc) + ((or (eof-object? line) (string=? line "")) + (kons header (string-concatenate-reverse value) acc)) + ((char-whitespace? (string-ref line 0)) + (in header (cons line value) acc (+ count 1))) + (else + (out line + (kons header (string-concatenate-reverse value) acc) + (+ count 1)))))) + (let ((first-line (read-line port mime-line-length-limit))) + (cond + ((eof-object? first-line) + knil) + ((and kons-from (match-mbox-from-line first-line)) + => (lambda (m) ; special case check on first line for mbox files + (out (read-line port mime-line-length-limit) + (kons-from "%from" (car m) + (kons-from "%date" (cadr m) knil)) + 0))) + (else + (out first-line knil 0))))) + +(define (mime-headers->list . o) + (reverse + (apply + mime-header-fold + (lambda (h v acc) (cons (cons (string-downcase h) v) acc)) + '() + o))) + +(define (mime-split-name+value s) + (let ((i (string-char-index s #\=))) + (if i + (cons (string-downcase (string-trim-white-space (substring s 0 i))) + (if (= i (string-length s)) + "" + (if (eqv? #\" (string-ref s (+ i 1))) + (substring s (+ i 2) (- (string-length s) 1)) + (substring s (+ i 1) (string-length s))))) + (cons (string-downcase (string-trim-white-space s)) "")))) + +(define (mime-parse-content-type str) + (map mime-split-name+value (string-split str #\;))) + +(define (mime-decode-header str) + (let* ((len (string-length str)) + (limit (- len 8))) ; need at least 8 chars: "=?Q?X??=" + (let lp ((i 0) (from 0) (res '())) + (if (>= i limit) + (string-concatenate (reverse (cons (substring str from len) res))) + (if (and (eqv? #\= (string-ref str i)) + (eqv? #\? (string-ref str (+ i 1)))) + (let* ((j (string-char-index str #\? (+ i 3))) + (k (string-char-index str #\? (+ j 3)))) + (if (and j k (< (+ k 1) len) + (eqv? #\? (string-ref str (+ j 2))) + (memq (string-ref str (+ j 1)) '(#\Q #\B #\q #\b)) + (eqv? #\= (string-ref str (+ k 1)))) + (let ((decode (if (memq (string-ref str (+ j 1)) '(#\Q #\q)) + quoted-printable-decode-string + base64-decode-string)) + (cset (substring str (+ i 2) j)) + (content (substring str (+ j 3) k)) + (k2 (+ k 2))) + (lp k2 k2 (cons (ces-convert (decode content) cset) + (cons (substring str from i) res)))) + (lp (+ i 2) from res))) + (lp (+ i 1) from res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; message parsing + +(define (mime-read-to-boundary port boundary next final) + (let ((final-boundary (and boundary (string-append boundary "--")))) + (let lp ((res '())) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((or (eof-object? line) (equal? line final-boundary)) + (final (string-concatenate (reverse res) + (call-with-output-string newline)))) + ((equal? line boundary) + (next (string-concatenate (reverse res) + (call-with-output-string newline)))) + (else + (lp (cons line res)))))))) + +(define (mime-convert-part str cte enc) + (let ((str (cond + ((and (string? cte) (string-ci=? cte "quoted-printable")) + (quoted-printable-decode-string str)) + ((and (string? cte) (string-ci=? cte "base64")) + (base64-decode-string str)) + (else + str)))) + (if (string? enc) (ces-convert str enc) str))) + +(define (mime-read-part port cte enc boundary next final) + (mime-read-to-boundary + port boundary + (lambda (x) (next (mime-convert-part x cte enc))) + (lambda (x) (final (mime-convert-part x cte enc))))) + +;; (kons parent-headers part-headers part-body seed) +;; (start headers seed) +;; (end headers parent-seed seed) +(define (mime-message-fold src kons init-seed . o) + (let ((port (if (string? src) (open-input-string src) src))) + (let ((kons-start + (if (pair? o) (car o) (lambda (headers seed) '()))) + (kons-end + (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)))) + (headers + (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + (mime-headers->list port)))) + (let tfold ((parent-headers '()) + (headers headers) + (seed init-seed) + (boundary #f) + (next (lambda (x) x)) + (final (lambda (x) x))) + (let* ((ctype (mime-parse-content-type + (mime-ref headers "Content-Type" "text/plain"))) + (type (string-trim-white-space (caar ctype))) + (enc (string-trim-white-space + (or (mime-ref ctype "charset") + (mime-ref headers "charset" "ASCII")))) + (cte (string-trim-white-space + (or (mime-ref headers "Content-Transfer-Encoding") + (mime-ref headers "Encoding" "7-bit"))))) + (cond + ((and (string-ci=? type "multipart/") + (mime-ref ctype "boundary")) + => (lambda (boundary2) + (let ((boundary2 (string-append "--" boundary2))) + ;; skip preamble + (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x)) + (let lp ((part-seed (kons-start headers seed))) + (let ((part-headers (mime-headers->list port))) + (tfold parent-headers part-headers + part-seed boundary2 + lp + (lambda (x) + ;; skip epilogue + (if boundary + (mime-read-to-boundary port boundary + (lambda (x) x) (lambda (x) x))) + (next (kons-end headers seed x))) + )))))) + (else + (mime-read-part + port cte enc boundary + (lambda (x) (next (kons parent-headers headers x seed))) + (lambda (x) (final (kons parent-headers headers x seed))))))))))) + +;; (mime (^ (header . value) ...) parts ...) +(define (mime-message->sxml . o) + (car + (apply + mime-message-fold + (if (pair? o) (car o) (current-input-port)) + (lambda (parent-headers headers body seed) + `((mime (^ ,@headers) ,body) ,@seed)) + '() + (lambda (headers seed) '()) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)) + (if (pair? o) (cdr o) '())))) + diff --git a/lib/chibi/modules.module b/lib/chibi/modules.module new file mode 100644 index 00000000..0d20861e --- /dev/null +++ b/lib/chibi/modules.module @@ -0,0 +1,8 @@ + +(define-module (chibi modules) + (export analyze-module module-ast module-ast-set! + module-ref module-contains? containing-module + procedure-analysis) + (import-immutable (scheme) (config)) + (import (chibi ast)) + (include "modules.scm")) diff --git a/lib/chibi/modules.scm b/lib/chibi/modules.scm new file mode 100644 index 00000000..b9e40e0d --- /dev/null +++ b/lib/chibi/modules.scm @@ -0,0 +1,103 @@ + +(define (file->sexp-list file) + (call-with-input-file file + (lambda (in) + (let lp ((res '())) + (let ((x (read in))) + (if (eof-object? x) + (reverse res) + (lp (cons x res)))))))) + +(define (module? x) (vector? x)) + +(define (module-ast mod) (vector-ref mod 3)) +(define (module-ast-set! mod x) (vector-set! mod 3 x)) + +(define (analyze-module-source name mod recursive?) + (let ((env (module-env mod)) + (dir (if (equal? name '(scheme)) "" (module-name-prefix name)))) + (define (include-source file) + (cond ((find-module-file (string-append dir file)) + => (lambda (x) (cons 'body (file->sexp-list x)))) + (else (error "couldn't find include" file)))) + (let lp ((ls (module-meta-data mod)) (res '())) + (cond + ((not (pair? ls)) + (reverse res)) + (else + (case (and (pair? (car ls)) (caar ls)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2-name (car mod2-name+imports))) + (if recursive? + (analyze-module mod2-name #t)))) + (cdar ls)) + (lp (cdr ls) res)) + ((include) + (lp (append (map include-source (cdar ls)) (cdr ls)) res)) + ((body) + (let lp2 ((ls2 (cdar ls)) (res res)) + (cond + ((pair? ls2) + (lp2 (cdr ls2) (cons (analyze (car ls2) env) res))) + (else + (lp (cdr ls) res))))) + (else + (lp (cdr ls) res)))))))) + +(define (analyze-module name . o) + (let ((recursive? (and (pair? o) (car o))) + (res (load-module name))) + (if (not (module-ast res)) + (module-ast-set! res (analyze-module-source name res recursive?))) + res)) + +(define (module-ref mod var-name . o) + (let ((cell (env-cell (module-env (if (module? mod) mod (load-module mod))) + var-name))) + (if cell + (cdr cell) + (if (pair? o) (car o) (error "no binding in module" mod var-name))))) + +(define (module-contains? mod var-name) + (and (env-cell (module-env (if (module? mod) mod (load-module mod))) var-name) + #t)) + +(define (module-defines? name mod var-name) + (if (not (module-ast mod)) + (module-ast-set! mod (analyze-module-source name mod #f))) + (let lp ((ls (module-ast mod))) + (and (pair? ls) + (or (and (set? (car ls)) + (eq? var-name (ref-name (set-var (car ls)))) + (begin + ;; (write `(found ,var-name in ,name ,(ast->sexp (car ls))) (current-error-port)) + ;; (newline (current-error-port)) + #t)) + (lp (cdr ls)))))) + +(define (containing-module x) + (let lp1 ((ls (reverse *modules*))) + (and (pair? ls) + (let ((env (module-env (cdar ls)))) + (let lp2 ((e-ls (env-exports env))) + (if (null? e-ls) + (lp1 (cdr ls)) + (let ((cell (env-cell env (car e-ls)))) + (if (and (eq? x (cdr cell)) + (module-defines? (caar ls) (cdar ls) (car cell))) + (car ls) + (lp2 (cdr e-ls)))))))))) + +(define (procedure-analysis x) + (let ((mod (containing-module x))) + (and mod + (let lp ((ls (module-ast (analyze-module (car mod))))) + (and (pair? ls) + (if (and (set? (car ls)) + (eq? (procedure-name x) (ref-name (set-var (car ls))))) + (set-value (car ls)) + (lp (cdr ls)))))))) + diff --git a/lib/chibi/net.module b/lib/chibi/net.module new file mode 100644 index 00000000..845a7aa8 --- /dev/null +++ b/lib/chibi/net.module @@ -0,0 +1,11 @@ + +(define-module (chibi net) + (export sockaddr? address-info? get-address-info socket connect + with-net-io open-net-io + address-info-family address-info-socket-type address-info-protocol + address-info-address address-info-address-length address-info-next) + (import-immutable (scheme)) + (import (chibi filesystem)) + (include-shared "net") + (include "net.scm")) + diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm new file mode 100644 index 00000000..5f912cb5 --- /dev/null +++ b/lib/chibi/net.scm @@ -0,0 +1,32 @@ +;; net.scm -- the high-level network interface +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (open-net-io host service) + (let lp ((addr (get-address-info host + (if (integer? service) + (number->string service) + service) + #f))) + (if (not addr) + (error "couldn't find address" host service) + (let ((sock (socket (address-info-family addr) + (address-info-socket-type addr) + (address-info-protocol addr)))) + (if (negative? sock) + (lp (address-info-next addr)) + (if (negative? + (connect sock + (address-info-address addr) + (address-info-address-length addr))) + (lp (address-info-next addr)) + (list (open-input-file-descriptor sock) + (open-output-file-descriptor sock)))))))) + +(define (with-net-io host service proc) + (let ((io (open-net-io host service))) + (if (not (pair? io)) + (error "couldn't find address" host service) + (let ((res (proc (car io) (car (cdr io))))) + (close-input-port (car io)) + res)))) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub new file mode 100644 index 00000000..0d72bc90 --- /dev/null +++ b/lib/chibi/net.stub @@ -0,0 +1,25 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/socket.h") +(c-system-include "netdb.h") + +(define-c-struct sockaddr + predicate: sockaddr?) + +(define-c-struct addrinfo + finalizer: freeaddrinfo + predicate: address-info? + (int ai_family address-info-family) + (int ai_socktype address-info-socket-type) + (int ai_protocol address-info-protocol) + ((link sockaddr) ai_addr address-info-address) + (size_t ai_addrlen address-info-address-length) + ((link addrinfo) ai_next address-info-next)) + +(define-c errno (get-address-info getaddrinfo) + (string string (maybe-null addrinfo) (result free addrinfo))) + +(define-c int bind (int sockaddr int)) +(define-c int listen (int int)) +(define-c int socket (int int int)) +(define-c int connect (int sockaddr int)) diff --git a/lib/chibi/net/http.module b/lib/chibi/net/http.module new file mode 100644 index 00000000..352bf7b4 --- /dev/null +++ b/lib/chibi/net/http.module @@ -0,0 +1,7 @@ + +(define-module (chibi net http) + (export http-get call-with-input-url with-input-from-url + http-parse-request http-parse-form) + (import-immutable (scheme) (srfi 39) (chibi net) (chibi io) + (chibi uri) (chibi mime)) + (include "http.scm")) diff --git a/lib/chibi/net/http.scm b/lib/chibi/net/http.scm new file mode 100644 index 00000000..37cac5e6 --- /dev/null +++ b/lib/chibi/net/http.scm @@ -0,0 +1,180 @@ +;; http.scm -- http client +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; client utils + +(define http-user-agent "chibi") + +(define http-redirect-limit 10) +(define http-chunked-buffer-size 4096) +(define http-chunked-size-limit 409600) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (http-parse-response line) + (let* ((len (string-length line)) + (i (or (string-scan line #\space 0 len) len)) + (j (or (string-scan line #\space (+ i 1) len) len)) + (n (and (< i j) (string->number (substring line (+ i 1) j))))) + (if (not (integer? n)) + (error "bad response" line i j) + (list (substring line 0 i) + n + (if (>= j len) "" (substring line (+ j 1) len)))))) + +(define (http-wrap-chunked-input-port in) + (define (read-chunk in) + (let* ((line (read-line in)) + (n (and (string? line) (string->number line 16)))) + (display "read-chunk ") (write line) (newline) + (cond + ((not (and (integer? n) (<= 0 n http-chunked-size-limit))) + (error "invalid chunked size line" line)) + ((zero? n) "") + (else (read-string n in))))) + (make-generated-input-port + (lambda () (read-chunk in)))) + +(define (http-get/raw url in-headers limit) + (if (<= limit 0) + (error "http-get: redirect limit reached" url) + (let* ((uri (if (uri? url) url (string->uri url))) + (host (and uri (uri-host uri)))) + (if (not host) + (error "invalid url" url) + (let* ((io (open-net-io + host + (or (uri-port uri) + (if (eq? 'https (uri-scheme uri)) 443 80)))) + (in (car io)) + (out (car (cdr io)))) + (display "GET " out) + (display (or (uri-path uri) "/") out) + (display " HTTP/1.0\r\n" out) + (display "Host: " out) (display host out) (display "\r\n" out) + (cond + ((not (mime-ref in-headers "user-agent")) + (display "User-Agent: " out) + (display http-user-agent out) + (display "\r\n" out))) + (for-each + (lambda (x) + (display (car x) out) (display ": " out) + (display (cdr x) out) (display "\r\n" out)) + in-headers) + (display "Connection: close\r\n\r\n" out) + (flush-output out) + (let* ((resp (http-parse-response (read-line in))) + (headers (mime-headers->list in)) + (status (quotient (cadr resp) 100))) + (case status + ((2) + (let ((enc (mime-ref headers "transfer-encoding"))) + (cond + ((equal? enc "chunked") + (http-wrap-chunked-input-port in)) + (else + in)))) + ((3) + (close-input-port in) + (close-output-port out) + (let ((url2 (mime-ref headers "location"))) + (if url2 + (http-get/raw url2 in-headers (- limit 1)) + (error "redirect with no location header")))) + (else + (close-input-port in) + (close-output-port out) + (error "couldn't retrieve url" url resp))))))))) + +(define (http-get url . headers) + (http-get/raw url + (if (pair? headers) (car headers) '()) + http-redirect-limit)) + +(define (call-with-input-url url proc) + (let* ((p (http-get url)) + (res (proc p))) + (close-input-port p) + res)) + +(define (with-input-from-url url thunk) + (let ((p (http-get url))) + (let ((res (parameterize ((current-input-port p)) (thunk)))) + (close-input-port p) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; server utils + +;; read and parse a request line +(define (http-parse-request . o) + (let ((line (string-split + (read-line (if (pair? o) (car o) (current-input-port)) 4096)))) + (cons (string->symbol (car line)) (cdr line)))) + +;; Parse a form body with a given URI and MIME headers (as parsed with +;; mime-headers->list). Returns an alist of (name . value) for every +;; query or form parameter. +(define (http-parse-form uri headers . o) + (let* ((in (if (pair? o) (car o) (current-input-port))) + (type (mime-ref headers + "content-type" + "application/x-www-form-urlencoded")) + (query0 (or (uri-query (if (string? uri) (string->uri uri) uri)) '())) + (query (if (string? query0) (uri-query->alist query0) query0))) + (cond + ((string-ci=? "multipart/" type) + (let ((mime (mime-message->sxml in headers))) + (append + (let lp ((ls (cddr mime)) + (res '())) + (cond + ((null? ls) + res) + ((and (pair? (car ls)) + (eq? 'mime (caar ls)) + (pair? (cdar ls)) + (pair? (cadar ls)) + (memq (caadar ls) '(^ @))) + (let* ((disp0 (mime-ref (cdadar ls) "content-disposition" "")) + (disp (mime-parse-content-type disp0)) + (name (mime-ref disp "name"))) + (if name + (lp (cdr ls) (cons (cons name (caddar ls)) res)) + (lp (cdr ls) res)))) + (else + (lp (cdr ls) res)))) + query))) + (else + query)))) + diff --git a/lib/chibi/pathname.module b/lib/chibi/pathname.module new file mode 100644 index 00000000..765ee189 --- /dev/null +++ b/lib/chibi/pathname.module @@ -0,0 +1,7 @@ + +(define-module (chibi pathname) + (export path-strip-directory path-directory path-extension-pos + path-extension path-strip-extension path-replace-extension + path-absolute? path-relative? path-normalize make-path) + (import-immutable (scheme)) + (include "pathname.scm")) diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm new file mode 100644 index 00000000..de27ad61 --- /dev/null +++ b/lib/chibi/pathname.scm @@ -0,0 +1,180 @@ +;; pathname.scm -- a general, non-host-specific path lib +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-scan-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (- i 1)))))) + +(define (string-skip c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (+ i 1))))))) + +(define (string-skip-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (- i 1)))))) + +;; POSIX basename +;; (define (path-strip-directory path) +;; (if (string=? path "") +;; path +;; (let ((end (string-skip-right #\/ path))) +;; (if (not end) +;; "/" +;; (let ((start (string-scan-right #\/ path (- end 1)))) +;; (substring path (if start (+ start 1) 0) (+ end 1))))))) + +;; GNU basename +(define (path-strip-directory path) + (if (string=? path "") + path + (let ((len (string-length path))) + (if (eqv? #\/ (string-ref path (- len 1))) + "" + (let ((slash (string-scan-right #\/ path))) + (if (not slash) + path + (substring path (+ slash 1) len))))))) + +(define (path-directory path) + (if (string=? path "") + "." + (let ((end (string-skip-right #\/ path))) + (if (not end) + "/" + (let ((start (string-scan-right #\/ path (- end 1)))) + (if (not start) + "." + (let ((start (string-skip-right #\/ path start))) + (if (not start) "/" (substring path 0 (+ start 1)))))))))) + +(define (path-extension-pos path) (string-scan-right #\. path)) + +(define (path-extension path) + (let ((i (path-extension-pos path))) + (and i + (let ((start (+ i 1)) (end (string-length path))) + (and (< start end) (substring path start end)))))) + +(define (path-strip-extension path) + (let ((i (path-extension-pos path))) + (if (and i (< (+ i 1) (string-length path))) + (substring path 0 i) + path))) + +(define (path-replace-extension path ext) + (string-append (path-strip-extension path) "." ext)) + +(define (path-absolute? path) + (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0)))) + +(define (path-relative? path) (not (path-absolute? path))) + +;; This looks big and hairy, but it's mutation-free and guarantees: +;; (string=? s (path-normalize s)) <=> (eq? s (path-normalize s)) +;; i.e. fast and simple for already normalized paths. + +(define (path-normalize path) + (let* ((len (string-length path)) (len-1 (- len 1))) + (define (collect i j res) + (if (>= i j) res (cons (substring path i j) res))) + (define (finish i res) + (if (zero? i) + path + (apply string-append (reverse (collect i len res))))) + ;; loop invariants: + ;; - res is a list such that (string-concatenate-reverse res) + ;; is always the normalized string up to j + ;; - the tail of the string from j onward can be concatenated to + ;; the above value to get a partially normalized path referring + ;; to the same location as the original path + (define (inside i j res) + (if (>= j len) + (finish i res) + (if (eqv? #\/ (string-ref path j)) + (boundary i (+ j 1) res) + (inside i (+ j 1) res)))) + (define (boundary i j res) + (if (>= j len-1) + (finish i res) + (case (string-ref path j) + ((#\.) + (case (string-ref path (+ j 1)) + ((#\.) + (if (or (>= j (- len 2)) (eqv? #\/ (string-ref path (+ j 2)))) + (if (>= i (- j 1)) + (if (null? res) + (backup j "" '()) + (backup j (car res) (cdr res))) + (backup j (substring path i j) res)) + (inside i (+ j 2) res))) + ((#\/) + (if (= i j) + (boundary (+ j 2) (+ j 2) res) + (let ((s (substring path i j))) + (boundary (+ j 2) (+ j 2) (cons s res))))) + (else (inside i (+ j 1) res)))) + ((#\/) (boundary (+ j 1) (+ j 1) (collect i j res))) + (else (inside i (+ j 1) res))))) + (define (backup j s res) + (let ((pos (+ j 3))) + (cond + ;; case 1: we're reduced to accumulating parents of the cwd + ((or (string=? s "/..") (string=? s "..")) + (boundary pos pos (cons "/.." (cons s res)))) + ;; case 2: the string isn't a component itself, skip it + ((or (string=? s "") (string=? s ".") (string=? s "/")) + (if (pair? res) + (backup j (car res) (cdr res)) + (boundary pos pos (if (string=? s "/") '("/") '(".."))))) + ;; case3: just take the directory of the string + (else + (let ((d (path-directory s))) + (cond + ((string=? d "/") + (boundary pos pos (if (null? res) '("/") res))) + ((string=? d ".") + (boundary pos pos res)) + (else (boundary pos pos (cons "/" (cons d res)))))))))) + ;; start with boundary if abs path, otherwise inside + (if (zero? len) + path + ((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '())))) + +(define (make-path . args) + (define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "not a valid path component" x)))) + (define (trim-trailing-slash s) + (let ((i (string-skip-right #\/ s))) + (if i (substring s 0 (+ i 1)) ""))) + (if (null? args) + "" + (let ((start (trim-trailing-slash (x->string (car args))))) + (let lp ((ls (cdr args)) + (res (if (string=? "" start) '() (list start)))) + (cond + ((null? ls) + (apply string-append (reverse res))) + ((pair? (car ls)) + (lp (append (car ls) (cdr ls)) res)) + (else + (let ((x (trim-trailing-slash (x->string (car ls))))) + (lp (cdr ls) + (if (string=? x "") res (cons x (cons "/" res))))))))))) diff --git a/lib/chibi/process.module b/lib/chibi/process.module new file mode 100644 index 00000000..372b56e4 --- /dev/null +++ b/lib/chibi/process.module @@ -0,0 +1,18 @@ + +(define-module (chibi process) + (export exit sleep alarm fork kill execute waitpid + set-signal-action! make-signal-set signal-set-contains? + signal-set-fill! signal-set-add! signal-set-delete! + current-signal-mask + signal-mask-block! signal-mask-unblock! signal-mask-set! + signal/hang-up signal/interrupt signal/quit + signal/illegal signal/abort signal/fpe + signal/kill signal/segv signal/pipe + signal/alarm signal/term signal/user1 + signal/user2 signal/child signal/continue + signal/stop signal/tty-stop signal/tty-input + signal/tty-output) + (import-immutable (scheme)) + (cond-expand (threads (import (srfi 18))) (else #f)) + (include-shared "process")) + diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub new file mode 100644 index 00000000..93b08d95 --- /dev/null +++ b/lib/chibi/process.stub @@ -0,0 +1,73 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/wait.h") +(c-system-include "signal.h") +(c-system-include "unistd.h") + +(define-c-type siginfo_t + predicate: signal-info? + (int si_signo signal-number) + (int si_errno signal-error-number) + (int si_code signal-code) + (pid_t si_pid signal-pid) + (uid_t si_uid signal-uid) + (int si_status signal-status) + ;;(clock_t si_utime signal-user-time) + ;;(clock_t si_stime signal-system-time) + ) + +(define-c-type sigset_t + predicate: signal-set?) + +(define-c-const int (signal/hang-up "SIGHUP")) +(define-c-const int (signal/interrupt "SIGINT")) +(define-c-const int (signal/quit "SIGQUIT")) +(define-c-const int (signal/illegal "SIGILL")) +(define-c-const int (signal/abort "SIGABRT")) +(define-c-const int (signal/fpe "SIGFPE")) +(define-c-const int (signal/kill "SIGKILL")) +(define-c-const int (signal/segv "SIGSEGV")) +(define-c-const int (signal/pipe "SIGPIPE")) +(define-c-const int (signal/alarm "SIGALRM")) +(define-c-const int (signal/term "SIGTERM")) +(define-c-const int (signal/user1"SIGUSR1")) +(define-c-const int (signal/user2 "SIGUSR2")) +(define-c-const int (signal/child "SIGCHLD")) +(define-c-const int (signal/continue "SIGCONT")) +(define-c-const int (signal/stop "SIGSTOP")) +(define-c-const int (signal/tty-stop "SIGTSTP")) +(define-c-const int (signal/tty-input "SIGTTIN")) +(define-c-const int (signal/tty-output "SIGTTOU")) + +(c-include "signal.c") + +(define-c sexp (set-signal-action! "sexp_set_signal_action") + ((value ctx sexp) (value self sexp) sexp sexp)) + +(define-c errno (make-signal-set "sigemptyset") ((pointer result sigset_t))) +(define-c errno (signal-set-fill! "sigfillset") ((pointer sigset_t))) +(define-c errno (signal-set-add! "sigaddset") ((pointer sigset_t) int)) +(define-c errno (signal-set-delete! "sigaddset") ((pointer sigset_t) int)) +(define-c boolean (signal-set-contains? "sigismember") ((pointer sigset_t) int)) + +(define-c errno (signal-mask-block! "sigprocmask") + ((value SIG_BLOCK int) (pointer sigset_t) (pointer value NULL sigset_t))) +(define-c errno (signal-mask-unblock! "sigprocmask") + ((value SIG_UNBLOCK int) (pointer sigset_t) (pointer value NULL sigset_t))) +(define-c errno (signal-mask-set! "sigprocmask") + ((value SIG_SETMASK int) (pointer sigset_t) (pointer value NULL sigset_t))) +(define-c errno (current-signal-mask "sigprocmask") + ((value SIG_BLOCK int) (pointer value NULL sigset_t) (pointer result sigset_t))) + +(define-c unsigned-int alarm (unsigned-int)) +(define-c unsigned-int sleep (unsigned-int)) + +(define-c pid_t fork ()) +;;(define-c pid_t wait ((result int))) +(define-c pid_t waitpid (int (result int) int)) +(define-c errno kill (int int)) +;;(define-c errno raise (int)) +(define-c void exit (int)) +(define-c int (execute execvp) (string (array string))) + +(c-init "sexp_init_signals(ctx, env);") diff --git a/lib/chibi/quoted-printable.module b/lib/chibi/quoted-printable.module new file mode 100644 index 00000000..9cbec430 --- /dev/null +++ b/lib/chibi/quoted-printable.module @@ -0,0 +1,7 @@ + +(define-module (chibi quoted-printable) + (export quoted-printable-encode quoted-printable-encode-string + quoted-printable-encode-header + quoted-printable-decode quoted-printable-decode-string) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "quoted-printable.scm")) diff --git a/lib/chibi/quoted-printable.scm b/lib/chibi/quoted-printable.scm new file mode 100644 index 00000000..80709026 --- /dev/null +++ b/lib/chibi/quoted-printable.scm @@ -0,0 +1,157 @@ +;; quoted-printable.scm -- RFC2045 implementation +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: quoted-printable-encode-string str [start-col max-col] +;; Return a quoted-printable encoded representation of string +;; according to the official standard as described in RFC2045. +;; +;; ? and _ are always encoded for compatibility with RFC1522 encoding, +;; and soft newlines are inserted as necessary to keep each lines +;; length less than MAX-COL (default 76). The starting column may be +;; overridden with START-COL (default 0). + +;; Procedure: quoted-printable-decode-string str [mime?] +;; Return a quoted-printable decoded representation of string. If +;; MIME? is specified and true, _ will be decoded as as space in +;; accordance with RFC1522. No errors will be raised on invalid +;; input. + +;; Procedure: quoted-printable-encode [port start-col max-col] +;; Procedure: quoted-printable-decode [port start-col max-col] +;; Variations of the above which read and write to ports. + +;; Procedure: quoted-printable-encode-header enc str [start-col max-col] +;; Return a quoted-printable encoded representation of string as +;; above, wrapped in =?ENC?Q?...?= as per RFC1522, split across +;; multiple MIME-header lines as needed to keep each lines length less +;; than MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring STR +;; is already encoded according to ENC. + +;; Example: + +;; (define (mime-encode-header header value charset) +;; (let ((prefix (string-append header ": ")) +;; (str (ces-convert value "UTF8" charset))) +;; (string-append +;; prefix +;; (quoted-printable-encode-header charset str (string-length prefix))))) + +;; This API is backwards compatible with the Gauche library +;; rfc.quoted-printable. + +(define *default-max-col* 76) + +;; Allow for RFC1522 quoting for headers by always escaping ? and _ +(define (qp-encode str start-col max-col separator) + (define (hex i) (integer->char (+ i (if (<= i 9) 48 55)))) + (let ((end (string-length str)) + (buf (make-string max-col))) + (let lp ((i 0) (col start-col) (res '())) + (cond + ((= i end) + (if (pair? res) + (string-concatenate (reverse (cons (substring buf 0 col) res)) + separator) + (substring buf start-col col))) + ((>= col (- max-col 3)) + (lp i 0 (cons (substring buf (if (pair? res) 0 start-col) col) res))) + (else + (let ((c (char->integer (string-ref str i)))) + (cond + ((and (<= 33 c 126) (not (memq c '(61 63 95)))) + (string-set! buf col (integer->char c)) + (lp (+ i 1) (+ col 1) res)) + (else + (string-set! buf col #\=) + (string-set! buf (+ col 1) (hex (arithmetic-shift c -4))) + (string-set! buf (+ col 2) (hex (bitwise-and c #b1111))) + (lp (+ i 1) (+ col 3) res))))))))) + +(define (quoted-printable-encode-string . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*))) + (qp-encode (if (string? src) src (read-string #f src)) + start-col max-col "=\r\n"))) + +(define (quoted-printable-encode . o) + (display (apply (quoted-printable-encode-string o)))) + +(define (quoted-printable-encode-header encoding . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdddr o))) + (cadddr o) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?Q?")) + (prefix-length (+ 2 (string-length prefix))) + (separator (string-append "?=" nl "\t" prefix)) + (effective-max-col (- max-col prefix-length))) + (string-append prefix + (qp-encode (if (string? src) src (read-string #f src)) + start-col effective-max-col separator) + "?=")))) + +(define (quoted-printable-decode-string . o) + (define (hex? c) (or (char-numeric? c) (<= 65 (char->integer c) 70))) + (define (unhex1 c) + (let ((i (char->integer c))) (if (>= i 65) (- i 55) (- i 48)))) + (define (unhex c1 c2) + (integer->char (+ (arithmetic-shift (unhex1 c1) 4) (unhex1 c2)))) + (let ((src (if (pair? o) (car o) (current-input-port))) + (mime-header? (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (let* ((str (if (string? src) src (read-string #f src))) + (end (string-length str))) + (call-with-output-string + (lambda (out) + (let lp ((i 0)) + (cond + ((< i end) + (let ((c (string-ref str i))) + (case c + ((#\=) ; = escapes + (cond + ((< (+ i 2) end) + (let ((c2 (string-ref str (+ i 1)))) + (cond + ((eq? c2 #\newline) (lp (+ i 2))) + ((eq? c2 #\return) + (lp (if (eq? (string-ref str (+ i 2)) #\newline) + (+ i 3) + (+ i 2)))) + ((hex? c2) + (let ((c3 (string-ref str (+ i 2)))) + (if (hex? c3) (write-char (unhex c2 c3) out)) + (lp (+ i 3)))) + (else (lp (+ i 3)))))))) + ((#\_) ; maybe translate _ to space + (write-char (if mime-header? #\space c) out) + (lp (+ i 1))) + ((#\space #\tab) ; strip trailing whitespace + (let lp2 ((j (+ i 1))) + (cond + ((not (= j end)) + (case (string-ref str j) + ((#\space #\tab) (lp2 (+ j 1))) + ((#\newline) + (lp (+ j 1))) + ((#\return) + (let ((k (+ j 1))) + (lp (if (and (< k end) + (eqv? #\newline (string-ref str k))) + (+ k 1) k)))) + (else (display (substring str i j) out) (lp j))))))) + (else ; a literal char + (write-char c out) + (lp (+ i 1))))))))))))) + +(define (quoted-printable-decode . o) + (display (apply quoted-printable-decode-string o))) + diff --git a/lib/chibi/repl.module b/lib/chibi/repl.module new file mode 100644 index 00000000..742b9581 --- /dev/null +++ b/lib/chibi/repl.module @@ -0,0 +1,9 @@ + +(define-module (chibi repl) + (export repl) + (import-immutable (scheme)) + (import (chibi ast) + (chibi process) + (chibi term edit-line) + (srfi 18)) + (include "repl.scm")) diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm new file mode 100644 index 00000000..b7ff79bc --- /dev/null +++ b/lib/chibi/repl.scm @@ -0,0 +1,41 @@ +;;;; repl.scm - friendlier repl with line editing and signal handling +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-syntax handle-exceptions + (syntax-rules () + ((handle-exceptions exn handler expr) + (call-with-current-continuation + (lambda (return) + (with-exception-handler (lambda (exn) (return handler)) + (lambda () expr))))))) + +(define (with-signal-handler sig handler thunk) + (let ((old-handler #f)) + (dynamic-wind + (lambda () (set! old-handler (set-signal-action! sig handler))) + thunk + (lambda () (set-signal-action! sig old-handler))))) + +(define (run-repl module env) + (let ((line (edit-line (if module (string-append (symbol->string module) "> ") "> ")))) + (cond + ((or (not line) (eof-object? line))) + ((equal? line "") (run-repl module env)) + (else + (handle-exceptions exn (print-exception exn (current-error-port)) + (let* ((expr (call-with-input-string line read)) + (thread (make-thread (lambda () + (let ((res (eval expr env))) + (if (not (eq? res (if #f #f))) + (write res))))))) + (with-signal-handler + signal/interrupt + (lambda (n) (thread-terminate! thread)) + (lambda () (thread-start! thread) (thread-join! thread))))) + (newline) + (run-repl module env))))) + +(define (repl) + (run-repl #f (interaction-environment))) diff --git a/lib/chibi/scribble.module b/lib/chibi/scribble.module new file mode 100644 index 00000000..b479eb64 --- /dev/null +++ b/lib/chibi/scribble.module @@ -0,0 +1,5 @@ + +(define-module (chibi scribble) + (export scribble-parse scribble-read) + (import-immutable (scheme)) + (include "scribble.scm")) diff --git a/lib/chibi/scribble.scm b/lib/chibi/scribble.scm new file mode 100644 index 00000000..1e4f15cd --- /dev/null +++ b/lib/chibi/scribble.scm @@ -0,0 +1,247 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; general character utils + +(define (char-mirror ch) + (case ch ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else ch))) + +(define (char-delimiter? ch) + (or (eof-object? ch) (char-whitespace? ch) + (memv ch '(#\( #\) #\[ #\] #\{ #\} #\" #\|)))) + +(define (char-punctuation? ch) + (memv ch '(#\- #\+ #\! #\< #\> #\[ #\] #\|))) + +(define (char-digit ch) (- (char->integer ch) (char->integer #\0))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; list utils + +(define (drop ls n) (if (<= n 0) ls (drop (cdr ls) (- n 1)))) + +(define (drop-while pred ls) + (if (or (null? ls) (not (pred (car ls)))) ls (drop-while pred (cdr ls)))) + +(define (list-prefix? prefix ls) + (cond ((null? prefix) #t) + ((null? ls) #f) + ((equal? (car prefix) (car ls)) (list-prefix? (cdr prefix) (cdr ls))) + (else #f))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; scribble reader (standalone, don't use the native reader) + +(define scribble-dot (list ".")) +(define scribble-close (list ")")) + +(define (if-peek-char ch in pass fail) + (cond ((eqv? ch (peek-char in)) (read-char in) pass) (else fail))) + +(define (skip-line in) + (do ((c #f (read-char in))) ((or (eof-object? c) (eqv? c #\newline))))) + +(define (read-float-tail in acc) + (let lp ((res acc) (k 0.1)) + (let ((ch (read-char in))) + (cond ((or (eof-object? ch) (char-delimiter? ch)) res) + ((char-numeric? ch) (lp (+ res (* k (char-digit ch))) (* k 0.1))) + (else (error "invalid numeric syntax")))))) + +(define (read-number in acc base) + (let lp ((acc acc)) + (let ((ch (peek-char in))) + (cond + ((or (eof-object? ch) (char-delimiter? ch)) acc) + ((char-numeric? ch) (read-char in) (lp (+ (* acc base) (char-digit ch)))) + ((eqv? #\. ch) + (read-char in) + (if (= base 10) + (begin (read-char in) (read-float-tail in (exact->inexact acc))) + (error "non-base-10 floating point"))) + (else (error "invalid numeric syntax")))))) + +(define (read-escaped in terminal) + (let lp ((ls '())) + (let ((ch (read-char in))) + (cond + ((or (eof-object? ch) (eqv? ch terminal)) (list->string (reverse ls))) + ((eqv? ch #\\) (lp (cons (read-char in) ls))) + (else (lp (cons ch ls))))))) + +(define (read-symbol in ls) + (do ((ls ls (cons c ls)) (c (peek-char in) (peek-char in))) + ((char-delimiter? c) (string->symbol (list->string (reverse ls)))) + (read-char in))) + +(define (scrib-read in) + (define ch (read-char in)) + (cond + ((eof-object? ch) ch) + ((char-whitespace? ch) (scrib-read in)) + (else + (case ch + ((#\( #\[ #\{) + (let lp ((res '())) + (let ((x (scrib-read in))) + (cond ((eof-object? x) (error "unterminated list" x)) + ((eq? x scribble-close) (reverse res)) + ((eq? x scribble-dot) + (let ((y (scrib-read in))) + (if (or (eof-object? y) (eq? y scribble-close)) + (error "unterminated dotted list") + (let ((z (scrib-read in))) + (if (not (eq? z scribble-close)) + (error "dot in non-terminal position in list" y z) + (append (reverse res) y)))))) + (else (lp (cons x res))))))) + ((#\} #\] #\)) scribble-close) + ((#\.) (if (char-delimiter? (peek-char in)) scribble-dot (read-float-tail in 0.0))) + ((#\') (list 'quote (scrib-read in))) + ((#\`) (list 'quasiquote (scrib-read in))) + ((#\,) (list (if-peek-char #\@ in 'unquote-splicing 'unquote) (scrib-read in))) + ((#\@) (scribble-parse-escape in #\@)) + ((#\;) (skip-line in) (scrib-read in)) + ((#\|) (string->symbol (read-escaped in #\|))) + ((#\") (read-escaped in #\")) + ((#\+ #\-) + (cond ((char-numeric? (peek-char in)) + ((if (eqv? ch #\+) + -) 0 (read-number in 0 10))) + (else (read-symbol in (list ch))))) + ((#\#) + (case (peek-char in) + ((#\t #\f) (eqv? (read-char in) #\t)) + ((#\() (list->vector (scrib-read in))) + ((#\\) + (read-char in) + (if (char-alphabetic? (peek-char in)) + (let ((name (scrib-read in))) + (case name + ((space) #\space) ((newline) #\newline) + (else (string-ref (symbol->string name) 0)))) + (read-char in))) + (else (error "unknown # syntax")))) + (else + (if (char-numeric? ch) + (read-number in (char-digit ch) 10) + (read-symbol in (list ch)))))))) + +(define (scribble-read in) + (let ((res (scrib-read in))) + (cond ((eq? res scribble-dot) (error "invalid . in source")) + ((eq? res scribble-close) (error "too many )'s")) + (else res)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; scribble parser + +(define (read-punctuation in) + (if (not (eqv? #\| (peek-char in))) + '() + (let lp ((ls '())) + (let ((c (peek-char in))) + (cond ((or (eof-object? c) (not(char-punctuation? c))) ls) + (else (lp (cons (char-mirror (read-char in)) ls)))))))) + +(define (read-prefix-wrapper in) + (let lp ((wrap (lambda (x) x))) + (case (peek-char in) + ((#\') (read-char in) (lp (lambda (x) (wrap (list 'quote x))))) + ((#\`) (read-char in) (lp (lambda (x) (wrap (list 'quasiquote x))))) + ((#\,) + (read-char in) + (cond ((eqv? #\@ (peek-char in)) + (read-char in) + (lp (lambda (x) (wrap (list 'unquote-splicing x))))) + (else (lp (lambda (x) (wrap (list 'unquote x))))))) + (else wrap)))) + +(define (scribble-parse-escape in ec) + (define bracket-char #\[) + (define brace-char #\{) + (let* ((wrap (read-prefix-wrapper in)) + (c (peek-char in)) + (cmd (if (or (eqv? c bracket-char) (eqv? c brace-char)) '() (list (scribble-read in)))) + (data? (eqv? (peek-char in) bracket-char)) + (data (if data? (scribble-read in) '())) + (punc (read-punctuation in)) + (body? (eqv? (peek-char in) brace-char)) + (body (cond (body? (read-char in) (scribble-parse in punc ec)) (else '())))) + (wrap (if (or data? body?) (append cmd data body) (car cmd))))) + +(define (scribble-parse in . o) + (define init-punc (if (pair? o) (car o) '())) + (define escape-char (if (and (pair? o) (pair? (cdr o))) (cadr o) #\@)) + (define comment-char #\;) + (define bracket-char #\[) + (define brace-char #\{) + (define close-bracket-char (char-mirror bracket-char)) + (define close-brace-char (char-mirror brace-char)) + (define (collect str res) + (if (pair? str) (cons (list->string (reverse str)) res) res)) + (define (skip-space in) + (let ((ch (peek-char in))) + (cond ((char-whitespace? ch) (read-char in) (skip-space in)) + ((eqv? ch #\;) (skip-line in) (skip-space in))))) + (define (tok str res punc depth) + (let ((c (read-char in))) + (cond + ((eof-object? c) + (if (zero? depth) + (reverse (collect str res)) + (error "unterminated expression" punc))) + ((and (eqv? c escape-char) (list-prefix? punc str)) + (let ((c (peek-char in))) + (cond + ((eof-object? c) + (tok str res punc depth)) + ((char-whitespace? c) + (tok (cons c str) res punc depth)) + ((eqv? c comment-char) + (read-char in) + (cond ((eqv? brace-char (peek-char in)) + (scribble-parse-escape in escape-char)) + (else + (skip-line in) + (let lp () + (cond ((char-whitespace? (peek-char in)) (read-char in) (lp)))))) + (tok str res punc depth)) + ((eqv? c #\|) + (read-char in) + (let lp ((ls (collect str res))) + (skip-space in) + (cond ((eqv? #\| (peek-char in)) (read-char in) (tok '() ls punc depth)) + (else (lp (cons (scribble-read in) ls)))))) + (else + (let ((str (drop str (length punc))) + (x (scribble-parse-escape in escape-char))) + (if (string? x) + (tok (append (reverse (string->list x)) str) res punc depth) + (tok '() (cons x (collect str res)) punc depth))))))) + ((eqv? c brace-char) + (tok (cons c str) res punc (+ depth 1))) + ((eqv? c close-brace-char) + (cond + ((zero? depth) + (let lp ((p punc) (ls '())) + (cond ((null? p) + (reverse (collect str res))) + ((not (eqv? (car p) (peek-char in))) + (tok (append ls (cons c str)) res punc (- depth 1))) + (else + (lp (cdr p) (cons (read-char in) ls)))))) + (else (tok (cons c str) res punc (- depth 1))))) + ((eqv? c #\newline) + (let* ((first? (and (null? res) (null? str))) + (res (collect (drop-while char-whitespace? str) res)) + (res (if (or first? (eqv? #\} (peek-char in))) + res + (cons "\n" res)))) + (let lp ((ls '())) + (let ((c (peek-char in))) + (cond + ((char-whitespace? c) (read-char in) (lp (cons c ls))) + (else (tok (if (eqv? c #\}) ls '()) res punc depth))))))) + (else + (tok (cons c str) res punc depth))))) + ;; begin + (tok '() '() init-punc 0)) diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c new file mode 100644 index 00000000..7202d96e --- /dev/null +++ b/lib/chibi/signal.c @@ -0,0 +1,76 @@ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_MAX_SIGNUM 32 + +static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM]; + +static struct sigaction call_sigaction, call_sigdefault, call_sigignore; + +static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { + sexp ctx; +#if ! SEXP_USE_GREEN_THREADS + sexp sigctx, handler; + sexp_gc_var1(args); +#endif + ctx = sexp_signal_contexts[signum]; + if (ctx) { +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = + (sexp) ((sexp_uint_t)sexp_global(ctx, SEXP_G_THREADS_SIGNALS) + | (sexp_uint_t)sexp_make_fixnum(1UL< 0 + && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) + return sexp_xtype_exception(ctx, self, "not a valid signal number", signum); + if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) + || sexp_booleanp(newaction))) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, newaction); + if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS))) + sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS) + = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE); + oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); + res = sigaction(sexp_unbox_fixnum(signum), + (sexp_booleanp(newaction) ? + (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore) + : &call_sigaction), + NULL); + if (res) + return sexp_user_exception(ctx, self, "couldn't set signal", signum); + sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction); + sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx; + return oldaction; +} + +static void sexp_init_signals (sexp ctx, sexp env) { + call_sigaction.sa_sigaction = sexp_call_sigaction; +#if SEXP_USE_GREEN_THREADS + call_sigaction.sa_flags = SA_SIGINFO | SA_RESTART /* | SA_NODEFER */; + sigfillset(&call_sigaction.sa_mask); +#else + call_sigaction.sa_flags = SA_SIGINFO | SA_RESTART | SA_NODEFER; +#endif + call_sigdefault.sa_handler = SIG_DFL; + call_sigignore.sa_handler = SIG_IGN; + memset(sexp_signal_contexts, 0, sizeof(sexp_signal_contexts)); +} diff --git a/lib/chibi/stty.module b/lib/chibi/stty.module new file mode 100644 index 00000000..4540cb18 --- /dev/null +++ b/lib/chibi/stty.module @@ -0,0 +1,11 @@ + +(define-module (chibi stty) + (export stty with-stty with-raw-io + get-terminal-width get-terminal-dimensions + TCSANOW TCSADRAIN TCSAFLUSH) + (import-immutable (scheme) + (srfi 33) + (srfi 69)) + (include-shared "stty") + (include "stty.scm")) + diff --git a/lib/chibi/stty.scm b/lib/chibi/stty.scm new file mode 100644 index 00000000..b4aee004 --- /dev/null +++ b/lib/chibi/stty.scm @@ -0,0 +1,235 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; symbolic representation of attributes + +(define stty-lookup (make-hash-table eq?)) + +(for-each + (lambda (c) + (let ((type (cadr c)) + (value (caddr c))) + (hash-table-set! stty-lookup (car c) (cdr c)))) + + ;; ripped from the stty man page, then trimmed down to what seemed + ;; available on most systems + + `(;; characters + ;;(dsusp char ,VDSUSP) ; CHAR will send a terminal stop signal + (eof char ,VEOF) ; CHAR will send an EOF (terminate input) + (eol char ,VEOL) ; CHAR will end the line + (eol2 char ,VEOL2) ; alternate CHAR for ending the line + (erase char ,VERASE) ; CHAR will erase the last character typed + (intr char ,VINTR) ; CHAR will send an interrupt signal + (kill char ,VKILL) ; CHAR will erase the current line + (lnext char ,VLNEXT) ; CHAR will enter the next character quoted + (quit char ,VQUIT) ; CHAR will send a quit signal + (rprnt char ,VREPRINT) ; CHAR will redraw the current line + (start char ,VSTART) ; CHAR will restart output after stopping it + (stop char ,VSTOP) ; CHAR will stop the output + (susp char ,VSUSP) ; CHAR will send a terminal stop signal + (werase char ,VWERASE) ; CHAR will erase the last word typed + + ;; special settings + (cols special #f) ; tell the kernel that the terminal has N columns + (columns special #f) ; same as cols N + (ispeed special #f) ; set the input speed to N + (line special #f) ; use line discipline N + (min special #f) ; with -icanon, set N characters minimum for a completed read + (ospeed special #f) ; set the output speed to N + (rows special #f) ; tell the kernel that the terminal has N rows + (size special #f) ; print the number of rows and columns according to the kernel + (speed special #f) ; print the terminal speed + (time special #f) ; with -icanon, set read timeout of N tenths of a second + + ;; control settings + (clocal control ,CLOCAL) ; disable modem control signals + (cread control ,CREAD) ; allow input to be received + (crtscts control ,CRTSCTS) ; enable RTS/CTS handshaking + (cs5 control ,CS5) ; set character size to 5 bits + (cs6 control ,CS6) ; set character size to 6 bits + (cs7 control ,CS7) ; set character size to 7 bits + (cs8 control ,CS8) ; set character size to 8 bits + (cstopb control ,CSTOPB) ; use two stop bits per character (one with `-') + (hup control ,HUPCL) ; send a hangup signal when the last process closes the tty + (hupcl control ,HUPCL) ; same as [-]hup + (parenb control ,PARENB) ; generate parity bit in output and expect parity bit in input + (parodd control ,PARODD) ; set odd parity (even with `-') + + ;; input settings + (brkint input ,BRKINT) ; breaks cause an interrupt signal + (icrnl input ,ICRNL) ; translate carriage return to newline + (ignbrk input ,IGNBRK) ; ignore break characters + (igncr input ,IGNCR) ; ignore carriage return + (ignpar input ,IGNPAR) ; ignore characters with parity errors + (imaxbel input ,IMAXBEL) ; * beep and do not flush a full input buffer on a character + (inlcr input ,INLCR) ; translate newline to carriage return + (inpck input ,INPCK) ; enable input parity checking + (istrip input ,ISTRIP) ; clear high (8th) bit of input characters + ;;(iuclc input ,IUCLC) ; * translate uppercase characters to lowercase + (ixany input ,IXANY) ; * let any character restart output, not only start character + (ixoff input ,IXOFF) ; enable sending of start/stop characters + (ixon input ,IXON) ; enable XON/XOFF flow control + (parmrk input ,PARMRK) ; mark parity errors (with a 255-0-character sequence) + (tandem input ,IXOFF) ; same as [-]ixoff + + ;; output settings + ;;(bs0 output ,BS0) ; backspace delay style, N in [0..1] + ;;(bs1 output ,BS1) ; backspace delay style, N in [0..1] + ;;(cr0 output ,CR0) ; carriage return delay style, N in [0..3] + ;;(cr1 output ,CR1) ; carriage return delay style, N in [0..3] + ;;(cr2 output ,CR2) ; carriage return delay style, N in [0..3] + ;;(cr3 output ,CR3) ; carriage return delay style, N in [0..3] + ;;(ff0 output ,FF0) ; form feed delay style, N in [0..1] + ;;(ff1 output ,FF1) ; form feed delay style, N in [0..1] + ;;(nl0 output ,NL0) ; newline delay style, N in [0..1] + ;;(nl1 output ,NL1) ; newline delay style, N in [0..1] + (ocrnl output ,OCRNL) ; translate carriage return to newline + ;;(ofdel output ,OFDEL) ; use delete characters for fill instead of null characters + ;;(ofill output ,OFILL) ; use fill (padding) characters instead of timing for delays + ;;(olcuc output ,OLCUC) ; translate lowercase characters to uppercase + (onlcr output ,ONLCR) ; translate newline to carriage return-newline + (onlret output ,ONLRET) ; newline performs a carriage return + (onocr output ,ONOCR) ; do not print carriage returns in the first column + (opost output ,OPOST) ; postprocess output + (tab0 output #f) ; horizontal tab delay style, N in [0..3] + (tab1 output #f) ; horizontal tab delay style, N in [0..3] + (tab2 output #f) ; horizontal tab delay style, N in [0..3] + (tab3 output #f) ; horizontal tab delay style, N in [0..3] + (tabs output #f) ; same as tab0 + ;;(-tabs output #f) ; same as tab3 + ;;(vt0 output ,VT0) ; vertical tab delay style, N in [0..1] + ;;(vt1 output ,VT1) ; vertical tab delay style, N in [0..1] + + ;; local settings + (crterase local ,ECHOE) ; echo erase characters as backspace-space-backspace + (crtkill local ,ECHOKE) ; kill all line by obeying the echoprt and echoe settings + ;;(-crtkill local #f) ; kill all line by obeying the echoctl and echok settings + (ctlecho local ,ECHOCTL) ; echo control characters in hat notation (`^c') + (echo local ,ECHO) ; echo input characters + (echoctl local ,ECHOCTL) ; same as [-]ctlecho + (echoe local ,ECHOE) ; same as [-]crterase + ;;(echok local ,ECHOK) ; echo a newline after a kill character + (echoke local ,ECHOKE) ; same as [-]crtkill + (echonl local ,ECHONL) ; echo newline even if not echoing other characters + (echoprt local ,ECHOPRT) ; echo erased characters backward, between `\' and '/' + (icanon local ,ICANON) ; enable erase, kill, werase, and rprnt special characters + ;;(iexten local ,IEXTEN) ; enable non-POSIX special characters + (isig local ,ISIG) ; enable interrupt, quit, and suspend special characters + (noflsh local ,NOFLSH) ; disable flushing after interrupt and quit special characters + (prterase local ,ECHOPRT) ; same as [-]echoprt + (tostop local ,TOSTOP) ; stop background jobs that try to write to the terminal + ;;(xcase local ,XCASE) ; with icanon, escape with `\' for uppercase characters + + ;; combination settings + (LCASE combine (lcase)) + (cbreak combine (not icanon)) + (cooked combine (brkint ignpar istrip icrnl ixon opost isig icanon)) + ; also eof and eol characters + ; to their default values + (crt combine (echoe echoctl echoke)) + (dec combine (echoe echoctl echoke (not ixany))) + ; also intr ^c erase 0177 kill ^u + (decctlq combine (ixany)) + (ek combine ()) ; erase and kill characters to their default values + (evenp combine (parenb (not parodd) cs7)) + ;;(-evenp combine #f) ; same as -parenb cs8 + (lcase combine (xcase iuclc olcuc)) + (litout combine (cs8 (not parenb istrip opost))) + ;;(-litout combine #f) ; same as parenb istrip opost cs7 + (nl combine (not icrnl onlcr)) + ;;(-nl combine #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret + (oddp combine (parenb parodd cs7)) + (parity combine (evenp)) ; same as [-]evenp + (pass8 combine (cs8 (not parenb istrip))) + ;;(-pass8 combine #f) ; same as parenb istrip cs7 + (raw combine (not ignbrk brkint ignpar parmrk + inpck istrip inlcr igncr icrnl)) + (ixon combine (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc + ;;(time combine #f) ; 0 + ;;(-raw combine #f) ; same as cooked + (sane combine (cread brkint icrnl imaxbel opost onlcr + isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0 + echo echoe echoctl echoke ;; iexten echok + (not ignbrk igncr ixoff ixany inlcr ;; iuclc + ocrnl onocr onlret ;; olcuc ofill ofdel + echonl noflsh tostop echoprt))) ;; xcase + ; plus all special characters to + ; their default values + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; high-level interface + +(define (port? x) (or (input-port? x) (output-port? x))) + +(define (stty . args) + (let* ((port (if (and (pair? args) (port? (car args))) + (car args) + (current-output-port))) + (attr (get-terminal-attributes port))) + ;; parse change requests + (let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args)) + (iflag (term-attrs-iflag attr)) + (oflag (term-attrs-oflag attr)) + (cflag (term-attrs-cflag attr)) + (lflag (term-attrs-lflag attr)) + (invert? #f) + (return (lambda (iflag oflag cflag lflag) + (term-attrs-iflag-set! attr iflag) + (term-attrs-oflag-set! attr oflag) + (term-attrs-cflag-set! attr cflag) + (term-attrs-lflag-set! attr lflag) + (set-terminal-attributes! port TCSANOW attr)))) + (define (join old new) + (if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new))) + (cond + ((pair? lst) + (let ((command (car lst))) + (cond + ((pair? command) ;; recurse on sub-expr + (lp command iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((eq? command 'not) ;; toggle current setting + (lp (cdr lst) iflag oflag cflag lflag (not invert?) return)) + (else + (let ((x (hash-table-ref/default stty-lookup command #f))) + (case (and x (car x)) + ((input) + (lp (cdr lst) (join iflag (cadr x)) oflag cflag lflag invert? return)) + ((output) + (lp (cdr lst) iflag (join oflag (cadr x)) cflag lflag invert? return)) + ((control) + (lp (cdr lst) iflag oflag (join cflag (cadr x)) lflag invert? return)) + ((local) + (lp (cdr lst) iflag oflag cflag (join lflag (cadr x)) invert? return)) + ((char) + ;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0)) + (lp (cddr lst) iflag oflag cflag lflag invert? return)) + ((combine) + (lp (cadr x) iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((special) + (error "special settings not yet supported" command)) + (else + (error "unknown stty command" command)))))))) + (else + (return iflag oflag cflag lflag)))))) + +(define (with-stty setting thunk . o) + (let* ((port (if (pair? o) (car o) (current-input-port))) + (orig-attrs (get-terminal-attributes port))) + (dynamic-wind + (lambda () (stty setting)) + thunk + (lambda () (set-terminal-attributes! port TCSANOW orig-attrs))))) + +(define (with-raw-io port thunk) + (with-stty '(not icanon echo) thunk port)) + +(define (get-terminal-width x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (winsize-col ws)))) + +(define (get-terminal-dimensions x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (list (winsize-col ws) (winsize-row ws))))) diff --git a/lib/chibi/stty.stub b/lib/chibi/stty.stub new file mode 100644 index 00000000..3c5939c5 --- /dev/null +++ b/lib/chibi/stty.stub @@ -0,0 +1,106 @@ + +(c-system-include "termios.h") +(c-system-include "sys/ioctl.h") + +(define-c-struct termios + predicate: term-attrs? + constructor: (make-term-attrs) + (unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!) + (unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!) + (unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!) + (unsigned-long c_lflag term-attrs-lflag term-attrs-lflag-set!) + ;;(unsigned-char (c_cc 22) term-attrs-cc term-attrs-cc-set!) + (unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!) + (unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!)) + +(define-c-struct winsize + predicate: winsize? + (unsigned-short ws_row winsize-row) + (unsigned-short ws_col winsize-col)) + +(define-c errno ioctl (port-or-fd unsigned-long (result winsize))) + +(define-c-const int TIOCGWINSZ) + +(define-c-const int TCSANOW) +(define-c-const int TCSADRAIN) +(define-c-const int TCSAFLUSH) + +(define-c-const unsigned-long IGNBRK) +(define-c-const unsigned-long BRKINT) +(define-c-const unsigned-long IGNPAR) +(define-c-const unsigned-long PARMRK) +(define-c-const unsigned-long INPCK) +(define-c-const unsigned-long ISTRIP) +(define-c-const unsigned-long INLCR) +(define-c-const unsigned-long IGNCR) +(define-c-const unsigned-long ICRNL) +(define-c-const unsigned-long IXON) +(define-c-const unsigned-long IXOFF) +(define-c-const unsigned-long IXANY) +(define-c-const unsigned-long IMAXBEL) +;; (define-c-const unsigned-long IUCLC) + +(define-c-const unsigned-long OPOST) +(define-c-const unsigned-long ONLCR) +;; (define-c-const unsigned-long OXTABS) +;; (define-c-const unsigned-long ONOEOT) +(define-c-const unsigned-long OCRNL) +;; (define-c-const unsigned-long OLCUC) +(define-c-const unsigned-long ONOCR) +(define-c-const unsigned-long ONLRET) + +(define-c-const unsigned-long CSIZE) +(define-c-const unsigned-long CS5) +(define-c-const unsigned-long CS6) +(define-c-const unsigned-long CS7) +(define-c-const unsigned-long CS8) +(define-c-const unsigned-long CSTOPB) +(define-c-const unsigned-long CREAD) +(define-c-const unsigned-long PARENB) +(define-c-const unsigned-long PARODD) +(define-c-const unsigned-long HUPCL) +(define-c-const unsigned-long CLOCAL) +;; (define-c-const unsigned-long CCTS_OFLOW) +(define-c-const unsigned-long CRTSCTS) +;; (define-c-const unsigned-long CRTS_IFLOW) +;; (define-c-const unsigned-long MDMBUF) + +(define-c-const unsigned-long ECHOKE) +(define-c-const unsigned-long ECHOE) +(define-c-const unsigned-long ECHO) +(define-c-const unsigned-long ECHONL) +(define-c-const unsigned-long ECHOPRT) +(define-c-const unsigned-long ECHOCTL) +(define-c-const unsigned-long ISIG) +(define-c-const unsigned-long ICANON) +;; (define-c-const unsigned-long ALTWERASE) +(define-c-const unsigned-long IEXTEN) +;; (define-c-const unsigned-long EXTPROC) +(define-c-const unsigned-long TOSTOP) +(define-c-const unsigned-long FLUSHO) +;; (define-c-const unsigned-long NOKERNINFO) +(define-c-const unsigned-long PENDIN) +(define-c-const unsigned-long NOFLSH) + +(define-c-const unsigned-long VEOF) +(define-c-const unsigned-long VEOL) +(define-c-const unsigned-long VEOL2) +(define-c-const unsigned-long VERASE) +;; (define-c-const unsigned-long VERASE2) +(define-c-const unsigned-long VWERASE) +(define-c-const unsigned-long VINTR) +(define-c-const unsigned-long VKILL) +(define-c-const unsigned-long VQUIT) +(define-c-const unsigned-long VSUSP) +(define-c-const unsigned-long VSTART) +(define-c-const unsigned-long VSTOP) +;; (define-c-const unsigned-long VDSUSP) +(define-c-const unsigned-long VLNEXT) +(define-c-const unsigned-long VREPRINT) +;; (define-c-const unsigned-long VSTATUS) + +(define-c errno (get-terminal-attributes "tcgetattr") + (port-or-fd (result termios))) +(define-c errno (set-terminal-attributes! "tcsetattr") + (port-or-fd int termios)) diff --git a/lib/chibi/system.module b/lib/chibi/system.module new file mode 100644 index 00000000..adc26ddc --- /dev/null +++ b/lib/chibi/system.module @@ -0,0 +1,15 @@ + +(define-module (chibi system) + (export user-information user-name user-password + user-id user-group-id user-gecos user-home user-shell + current-user-id current-group-id + current-effective-user-id current-effective-group-id + set-current-user-id! set-current-effective-user-id! + set-current-group-id! set-current-effective-group-id! + current-session-id create-session + set-root-directory!) + (import-immutable (scheme)) + (include-shared "system") + ;;(include "system.scm") + ) + diff --git a/lib/chibi/system.stub b/lib/chibi/system.stub new file mode 100644 index 00000000..7d4a836f --- /dev/null +++ b/lib/chibi/system.stub @@ -0,0 +1,34 @@ + +(c-system-include "unistd.h") +(c-system-include "pwd.h") +(c-system-include "sys/types.h") + +(define-c-struct passwd + predicate: user? + (string pw_name user-name) + (string pw_passwd user-password) + (uid_t pw_uid user-id) + (gid_t pw_gid user-group-id) + (string pw_gecos user-gecos) + (string pw_dir user-home) + (string pw_shell user-shell)) + +(define-c uid_t (current-user-id "getuid") ()) +(define-c gid_t (current-group-id "getgid") ()) +(define-c uid_t (current-effective-user-id "geteuid") ()) +(define-c gid_t (current-effective-group-id "getegid") ()) + +(define-c errno (set-current-user-id! "setuid") (uid_t)) +(define-c errno (set-current-effective-user-id! "seteuid") (uid_t)) +(define-c errno (set-current-group-id! "setgid") (gid_t)) +(define-c errno (set-current-effective-group-id! "setegid") (gid_t)) + +(define-c pid_t (current-session-id "getsid") ((default 0 pid_t))) +(define-c pid_t (create-session "setsid") ()) + +(define-c errno (set-root-directory! "chroot") (string)) + +;; (define-c errno getpwuid_r +;; (uid_t (result passwd) (result (array char arg3)) +;; (value 256 int) (result pointer passwd))) + diff --git a/lib/chibi/term/edit-line.module b/lib/chibi/term/edit-line.module new file mode 100644 index 00000000..d8116473 --- /dev/null +++ b/lib/chibi/term/edit-line.module @@ -0,0 +1,5 @@ + +(define-module (chibi term edit-line) + (export edit-line edit-line-repl) + (import-immutable (scheme) (chibi stty) (srfi 9)) + (include "edit-line.scm")) diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm new file mode 100644 index 00000000..1c985919 --- /dev/null +++ b/lib/chibi/term/edit-line.scm @@ -0,0 +1,505 @@ +;;;; edit-line.scm - pure scheme line editing tool +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; vt100 terminal utilities + +(define (terminal-escape out ch arg) + (write-char (integer->char 27) out) + (write-char #\[ out) + (if arg (display arg out)) + (write-char ch out)) + +;; we use zero-based columns +(define (terminal-goto-col out n) (terminal-escape out #\G (+ n 1))) +(define (terminal-up out n) (terminal-escape out #\A n)) +(define (terminal-down out n) (terminal-escape out #\B n)) +(define (terminal-clear-below out) (terminal-escape out #\J #f)) +(define (terminal-clear-right out) (terminal-escape out #\K #f)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; history + +(define maximum-history-size 128) + +(define-record-type history + (%make-history remaining past future) + history? + (remaining history-remaining history-remaining-set!) + (past history-past history-past-set!) + (future history-future history-future-set!)) + +(define (make-history . o) + (%make-history (if (pair? o) (car o) maximum-history-size) '() '())) + +(define (history-current h) + (let ((p (history-past h))) + (and (pair? p) (car p)))) + +(define (history->list h) + (let ((past (history-past h)) (future (history-future h))) + (if (pair? past) (cons (car past) (append future (cdr past))) future))) + +(define (history-flatten! h) + (history-past-set! h (history->list h)) + (history-future-set! h '())) + +(define (drop-last ls) (reverse (cdr (reverse ls)))) + +(define (history-past-push! h x) + (if (positive? (history-remaining h)) + (history-remaining-set! h (- (history-remaining h) 1)) + (if (pair? (history-past h)) + (history-past-set! h (drop-last (history-past h))) + (history-future-set! h (drop-last (history-future h))))) + (history-past-set! h (cons x (history-past h)))) + +(define (history-insert! h x) + (history-flatten! h) + (history-past-push! h x)) + +(define (history-commit! h x) + (cond + ((pair? (history-future h)) + (history-past-set! + h (cons x (append (drop-last (history-future h)) (history-past h)))) + (history-future-set! h '())) + (else + (history-insert! h x)))) + +(define (history-prev! h) + (let ((past (history-past h))) + (and (pair? past) + (pair? (cdr past)) + (begin + (history-future-set! h (cons (car past) (history-future h))) + (history-past-set! h (cdr past)) + (cadr past))))) + +(define (history-next! h) + (let ((future (history-future h))) + (and (pair? future) + (begin + (history-past-set! h (cons (car future) (history-past h))) + (history-future-set! h (cdr future)) + (car future))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; char and string utils + +(define (char-word-constituent? ch) + (or (char-alphabetic? ch) (char-numeric? ch) + (memv ch '(#\_ #\- #\+ #\:)))) + +(define (char-non-word-constituent? ch) (not (char-word-constituent? ch))) + +(define (string-copy! dst dstart src start end) + (if (>= start dstart) + (do ((i start (+ i 1)) (j dstart (+ j 1))) + ((= i end)) + (string-set! dst j (string-ref src i))) + (do ((i (- end 1) (- i 1)) (j (+ dstart (- end start 1)) (- j 1))) + ((< i start)) + (string-set! dst j (string-ref src i))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; buffers + +(define-record-type buffer + (%make-buffer refresh? min pos row max-row col gap width string history) + buffer? + (refresh? buffer-refresh? buffer-refresh?-set!) + (min buffer-min buffer-min-set!) + (pos buffer-pos buffer-pos-set!) + (row buffer-row buffer-row-set!) + (max-row buffer-max-row buffer-max-row-set!) + (col buffer-col buffer-col-set!) + (gap buffer-gap buffer-gap-set!) + (width buffer-width buffer-width-set!) + (string buffer-string buffer-string-set!) + (kill-ring buffer-kill-ring buffer-kill-ring-set!) + (history buffer-history buffer-history-set!)) + +(define default-buffer-size 256) +(define default-buffer-width 80) + +(define (make-buffer) + (%make-buffer #f 0 0 0 0 0 default-buffer-size default-buffer-width + (make-string default-buffer-size) '())) + +(define (buffer->string buf) + (let ((str (buffer-string buf))) + (string-append (substring str (buffer-min buf) (buffer-pos buf)) + (substring str (buffer-gap buf) (string-length str))))) + +(define (buffer-right-length buf) + (- (string-length (buffer-string buf)) (buffer-gap buf))) +(define (buffer-length buf) + (+ (buffer-pos buf) (buffer-right-length buf))) +(define (buffer-free-space buf) + (- (buffer-gap buf) (buffer-pos buf))) + +(define (buffer-clamp buf n) + (max (buffer-min buf) (min n (buffer-length buf)))) + +(define (buffer-resize buf n) + (cond ((<= (buffer-free-space buf) n) + (let* ((right-len (buffer-right-length buf)) + (new-len (* 2 (max n (buffer-length buf)))) + (new-gap (- new-len right-len)) + (new (make-string new-len)) + (old (buffer-string buf))) + (string-copy! new 0 old 0 (buffer-pos buf)) + (string-copy! new new-gap old (buffer-gap buf) (string-length old)) + (buffer-string-set! buf new) + (buffer-gap-set! buf new-gap))))) + +(define (buffer-update-position! buf) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (end (string-length (buffer-string buf))) + (width (buffer-width buf))) + (let lp ((i 0) (row 0) (col 0)) ;; update row/col + (cond ((= i pos) + (buffer-row-set! buf row) + (buffer-col-set! buf col) + (lp gap row col)) + ((>= i end) + (buffer-max-row-set! + buf (if (and (zero? col) (> row 0)) (- row 1) row))) + ((= (+ col 1) width) + (lp (+ i 1) (+ row 1) 0)) + (else + (lp (+ i 1) row (+ col 1))))))) + +(define (buffer-draw buf out) + (let* ((gap (buffer-gap buf)) + (str (buffer-string buf)) + (end (string-length str)) + (old-row (buffer-row buf)) + (old-col (buffer-col buf))) + (buffer-update-position! buf) + ;; goto start of input + (terminal-goto-col out 0) + (if (positive? old-row) + (terminal-up out old-row)) + ;; clear and display new buffer + (terminal-clear-below out) + (display (substring str 0 (buffer-pos buf)) out) + (display (substring str (buffer-gap buf) end) out) + ;; move to next line if point at eol + (if (and (zero? (buffer-col buf)) (positive? (buffer-row buf))) + (write-char #\space out)) + ;; move to correct row then col + (if (< (buffer-row buf) (buffer-max-row buf)) + (terminal-up out (- (buffer-max-row buf) (buffer-row buf)))) + (terminal-goto-col out (buffer-col buf)))) + +(define (buffer-refresh buf out) + (cond ((buffer-refresh? buf) + (buffer-draw buf out) + (buffer-refresh?-set! buf #f)))) + +(define (buffer-goto! buf out n) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (n (buffer-clamp buf n))) + (cond ((not (= n pos)) + (buffer-update-position! buf) ;; XXXX shouldn't be needed + (if (< n pos) + (string-copy! str (- gap (- pos n)) str n pos) + (string-copy! str pos str gap (+ gap (- n pos)))) + (buffer-pos-set! buf n) + (buffer-gap-set! buf (+ gap (- n pos))) + (cond + ((not (buffer-refresh? buf)) + (let ((old-row (buffer-row buf))) + (buffer-update-position! buf) + (let ((row-diff (- old-row (buffer-row buf)))) + (cond ((> row-diff 0) (terminal-up out row-diff)) + ((< row-diff 0) (terminal-down out (- row-diff))))) + (terminal-goto-col out (buffer-col buf))))))))) + +(define (buffer-insert! buf out x) + (let ((len (if (char? x) 1 (string-length x))) + (pos (buffer-pos buf))) + (buffer-resize buf len) + (if (char? x) + (string-set! (buffer-string buf) pos x) + (string-copy! (buffer-string buf) pos x 0 len)) + (buffer-pos-set! buf (+ (buffer-pos buf) len)) + (cond + ((buffer-refresh? buf)) + ((and (= (buffer-gap buf) (string-length (buffer-string buf))) + (< (+ (buffer-col buf) len) (buffer-width buf))) + ;; fast path - append to end of buffer w/o wrapping to next line + (display x out) + (buffer-col-set! buf (+ (buffer-col buf) len))) + (else + (buffer-refresh?-set! buf #t))))) + +(define (buffer-delete! buf out start end) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (start (buffer-clamp buf start)) + (end (buffer-clamp buf end))) + (if (not (buffer-refresh? buf)) + (if (and (= start pos) (>= end (buffer-length buf))) + (terminal-clear-below out) + (buffer-refresh?-set! buf #t))) + (cond ((< end pos) + (string-copy! str start str end pos) + (buffer-pos-set! buf (+ start (- pos end)))) + ((> start gap) + (string-copy! str start str gap (+ gap (- end start))) + (buffer-gap-set! buf (+ gap (- end start)))) + (else + (buffer-pos-set! buf (min pos start)) + (buffer-gap-set! buf (max gap (+ pos (- gap pos) (- end pos)))))))) + +(define (buffer-skip buf pred) + (let* ((str (buffer-string buf)) (end (string-length str))) + (let lp ((i (buffer-gap buf))) + (if (or (>= i end) (not (pred (string-ref str i)))) + (+ (- i (buffer-gap buf)) (buffer-pos buf)) + (lp (+ i 1)))))) + +(define (buffer-skip-reverse buf pred) + (let ((str (buffer-string buf))) + (let lp ((i (- (buffer-pos buf) 1))) + (if (or (< i 0) (not (pred (string-ref str i)))) i (lp (- i 1)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; keymaps + +(define keymap? pair?) + +(define (make-keymap . o) + (cons (make-vector 256 #f) (and (pair? o) (car o)))) + +(define (make-sparse-keymap . o) + (cons '() (and (pair? o) (car o)))) + +(define (make-printable-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (do ((i #x20 (+ i 1))) ((= i #x7F) keymap) + (vector-set! v i command/self-insert)))) + +(define (make-standard-escape-bracket-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 65 command/backward-history) + (vector-set! v 66 command/forward-history) + (vector-set! v 67 command/forward-char) + (vector-set! v 68 command/backward-char) + keymap)) + +(define (make-standard-escape-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 8 command/backward-delete-word) + (vector-set! v 91 (make-standard-escape-bracket-keymap)) + (vector-set! v 98 command/backward-word) + (vector-set! v 100 command/forward-delete-word) + (vector-set! v 102 command/forward-word) + (vector-set! v 127 command/backward-delete-word) + keymap)) + +(define (make-standard-keymap) + (let* ((keymap (make-printable-keymap)) + (v (car keymap))) + (vector-set! v 1 command/beggining-of-line) + (vector-set! v 2 command/backward-char) + (vector-set! v 4 command/forward-delete-char) + (vector-set! v 5 command/end-of-line) + (vector-set! v 6 command/forward-char) + (vector-set! v 8 command/backward-delete-char) + (vector-set! v 10 command/enter) + (vector-set! v 11 command/forward-delete-line) + (vector-set! v 12 command/refresh) + (vector-set! v 13 command/enter) + (vector-set! v 21 command/backward-delete-line) + (vector-set! v 27 (make-standard-escape-keymap)) + (vector-set! v 127 command/backward-delete-char) + keymap)) + +(define (keymap-lookup keymap n) + (let ((table (car keymap))) + (or (if (vector? table) + (and (< n (vector-length table)) (vector-ref table n)) + (cond ((assv n table) => cdr) (else #f))) + (if (keymap? (cdr keymap)) + (keymap-lookup (cdr keymap) n) + (cdr keymap))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; commands + +(define (command/self-insert ch buf out return) + (buffer-insert! buf out ch)) + +(define (command/enter ch buf out return) + (command/end-of-line ch buf out return) + (newline out) + (return)) + +(define (command/beep ch buf out return) + (write-char (integer->char 7) out)) + +(define (command/refresh ch buf out return) + (buffer-draw buf out)) + +(define (command/beggining-of-line ch buf out return) + (buffer-goto! buf out 0)) + +(define (command/end-of-line ch buf out return) + (buffer-goto! buf out (buffer-length buf))) + +(define (command/forward-char ch buf out return) + (buffer-goto! buf out (+ (buffer-pos buf) 1))) + +(define (command/backward-char ch buf out return) + (buffer-goto! buf out (- (buffer-pos buf) 1))) + +(define (command/forward-delete-char ch buf out return) + (cond + ((zero? (- (buffer-length buf) (buffer-min buf))) + (newline out) + (return 'eof)) + (else + (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1))))) + +(define (command/backward-delete-char ch buf out return) + (buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf))) + +(define (command/forward-delete-line ch buf out return) + (buffer-delete! buf out (buffer-pos buf) (buffer-length buf))) + +(define (command/backward-delete-line ch buf out return) + (buffer-delete! buf out 0 (buffer-pos buf))) + +(define (command/backward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-past history))) + (if (null? (history-future history)) + (history-insert! history (buffer->string buf))) + (cond + ((pair? (cdr (history-past history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (buffer-insert! buf out (history-prev! history)))))))) + +(define (command/forward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-future history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (let ((res (buffer-insert! buf out (history-next! history)))) + (if (null? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + res))))) + +(define (command/forward-word ch buf out return) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-goto! buf out (buffer-skip buf char-word-constituent?))) + +(define (command/backward-word ch buf out return) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (buffer-goto! buf out (+ (buffer-skip-reverse buf char-word-constituent?) 1))) + +(define (command/forward-delete-word ch buf out return) + (let ((start (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-delete! buf out start (buffer-skip buf char-word-constituent?)))) + +(define (command/backward-delete-word ch buf out return) + (let ((end (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (let ((start (buffer-skip-reverse buf char-word-constituent?))) + (buffer-delete! buf out (+ start 1) end)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; line-editing + +(define standard-keymap (make-standard-keymap)) + +(define (get-key ls key . o) + (let ((x (memq key ls))) + (if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o))))) + +(define (with-leading-ports ls proc) + (if (and (pair? ls) (input-port? (car ls))) + (if (and (pair? (cdr ls)) (output-port? (cadr ls))) + (proc (car ls) (cadr ls) (cddr ls)) + (proc (car ls) (current-output-port) (cdr ls))) + (proc (current-input-port) (current-output-port) ls))) + +(define (make-line-editor . args) + (let* ((prompt (get-key args 'prompt: "> ")) + (history (get-key args 'history:)) + (terminal-width (get-key args 'terminal-width:)) + (keymap (get-key args 'keymap: standard-keymap))) + (lambda (in out) + (let* ((width (or terminal-width (get-terminal-width out))) + (buf (make-buffer)) + (done? #f) + (return (lambda o (set! done? (if (pair? o) (car o) #t))))) + (buffer-refresh?-set! buf #t) + (buffer-width-set! buf width) + (buffer-insert! buf out prompt) + (buffer-min-set! buf (string-length prompt)) + (buffer-history-set! buf history) + (buffer-refresh buf out) + (flush-output out) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp ((kmap keymap)) + (let ((ch (read-char in))) + (if (eof-object? ch) + (let ((res (buffer->string buf))) + (if (equal? res "") ch res)) + (let ((x (keymap-lookup kmap (char->integer ch)))) + (cond + ((keymap? x) + (lp x)) + ((procedure? x) + (x ch buf out return) + (buffer-refresh buf out) + (if done? + (and (not (eq? done? 'eof)) (buffer->string buf)) + (lp keymap))) + (else + ;;(command/beep ch buf out return) + (lp keymap))))))))))))) + +(define (edit-line . args) + (with-leading-ports + args + (lambda (in out rest) ((apply make-line-editor rest) in out)))) + +(define (edit-line-repl . args) + (with-leading-ports + args + (lambda (in out rest) + (let ((eval (get-key rest 'eval: (lambda (x) x))) + (print (get-key rest 'write: write)) + (history (or (get-key rest 'history:) (make-history)))) + (let ((edit-line + (apply make-line-editor 'no-stty?: #t 'history: history rest))) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp () + (let ((line (edit-line in out))) + (if (pair? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + (history-commit! history line) + (print (eval line) out) + (newline out) + (lp)))))))))) diff --git a/lib/chibi/test.module b/lib/chibi/test.module new file mode 100644 index 00000000..d8b405f1 --- /dev/null +++ b/lib/chibi/test.module @@ -0,0 +1,14 @@ + +(define-module (chibi test) + (export + test test-error test-assert test-values + test-group current-test-group + test-begin test-end test-syntax-error test-info + test-vars test-run ;;test-exit + current-test-verbosity current-test-epsilon current-test-comparator + current-test-applier current-test-handler current-test-skipper + current-test-group-reporter test-failure-count) + (import-immutable (scheme)) + (import (srfi 39) (srfi 98) (chibi time) (chibi ast)) + (include "test.scm")) + diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm new file mode 100644 index 00000000..bfa7429e --- /dev/null +++ b/lib/chibi/test.scm @@ -0,0 +1,662 @@ +;;;; test.scm -- testing framework +;; +;; Easy to use test suite adapted from the Chicken "test" module. +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exception utilities + +;; from SRFI-12, pending stabilization of an exception library for WG1 +(define-syntax handle-exceptions + (syntax-rules () + ((handle-exceptions exn handler body ...) + (call-with-current-continuation + (lambda (return) + (with-exception-handler + (lambda (exn) (return handler)) + (lambda () body ...))))))) + +(define (warning msg . args) + (display msg (current-error-port)) + (for-each (lambda (x) + (write-char #\space (current-error-port)) + (write x (current-error-port))) + args) + (newline (current-error-port))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utilities + +(define (string-search pat str) + (let* ((pat-len (string-length pat)) + (limit (- (string-length str) pat-len))) + (let lp1 ((i 0)) + (cond + ((>= i limit) #f) + (else + (let lp2 ((j i) (k 0)) + (cond ((>= k pat-len) #t) + ((not (eqv? (string-ref str j) (string-ref pat k))) + (lp1 (+ i 1))) + (else (lp2 (+ j 1) (+ k 1)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; time utilities + +(define (timeval-difference tv1 tv2) + (let ((seconds (- (timeval-seconds tv1) (timeval-seconds tv2))) + (ms (- (timeval-microseconds tv1) (timeval-microseconds tv2)))) + (+ (max seconds 0.0) (/ ms 1000000.0)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; test interface + +(define-syntax test + (syntax-rules () + ((test expect expr) + (test #f expect expr)) + ((test name expect (expr ...)) + (test-info name expect (expr ...) ())) + ((test name (expect ...) expr) + (test-syntax-error + 'test + "the test expression should come last " + (test name (expect ...) expr))) + ((test name expect expr) + (test-info name expect expr ())) + ((test a ...) + (test-syntax-error 'test "2 or 3 arguments required" + (test a ...))))) + +(define-syntax test-assert + (syntax-rules () + ((_ expr) + (test-assert #f expr)) + ((_ name expr) + (test-info name #f expr ((assertion . #t)))) + ((test a ...) + (test-syntax-error 'test-assert "1 or 2 arguments required" + (test a ...))))) + +(define-syntax test-values + (syntax-rules () + ((_ expect expr) + (test-values #f expect expr)) + ((_ name expect expr) + (test name (call-with-values (lambda () expect) (lambda results results)) + (call-with-values (lambda () expr) (lambda results results)))))) + +(define-syntax test-error + (syntax-rules () + ((_ expr) + (test-error #f expr)) + ((_ name expr) + (test-info name #f expr ((expect-error . #t)))) + ((test a ...) + (test-syntax-error 'test-error "1 or 2 arguments required" + (test a ...))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; group interface + +(define-syntax test-group + (syntax-rules () + ((_ name-expr body ...) + (let ((name name-expr) + (old-group (current-test-group))) + (if (not (string? name)) + (error "a name is required, got " 'name-expr name)) + (test-begin name) + (handle-exceptions + exn + (begin + (warning "error in group outside of tests") + (print-exception e (current-error-port)) + (test-group-inc! (current-test-group) 'count) + (test-group-inc! (current-test-group) 'ERROR)) + body ...) + (test-end name) + (current-test-group old-group))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define-syntax test-syntax-error + (syntax-rules () + ((_) (syntax-error "invalid use of test-syntax-error")))) + +(define-syntax test-info + (syntax-rules () + ((test-info name expect expr info) + (test-vars () name expect expr ((source . expr) . info))))) + +(define-syntax test-vars + (syntax-rules () + ((_ (vars ...) n expect expr ((key . val) ...)) + (test-run (lambda () expect) + (lambda () expr) + (cons (cons 'name n) + '((source . expr) + ;;(var-names . (vars ...)) + ;;(var-values . ,(list vars)) + (key . val) ...)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; test-group representation + +;; (name (prop value) ...) +(define (make-test-group name) + (list name + (cons 'start-time (get-time-of-day)))) + +(define test-group-name car) + +(define (test-group-ref group field . o) + (apply assq-ref (cdr group) field o)) + +(define (test-group-set! group field value) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x value))) + (else (set-cdr! group (cons (cons field value) (cdr group)))))) + +(define (test-group-inc! group field) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x (+ 1 (cdr x))))) + (else (set-cdr! group (cons (cons field 1) (cdr group)))))) + +(define (test-group-push! group field value) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x (cons value (cdr x))))) + (else (set-cdr! group (cons (cons field (list value)) (cdr group)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (assq-ref ls key . o) + (cond ((assq key ls) => cdr) + ((pair? o) (car o)) + (else #f))) + +(define (approx-equal? a b epsilon) + (< (abs (- 1 (abs (if (zero? b) (+ 1 a) (/ a b))))) + epsilon)) + +;; partial pretty printing to abbreviate `quote' forms and the like +(define (write-to-string x) + (call-with-output-string + (lambda (out) + (let wr ((x x)) + (if (pair? x) + (cond + ((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x)) + (assq (car x) + '((quote . "'") (quasiquote . "`") + (unquote . ",") (unquote-splicing . ",@")))) + => (lambda (s) (display (cdr s) out) (wr (cadr x)))) + (else + (display "(" out) + (wr (car x)) + (let lp ((ls (cdr x))) + (cond ((pair? ls) + (display " " out) + (wr (car ls)) + (lp (cdr ls))) + ((not (null? ls)) + (display " . " out) + (write ls out)))) + (display ")" out))) + (write x out)))))) + +;; if we need to truncate, try first dropping let's to get at the +;; heart of the expression +(define (truncate-source x width . o) + (let* ((str (write-to-string x)) + (len (string-length str))) + (cond + ((<= len width) + str) + ((and (pair? x) (eq? 'let (car x))) + (if (and (pair? o) (car o)) + (truncate-source (car (reverse x)) width #t) + (string-append "..." + (truncate-source (car (reverse x)) (- width 3) #t)))) + ((and (pair? x) (eq? 'call-with-current-continuation (car x))) + (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o)))) + ((and (pair? x) (eq? 'call-with-values (car x))) + (string-append + "..." + (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (caadr x))) + (car (reverse (cadr x))) + (cadr x)) + (- width 3) + #t))) + (else + (string-append + (substring str 0 (min (max 0 (- width 3)) (string-length str))) + "..."))))) + +(define (test-get-name! info) + (or + (assq-ref info 'name) + (assq-ref info 'gen-name) + (let ((name + (cond + ((assq-ref info 'source) + => (lambda (src) + (truncate-source src (- (current-column-width) 12)))) + ((current-test-group) + => (lambda (g) + (string-append + "test-" + (number->string (test-group-ref g 'count 0))))) + (else "")))) + (if (pair? info) + (set-cdr! info (cons (cons 'gen-name name) (cdr info)))) + name))) + +(define (test-print-name info . indent) + (let ((width (- (current-column-width) + (or (and (pair? indent) (car indent)) 0))) + (name (test-get-name! info))) + (display name) + (display " ") + (let ((diff (- width 9 (string-length name)))) + (cond + ((positive? diff) + (display (make-string diff #\.))))) + (display " ") + (flush-output))) + +(define (test-group-indent-width group) + (let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0) + (test-first-indentation)))))) + (* 4 (min level (test-max-indentation))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ansi tools + +(define (display-to-string x) + (if (string? x) x (call-with-output-string (lambda (out) (display x out))))) + +(define (red x) (string-append "\x1B[31m" (display-to-string x) "\x1B[0m")) +(define (green x) (string-append "\x1B[32m" (display-to-string x) "\x1B[0m")) +(define (yellow x) (string-append "\x1B[33m" (display-to-string x) "\x1B[0m")) +;; (define (blue x) (string-append "\x1B[34m" (display-to-string x) "\x1B[0m")) +;; (define (magenta x) (string-append "\x1B[35m" (display-to-string x) "\x1B[0m")) +;; (define (cyan x) (string-append "\x1B[36m" (display-to-string x) "\x1B[0m")) +(define (bold x) (string-append "\x1B[1m" (display-to-string x) "\x1B[0m")) +(define (underline x) (string-append "\x1B[4m" (display-to-string x) "\x1B[0m")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (test-run expect expr info) + (if (and (cond ((current-test-group) + => (lambda (g) (not (test-group-ref g 'skip-group?)))) + (else #t)) + (every (lambda (f) (f info)) (current-test-filters))) + ((current-test-applier) expect expr info) + ((current-test-skipper) expect expr info))) + +(define (test-default-applier expect expr info) + (let* ((group (current-test-group)) + (indent (and group (test-group-indent-width group)))) + (cond + ((and group + (equal? 0 (test-group-ref group 'count 0)) + (zero? (test-group-ref group 'subgroups-count 0)) + (test-group-ref group 'verbosity)) + (newline) + (print-header-line + (string-append "testing " (or (test-group-name group) "")) + (or indent 0)))) + (if (and indent (positive? indent)) + (display (make-string indent #\space))) + (test-print-name info indent) + (let ((expect-val + (handle-exceptions + exn + (begin + (warning "bad expect value") + (print-exception exn (current-error-port)) + #f) + (expect)))) + (handle-exceptions + exn + (begin + ((current-test-handler) + (if (assq-ref info 'expect-error) 'PASS 'ERROR) + expect + expr + (append `((exception . ,exn)) info))) + (let ((res (expr))) + (let ((status + (if (and (not (assq-ref info 'expect-error)) + (if (assq-ref info 'assertion) + res + ((current-test-comparator) expect-val res))) + 'PASS + 'FAIL)) + (info `((result . ,res) (expected . ,expect-val) ,@info))) + ((current-test-handler) status expect expr info))))))) + +(define (test-default-skipper expect expr info) + ((current-test-handler) 'SKIP expect expr info)) + +(define (test-default-handler status expect expr info) + (define indent + (make-string + (+ 4 (cond ((current-test-group) + => (lambda (group) (or (test-group-indent-width group) 0))) + (else 0))) + #\space)) + ;; update group info + (cond ((current-test-group) + => (lambda (group) + (if (not (eq? 'SKIP status)) + (test-group-inc! group 'count)) + (test-group-inc! group status)))) + (cond + ((or (eq? status 'FAIL) (eq? status 'ERROR)) + (test-failure-count (+ 1 (test-failure-count))))) + (cond + ((not (eq? status 'SKIP)) + ;; display status + (display "[") + (if (not (eq? status 'ERROR)) (display " ")) ; pad + (display ((if (test-ansi?) + (case status + ((ERROR) (lambda (x) (underline (red x)))) + ((FAIL) red) + ((SKIP) yellow) + (else green)) + (lambda (x) x)) + status)) + (display "]") + (newline) + ;; display status explanation + (cond + ((eq? status 'ERROR) + (display indent) + (cond ((assq 'exception info) + => (lambda (e) + (print-exception (cdr e) (current-output-port)))))) + ((and (eq? status 'FAIL) (assq-ref info 'assertion)) + (display indent) + (display "assertion failed\n")) + ((and (eq? status 'FAIL) (assq-ref info 'expect-error)) + (display indent) + (display "expected an error but got ") + (write (assq-ref info 'result)) (newline)) + ((eq? status 'FAIL) + (display indent) + (display "expected ") (write (assq-ref info 'expected)) + (display " but got ") (write (assq-ref info 'result)) (newline))) + ;; display line, source and values info + (cond + ((or (not (current-test-group)) + (test-group-ref (current-test-group) 'verbosity)) + (case status + ((FAIL ERROR) + (cond + ((assq-ref info 'line-number) + => (lambda (line) + (display " in line ") + (write line) + (cond ((assq-ref info 'file-name) + => (lambda (file) (display " of file ") (write file)))) + (newline)))) + (cond + ((assq-ref info 'source) + => (lambda (s) + (cond + ((or (assq-ref info 'name) + (> (string-length (write-to-string s)) + (current-column-width))) + (display (write-to-string s)) + (newline)))))) + (cond + ((assq-ref info 'values) + => (lambda (v) + (for-each + (lambda (v) + (display " ") (display (car v)) + (display ": ") (write (cdr v)) (newline)) + v)))))))))) + status) + +(define (test-default-group-reporter group) + (define (plural word n) + (if (= n 1) word (string-append word "s"))) + (define (percent n d) + (string-append " (" (number->string (/ (round (* 1000 (/ n d))) 10)) "%)")) + (let* ((end-time (get-time-of-day)) + (start-time (test-group-ref group 'start-time)) + (duration (timeval-difference (car end-time) (car start-time))) + (count (or (test-group-ref group 'count) 0)) + (pass (or (test-group-ref group 'PASS) 0)) + (fail (or (test-group-ref group 'FAIL) 0)) + (err (or (test-group-ref group 'ERROR) 0)) + (skip (or (test-group-ref group 'SKIP) 0)) + (subgroups-count (or (test-group-ref group 'subgroups-count) 0)) + (subgroups-pass (or (test-group-ref group 'subgroups-pass) 0)) + (indent (make-string (or (test-group-indent-width group) 0) #\space))) + (cond + ((or (positive? count) (positive? subgroups-count)) + (if (not (= count (+ pass fail err))) + (warning "inconsistent count:" count pass fail err)) + (display indent) + (cond + ((positive? count) + (write count) (display (plural " test" count)))) + (if (and (positive? count) (positive? subgroups-count)) + (display " and ")) + (cond + ((positive? subgroups-count) + (write subgroups-count) + (display (plural " subgroup" subgroups-count)))) + (display " completed in ") (write duration) (display " seconds") + (cond + ((not (zero? skip)) + (display " (") (write skip) (display (plural " test" skip)) + (display " skipped)"))) + (display ".") (newline) + (cond ((positive? fail) + (display indent) + (display + ((if (test-ansi?) red (lambda (x) x)) + (string-append + (number->string fail) (plural " failure" fail) + (percent fail count) "."))) + (newline))) + (cond ((positive? err) + (display indent) + (display + ((if (test-ansi?) (lambda (x) (underline (red x))) (lambda (x) x)) + (string-append + (number->string err) (plural " error" err) + (percent err count) "."))) + (newline))) + (cond + ((positive? count) + (display indent) + (display + ((if (and (test-ansi?) (= pass count)) green (lambda (x) x)) + (string-append + (number->string pass) " out of " (number->string count) + (percent pass count) (plural " test" pass) " passed."))) + (newline))) + (cond + ((positive? subgroups-count) + (display indent) + (display + ((if (and (test-ansi?) (= subgroups-pass subgroups-count)) + green (lambda (x) x)) + (string-append + (number->string subgroups-pass) " out of " + (number->string subgroups-count) + (percent subgroups-pass subgroups-count) + (plural " subgroup" subgroups-pass) " passed."))) + (newline))) + )) + (print-header-line + (string-append "done testing " (or (test-group-name group) "")) + (or (test-group-indent-width group) 0)) + (newline) + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (test-equal? expect res) + (or (equal? expect res) + (and (number? expect) + (inexact? expect) + (approx-equal? expect res (current-test-epsilon))))) + +(define (print-header-line str . indent) + (let* ((header (string-append + (make-string (if (pair? indent) (car indent) 0) #\space) + "-- " str " ")) + (len (string-length header))) + (display (if (test-ansi?) (bold header) header)) + (display (make-string (max 0 (- (current-column-width) len)) #\-)) + (newline))) + +(define (test-begin . o) + (let* ((name (if (pair? o) (car o) "")) + (group (make-test-group name)) + (parent (current-test-group))) + (cond + ((and parent + (equal? 0 (test-group-ref parent 'count 0)) + (zero? (test-group-ref parent 'subgroups-count 0)) + (test-group-ref parent 'verbosity)) + (newline) + (print-header-line + (string-append "testing " (test-group-name parent)) + (or (test-group-indent-width parent) 0)))) + (test-group-set! group 'parent parent) + (test-group-set! group 'verbosity + (if parent + (test-group-ref parent 'verbosity) + (current-test-verbosity))) + (test-group-set! group 'level + (if parent + (+ 1 (test-group-ref parent 'level 0)) + 0)) + (test-group-set! + group + 'skip-group? + (or (and parent (test-group-ref parent 'skip-group?)) + (not (every (lambda (f) (f group)) (current-test-group-filters))))) + (current-test-group group))) + +(define (test-end . o) + (cond + ((current-test-group) + => (lambda (group) + (if (and (pair? o) (not (equal? (car o) (test-group-name group)))) + (warning "mismatched test-end:" (car o) (test-group-name group))) + (let ((parent (test-group-ref group 'parent))) + (cond + ((not (test-group-ref group 'skip-group?)) + ;; only report if there's something to say + ((current-test-group-reporter) group) + (cond + (parent + (test-group-inc! parent 'subgroups-count) + (cond + ((and (zero? (test-group-ref group 'FAIL 0)) + (zero? (test-group-ref group 'ERROR 0)) + (= (test-group-ref group 'subgroups-pass 0) + (test-group-ref group 'subgroups-count 0))) + (test-group-inc! parent 'subgroups-pass))))))) + (current-test-group parent) + group))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parameters + +(define current-test-group (make-parameter #f)) +(define current-test-verbosity + (make-parameter + (cond ((get-environment-variable "TEST_QUIET") + => (lambda (s) (equal? s "0"))) + (else #t)))) +(define current-test-epsilon (make-parameter 1e-5)) +(define current-test-comparator (make-parameter test-equal?)) +(define current-test-applier (make-parameter test-default-applier)) +(define current-test-handler (make-parameter test-default-handler)) +(define current-test-skipper (make-parameter test-default-skipper)) +(define current-test-group-reporter + (make-parameter test-default-group-reporter)) +(define test-failure-count (make-parameter 0)) + +(define test-first-indentation + (make-parameter + (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION") + => string->number) + (else #f)) + 1))) + +(define test-max-indentation + (make-parameter + (or (cond ((get-environment-variable "TEST_MAX_INDENTATION") + => string->number) + (else #f)) + 5))) + +(define (string->info-matcher str) + (lambda (info) + (cond ((test-get-name! info) + => (lambda (n) (string-search str n))) + (else #f)))) + +(define (string->group-matcher str) + (lambda (group) (string-search str (car group)))) + +(define (getenv-filter-list proc name . o) + (cond + ((get-environment-variable name) + => (lambda (s) + (handle-exceptions + exn + (begin + (warning + (string-append "invalid filter '" s + "' from environment variable: " name)) + (print-exception exn (current-error-port)) + '()) + (let ((f (proc s))) + (list (if (and (pair? o) (car o)) + (lambda (x) (not (f x))) + f)))))) + (else '()))) + +(define current-test-filters + (make-parameter + (append (getenv-filter-list string->info-matcher "TEST_FILTER") + (getenv-filter-list string->info-matcher "TEST_REMOVE" #t)))) + +(define current-test-group-filters + (make-parameter + (append (getenv-filter-list string->group-matcher "TEST_GROUP_FILTER") + (getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE" #t)))) + +(define current-column-width + (make-parameter + (or (cond ((get-environment-variable "TEST_COLUMN_WIDTH") + => string->number) + (else #f)) + 78))) + +(define test-ansi? + (make-parameter + (cond + ((get-environment-variable "TEST_USE_ANSI") + => (lambda (s) (not (equal? s "0")))) + (else + (member (get-environment-variable "TERM") + '("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm" + "linux" "screen" "screen-256color" "vt100")))))) diff --git a/lib/chibi/time.module b/lib/chibi/time.module new file mode 100644 index 00000000..8d591100 --- /dev/null +++ b/lib/chibi/time.module @@ -0,0 +1,12 @@ + +(define-module (chibi time) + (export current-seconds get-time-of-day set-time-of-day! + seconds->time seconds->string time->seconds time->string + timeval-seconds timeval-microseconds + timezone-offset timezone-dst-time + time-second time-minute time-hour time-day time-month time-year + time-day-of-week time-day-of-year time-dst? + tm? timeval? timezone?) + (import-immutable (scheme)) + (include-shared "time")) + diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub new file mode 100644 index 00000000..adde486e --- /dev/null +++ b/lib/chibi/time.stub @@ -0,0 +1,46 @@ + +(c-system-include "time.h") +(c-system-include "sys/time.h") + +(define-c-struct tm + predicate: tm? + (int tm_sec time-second) + (int tm_min time-minute) + (int tm_hour time-hour) + (int tm_mday time-day) + (int tm_mon time-month) + (int tm_year time-year) + (int tm_wday time-day-of-week) + (int tm_yday time-day-of-year) + (int tm_isdst time-dst?)) + +(define-c-struct timeval + predicate: timeval? + (time_t tv_sec timeval-seconds) + (int tv_usec timeval-microseconds)) + +(define-c-struct timezone + predicate: timezone? + (int tz_minuteswest timezone-offset) + (int tz_dsttime timezone-dst-time)) + +(define-c time_t (current-seconds "time") ((value NULL))) + +(define-c errno (get-time-of-day "gettimeofday") + ((result timeval) (result timezone))) + +(define-c errno (set-time-of-day! "settimeofday") + (timeval (maybe-null default NULL timezone))) + +(define-c non-null-pointer (seconds->time "localtime_r") + ((pointer time_t) (result tm))) + +(define-c time_t (time->seconds "mktime") + (tm)) + +(define-c non-null-string (seconds->string "ctime_r") + ((pointer time_t) (result (array char 64)))) + +(define-c non-null-string (time->string "asctime_r") + (tm (result (array char 64)))) + diff --git a/lib/chibi/type-inference.module b/lib/chibi/type-inference.module new file mode 100644 index 00000000..2f9534d2 --- /dev/null +++ b/lib/chibi/type-inference.module @@ -0,0 +1,7 @@ + +(define-module (chibi type-inference) + (export type-analyze-module type-analyze procedure-signature) + (import-immutable (scheme)) + (import (srfi 1) (srfi 69) (chibi modules) (chibi ast) (chibi match)) + (include "type-inference.scm")) + diff --git a/lib/chibi/type-inference.scm b/lib/chibi/type-inference.scm new file mode 100644 index 00000000..6b21a230 --- /dev/null +++ b/lib/chibi/type-inference.scm @@ -0,0 +1,272 @@ +;; type-inference.scm -- general type-inference for Scheme +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (typed? x) + (and (lambda? x) + (lambda-return-type x))) + +(define (union-type? a) + (and (pair? a) (equal? (car a) 'or))) + +(define (intersection-type? a) + (and (pair? a) (equal? (car a) 'and))) + +(define (unfinalized-type? a) + (and (pair? a) + (or (memq (car a) '(return-type param-type)) + (and (memq (car a) '(and or)) + (any unfinalized-type? (cdr a)))))) + +(define (finalized-type? a) + (not (unfinalized-type? a))) + +(define (numeric-type? a) + (or (eq? a ) (eq? a ) (eq? a ))) + +(define (procedure-type? a) + (or (eq? a ) + (eq? a ) + (and (pair? a) (eq? (car a) 'lambda)))) + +(define (type-subset? a b) + (or (equal? a b) + (equal? a ) + (equal? b ) + (and (numeric-type? a) (numeric-type? b)) + (and (procedure-type? a) (procedure-type? b)) + (if (union-type? a) + (if (union-type? b) + (lset<= equal? (cdr a) (cdr b)) + (member b (cdr a))) + (and (union-type? b) (member a (cdr b)))))) + +;; XXXX check for type hierarchies +(define (type-union a b) + (cond + ((equal? a b) a) + ((or (equal? a ) (equal? b )) ) + ((union-type? a) + (if (union-type? b) + (cons (car a) (lset-union equal? (cdr a) (cdr b))) + (cons (car a) (lset-adjoin equal? (cdr a) b)))) + (else (list 'or a b)))) + +;; XXXX check for conflicts +(define (type-intersection a b) + (cond + ((equal? a b) a) + ((or (equal? a ) (unfinalized-type? a)) b) + ((or (equal? b ) (unfinalized-type? b)) a) + ((intersection-type? a) + (if (intersection-type? b) + (lset-intersection equal? (cdr a) (cdr b)) + (cons (car a) (lset-adjoin equal? (cdr a) b)))) + (else (list 'and a b)))) + +(define (lambda-param-types-initialize! f) + (lambda-param-types-set! f (map (lambda (p) (list 'param-type f p)) + (lambda-params f)))) + +(define (lambda-param-type-memq f x) + (let lp ((p (lambda-params f)) + (t (lambda-param-types f))) + (and (pair? p) + (pair? t) + (if (eq? x (car p)) + t + (lp (cdr p) (cdr t)))))) + +(define (lambda-param-type-ref f x) + (cond ((lambda-param-type-memq f x) => car) + (else #f))) + +(define (lambda-param-type-set! f x y) + (if (not (pair? (lambda-param-types f))) + (lambda-param-types-initialize! f)) + (cond ((lambda-param-type-memq f x) + => (lambda (cell) (set-car! cell y))))) + +(define (type-analyze-expr x) + (match x + (($ name params body defs) + (cond + ((not (lambda-return-type x)) + (lambda-return-type-set! x (list 'return-type x)) + (lambda-param-types-initialize! x) + (let ((ret-type (type-analyze-expr body))) + (lambda-return-type-set! x ret-type) + (cons 'lambda (cons ret-type (lambda-param-types x))))))) + (($ ref value) + (type-analyze-expr value) + (if #f #f)) + (($ name (value . loc) source) + (cond + ((lambda? loc) (lambda-param-type-ref loc name)) + ((procedure? loc) + (let ((sig (procedure-signature loc))) + (if (and (pair? sig) (car sig)) + (cons 'lambda sig) + (list 'return-type (procedure-analysis loc))))) + (else ))) + (($ test pass fail) + (let ((test-type (type-analyze-expr test)) + (pass-type (type-analyze-expr pass)) + (fail-type (type-analyze-expr fail))) + (type-union pass-type fail-type))) + (($ ls) + (let lp ((ls ls)) + (cond ((null? (cdr ls)) + (type-analyze-expr (car ls))) + (else + (type-analyze-expr (car ls)) + (lp (cdr ls)))))) + ((f args ...) + (cond + ((opcode? f) + (let lp ((p (opcode-param-types f)) + (a args)) + (cond + ((pair? a) + (cond ((or (pair? p) (opcode-variadic? f)) + (let ((p-type + (if (pair? p) + (car p) + (opcode-param-type f (opcode-num-params f))))) + (match (car a) + (($ name (_ . (and g ($ )))) + (let ((t (type-intersection (lambda-param-type-ref g name) + p-type))) + (lambda-param-type-set! g name t))) + (else + (let ((t (type-analyze-expr (car a)))) + (cond + ((and t p-type + (finalized-type? t) + (finalized-type? p-type) + (not (type-subset? t p-type))) + (display "WARNING: incompatible type: " + (current-error-port)) + (write (list x t p-type) (current-error-port)) + (newline (current-error-port)))) + t)))) + (lp (and (pair? p) (cdr p)) (cdr a))) + (else + (for-each type-analyze-expr a)))))) + (opcode-return-type f)) + (else + (let ((f-type (type-analyze-expr f))) + ;; XXXX apply f-type to params + (for-each type-analyze-expr args) + (cond + ((and (pair? f-type) (eq? (car f-type) 'lambda)) + (cadr f-type)) + ((and (pair? f-type) (memq (car f-type) '(return-type param-type))) + f-type) + (else + )))))) + (else + (type-of x)))) + +(define (resolve-delayed-type x) + (let lp ((x x) (seen '()) (default )) + (match x + (('return-type f) + (if (memq f seen) + default + (lp (lambda-return-type f) (cons f seen) default))) + (('param-type f p) + (if (member x seen) + default + (lp (lambda-param-type-ref f p) (cons x seen) default))) + (('or y ...) + (let ((z (find finalized-type? y))) + (if z + (let ((default (if (eq? default ) + (lp z seen default) + (type-union (lp z seen default) default)))) + (fold type-union + default + (map (lambda (y1) (lp y1 seen default)) (delete z y)))) + (fold type-union default (map (lambda (y1) (lp y1 seen default)) y))))) + (('and y ...) + (fold type-intersection default (map (lambda (y1) (lp y1 seen default)) y))) + (('not y) + (list 'not (lp y seen default))) + (else + x)))) + +(define (type-resolve-circularities x) + (match x + (($ name params body defs) + (if (unfinalized-type? (lambda-return-type x)) + (lambda-return-type-set! x (resolve-delayed-type + (lambda-return-type x)))) + (for-each + (lambda (p t) + (if (unfinalized-type? t) + (lambda-param-type-set! x p (resolve-delayed-type t)))) + params + (lambda-param-types x)) + (type-resolve-circularities (lambda-body x))) + (($ ref value) + (type-resolve-circularities value)) + (($ test pass fail) + (type-resolve-circularities test) + (type-resolve-circularities pass) + (type-resolve-circularities fail)) + (($ ls) + (for-each type-resolve-circularities ls)) + ((app ...) + (for-each type-resolve-circularities app)) + (else #f))) + +(define (type-analyze-module-body name ls) + (for-each type-analyze-expr ls) + (for-each type-resolve-circularities ls)) + +(define (type-analyze-module name) + (let* ((mod (analyze-module name)) + (ls (and (vector? mod) (module-ast mod)))) + (and ls + (let ((x (let lp ((ls ls)) ;; first lambda + (and (pair? ls) + (if (and (set? (car ls)) + (lambda? (set-value (car ls)))) + (set-value (car ls)) + (lp (cdr ls))))))) + (if (and x (not (typed? x))) + (type-analyze-module-body name ls)) + ls)))) + +(define (type-analyze sexp . o) + (type-analyze-expr (apply analyze sexp o))) + +(define (opcode-param-types x) + (let lp ((n (- (opcode-num-params x) 1)) (res '())) + (if (< n 0) + res + (lp (- n 1) (cons (opcode-param-type x n) res))))) + +(define (opcode-type x) + (cons 'lambda (cons (opcode-return-type x) (opcode-param-types x)))) + +(define (lambda-type x) + (cons 'lambda (cons (lambda-return-type x) (lambda-param-types x)))) + +(define (procedure-signature x) + (if (opcode? x) + (cdr (opcode-type x)) + (let lp ((count 0)) + (let ((lam (procedure-analysis x))) + (cond + ((and lam (not (typed? lam)) (zero? count) + (containing-module x)) + => (lambda (mod) + (and (type-analyze-module (car mod)) + (lp (+ count 1))))) + ((lambda? lam) + (cdr (lambda-type lam))) + (else + #f)))))) diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module new file mode 100644 index 00000000..46f9e6a6 --- /dev/null +++ b/lib/chibi/uri.module @@ -0,0 +1,10 @@ + +(define-module (chibi uri) + (export uri? uri->string make-uri string->uri + uri-scheme uri-user uri-host uri-port uri-path uri-query uri-fragment + uri-with-scheme uri-with-user uri-with-host uri-with-path + uri-with-query uri-with-fragment + uri-encode uri-decode uri-query->alist uri-alist->query) + (import-immutable (scheme) + (srfi 9)) + (include "uri.scm")) diff --git a/lib/chibi/uri.scm b/lib/chibi/uri.scm new file mode 100644 index 00000000..41507961 --- /dev/null +++ b/lib/chibi/uri.scm @@ -0,0 +1,306 @@ +;; uri.scm -- URI parsing library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URI representation + +(define-record-type uri + (%make-uri scheme user host port path query fragment) + uri? + (scheme uri-scheme) + (user uri-user) + (host uri-host) + (port uri-port) + (path uri-path) + (query uri-query) + (fragment uri-fragment)) + +;; (make-uri scheme [user host port path query fragment]) +(define (make-uri scheme . o) + (let* ((user (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (host (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (port (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (path (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (query (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f))) + (%make-uri scheme user host port path query fragment))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils (don't feel like using SRFI-13 and these are more +;; specialised) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (string-scan-right str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i (- end 1))) + (and (>= i start) + (if (eqv? ch (string-ref str i)) + i + (lp (- i 1))))))) + +(define (string-index-of str pred . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond ((>= i end) #f) + ((pred (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase->symbol str) + (let ((len (string-length str))) + (let lp ((i 0)) + (cond + ((= i len) + (string->symbol str)) + ((char-upper-case? (string-ref str i)) + (let ((res (make-string len))) + (do ((j 0 (+ j 1))) + ((= j i)) + (string-set! res j (string-ref str j))) + (string-set! res i (char-downcase (string-ref str i))) + (do ((j (+ i 1) (+ j 1))) + ((= j len)) + (string-set! res j (char-downcase (string-ref str j)))) + (string->symbol res))) + (else + (lp (+ i 1))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; functional updaters (uses as much shared state as possible) + +(define (uri-with-scheme u scheme) + (%make-uri scheme (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-user u user) + (%make-uri (uri-scheme u) user (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-host u host) + (%make-uri (uri-scheme u) (uri-user u) host (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-port u port) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) port + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-path u path) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + path (uri-query u) (uri-fragment u))) + +(define (uri-with-query u query) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) query (uri-fragment u))) + +(define (uri-with-fragment u fragment) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) fragment)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parsing - without :// we just split into scheme & path + +(define (char-uri-scheme-unsafe? ch) + (not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\_ #\-))))) + +(define (string->path-uri scheme str . o) + (define decode? (and (pair? o) (car o))) + (define decode (if decode? uri-decode (lambda (x) x))) + (define decode-query + (if (and (pair? o) (pair? (cdr o)) (cadr o)) + uri-query->alist + decode)) + (if (pair? str) + str + (let* ((len (string-length str)) + (colon0 (string-scan str #\:)) + (colon + (and (not (string-index-of str char-uri-scheme-unsafe? + 0 (or colon0 len))) + colon0))) + (if (or (not colon) (zero? colon)) + (and scheme + (let* ((quest (string-scan str #\? 0)) + (pound (string-scan str #\# (or quest 0)))) + (make-uri scheme #f #f #f + (decode (substring str 0 (or quest pound len))) + (and quest + (decode-query + (substring str (+ quest 1) (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len)))))) + (let ((sc1 (+ colon 1)) + (scheme (string-downcase->symbol (substring str 0 colon)))) + (if (= sc1 len) + (make-uri scheme) + (if (or (>= (+ sc1 1) len) + (not (and (eqv? #\/ (string-ref str sc1)) + (eqv? #\/ (string-ref str (+ sc1 1)))))) + (make-uri scheme #f #f #f (substring str sc1 len)) + (if (>= (+ sc1 2) len) + (make-uri scheme #f "") + (let* ((sc2 (+ sc1 2)) + (slash (string-scan str #\/ sc2)) + (sc3 (or slash len)) + (at (string-scan-right str #\@ sc2 sc3)) + (colon3 (string-scan str #\: (or at sc2) sc3)) + (quest (string-scan str #\? sc3)) + (pound (string-scan str #\# (or quest sc3)))) + (%make-uri + scheme + (and at (decode (substring str sc2 at))) + (decode + (substring str + (if at (+ at 1) sc2) + (or colon3 sc3))) + (and colon3 + (string->number + (substring str (+ colon3 1) sc3))) + (and slash + (decode + (substring str slash (or quest pound len)))) + (and quest + (decode-query + (substring str (+ quest 1) + (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len))) + )))))))))) + +(define (string->uri str . o) + (apply string->path-uri #f str o)) + +(define (uri->string uri . o) + (define encode? (and (pair? o) (car o))) + (define encode (if encode? uri-encode (lambda (x) x))) + (if (string? uri) + uri + (let ((fragment (uri-fragment uri)) + (query (uri-query uri)) + (path (uri-path uri)) + (port (uri-port uri)) + (host (uri-host uri)) + (user (uri-user uri))) + (string-append + (symbol->string (uri-scheme uri)) ":" + (if (or user host port) "//" "") + (if user (encode user) "") (if user "@" "") + (or host "") ; host shouldn't need encoding + (if port ":" "") (if port (number->string port) "") + (if path (encode path) "") + (if query "?" "") + (if (pair? query) (uri-alist->query query) (or query "")) + (if fragment "#" "") (if fragment (encode fragment) ""))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; query encoding and decoding + +(define (uri-safe-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (case ch + ((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t) + (else #f)))) + +(define (collect str from to res) + (if (>= from to) + res + (cons (substring str from to) res))) + +(define (uri-encode str . o) + (define (encode-1-space ch) + (if (eqv? ch #\space) + "+" + (encode-1-normal ch))) + (define (encode-1-normal ch) + (let* ((i (char->integer ch)) + (hex (number->string i 16))) + (if (< i 16) + (string-append "%0" hex) + (string-append "%" hex)))) + (let ((start 0) + (end (string-length str)) + (encode-1 (if (and (pair? o) (car o)) + encode-1-space + encode-1-normal))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (if (uri-safe-char? ch) + (lp from next res) + (lp next next (cons (encode-1 ch) + (collect str from to res))))))))) + +(define (uri-decode str . o) + (let ((space-as-plus? (and (pair? o) (car o))) + (start 0) + (end (string-length str))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (cond + ((eqv? ch #\%) + (if (>= next end) + (lp next next (collect str from to res)) + (let ((next2 (+ next 1))) + (if (>= next2 end) + (lp next2 next2 (collect str from to res)) + (let* ((next3 (+ next2 1)) + (hex (substring str next next3)) + (i (string->number hex 16))) + (lp next3 next3 (cons (string (integer->char i)) + (collect str from to res)))))))) + ((and space-as-plus? (eqv? ch #\+)) + (lp next next (cons " " (collect str from to res)))) + (else + (lp from next res)))))))) + +(define (uri-query->alist str . o) + (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;))) + (let ((len (string-length str)) + (plus? (and (pair? o) (car o)))) + (let lp ((i 0) (res '())) + (if (>= i len) + (reverse res) + (let* ((j (or (string-index-of str split-char? i) len)) + (k (string-scan str #\= i j)) + (cell (if k + (cons (uri-decode (substring str i k) plus?) + (uri-decode (substring str (+ k 1) j) plus?)) + (cons (uri-decode (substring str i j) plus?) #f)))) + (lp (+ j 1) (cons cell res))))))) + +(define (uri-alist->query ls . o) + (define plus? (and (pair? o) (car o))) + (define (encode key val res) + (let ((res (cons (uri-encode key plus?) res))) + (if val (cons (uri-encode val plus?) (cons "=" res)) res))) + (if (null? ls) + "" + (let lp ((x (car ls)) (ls (cdr ls)) (res '())) + (let ((res (encode (car x) (cdr x) res))) + (if (null? ls) + (string-concatenate (reverse res)) + (lp (car ls) (cdr ls) (cons "&" res))))))) diff --git a/lib/config.scm b/lib/config.scm new file mode 100644 index 00000000..55a4e1e0 --- /dev/null +++ b/lib/config.scm @@ -0,0 +1,179 @@ +;; config.scm -- configuration module +;; Copyright (c) 2009-2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *this-module* '()) + +(define (make-module exports env meta) (vector exports env meta #f)) +(define (%module-exports mod) (vector-ref mod 0)) +(define (module-env mod) (vector-ref mod 1)) +(define (module-meta-data mod) (vector-ref mod 2)) +(define (module-env-set! mod env) (vector-set! mod 1 env)) + +(define (module-exports mod) + (or (%module-exports mod) (env-exports (module-env mod)))) + +(define (module-name->strings ls res) + (if (null? ls) + res + (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls))) + ((number? (car ls)) (number->string (car ls))) + ((string? (car ls)) (car ls)) + (else (error "invalid module name" (car ls)))))) + (module-name->strings (cdr ls) (cons "/" (cons str res)))))) + +(define (module-name->file name) + (string-concatenate + (reverse (cons ".module" (cdr (module-name->strings name '())))))) + +(define (module-name-prefix name) + (string-concatenate (reverse (cdr (cdr (module-name->strings name '())))))) + +(define (load-module-definition name) + (let* ((file (module-name->file name)) + (path (find-module-file file))) + (if path (load path *config-env*)))) + +(define (find-module name) + (cond + ((assoc name *modules*) => cdr) + (else + (load-module-definition name) + (cond ((assoc name *modules*) => cdr) + (else #f))))) + +(define (symbol-append a b) + (string->symbol (string-append (symbol->string a) (symbol->string b)))) + +(define (to-id id) (if (pair? id) (car id) id)) +(define (from-id id) (if (pair? id) (cdr id) id)) +(define (id-filter pred ls) + (cond ((null? ls) '()) + ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls)))) + (else (id-filter pred (cdr ls))))) + +(define (resolve-import x) + (cond + ((not (and (pair? x) (list? x))) + (error "invalid module syntax" x)) + ((and (pair? (cdr x)) (pair? (cadr x))) + (if (memq (car x) '(only except rename)) + (let* ((mod-name+imports (resolve-import (cadr x))) + (imp-ids (cdr mod-name+imports)) + (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x)))) + (begin + (set-cdr! mod-name+imports + (module-exports + (find-module (car mod-name+imports)))) + (cdr mod-name+imports)) + imp-ids))) + (cons (car mod-name+imports) + (case (car x) + ((only) + (if (not imp-ids) + (cddr x) + (id-filter (lambda (i) (memq i (cddr x))) imp-ids))) + ((except) + (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids)) + ((rename) + (map (lambda (i) + (let ((rename (assq (to-id i) (cddr x)))) + (if rename (cons (cdr rename) (from-id i)) i))) + imp-ids))))) + (error "invalid import modifier" x))) + ((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x))) + (let ((mod-name+imports (resolve-import (caddr x)))) + (cons (car mod-name+imports) + (map (lambda (i) + (cons (symbol-append (cadr x) (if (pair? i) (car i) i)) + (if (pair? i) (cdr i) i))) + (cdr mod-name+imports))))) + ((find-module x) + => (lambda (mod) (cons x (%module-exports mod)))) + (else + (error "couldn't find import" x)))) + +(define (eval-module name mod) + (let ((env (make-environment)) + (dir (module-name-prefix name))) + (define (load-modules files extension) + (for-each + (lambda (f) + (let ((f (string-append dir f extension))) + (cond ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + files)) + (for-each + (lambda (x) + (case (and (pair? x) (car x)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2 (load-module (car mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports) + (eq? (car x) 'import-immutable)))) + (cdr x))) + ((include) + (load-modules (cdr x) "")) + ((include-shared) + (cond-expand + (dynamic-loading (load-modules (cdr x) *shared-object-extension*)) + (else #f))) + ((body) + (for-each (lambda (expr) (eval expr env)) (cdr x))))) + (module-meta-data mod)) + env)) + +(define (load-module name) + (let ((mod (find-module name))) + (if (and mod (not (module-env mod))) + (module-env-set! mod (eval-module name mod))) + mod)) + +(define-syntax define-module + (er-macro-transformer + (lambda (expr rename compare) + (let ((name (cadr expr)) + (body (cddr expr))) + `(let ((tmp *this-module*)) + (set! *this-module* '()) + ,@body + (set! *this-module* (reverse *this-module*)) + (let ((exports + (cond ((assq 'export *this-module*) => cdr) + (else '())))) + (set! *modules* + (cons (cons ',name (make-module exports #f *this-module*)) + *modules*))) + (set! *this-module* tmp)))))) + +(define-syntax define-config-primitive + (er-macro-transformer + (lambda (expr rename compare) + `(define-syntax ,(cadr expr) + (er-macro-transformer + (lambda (expr rename compare) + `(set! *this-module* (cons ',expr *this-module*)))))))) + +(define-config-primitive import) +(define-config-primitive import-immutable) +(define-config-primitive export) +(define-config-primitive include) +(define-config-primitive include-shared) +(define-config-primitive body) + +(define *modules* + (list (cons '(scheme) (make-module #f (interaction-environment) + '((include "init.scm")))) + (cons '(config) (make-module #f (current-environment) '())) + (cons '(srfi 0) (make-module (list 'cond-expand) + (interaction-environment) + (list (list 'export 'cond-expand)))) + (cons '(srfi 46) (make-module (list 'syntax-rules) + (interaction-environment) + (list (list 'export 'syntax-rules)))))) + diff --git a/lib/init.scm b/lib/init.scm new file mode 100644 index 00000000..62d044ec --- /dev/null +++ b/lib/init.scm @@ -0,0 +1,875 @@ +;; init.scm -- R5RS library procedures +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; 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 (pair? (car lol)) + (mapn proc + (map1 cdr lol '()) + (cons (apply1 proc (map1 car lol '())) res)) + (reverse res))) + (if (null? lol) + (map1 proc ls '()) + (mapn proc (cons ls lol) '()))) + +(define (for-each f ls . lol) + (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls))))) + (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f)))) + +(define (any pred ls) + (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f)) + +(define (every pred ls) + (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t)) + +(define (delq x ls) + (if (pair? ls) + (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls)))) + '())) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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) + (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 (rename 'else) (car cl)) + (if (pair? (cddr expr)) + (error "non-final else in cond" expr) + (cons (rename 'begin) (cdr cl))) + (if (if (null? (cdr cl)) #t (compare (rename '=>) (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 + ((compare (rename 'unquote) (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((compare (rename '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))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (compare (rename '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 (null? (cdr expr)) (error "empty let" expr)) + (if (null? (cddr expr)) (error "no let body" expr)) + ((lambda (bindings) + (if (list? bindings) #f (error "bad let bindings")) + (if (every (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + bindings) + ((lambda (vars vals) + (if (identifier? (cadr expr)) + `((,(rename 'lambda) ,vars + (,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,vars + ,@(cdddr expr)))) + (,(cadr expr) ,@vars))) + ,@vals) + `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals))) + (map car bindings) + (map cadr bindings)) + (error "bad let syntax" expr))) + (if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let*" expr)) + (if (null? (cddr expr)) (error "no let* body" expr)) + (if (null? (cadr expr)) + `(,(rename 'let) () ,@(cddr expr)) + (if (if (list? (cadr expr)) + (every + (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + (cadr expr)) + #f) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))) + (error "bad let* syntax")))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare (rename '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)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; promises + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exceptions + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f))) + +(define (with-exception-handler handler thunk) + (letrec ((orig-handler (current-exception-handler)) + (self (lambda (exn) + (current-exception-handler orig-handler) + (let ((res (handler exn))) + (current-exception-handler self) + res)))) + (current-exception-handler self) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; library functions + +;; 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 . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (and (pair? ls) (if (eq obj (car ls)) ls (lp (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 (if (bignum? x) #t (flonum? x)))) +(define complex? number?) +(define rational? number?) +(define real? number?) +(define (exact? x) (if (fixnum? x) #t (bignum? x))) +(define inexact? flonum?) +(define (integer? x) + (if (fixnum? x) #t (if (bignum? 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 (numerator x) + (if (integer? x) x (numerator (* x 10)))) +(define (denominator x) + (if (exact? x) + 1 + (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10)))))) + +(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) + (if (<= n 9) + (integer->char (+ n (char->integer #\0))) + (integer->char (+ (- n 10) (char->integer #\A))))) +(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)) 55)))) + +(define (number->string num . o) + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-output-string (lambda (out) (write num out))) + (let lp ((n (abs num)) (d (car o)) (res '())) + (if (> n 0) + (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) + (if (null? res) + "0" + (list->string (if (negative? num) (cons #\- 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 (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-output-port)) + (tmp-out (open-output-file file))) + (current-output-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)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dynamic-wind + +(define *dk* (list #f)) + +(define (dynamic-wind before thunk after) + (let ((dk *dk*)) + (set-dk! (cons (cons before after) dk)) + (let ((res (thunk))) (set-dk! dk) res))) + +(define (set-dk! dk) + (if (not (eq? dk *dk*)) + (begin + (set-dk! (cdr dk)) + (let ((before (car (car dk))) (dk dk)) + (set-car! *dk* (cons (cdr (car dk)) before)) + (set-cdr! *dk* dk) + (set-car! dk #f) + (set-cdr! dk '()) + (set! *dk* dk) + (before))))) + +(define (call-with-current-continuation proc) + (let ((dk *dk*)) + (%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((ellipse-specified? (identifier? (cadr 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 'syntax-quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_len (rename'len)) (_length (rename 'length)) + (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error)) + (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define ellipse (rename (if ellipse-specified? (cadr expr) '...))) + (define lits (if ellipse-specified? (caddr expr) (cadr expr))) + (define forms (if ellipse-specified? (cdddr expr) (cddr expr))) + (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))) + (cond + ((not (list? (cddr p))) + (error "dotted ellipse" p)) + ((any (lambda (x) (and (identifier? x) (compare x ellipse))) + (cddr p)) + (error "multiple ellipses" p)) + (else + (let ((len (length (cdr (cdr p))))) + `(,_let ((,_len (,_length ,v))) + (,_and (,_>= ,_len ,len) + (,_let ,_lp ((,_ls ,v) + (,_i (,_- ,_len ,len)) + (,_res (,_quote ()))) + (,_if (,_>= 0 ,_i) + ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p))) + `(,_append ,_ls (,_reverse ,_res)) + dim + vars + k) + (,_lp (,_cdr ,_ls) + (,_- ,_i 1) + (,_cons (,_car ,_ls) ,_res)))))))))) + ((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-escape? x) (and (pair? x) (compare ellipse (car x)))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare ellipse (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 (any (lambda (lit) (compare x lit)) 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 + ((any (lambda (v) (compare t (car v))) vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (cond + ((ellipse-escape? t) + (if (pair? (cdr t)) + (if (pair? (cddr t)) (cddr t) (cadr t)) + (cdr t))) + ((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))))))) + (else (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 for" + (list (rename 'strip-syntactic-closures) _expr))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *config-env* #f) + +(define-syntax import + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (res '())) + (cond + ((null? ls) + (cons 'begin (reverse res))) + (else + (let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*))) + (if (pair? mod+imps) + (lp (cdr ls) + (cons `(%env-copy! + #f + (vector-ref + (eval '(load-module ',(car mod+imps)) *config-env*) + 1) + ',(cdr mod+imps) + #f) + res)) + (error "couldn't find module" (car ls)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SRFI-0 + +(define-syntax cond-expand + (er-macro-transformer + (lambda (expr rename compare) + (define (check x) + (if (pair? x) + (case (car x) + ((and) (every check (cdr x))) + ((or) (any check (cdr x))) + ((not) (not (check (cadr x)))) + (else (error "cond-expand: bad feature" x))) + (memq (identifier->symbol x) *features*))) + (let expand ((ls (cdr expr))) + (cond ((null? ls) (error "cond-expand: no expansions" expr)) + ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) + ((eq? 'else (identifier->symbol (caar ls))) + (if (pair? (cdr ls)) + (error "cond-expand: else in non-final position") + `(,(rename 'begin) ,@(cdar ls)))) + ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) + (else (expand (cdr ls)))))))) + diff --git a/lib/srfi/1.module b/lib/srfi/1.module new file mode 100644 index 00000000..3d3da044 --- /dev/null +++ b/lib/srfi/1.module @@ -0,0 +1,31 @@ + +(define-module (srfi 1) + (export + xcons cons* make-list list-tabulate list-copy circular-list iota + proper-list? circular-list? dotted-list? not-pair? null-list? list= + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr take drop take-right drop-right take! drop-right! split-at split-at! + last last-pair length+ concatenate append! concatenate! reverse! + append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 count + fold unfold pair-fold reduce fold-right unfold-right + pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter partition remove filter! partition! remove! find find-tail any every + list-index take-while drop-while take-while! span break span! break! + delete delete-duplicates delete! delete-duplicates! + alist-cons alist-copy alist-delete alist-delete! + lset<= lset= lset-adjoin lset-union lset-union! lset-intersection + lset-intersection! lset-difference lset-difference! lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection!) + (import (scheme)) + (include "1/predicates.scm" + "1/selectors.scm" + "1/search.scm" + "1/misc.scm" + "1/constructors.scm" + "1/fold.scm" + "1/deletion.scm" + "1/alists.scm" + "1/lset.scm")) + diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm new file mode 100644 index 00000000..a35db42c --- /dev/null +++ b/lib/srfi/1/alists.scm @@ -0,0 +1,14 @@ +;; alist.scm -- association list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (alist-cons key value ls) (cons (cons key value) ls)) + +(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls)) + +(define (alist-delete key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (remove (lambda (x) (eq (car x) key)) ls))) + +(define alist-delete! alist-delete) + diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm new file mode 100644 index 00000000..1f8a8d5e --- /dev/null +++ b/lib/srfi/1/constructors.scm @@ -0,0 +1,36 @@ +;; constructors.scm -- list construction utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (xcons a b) (cons b a)) + +(define (cons* x . args) + (let lp ((rev '()) (x x) (ls args)) + (if (null? ls) + (append-reverse rev x) + (lp (cons x rev) (car ls) (cdr ls))))) + +(define (make-list n . o) + (let ((default (if (pair? o) (car o)))) + (let lp ((n n) (res '())) + (if (<= n 0) res (lp (- n 1) (cons default res)))))) + +(define (list-tabulate n proc) + (let lp ((n n) (res '())) + (if (< n 0) res (lp (- n 1) (cons (proc n) res))))) + +(define (list-copy ls) (reverse! (reverse ls))) + +(define (circular-list x . args) + (let ((res (cons x args))) + (set-cdr! (last-pair res) res) + res)) + +(define (iota count . o) + (let ((start (if (pair? o) (car o) 0)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) + (let lp ((i count) (n (+ start (* (- count 1) step))) (res '())) + (if (<= i 0) + res + (lp (- i 1) (- n step) (cons n res)))))) + diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm new file mode 100644 index 00000000..2d44275a --- /dev/null +++ b/lib/srfi/1/deletion.scm @@ -0,0 +1,25 @@ +;; deletion.scm -- list deletion utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (delete x ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (if (eq? eq eq?) + (let lp ((ls ls) (rev '())) ;; fast path for delq + (let ((tail (memq x ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls)))) + (remove (lambda (y) (eq x y)) ls)))) + +(define delete! delete) + +(define (delete-duplicates ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res))) + (reverse! res))))) + +(define delete-duplicates! delete-duplicates) + diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm new file mode 100644 index 00000000..892b075c --- /dev/null +++ b/lib/srfi/1/fold.scm @@ -0,0 +1,115 @@ +;; fold.scm -- list fold/reduce utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (map-onto car lists (list acc)))) + acc)))) + +(define (fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (map-onto car lists (lp (map cdr lists)))) + knil)))) + +(define (pair-fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (append lists (list acc)))) + acc)))) + +(define (pair-fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (append lists (lp (map cdr lists)))) + knil)))) + +(define (reduce f identity ls) + (if (null? ls) identity (fold f (car ls) (cdr ls)))) + +(define (reduce-right f identity ls) + (if (null? ls) identity (fold-right f (car ls) (cdr ls)))) + +(define (unfold p f g seed . o) + (let lp ((seed seed)) + (if (p seed) + (if (pair? o) ((car o) seed) '()) + (cons (f seed) (lp (g seed)))))) + +(define (unfold-right p f g seed . o) + (let lp ((seed seed) (res (if (pair? o) (car o) '()))) + (if (p seed) res (lp (g seed) (cons (f seed) res))))) + +(define (append-map-helper append f ls lists) + (if (null? lists) + (if (null? ls) + '() + (let ((rev-ls (reverse ls))) + (let lp ((ls (cdr rev-ls)) (res (car rev-ls))) + (if (null? ls) res (lp (cdr ls) (append (f (car ls) res)))) + ))) + (if (and (pair? ls) (every pair? lists)) + (let lp ((lists (cons ls lists))) + (let ((vals (apply f (map car lists))) + (cdrs (map cdr lists))) + (if (every pair? cdrs) (append vals (lp cdrs)) vals))) + '()))) + +(define (append-map f ls . lists) + (append-map-helper append f ls lists)) + +(define (append-map! f ls . lists) + (append-map-helper append! f ls lists)) + +(define map! map) +(define map-in-order map) + +(define (pair-for-each f ls . lists) + (apply pair-fold (lambda (x _) (f x)) ls lists)) + +(define (filter-map f ls . lists) + (if (null? lists) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res))) + (reverse! res))) + (filter (lambda (x) x) (apply map f ls lists)))) + +(define (take-up-to-reverse from to init) + (if (eq? from to) + init + (take-up-to-reverse (cdr from) to (cons (car from) init)))) + +(define (remove pred ls) + (let lp ((ls ls) (rev '())) + (let ((tail (find-tail pred ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls))))) + +(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls)) + +(define (partition pred ls) + (let lp ((ls ls) (good '()) (bad '())) + (cond ((null? ls) (values (reverse! good) (reverse! bad))) + ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad)) + (else (lp (cdr ls) good (cons (car ls) bad)))))) + +(define filter! filter) +(define remove! remove) +(define partition! partition) + diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm new file mode 100644 index 00000000..8565fac3 --- /dev/null +++ b/lib/srfi/1/lset.scm @@ -0,0 +1,51 @@ +;; lset.scm -- list set library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (lset<= eq . sets) + (if (null? sets) + #t + (let lp1 ((set1 (car sets)) (sets (cdr sets))) + (if (null? sets) + #t + (let ((set2 (car sets))) + (let lp2 ((ls set1)) + (if (pair? ls) + (and (member (car set1) set2 eq) (lp2 (cdr ls))) + (lp1 set2 (cdr sets))))))))) + +(define (lset= eq . sets) + (and (apply lset<= eq sets) (apply lset<= eq (reverse sets)))) + +(define (lset-adjoin eq set . elts) + (lset-union2 eq elts set)) + +(define (lset-union2 eq a b) + (if (null? b) + a + (lset-union2 eq (if (member (car b) a eq) a (cons (car b) a)) (cdr b)))) + +(define (lset-union eq . sets) + (reduce (lambda (a b) (lset-union2 eq a b)) '() sets)) + +(define (lset-intersection eq . sets) + (reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-difference eq . sets) + (reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-xor eq . sets) + (reduce (lambda (a b) + (append (filter (lambda (x) (member x b eq)) a) + (filter (lambda (x) (member x a eq)) b))) + '() + sets)) + +(define (lset-diff+intersection eq . sets) + (values (apply lset-difference eq sets) (apply lset-intersection eq sets))) + +(define lset-diff+intersection! lset-diff+intersection) +(define lset-xor! lset-xor) +(define lset-difference! lset-difference) +(define lset-intersection! lset-intersection) +(define lset-union! lset-union) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm new file mode 100644 index 00000000..1e7568df --- /dev/null +++ b/lib/srfi/1/misc.scm @@ -0,0 +1,54 @@ +;; misc.scm -- miscellaneous list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (map-onto proc ls init) + (let lp ((ls ls) (res init)) + (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res))))) + +(define (append! . lists) (concatenate! lists)) + +(define (concatenate lists) + (let lp ((ls (reverse lists)) (res '())) + (if (null? ls) res (lp (cdr ls) (append (car ls) res))))) + +(define (concatenate! lists) + (if (null? lists) + '() + (let lp ((ls lists)) + (cond ((not (pair? (cdr ls))) + lists) + (else + (set-cdr! (last-pair (car ls)) (cadr ls)) + (lp (cdr ls))))))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define (append-reverse! rev tail) + (if (null? rev) + tail + (let ((head (reverse! rev))) + (set-cdr! rev tail) + head))) + +(define (zip . lists) (apply map list lists)) + +(define (unzip1 ls) (map car ls)) +(define (unzip2 ls) (values (map car ls) (map cadr ls))) +(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls))) +(define (unzip4 ls) + (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) +(define (unzip5 ls) + (values (map car ls) (map cadr ls) (map caddr ls) + (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls))) + +(define (count pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (res 0)) + (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res)) + (let lp ((lists (cons ls lists)) (res 0)) + (if (every pair? lists) + (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res)) + res)))) + diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm new file mode 100644 index 00000000..be84e085 --- /dev/null +++ b/lib/srfi/1/predicates.scm @@ -0,0 +1,42 @@ +;; predicates.scm -- list prediates +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (proper-list? x) + (cond ((null? x) #t) + ((pair? x) (proper-list? (cdr x))) + (else #f))) + +(define (circular-list? x) + (and (pair? x) (pair? (cdr x)) + (let race ((hare (cdr x)) (tortoise x)) + (or (eq? hare tortoise) + (and (pair? hare) (pair? (cdr hare)) + (race (cddr hare) (cdr tortoise))))))) + +(define (dotted-list? x) + (not (proper-list? x))) + +(define (not-pair? x) (not (pair? x))) + +(define (null-list? x) (null? x)) ; no error + +(define (list= eq . lists) + (let lp1 ((lists lists)) + (or (null? lists) + (null? (cdr lists)) + (let lp2 ((ls1 (car lists)) (ls2 (cadr lists))) + (if (null? ls1) + (and (null? ls2) + (lp1 (cdr lists))) + (and (eq (car ls1) (car ls2)) + (lp2 (cdr ls1) (cdr ls2)))))))) + +(define (length+ x) + (if (not (pair? x)) + 0 + (let lp ((hare (cdr x)) (tortoise x) (res 0)) + (and (not (eq? hare tortoise)) + (if (pair? hare) + (lp (cddr hare) (cdr tortoise) (+ res 1)) + res))))) diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm new file mode 100644 index 00000000..ea31d931 --- /dev/null +++ b/lib/srfi/1/search.scm @@ -0,0 +1,54 @@ +;; search.scm -- list searching and splitting +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (find pred ls) + (cond ((find-tail pred ls) => car) (else #f))) + +(define (find-tail pred ls) + (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls))))) + +(define (take-while pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (reverse! res)))) + +(define take-while! take-while) + +(define (drop-while pred ls) + (or (find-tail (lambda (x) (not (pred x))) ls) '())) + +(define (span pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (values (reverse! res) ls)))) + +(define span! span) + +(define (break pred ls) (span (lambda (x) (not (pred x))) ls)) + +(define break! break) + +(define (any pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls))))) + (let lp ((lists (cons ls lists))) + (and (every pair? lists) + (let ((args (map car lists))) + (if (apply pred args) args (lp (map cdr lists)))))))) + +(define (every pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t)) + (not (apply any (lambda (x) (not (pred x))) ls lists)))) + +(define (list-index pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (n 0)) + (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1))))) + (let lp ((lists (cons ls lists)) (n 0)) + (and (every pair? lists) + (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1))) + )))) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm new file mode 100644 index 00000000..74ef7119 --- /dev/null +++ b/lib/srfi/1/selectors.scm @@ -0,0 +1,59 @@ +;; selectors.scm -- extended list selectors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth ls) (car (cdr (cdr (cdr (cdr ls)))))) +(define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls))))))) +(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (eighth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (ninth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))) +(define (tenth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))) + +(define (car+cdr x) (values (car x) (cdr x))) + +(define (take ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (reverse! res) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (take! ls i) + (if (<= i 0) + '() + (let ((tail (list-tail ls (- i 1)))) + (set-cdr! tail '()) + ls))) + +(define (drop ls i) + (if (<= i 0) ls (drop (cdr ls) (- i 1)))) + +(define (take-right ls i) + (drop ls (- (length+ ls) i))) + +(define (drop-right ls i) + (take ls (- (length+ ls) i))) + +(define (drop-right! ls i) + (take! ls (- (length+ ls) i))) + +(define (split-at ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (values (reverse! res) ls) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (split-at! ls i) + (if (<= i 0) + (values '() ls) + (let* ((tail (list-tail ls (- i 1))) + (right (cdr tail))) + (set-cdr! tail '()) + (values ls right)))) + +(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls)))) +(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls)))) + diff --git a/lib/srfi/11.module b/lib/srfi/11.module new file mode 100644 index 00000000..f3c91df8 --- /dev/null +++ b/lib/srfi/11.module @@ -0,0 +1,28 @@ + +(define-module (srfi 11) + (export let-values let*-values) + (import-immutable (scheme)) + (body + (define-syntax let*-values + (syntax-rules () + ((let*-values () . body) + (begin . body)) + ((let*-values (((a) expr) . rest) . body) + (let ((a expr)) (let*-values rest . body))) + ((let*-values ((params expr) . rest) . body) + (call-with-values (lambda () expr) + (lambda params (let*-values rest . body)))))) + (define-syntax let-values + (syntax-rules () + ((let-values ("step") (binds ...) bind expr maps () () . body) + (let*-values (binds ... (bind expr)) (let maps . body))) + ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body) + (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body) + (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body) + (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body)) + ((let-values ((params expr) . rest) . body) + (let-values ("step") () () expr () params rest . body)) + )))) + diff --git a/lib/srfi/16.module b/lib/srfi/16.module new file mode 100644 index 00000000..f931a376 --- /dev/null +++ b/lib/srfi/16.module @@ -0,0 +1,24 @@ + +(define-module (srfi 16) + (export case-lambda) + (import-immutable (scheme)) + (body + (define-syntax %case + (syntax-rules () + ((%case args len n p ((params ...) . body) . rest) + (if (= len (length '(params ...))) + (apply (lambda (params ...) . body) args) + (%case args len 0 () . rest))) + ((%case args len n (p ...) ((x . y) . body) . rest) + (%case args len (+ n 1) (p ... x) (y . body) . rest)) + ((%case args len n (p ...) (y . body) . rest) + (if (>= len n) + (apply (lambda (p ... y) . body) args) + (%case args len 0 () . rest))) + ((%case args len n p) + (error "case-lambda: no cases matched")))) + (define-syntax case-lambda + (syntax-rules () + ((case-lambda . clauses) + (lambda args (let ((len (length args))) (%case args len 0 () . clauses)))))))) + diff --git a/lib/srfi/18.module b/lib/srfi/18.module new file mode 100644 index 00000000..3ed564f8 --- /dev/null +++ b/lib/srfi/18.module @@ -0,0 +1,24 @@ + +(define-module (srfi 18) + (export + current-thread thread? make-thread thread-name + thread-specific thread-specific-set! thread-start! + thread-yield! thread-sleep! thread-terminate! + thread-join! mutex? make-mutex mutex-name + mutex-specific mutex-specific-set! mutex-state + mutex-lock! mutex-unlock! condition-variable? + make-condition-variable condition-variable-name + condition-variable-specific condition-variable-specific-set! + condition-variable-signal! condition-variable-broadcast! + current-time time? time->seconds seconds->time + current-exception-handler with-exception-handler raise + join-timeout-exception? abandoned-mutex-exception? + terminated-thread-exception? uncaught-exception? + uncaught-exception-reason) + (import-immutable (scheme) + (srfi 9) + (chibi ast) + (chibi time)) + (include-shared "18/threads") + (include "18/types.scm" "18/interface.scm")) + diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm new file mode 100644 index 00000000..f814aa6a --- /dev/null +++ b/lib/srfi/18/interface.scm @@ -0,0 +1,63 @@ + +(define (thread-join! thread . o) + (let ((timeout (if (pair? o) (car o) #f))) + (cond + ((%thread-join! thread timeout)) + (else + (thread-yield!) + (if (thread-timeout?) + (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (error "timed out waiting for thread" thread)) + #t))))) + +(define (thread-terminate! thread) + (if (%thread-terminate! thread) ;; need to yield if terminating ourself + (thread-yield!))) + +(define (thread-sleep! timeout) + (%thread-sleep! timeout) + (thread-yield!)) + +(define (mutex-lock! mutex . o) + (let ((timeout (and (pair? o) (car o))) + (thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t))) + (cond ((%mutex-lock! mutex timeout thread)) + (else + (thread-yield!) + (not (thread-timeout?)))))) + +(define (mutex-unlock! mutex . o) + (let ((condvar (and (pair? o) (car o))) + (timeout (if (and (pair? o) (pair? (cdr o))) (cadr o) #f))) + (cond ((%mutex-unlock! mutex condvar timeout)) + (else + (thread-yield!) + (not (thread-timeout?)))))) + +(define current-time get-time-of-day) +(define time? timeval?) + +(define (join-timeout-exception? x) + (and (exception? x) + (equal? (exception-message x) "timed out waiting for thread"))) + +;; XXXX flush out exception types +(define (abandoned-mutex-exception? x) #f) +(define (terminated-thread-exception? x) #f) +(define (uncaught-exception? x) #f) +(define (uncaught-exception-reason x) #f) + +;; signal runner + +(define (signal-runner) + (let lp () + (let ((n (pop-signal!))) + (cond + ((integer? n) + (let ((handler (get-signal-handler n))) + (if (procedure? handler) + (handler n)))) + (else + (thread-sleep! #t)))) + (lp))) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c new file mode 100644 index 00000000..b84d59f4 --- /dev/null +++ b/lib/srfi/18/threads.c @@ -0,0 +1,421 @@ +/* threads.c -- SRFI-18 thread primitives */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include +#include +#include + +#define sexp_mutex_name(x) sexp_slot_ref(x, 0) +#define sexp_mutex_specific(x) sexp_slot_ref(x, 1) +#define sexp_mutex_thread(x) sexp_slot_ref(x, 2) +#define sexp_mutex_lockp(x) sexp_slot_ref(x, 3) + +#define sexp_condvar_name(x) sexp_slot_ref(x, 0) +#define sexp_condvar_specific(x) sexp_slot_ref(x, 1) +#define sexp_condvar_threads(x) sexp_slot_ref(x, 2) + +#define timeval_le(a, b) (((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec < (b).tv_usec))) +#define sexp_context_before(c, t) (((sexp_context_timeval(c).tv_sec != 0) || (sexp_context_timeval(c).tv_usec != 0)) && timeval_le(sexp_context_timeval(c), t)) + +/* static int mutex_id, condvar_id; */ + +/**************************** threads *************************************/ + +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); + sexp_gc_release2(ctx); +} + +sexp sexp_thread_timeoutp (sexp ctx sexp_api_params(self, n)) { + return sexp_make_boolean(sexp_context_timeoutp(ctx)); +} + +sexp sexp_thread_name (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + return sexp_context_name(thread); +} + +sexp sexp_thread_specific (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + return sexp_context_specific(thread); +} + +sexp sexp_thread_specific_set (sexp ctx sexp_api_params(self, n), sexp thread, sexp val) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + sexp_context_specific(thread) = val; + return SEXP_VOID; +} + +sexp sexp_current_thread (sexp ctx sexp_api_params(self, n)) { + return ctx; +} + +sexp sexp_make_thread (sexp ctx sexp_api_params(self, n), sexp thunk, sexp name) { + sexp res, *stack; + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk); + res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0); + sexp_context_proc(res) = thunk; + sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk)); + stack = sexp_stack_data(sexp_context_stack(res)); + stack[0] = stack[1] = stack[3] = SEXP_ZERO; + stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + sexp_context_top(res) = 4; + sexp_context_last_fp(res) = 0; + return res; +} + +sexp sexp_thread_start (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp cell; + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + cell = sexp_cons(ctx, thread, SEXP_NULL); + if (sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = cell; + sexp_global(ctx, SEXP_G_THREADS_BACK) = cell; + } else { /* init queue */ + sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) = cell; + } + return SEXP_VOID; +} + +sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp res = sexp_make_boolean(ctx == thread); + for ( ; thread && sexp_contextp(thread); thread=sexp_context_child(thread)) + sexp_context_refuel(thread) = 0; + /* return true if terminating self */ + return res; +} + +static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { +#if SEXP_USE_FLONUMS + double d; +#endif + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + if (sexp_integerp(timeout) || sexp_flonump(timeout)) + gettimeofday(&sexp_context_timeval(ctx), NULL); + if (sexp_integerp(timeout)) { + sexp_context_timeval(ctx).tv_sec += sexp_unbox_fixnum(timeout); +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(timeout)) { + d = sexp_flonum_value(timeout); + sexp_context_timeval(ctx).tv_sec += trunc(d); + sexp_context_timeval(ctx).tv_usec += (d-trunc(d))*1000000; +#endif + } else { + sexp_context_timeval(ctx).tv_sec = 0; + sexp_context_timeval(ctx).tv_usec = 0; + } + if (sexp_numberp(timeout)) + while (sexp_pairp(ls2) + && sexp_context_before(sexp_car(ls2), sexp_context_timeval(ctx))) + ls1=ls2, ls2=sexp_cdr(ls2); + else + while (sexp_pairp(ls2) && sexp_context_timeval(sexp_car(ls2)).tv_sec) + ls1=ls2, ls2=sexp_cdr(ls2); + if (ls1 == SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cons(ctx, thread, ls2); + else + sexp_cdr(ls1) = sexp_cons(ctx, thread, ls2); +} + +sexp sexp_thread_join (sexp ctx sexp_api_params(self, n), sexp thread, sexp timeout) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + if (sexp_context_refuel(thread) <= 0) /* return true if already terminated */ { + return SEXP_TRUE; + } + sexp_context_timeoutp(ctx) = 0; + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = thread; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; +} + +sexp sexp_thread_sleep (sexp ctx sexp_api_params(self, n), sexp timeout) { + sexp_context_waitp(ctx) = 1; + if (timeout != SEXP_TRUE) { + sexp_assert_type(ctx, sexp_numberp, SEXP_NUMBER, timeout); + sexp_insert_timed(ctx, ctx, timeout); + } + return SEXP_FALSE; +} + +/**************************** mutexes *************************************/ + +sexp sexp_mutex_state (sexp ctx sexp_api_params(self, n), sexp mutex) { + /* sexp_assert_type(ctx, sexp_mutexp, mutex_id, timeout); */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + if (sexp_contextp(sexp_mutex_thread(mutex))) + return sexp_mutex_thread(mutex); + else + return sexp_intern(ctx, "not-owned", -1); + } else { + return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1); + } +} + +sexp sexp_mutex_lock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp timeout, sexp thread) { + if (thread == SEXP_TRUE) + thread = ctx; + if (sexp_not(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_TRUE; + sexp_mutex_thread(mutex) = thread; + return SEXP_TRUE; + } else { + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = mutex; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; + } +} + +sexp sexp_mutex_unlock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp condvar, sexp timeout) { + sexp ls1, ls2; + if (sexp_not(condvar)) { + /* normal unlock - always succeeds, just need to unblock threads */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_FALSE; + sexp_mutex_thread(mutex) = ctx; + /* search for threads blocked on this mutex */ + for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == mutex) { + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2; + if (! sexp_pairp(sexp_cdr(ls2))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + sexp_context_waitp(sexp_car(ls2)) + = sexp_context_timeoutp(sexp_car(ls2)) = 0; + break; + } + } + return SEXP_TRUE; + } else { + /* wait on condition var */ + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = condvar; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; + } +} + +/**************************** condition variables *************************/ + +sexp sexp_condition_variable_signal (sexp ctx sexp_api_params(self, n), sexp condvar) { + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + for ( ; sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == condvar) { + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2; + if (! sexp_pairp(sexp_cdr(ls2))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + sexp_context_waitp(sexp_car(ls2)) = sexp_context_timeoutp(sexp_car(ls2)) = 0; + return SEXP_TRUE; + } + return SEXP_FALSE; +} + +sexp sexp_condition_variable_broadcast (sexp ctx sexp_api_params(self, n), sexp condvar) { + sexp res = SEXP_FALSE; + while (sexp_truep(sexp_condition_variable_signal(ctx, self, n, condvar))) + res = SEXP_TRUE; + return res; +} + +/**************************** the scheduler *******************************/ + +void sexp_wait_on_single_thread (sexp ctx) { + struct timeval tval; + useconds_t usecs = 0; + gettimeofday(&tval, NULL); + if (tval.tv_sec < sexp_context_timeval(ctx).tv_sec) + usecs = (sexp_context_timeval(ctx).tv_sec - tval.tv_sec) * 1000000; + if (tval.tv_usec < sexp_context_timeval(ctx).tv_usec) + usecs += sexp_context_timeval(ctx).tv_usec - tval.tv_usec; + usleep(usecs); +} + +static const sexp_uint_t sexp_log2_lookup[32] = { + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 +}; + +/* only works on powers of two */ +static sexp_uint_t sexp_log2_of_pow2 (sexp_uint_t n) { + return sexp_log2_lookup[(n * 0x077CB531U) >> 27]; +} + +static sexp sexp_pop_signal (sexp ctx sexp_api_params(self, n)) { + int allsigs, restsigs, signum; + if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) == SEXP_ZERO) { + return SEXP_FALSE; + } else { + allsigs = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS)); + restsigs = allsigs & (allsigs-1); + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = sexp_make_fixnum(restsigs); + signum = sexp_log2_of_pow2(allsigs-restsigs); + return sexp_make_fixnum(signum); + } +} + +static sexp sexp_get_signal_handler (sexp ctx sexp_api_params(self, n), sexp signum) { + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, signum); + return sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); +} + +sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { + struct timeval tval; + sexp res, ls1, ls2, runner, paused, front; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + + front = sexp_global(ctx, SEXP_G_THREADS_FRONT); + paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); + + /* check for signals */ + if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) { + runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER); + if (! sexp_contextp(runner)) { /* ensure the runner exists */ + if (sexp_envp(runner)) { + tmp = sexp_env_cell(runner, (tmp=sexp_intern(ctx, "signal-runner", -1))); + if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) { + runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE); + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner; + sexp_thread_start(ctx, self, 1, runner); + } + } + } else if (sexp_context_waitp(runner)) { /* wake it if it's sleeping */ + sexp_context_waitp(runner) = 0; + sexp_thread_start(ctx, self, 1, runner); + } + } + + /* if we've terminated, check threads joining us */ + if (sexp_context_refuel(ctx) <= 0) { + for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { + if (sexp_context_event(sexp_car(ls2)) == ctx) { + sexp_context_waitp(sexp_car(ls2)) = 0; + sexp_context_timeoutp(sexp_car(ls2)) = 0; + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + tmp = sexp_cdr(ls2); + sexp_cdr(ls2) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + ls2 = tmp; + } else { + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + } + } + + /* check timeouts */ + if (sexp_pairp(paused)) { + if (gettimeofday(&tval, NULL) == 0) { + ls1 = SEXP_NULL; + ls2 = paused; + while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), tval)) { + sexp_context_timeoutp(sexp_car(ls2)) = 1; + sexp_context_waitp(ctx) = 0; + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + if (sexp_pairp(ls1)) { + sexp_cdr(ls1) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = paused; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1; + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = ls2; + } + } + } + + /* dequeue next thread */ + if (sexp_pairp(front)) { + res = sexp_car(front); + if ((sexp_context_refuel(ctx) <= 0) || sexp_context_waitp(ctx)) { + /* either terminated or paused */ + sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(front); + if (! sexp_pairp(sexp_cdr(front))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + } else { + /* swap with front of queue */ + sexp_car(sexp_global(ctx, SEXP_G_THREADS_FRONT)) = ctx; + /* rotate front of queue to back */ + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) + = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) + = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_FRONT)); + sexp_global(ctx, SEXP_G_THREADS_BACK) + = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)); + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = SEXP_NULL; + } + } else { + res = ctx; + } + + if (sexp_context_waitp(res)) { + /* the only thread available was waiting */ + sexp_wait_on_single_thread(res); + sexp_context_timeoutp(res) = 1; + sexp_context_waitp(res) = 0; + } + + sexp_gc_release1(ctx); + return res; +} + +/**************************************************************************/ + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + + sexp_define_type_predicate(ctx, env, "thread?", SEXP_CONTEXT); + sexp_define_foreign(ctx, env, "thread-timeout?", 0, sexp_thread_timeoutp); + sexp_define_foreign(ctx, env, "current-thread", 0, sexp_current_thread); + sexp_define_foreign_opt(ctx, env, "make-thread", 2, sexp_make_thread, SEXP_FALSE); + sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start); + sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate); + sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join); + sexp_define_foreign(ctx, env, "%thread-sleep!", 1, sexp_thread_sleep); + sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name); + sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific); + sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set); + sexp_define_foreign(ctx, env, "mutex-state", 1, sexp_mutex_state); + sexp_define_foreign(ctx, env, "%mutex-lock!", 3, sexp_mutex_lock); + sexp_define_foreign(ctx, env, "%mutex-unlock!", 3, sexp_mutex_unlock); + sexp_define_foreign(ctx, env, "condition-variable-signal!", 1, sexp_condition_variable_signal); + sexp_define_foreign(ctx, env, "condition-variable-broadcast!", 1, sexp_condition_variable_broadcast); + sexp_define_foreign(ctx, env, "pop-signal!", 0, sexp_pop_signal); + sexp_define_foreign(ctx, env, "get-signal-handler", 1, sexp_get_signal_handler); + + sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) + = sexp_make_foreign(ctx, "scheduler", 0, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); + + /* remember the env to lookup the runner later */ + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env; + + return SEXP_VOID; +} + diff --git a/lib/srfi/18/types.scm b/lib/srfi/18/types.scm new file mode 100644 index 00000000..093c97a7 --- /dev/null +++ b/lib/srfi/18/types.scm @@ -0,0 +1,24 @@ +;; types.scm -- thread types +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type mutex + (%make-mutex name specific thread lock) + mutex? + (name mutex-name) + (specific mutex-specific mutex-specific-set!) + (thread %mutex-thread %mutex-thread-set!) + (lock %mutex-lock %mutex-lock-set!)) + +(define (make-mutex . o) + (%make-mutex (and (pair? o) (car o)) #f #f #f)) + +(define-record-type condition-variable + (%make-condition-variable name specific threads) + condition-variable? + (name condition-variable-name) + (specific condition-variable-specific condition-variable-specific-set!) + (threads %condition-variable-threads %condition-variable-threads-set!)) + +(define (make-condition-variable . o) + (%make-condition-variable (and (pair? o) (car o)) #f #f)) diff --git a/lib/srfi/2.module b/lib/srfi/2.module new file mode 100644 index 00000000..4ceb8b6b --- /dev/null +++ b/lib/srfi/2.module @@ -0,0 +1,16 @@ + +(define-module (srfi 2) + (export and-let*) + (import-immutable (scheme)) + (body + (define-syntax and-let* + (syntax-rules () + ((and-let* () . body) + (begin . body)) + ((and-let* ((var expr) . rest) . body) + (let ((var expr)) + (and var (and-let* rest . body)))) + ((and-let* ((expr) . rest) . body) + (let ((tmp expr)) + (and tmp (and-let* rest . body)))))))) + diff --git a/lib/srfi/26.module b/lib/srfi/26.module new file mode 100644 index 00000000..f97ab783 --- /dev/null +++ b/lib/srfi/26.module @@ -0,0 +1,24 @@ + +(define-module (srfi 26) + (export cut cute) + (import-immutable (scheme)) + (body + (define-syntax %cut + (syntax-rules (<> <...>) + ((%cut e? params args) + (lambda params args)) + ((%cut e? (params ...) (args ...) <> . rest) + (%cut e? (params ... tmp) (args ... tmp) . rest)) + ((%cut e? (params ...) (args ...) <...>) + (%cut e? (params ... . tmp) (apply args ... tmp))) + ((%cut e? (params ...) (args ...) <...> . rest) + (error "cut: non-terminal <...>")) + ((%cut #t (params ...) (args ...) x . rest) + (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest))) + ((%cut #f (params ...) (args ...) x . rest) + (%cut #t (params ...) (args ... x) . rest)))) + (define-syntax cut + (syntax-rules () ((cut args ...) (%cut #f () () args ...)))) + (define-syntax cute + (syntax-rules () ((cute args ...) (%cut #t () () args ...)))))) + diff --git a/lib/srfi/27.module b/lib/srfi/27.module new file mode 100644 index 00000000..5c451629 --- /dev/null +++ b/lib/srfi/27.module @@ -0,0 +1,11 @@ + +(define-module (srfi 27) + (export random-integer random-real default-random-source + make-random-source random-source? + random-source-state-ref random-source-state-set! + random-source-randomize! random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals) + (import-immutable (scheme)) + (include-shared "27/rand") + (include "27/constructors.scm")) + diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm new file mode 100644 index 00000000..dbd0a8c6 --- /dev/null +++ b/lib/srfi/27/constructors.scm @@ -0,0 +1,10 @@ +;; constructors.scm -- random function constructors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (random-source-make-integers rs) + (lambda (n) (%random-integer rs n))) + +(define (random-source-make-reals rs . o) + (lambda () (%random-real rs))) + diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c new file mode 100644 index 00000000..6e971df8 --- /dev/null +++ b/lib/srfi/27/rand.c @@ -0,0 +1,204 @@ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include + +#define SEXP_RANDOM_STATE_SIZE 128 + +#define ZERO sexp_make_fixnum(0) +#define ONE sexp_make_fixnum(1) +#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE) + +#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id) + +#define sexp_random_init(x, seed) \ + initstate_r(seed, \ + sexp_string_data(sexp_random_state(x)), \ + SEXP_RANDOM_STATE_SIZE, \ + sexp_random_data(x)) + +#if SEXP_BSD || defined(__CYGWIN__) +typedef unsigned int sexp_random_t; +#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs))) +#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n) +#else +typedef struct random_data sexp_random_t; +#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst) +#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs)) +#endif + +#define sexp_random_state(x) (sexp_slot_ref((x), 0)) +#define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1))) + +#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp)) + +static sexp_uint_t rs_type_id; +static sexp default_random_source; + +static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, sexp bound) { + sexp res; + int32_t m; +#if SEXP_USE_BIGNUMS + int32_t hi, mod, len, i, *data; +#endif + if (! sexp_random_source_p(rs)) + res = sexp_type_exception(ctx, self, rs_type_id, rs); + if (sexp_fixnump(bound)) { + sexp_call_random(rs, m); + res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(bound)) { + hi = sexp_bignum_hi(bound); + len = hi * sizeof(sexp_uint_t) / sizeof(int32_t); + res = sexp_make_bignum(ctx, hi); + data = (int32_t*) sexp_bignum_data(res); + for (i=0; i +#include + +#if SEXP_USE_BIGNUMS +#include +#else +#define sexp_bignum_normalize(x) x +#endif + +static sexp sexp_bit_and (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { + sexp res; +#if SEXP_USE_BIGNUMS + sexp_sint_t len, i; +#endif + if (sexp_fixnump(x)) { + if (sexp_fixnump(y)) + res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(y)) + res = sexp_bit_and(ctx sexp_api_pass(self, n), y, x); +#endif + else + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + if (sexp_fixnump(y)) { + res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); + } else if (sexp_bignump(y)) { + if (sexp_bignum_length(x) < sexp_bignum_length(y)) + res = sexp_copy_bignum(ctx, NULL, x, 0); + else + res = sexp_copy_bignum(ctx, NULL, y, 0); + for (i=0, len=sexp_bignum_length(res); i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i> -c); + } else { + tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c; +#if SEXP_USE_BIGNUMS + if (((tmp >> c) == sexp_unbox_fixnum(i)) + && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) { +#endif + res = sexp_make_fixnum(tmp); +#if SEXP_USE_BIGNUMS + } else { + sexp_gc_preserve1(ctx, res); + res = sexp_fixnum_to_bignum(ctx, i); + res = sexp_arithmetic_shift(ctx sexp_api_pass(self, n), res, count); + sexp_gc_release1(ctx); + } +#endif + } +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(i)) { + len = sexp_bignum_hi(i); + if (c < 0) { + c = -c; + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + if (len < offset) { + res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1); + } else { + res = sexp_make_bignum(ctx, len - offset + 1); + for (j=len-offset, tmp=0; j>=0; j--) { + sexp_bignum_data(res)[j] + = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp; + tmp = sexp_bignum_data(i)[j+offset] + << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + } + } else { + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + res = sexp_make_bignum(ctx, len + offset + 1); + for (j=tmp=0; j> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + sexp_bignum_data(res)[len+offset] = tmp; + } +#endif + } else { + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + } + return sexp_bignum_normalize(res); +} + +/* bit-count and integer-length were adapted from: */ +/* http://graphics.stanford.edu/~seander/bithacks.html */ +static sexp_uint_t bit_count (sexp_uint_t i) { + i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3); + i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3) + + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3)); + i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15; + return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255)) + >> (sizeof(i) - 1) * CHAR_BIT); +} + +static sexp sexp_bit_count (sexp ctx sexp_api_params(self, n), sexp x) { + sexp res; + sexp_sint_t i; +#if SEXP_USE_BIGNUMS + sexp_uint_t count; +#endif + if (sexp_fixnump(x)) { + i = sexp_unbox_fixnum(x); + res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + for (i=count=0; i> 32)) + return integer_log2(tt) + 32; + else +#endif + if ((tt = x >> 16)) + return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt]; + else + return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; +} + +static sexp sexp_integer_length (sexp ctx sexp_api_params(self, n), sexp x) { + sexp_sint_t tmp; +#if SEXP_USE_BIGNUMS + sexp_sint_t hi; +#endif + if (sexp_fixnump(x)) { + tmp = sexp_unbox_fixnum(x); + return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + hi = sexp_bignum_hi(x); + return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi]) + + hi*sizeof(sexp_uint_t)); +#endif + } else { + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + } +} + +static sexp sexp_bit_set_p (sexp ctx sexp_api_params(self, n), sexp i, sexp x) { +#if SEXP_USE_BIGNUMS + sexp_uint_t pos; +#endif + if (! sexp_fixnump(i)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + if (sexp_fixnump(x)) { + return sexp_make_boolean(sexp_unbox_fixnum(x) & (1< (lambda (cell) (set-cdr! cell (+ (cdr cell) 1)))) + ((pair? x) + (set! seen (cons (cons x 1) seen)) + (find (car x)) + (find (cdr x))) + ((vector? x) + (set! seen (cons (cons x 1) seen)) + (do ((i 0 (+ i 1))) + ((= i (vector-length x))) + (find (vector-ref x i)))))) + (let extract ((ls seen) (res '())) + (cond + ((null? ls) res) + ((> (cdar ls) 1) (extract (cdr ls) (cons (cons (caar ls) #f) res))) + (else (extract (cdr ls) res)))))) + +(define (write-with-shared-structure x . o) + (let ((out (if (pair? o) (car o) (current-output-port))) + (shared (extract-shared-objects x)) + (count 0)) + (define (check-shared x prefix cont) + (let ((cell (assq x shared))) + (cond ((and cell (cdr cell)) + (display prefix out) + (display "#" out) + (write (cdr cell)) + (display "#" out)) + (else + (cond (cell + (display prefix out) + (display "#=" out) + (write count out) + (set-cdr! cell count) + (set! count (+ count 1)))) + (cont x))))) + (cond + ((null? shared) + (write x out)) + (else + (let wr ((x x)) + (check-shared + x + "" + (lambda (x) + (cond + ((pair? x) + (display "(" out) + (wr (car x)) + (let lp ((ls (cdr x))) + (check-shared + ls + " . " + (lambda (ls) + (cond ((null? ls)) + ((pair? ls) + (display " " out) + (wr (car ls)) + (lp (cdr ls))) + (else + (display " . " out) + (wr ls)))))) + (display ")" out)) + ((vector? x) + (display "#(" out) + (let ((len (vector-length x))) + (cond ((> len 0) + (wr (vector-ref x 0)) + (do ((i 1 (+ i 1))) + ((= i len)) + (display " " out) + (wr (vector-ref x i)))))) + (display ")" out)) + (else + (write x out)))))))))) + +(define write/ss write-with-shared-structure) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (skip-line in) + (let ((c (read-char in))) + (if (not (or (eof-object? c) (eqv? c #\newline))) + (skip-line in)))) + +(define (skip-whitespace in) + (case (peek-char in) + ((#\space #\tab #\newline #\return) + (read-char in) + (skip-whitespace in)) + ((#\;) + (skip-line in) + (skip-whitespace in)))) + +(define (skip-comment in depth) + (case (read-char in) + ((#\#) (skip-comment in (if (eqv? #\| (peek-char in)) (+ depth 1) depth))) + ((#\|) (if (eqv? #\# (peek-char in)) + (if (zero? depth) (read-char in) (skip-comment in (- depth 1))) + (skip-comment in depth))) + (else (if (eof-object? (peek-char in)) + (error "unterminated #| comment") + (skip-comment in depth))))) + +(define delimiters + '(#\( #\) #\[ #\] #\space #\tab #\newline #\return)) + +(define read-with-shared-structure + (let ((read read)) + (lambda o + (let ((in (if (pair? o) (car o) (current-input-port))) + (shared '())) + (define (read-label res) + (let ((c (char-downcase (peek-char in)))) + (if (if (char-numeric? c) #t (memv c '(#\a #\b #\c #\d #\e))) + (read-label (cons (read-char in) res)) + (list->string (reverse res))))) + (define (read-number base) + (let* ((str (read-label '())) + (n (string->number str base))) + (if (or (not n) (not (memv (peek-char in) delimiters))) + (error "read error: invalid number syntax" str (peek-char in)) + n))) + (define (read-float-tail in) ;; called only after a leading period + (let lp ((res 0.0) (k 0.1)) + (let ((c (peek-char in))) + (cond + ((char-numeric? c) (lp (+ res (* (read-char in) k)) (* k 0.1))) + ((memv c delimiters) res) + (else (error "invalid char in float syntax" c)))))) + (define (read-name c in) + (let lp ((ls (if (char? c) (list c) '()))) + (let ((c (peek-char in))) + (cond ((memv c delimiters) (list->string (reverse ls))) + (else (lp (cons (read-char in) ls))))))) + (define (read-named-char c in) + (let ((name (read-name c in))) + (cond ((string-ci=? name "space") #\space) + ((string-ci=? name "newline") #\newline) + (else (error "unknown char name"))))) + (define (read-one) + (skip-whitespace in) + (case (peek-char in) + ((#\#) + (read-char in) + (case (char-downcase (peek-char in)) + ((#\=) + (read-char in) + (let* ((str (read-label '())) + (n (string->number str)) + (cell (list #f)) + (thunk (lambda () (car cell)))) + (if (not n) (error "read error: invalid reference" str)) + (set! shared (cons (cons n thunk) shared)) + (let ((x (read-one))) + (set-car! cell x) + x))) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let ((n (string->number (read-label '())))) + (cond + ((not (eqv? #\# (peek-char in))) + (error "read error: expected # after #n" (read-char in))) + (else + (read-char in) + (cond ((assv n shared) => cdr) + (else (error "read error: unknown reference" n))))))) + ((#\;) + (read-char in) + (read-one) ;; discard + (read-one)) + ((#\|) + (skip-comment in 0)) + ((#\!) (skip-line in) (read-one in)) + ((#\() (list->vector (read-one))) + ((#\') (read-char in) (list 'syntax (read-one))) + ((#\`) (read-char in) (list 'quasisyntax (read-one))) + ((#\t) (read-char in) #t) + ((#\f) (read-char in) #t) ; support SRFI-4 f32/64 vectors + ((#\d) (read-char in) (read in)) + ((#\x) (read-char in) (read-number 16)) + ((#\o) (read-char in) (read-number 8)) + ((#\b) (read-char in) (read-number 2)) + ((#\i) (read-char in) (exact->inexact (read-one))) + ((#\e) (read-char in) (inexact->exact (read-one))) + ((#\\) + (read-char in) + (let ((c (read-char in))) + (if (memv (peek-char in) delimiters) + c + (read-named-char c in)))) + (else + (error "unknown # syntax: " (peek-char in))))) + ((#\() + (read-char in) + (let lp ((res '())) + (skip-whitespace in) + (case (peek-char in) + ((#\)) + (read-char in) + (reverse res)) + ((#\.) + (read-char in) + (cond + ((memv (peek-char in) delimiters) + (let ((tail (read-one))) + (skip-whitespace in) + (if (eqv? #\) (peek-char in)) + (begin (read-char in) (append (reverse res) tail)) + (error "expected end of list after dot")))) + ((char-numeric? (peek-char in)) (read-float-tail in)) + (else (string->symbol (read-name #\. in))))) + (else + (lp (cons (read-one) res)))))) + ((#\') (read-char in) (list 'quote (read-one))) + ((#\`) (read-char in) (list 'quasiquote (read-one))) + ((#\,) + (read-char in) + (list (if (eqv? #\@ (peek-char in)) + (begin (read-char in) 'unquote-splicing) + 'unquote) + (read-one))) + (else + (read in)))) + ;; body + (let ((res (read-one))) + (if (pair? shared) + (patch res)) + res))))) + +(define (hole? x) (procedure? x)) +(define (fill-hole x) (if (hole? x) (fill-hole (x)) x)) + +(define (patch x) + (cond + ((pair? x) + (if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch (car x))) + (if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch (cdr x)))) + ((vector? x) + (do ((i (- (vector-length x) 1) (- i 1))) + ((< i 0)) + (let ((elt (vector-ref x i))) + (if (hole? elt) + (vector-set! x i (fill-hole elt)) + (patch elt))))))) + +(define read/ss read-with-shared-structure) diff --git a/lib/srfi/39.module b/lib/srfi/39.module new file mode 100644 index 00000000..11b9ed9f --- /dev/null +++ b/lib/srfi/39.module @@ -0,0 +1,25 @@ + +(define-module (srfi 39) + (export make-parameter parameterize) + (import-immutable (scheme)) + (body + (define (make-parameter value . o) + (if (pair? o) + (let ((converter (car o))) + (lambda args + (if (null? args) + value + (set! value (converter (car args)))))) + (lambda args (if (null? args) value (set! value (car args)))))) + (define-syntax parameterize + (syntax-rules () + ((parameterize ("step") ((param value tmp1 tmp2) ...) () body) + (let ((tmp1 value) ...) + (let ((tmp2 (param)) ...) + (dynamic-wind (lambda () (param tmp1) ...) + (lambda () . body) + (lambda () (param tmp2) ...))))) + ((parameterize ("step") args ((param value) . rest) body) + (parameterize ("step") ((param value tmp1 tmp2) . args) rest body)) + ((parameterize ((param value) ...) . body) + (parameterize ("step") () ((param value) ...) body)))))) diff --git a/lib/srfi/6.module b/lib/srfi/6.module new file mode 100644 index 00000000..e589b6ff --- /dev/null +++ b/lib/srfi/6.module @@ -0,0 +1,5 @@ + +(define-module (srfi 6) + (export open-input-string open-output-string get-output-string) + (import-immutable (scheme))) + diff --git a/lib/srfi/69.module b/lib/srfi/69.module new file mode 100644 index 00000000..037b6393 --- /dev/null +++ b/lib/srfi/69.module @@ -0,0 +1,17 @@ + +(define-module (srfi 69) + (export + make-hash-table hash-table? alist->hash-table + hash-table-equivalence-function hash-table-hash-function + hash-table-ref hash-table-ref/default hash-table-set! + hash-table-delete! hash-table-exists? + hash-table-update! hash-table-update!/default + hash-table-size hash-table-keys hash-table-values + hash-table-walk hash-table-fold hash-table->alist + hash-table-copy hash-table-merge! + hash string-hash string-ci-hash hash-by-identity) + (import-immutable (scheme) + (srfi 9)) + (include-shared "69/hash") + (include "69/type.scm" "69/interface.scm")) + diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c new file mode 100644 index 00000000..42d1e864 --- /dev/null +++ b/lib/srfi/69/hash.c @@ -0,0 +1,242 @@ +/* hash.c -- type-general hashing */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define HASH_DEPTH 5 +#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM) + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0) +#define sexp_hash_table_size(x) sexp_slot_ref(x, 1) +#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2) +#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3) + +#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2)) + +static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc % bound; +} + +static sexp sexp_string_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); + return sexp_make_fixnum(string_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= (tolower)(*str++);} + return acc % bound; +} + +static sexp sexp_string_ci_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); + return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) { + sexp_uint_t acc = FNV_OFFSET_BASIS, size; + sexp_sint_t i, len; + sexp t, *p; + char *p0; + loop: +#if SEXP_USE_FLONUMS + if (sexp_flonump(obj)) + acc ^= (sexp_sint_t) sexp_flonum_value(obj); + else +#endif + if (sexp_pointerp(obj)) { + if (depth) { + t = sexp_object_type(ctx, obj); + p = (sexp*) (((char*)obj) + sexp_type_field_base(t)); + p0 = ((char*)obj) + offsetof(struct sexp_struct, value); + if ((sexp)p == obj) p=(sexp*)p0; + /* hash trailing non-object data */ + size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp)); + if (((char*)obj + size) > p0) + for (i=0; i 0) { + depth--; + for (i=0; ialist table) + (hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '())) + +(define (hash-table-keys table) + (hash-table-fold table (lambda (k v a) (cons k a)) '())) + +(define (hash-table-values table) + (hash-table-fold table (lambda (k v a) (cons v a)) '())) + +(define (alist->hash-table ls . o) + (let ((res (apply make-hash-table o))) + (for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls) + res)) + +(define (hash-table-merge! a b) + (hash-table-walk b (lambda (k v) (hash-table-set! a k v))) + a) + +(define (hash-table-copy table) + (assert-hash-table "hash-table-copy" table) + (let ((res (make-hash-table (hash-table-equivalence-function table)))) + (hash-table-merge! res table) + res)) + diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm new file mode 100644 index 00000000..1fca9953 --- /dev/null +++ b/lib/srfi/69/type.scm @@ -0,0 +1,12 @@ +;; types.scm -- the hash-table record type +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type hash-table + (%make-hash-table buckets size hash-fn eq-fn) + hash-table? + (buckets hash-table-buckets hash-table-buckets-set!) + (size hash-table-size hash-table-size-set!) + (hash-fn %hash-table-hash-function) + (eq-fn %hash-table-equivalence-function)) + diff --git a/lib/srfi/8.module b/lib/srfi/8.module new file mode 100644 index 00000000..64a3e6e2 --- /dev/null +++ b/lib/srfi/8.module @@ -0,0 +1,10 @@ + +(define-module (srfi 8) + (export receive) + (import-immutable (scheme)) + (body + (define-syntax receive + (syntax-rules () + ((receive params expr . body) + (call-with-values (lambda () expr) (lambda params . body))))))) + diff --git a/lib/srfi/9.module b/lib/srfi/9.module new file mode 100644 index 00000000..58368111 --- /dev/null +++ b/lib/srfi/9.module @@ -0,0 +1,90 @@ + +(define-module (srfi 9) + (export define-record-type) + (import-immutable (scheme)) + (body + (define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((name (cadr expr)) + (name-str (symbol->string (identifier->symbol name))) + (make (caaddr expr)) + (make-fields (cdaddr expr)) + (pred (cadddr expr)) + (fields (cddddr expr)) + (num-fields (length fields)) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let)) + (_register (rename 'register-simple-type))) + (define (index-of field ls) + (let lp ((ls ls) (i 0)) + (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) + `(,(rename 'begin) + ;; type + (,_define ,name (,_register ,name-str ,num-fields)) + ;; predicate + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string (identifier->symbol pred)) + ,name)) + ;; fields + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string + (identifier->symbol (cadar ls))) + ,name + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string + (identifier->symbol (caddar ls))) + ,name + ,i)) + res) + res))))) + ;; constructor + (,_define ,make + ,(let lp ((ls make-fields) (sets '()) (set-defs '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string (identifier->symbol make)) + ,name)) + ,@set-defs) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets) + set-defs)) + (else + (let* ((setter-name + (string-append "%" name-str "-" + (symbol->string (car ls)) "-set!")) + (setter (rename (string->symbol setter-name))) + (i (index-of (car ls) fields))) + (lp (cdr ls) + (cons (list setter 'res (car ls)) sets) + (cons (list setter + (list (rename 'make-setter) + setter-name + name + (index-of (car ls) fields))) + set-defs))))))))))))))))) + diff --git a/lib/srfi/95.module b/lib/srfi/95.module new file mode 100644 index 00000000..43bab9dd --- /dev/null +++ b/lib/srfi/95.module @@ -0,0 +1,7 @@ + +(define-module (srfi 95) + (export sorted? merge merge! sort sort! object-cmp) + (import-immutable (scheme)) + (include-shared "95/qsort") + (include "95/sort.scm")) + diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c new file mode 100644 index 00000000..14329e37 --- /dev/null +++ b/lib/srfi/95/qsort.c @@ -0,0 +1,228 @@ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#if SEXP_USE_HUFF_SYMS +#include "../../../opt/sexp-hufftabs.c" +#endif + +#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var) + +static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) { + sexp_sint_t i; + sexp ls, *data=sexp_vector_data(vec); + for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls)) + sexp_car(ls) = data[i]; + return seq; +} + +static sexp sexp_vector_nreverse (sexp ctx, sexp vec) { + int i, j; + sexp tmp, *data=sexp_vector_data(vec); + for (i=0, j=sexp_vector_length(vec)-1; i>3, d = ((sexp_uint_t)b)>>3; + while (c && d) { +#include "../../../opt/sexp-unhuff.c" +#define c d +#define res res2 +#include "../../../opt/sexp-unhuff.c" +#undef c +#undef res + if ((tmp=res-res2) != 0) + return tmp; + } + return c ? 1 : d ? -1 : 0; +} +#endif + +static int sexp_object_compare (sexp ctx, sexp a, sexp b) { + int res; + if (a == b) + return 0; + if (sexp_pointerp(a)) { + if (sexp_pointerp(b)) { + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) { + res = sexp_pointer_tag(a) - sexp_pointer_tag(b); + } else { + switch (sexp_pointer_tag(a)) { + case SEXP_FLONUM: + res = sexp_flonum_value(a) - sexp_flonum_value(b); + break; + case SEXP_BIGNUM: + res = sexp_bignum_compare(a, b); + break; + case SEXP_STRING: + res = strcmp(sexp_string_data(a), sexp_string_data(b)); + break; + case SEXP_SYMBOL: + res = strcmp(sexp_symbol_data(a), sexp_symbol_data(b)); + break; + default: + res = 0; + break; + } + } +#if SEXP_USE_HUFF_SYMS + } else if (sexp_lsymbolp(a) && sexp_isymbolp(b)) { + res = strcmp(sexp_symbol_data(a), + sexp_string_data(sexp_write_to_string(ctx, b))); +#endif + } else { + res = 1; + } + } else if (sexp_pointerp(b)) { +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_lsymbolp(b)) + res = strcmp(sexp_string_data(sexp_write_to_string(ctx, a)), + sexp_symbol_data(b)); + else +#endif + res = -1; + } else { +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_isymbolp(b)) + return sexp_isymbol_compare(ctx, a, b); + else +#endif + res = (sexp_sint_t)a - (sexp_sint_t)b; + } + return res; +} + +static sexp sexp_object_compare_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + return sexp_make_fixnum(sexp_object_compare(ctx, a, b)); +} + +/* fast path when using general object-cmp comparator with no key */ +static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) { + sexp_sint_t mid, i, j; + sexp tmp, tmp2; + loop: + if (lo < hi) { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + for (i=j=lo; i < hi; i++) + if (sexp_object_compare(ctx, vec[i], tmp) < 0) + swap(tmp2, vec[i], vec[j]), j++; + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + sexp_qsort(ctx, vec, lo, j-1); + lo = j; + goto loop; /* tail recurse on right side */ + } + } +} + +static sexp sexp_qsort_less (sexp ctx, sexp *vec, + sexp_sint_t lo, sexp_sint_t hi, + sexp less, sexp key) { + sexp_sint_t mid, i, j; + sexp tmp, res, args1; + sexp_gc_var3(a, b, args2); + sexp_gc_preserve3(ctx, a, b, args2); + args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID); + args1 = sexp_cdr(args2); + loop: + if (lo >= hi) { + res = SEXP_VOID; + } else { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + if (sexp_truep(key)) { + sexp_car(args1) = tmp; + b = sexp_apply(ctx, key, args1); + } else { + b = tmp; + } + for (i=j=lo; i < hi; i++) { + if (sexp_truep(key)) { + sexp_car(args1) = vec[i]; + a = sexp_apply(ctx, key, args1); + } else { + a = vec[i]; + } + sexp_car(args2) = a; + sexp_car(args1) = b; + res = sexp_apply(ctx, less, args2); + if (sexp_exceptionp(res)) + goto done; + else if (sexp_truep(res)) + swap(res, vec[i], vec[j]), j++; + } + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + res = sexp_qsort_less(ctx, vec, lo, j-1, less, key); + if (sexp_exceptionp(res)) + goto done; + lo = j; + goto loop; /* tail recurse on right side */ + } + } + done: + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, + sexp less, sexp key) { + sexp_sint_t len; + sexp res, *data; + sexp_gc_var1(vec); + + if (sexp_nullp(seq)) return seq; + + sexp_gc_preserve1(ctx, vec); + + vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); + + if (! sexp_vectorp(vec)) { + res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec); + } else { + data = sexp_vector_data(vec); + len = sexp_vector_length(vec); + if (sexp_not(key) && sexp_basic_comparator(less)) { + sexp_qsort(ctx, data, 0, len-1); + if (sexp_opcodep(less) && sexp_opcode_inverse(less)) + sexp_vector_nreverse(ctx, vec); + } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less); + } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key); + } else { + res = sexp_qsort_less(ctx, data, 0, len-1, less, key); + } + } + + if (sexp_pairp(seq)) + res = sexp_vector_copy_to_list(ctx, vec, seq); + else if (! sexp_exceptionp(res)) + res = vec; + + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "object-cmp", 2, sexp_object_compare_op); + sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE); + return SEXP_VOID; +} diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm new file mode 100644 index 00000000..14e24517 --- /dev/null +++ b/lib/srfi/95/sort.scm @@ -0,0 +1,70 @@ +;; sort.scm -- SRFI-95 sorting utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (copy seq) + (if (vector? seq) + (let* ((len (vector-length seq)) + (res (make-vector len))) + (do ((i (- len 1) (- i 1))) + ((< i 0) res) + (vector-set! res i (vector-ref seq i)))) + (map (lambda (x) x) seq))) + +(define (sort seq . o) + (let ((less (and (pair? o) (car o))) + (key (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (sort! (copy seq) less key))) + +(define (sorted? seq less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (cond + ((vector? seq) + (let ((len (- (vector-length seq) 1))) + (let lp ((i 0)) + (cond + ((>= i len) #t) + ((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f) + (else (lp (+ i 1))))))) + ((null? seq) + #t) + (else + (let lp ((ls1 seq) (ls2 (cdr seq))) + (cond ((null? ls2) #t) + ((less (key (car ls2)) (key (car ls1))) #f) + (else (lp ls2 (cdr ls2))))))))) + +(define (merge! ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (define (lp prev ls1 ls2 a b less key) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))) + (else + (set-cdr! prev ls2) + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))))) + (cond + ((null? ls1) ls2) + ((null? ls2) ls1) + (else + (let ((a (key (car ls1))) + (b (key (car ls2)))) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)) + ls1) + (else + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)) + ls2))))))) + +(define (merge ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (merge! (copy ls1) (copy ls2) less key))) diff --git a/lib/srfi/98.module b/lib/srfi/98.module new file mode 100644 index 00000000..9d124d66 --- /dev/null +++ b/lib/srfi/98.module @@ -0,0 +1,5 @@ + +(define-module (srfi 98) + (export get-environment-variable get-environment-variables) + (include-shared "98/env")) + diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c new file mode 100644 index 00000000..f8e519f3 --- /dev/null +++ b/lib/srfi/98/env.c @@ -0,0 +1,48 @@ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifdef __APPLE__ +#include +#define environ (*_NSGetEnviron()) +#else +extern char **environ; +#endif + +#include + +sexp sexp_get_environment_variable (sexp ctx sexp_api_params(self, n), sexp str) { + char *cstr; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + cstr = getenv(sexp_string_data(str)); + return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE; +} + +sexp sexp_get_environment_variables (sexp ctx sexp_api_params(self, n)) { + int i; + char **env, *cname, *cval; + sexp_gc_var3(res, name, val); + sexp_gc_preserve3(ctx, res, name, val); + res = SEXP_NULL; + env = environ; + for (i=0; env[i]; i++) { + cname = env[i]; + cval = strchr(cname, '='); + if (cval) { + name = sexp_c_string(ctx, cname, cval-cname); + val = sexp_c_string(ctx, cval+1, -1); + val = sexp_cons(ctx, name, val); + res = sexp_cons(ctx, val, res); + } + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable); + sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables); + return SEXP_VOID; +} + diff --git a/main.c b/main.c new file mode 100644 index 00000000..d07a9767 --- /dev/null +++ b/main.c @@ -0,0 +1,219 @@ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define sexp_argv_symbol "*command-line-arguments*" +#define sexp_argv_proc "(define (command-line-arguments) "sexp_argv_symbol")" + +#define sexp_import_prefix "(import (" +#define sexp_import_suffix "))" + +#define sexp_version_string "chibi-scheme "sexp_version" \""sexp_release_name"\" " + +#ifdef PLAN9 +#define exit_failure() exits("ERROR") +#else +#define exit_failure() exit(70) +#endif + +static void repl (sexp ctx) { + sexp in, out, err; + sexp_gc_var4(obj, tmp, res, env); + sexp_gc_preserve4(ctx, obj, tmp, res, env); + env = sexp_make_env(ctx); + sexp_env_parent(env) = sexp_context_env(ctx); + sexp_env_define(ctx, sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); + sexp_context_tracep(ctx) = 1; + in = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE); + out = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE); + err = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE); + 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, env); + if (sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); + } else { +#if SEXP_USE_WARN_UNDEFS + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + if (res != SEXP_VOID) { + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + } + } + } + sexp_gc_release4(ctx); +} + +static void check_nonull_arg (int c, char *arg) { + if (! arg) { + fprintf(stderr, "chibi-scheme: option '%c' requires an argument\n", c); + exit_failure(); + } +} + +static sexp check_exception (sexp ctx, sexp res) { + sexp err; + if (res && sexp_exceptionp(res)) { + err = sexp_current_error_port(ctx); + if (! sexp_oportp(err)) + err = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); + exit_failure(); + } + return res; +} + +#define init_context() if (! ctx) do { \ + ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \ + env = sexp_context_env(ctx); \ + sexp_gc_preserve2(ctx, tmp, args); \ + } while (0) + +#define load_init() if (! init_loaded++) do { \ + init_context(); \ + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \ + } while (0) + +void run_main (int argc, char **argv) { + char *arg, *impmod, *p; + sexp env, out=SEXP_FALSE, res=SEXP_VOID, ctx=NULL; + sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0; + sexp_uint_t heap_size=0; + sexp_gc_var2(tmp, args); + args = SEXP_NULL; + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + case 'p': + load_init(); + print = (argv[i][1] == 'p'); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('e', arg); + res = check_exception(ctx, sexp_read_from_string(ctx, arg, -1)); + res = check_exception(ctx, sexp_eval(ctx, res, env)); + if (print) { + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + quit = 1; + break; + case 'l': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('l', arg); + check_exception(ctx, sexp_load_module_file(ctx, arg, env)); + break; + case 'm': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('m', arg); + len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); + impmod = (char*) malloc(len+1); + strcpy(impmod, sexp_import_prefix); + strcpy(impmod+strlen(sexp_import_prefix), arg); + strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix); + impmod[len] = '\0'; + for (p=impmod; *p; p++) + if (*p == '.') *p=' '; + check_exception(ctx, sexp_eval_string(ctx, impmod, -1, env)); + free(impmod); + break; + case 'q': + init_context(); + if (! init_loaded++) sexp_load_standard_parameters(ctx, env); + break; + case 'A': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('A', arg); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); + break; + case 'I': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('I', arg); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); + break; + case '-': + i++; + goto done_options; + case 'h': + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('h', arg); + heap_size = atol(arg); + len = strlen(arg); + if (heap_size && (isalpha)(arg[len-1])) { + switch ((tolower)(arg[len-1])) { + case 'k': heap_size *= 1024; break; + case 'm': heap_size *= (1024*1024); break; + } + } + break; + case 'V': + load_init(); + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + sexp_write_string(ctx, sexp_version_string, out); + tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*", -1), SEXP_NULL); + sexp_write(ctx, tmp, out); + sexp_newline(ctx, out); + return; + default: + fprintf(stderr, "unknown option: %s\n", argv[i]); + exit_failure(); + } + } + + done_options: + if (! quit) { + load_init(); + if (i < argc) + for (j=argc-1; j>i; j--) + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); + else + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); + sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args); + sexp_eval_string(ctx, sexp_argv_proc, -1, env); + if (i < argc) { /* script usage */ + check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); + tmp = sexp_intern(ctx, "main", -1); + tmp = sexp_env_ref(env, tmp, SEXP_FALSE); + if (sexp_procedurep(tmp)) { + args = sexp_list1(ctx, args); + check_exception(ctx, sexp_apply(ctx, tmp, args)); + } + } else { + repl(ctx); + } + } + + sexp_gc_release2(ctx); + sexp_destroy_context(ctx); +} + +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..a193e9b6 --- /dev/null +++ b/mkfile @@ -0,0 +1,28 @@ + include/chibi/install.h + echo '#define sexp_platform "plan9"' >> include/chibi/install.h + echo '#define sexp_version "'`{cat VERSION}'"' >> include/chibi/install.h + echo '#define sexp_release_name "'`{cat RELEASE}'"' >> include/chibi/install.h + +install:V: $BIN/$TARG + test -d $MODDIR || mkdir -p $MODDIR + cp -r lib/* $MODDIR/ + +test:V: + ./$O.out tests/r5rs-tests.scm + +sexp.c:N: gc.c opt/bignum.c diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..34505644 --- /dev/null +++ b/opcodes.c @@ -0,0 +1,178 @@ + +#define _I(n) sexp_make_fixnum(n) +#define _OP(c,o,n,m,rt,a1,a2,a3,i,s,d,f) {c, o, n, m, i, s, d, NULL, NULL, rt, a1, a2, a3, f} +#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, rt, a1, a2, a3, 0, s, d, (sexp_proc1)f) +#define _FN0(rt, s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, rt, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1OPT(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1OPTP(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN2(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN2OPT(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN2OPTP(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN3(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, rt, a1, a2, a3, s, d, f) +#define _FN4(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, rt, a1, a2, a3, s, d, f) +#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, t, SEXP_FALSE, SEXP_FALSE, 0, n, a, 0) + +static struct sexp_opcode_struct opcodes[] = { +_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "car", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF, 2, 0, _I(SEXP_OBJECT), _I(SEXP_VECTOR), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET, 3, 0, SEXP_VOID, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_VECTOR), SEXP_FALSE, SEXP_FALSE, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"byte-vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET, 3, 0, SEXP_VOID, _I(SEXP_BYTES), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0,"byte-vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), SEXP_FALSE, SEXP_FALSE, 0,"byte-vector-length", 0, NULL), +#if SEXP_USE_UTF8_STRINGS +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-cursor-ref", 0, NULL), +#else +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-ref", 0, NULL), +#endif +#if SEXP_USE_MUTABLE_STRINGS +#if SEXP_USE_UTF8_STRINGS +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), 0,"string-cursor-set!", 0, NULL), +#else +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), 0,"string-set!", 0, NULL), +#endif +#endif +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), SEXP_FALSE, SEXP_FALSE, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, _I(SEXP_FLONUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, _I(SEXP_CHAR), _I(SEXP_FIXNUM), SEXP_FALSE, SEXP_FALSE, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "+", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "*", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "-", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "/", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, _I(SEXP_PAIR), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), SEXP_FALSE, 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, _I(SEXP_PROCEDURE), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_BYTECODE), 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, _I(SEXP_EXCEPTION), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA, 2, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "is-a?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "pair?", _I(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "string?", _I(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "vector?", _I(SEXP_VECTOR), 0), +#if SEXP_USE_IMMEDIATE_FLONUMS +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op), +#else +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "flonum?", _I(SEXP_FLONUM), 0), +#endif +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "bignum?", _I(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "closure?", _I(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "opcode?", _I(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "input-port?", _I(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "output-port?", _I(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), SEXP_FALSE, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, SEXP_VOID, _I(SEXP_OPORT), SEXP_FALSE, SEXP_FALSE, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_FN1OPTP(_I(SEXP_OBJECT), _I(SEXP_IPORT), "read", (sexp)"*current-input-port*", sexp_read_op), +_FN2OPTP(SEXP_VOID,_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"*current-output-port*", sexp_write_op), +_FN2OPTP(SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"*current-output-port*", sexp_display_op), +_FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op), +_FN2(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op), +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "list?", 0, sexp_listp_op), +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "identifier?", 0, sexp_identifierp_op), +_FN1(_I(SEXP_SYMBOL), _I(SEXP_OBJECT), "identifier->symbol", 0, sexp_syntactic_closure_expr_op), +_FN4(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_ENV), _I(SEXP_OBJECT), "identifier=?", 0, sexp_identifier_eq_op), +_FN1(_I(SEXP_FIXNUM), SEXP_NULL, "length", 0, sexp_length_op), +_FN1(SEXP_NULL, SEXP_NULL, "reverse", 0, sexp_reverse_op), +_FN1(SEXP_NULL, SEXP_NULL, "reverse!", 0, sexp_nreverse_op), +_FN2(SEXP_NULL, SEXP_NULL, SEXP_NULL, "append2", 0, sexp_append2_op), +_FN1(_I(SEXP_VECTOR), SEXP_NULL, "list->vector", 0, sexp_list_to_vector_op), +_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-file", 0, sexp_open_input_file_op), +_FN1(_I(SEXP_OPORT), _I(SEXP_STRING), "open-output-file", 0, sexp_open_output_file_op), +_FN1(SEXP_VOID, _I(SEXP_IPORT), "close-input-port", 0, sexp_close_port_op), +_FN1(SEXP_VOID, _I(SEXP_OPORT), "close-output-port", 0, sexp_close_port_op), +_FN0(_I(SEXP_ENV), "make-environment", 0, sexp_make_env_op), +_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op), +_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op), +_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "eval", (sexp)"*interaction-environment*", sexp_eval_op), +_FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"*interaction-environment*", sexp_load_op), +_FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%env-copy!", 0, sexp_env_copy_op), +_FN2(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op), +_FN1(_I(SEXP_OBJECT), _I(SEXP_EXCEPTION), "exception-type", 0, sexp_exception_type_op), +_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "make-string", sexp_make_character(' '), sexp_make_string_op), +_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-byte-vector", SEXP_ZERO, sexp_make_bytes_op), +_FN2OPT(_I(SEXP_NUMBER), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string->number", SEXP_TEN, sexp_string_to_number_op), +_FN3(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_BOOLEAN), "string-cmp", 0, sexp_string_cmp_op), +_FN3(_I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "substring", 0, sexp_substring_op), +_FN1(_I(SEXP_SYMBOL), _I(SEXP_STRING), "string->symbol", 0, sexp_string_to_symbol_op), +_FN2OPT(_I(SEXP_STRING), SEXP_NULL, _I(SEXP_STRING), "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op), +_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "memq", 0, sexp_memq_op), +_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "assq", 0, sexp_assq_op), +_FN3(_I(SEXP_SYNCLO), _I(SEXP_ENV), SEXP_NULL, _I(SEXP_OBJECT), "make-syntactic-closure", 0, sexp_make_synclo_op), +_FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip_synclos), +_PARAM("current-input-port", (sexp)"*current-input-port*", _I(SEXP_IPORT)), +_PARAM("current-output-port", (sexp)"*current-output-port*", _I(SEXP_OPORT)), +_PARAM("current-error-port", (sexp)"*current-error-port*", _I(SEXP_OPORT)), +_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", _I(SEXP_PROCEDURE)), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", _I(SEXP_ENV)), +_FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_make_output_string_port_op), +_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_make_input_string_port_op), +_FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op), +#if SEXP_USE_MATH +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "exp", 0, sexp_exp), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "log", 0, sexp_log), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sin", 0, sexp_sin), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "cos", 0, sexp_cos), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "tan", 0, sexp_tan), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "asin", 0, sexp_asin), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "acos", 0, sexp_acos), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "atan1", 0, sexp_atan), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sqrt", 0, sexp_sqrt), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "round", 0, sexp_round), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "truncate", 0, sexp_trunc), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "floor", 0, sexp_floor), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "ceiling", 0, sexp_ceiling), +#endif +_FN2(_I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), "expt", 0, sexp_expt_op), +#if SEXP_USE_UTF8_STRINGS +_FN2(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-index->offset", 0, sexp_string_index_to_offset), +_FN2(_I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-ref", 0, sexp_string_utf8_index_ref), +_FN3(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "string-set!", 0, sexp_string_utf8_index_set), +#endif +#if SEXP_USE_TYPE_DEFS +_FN2(_I(SEXP_TYPE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "register-simple-type", 0, sexp_register_simple_type_op), +_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0, sexp_make_type_predicate_op), +_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op), +_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op), +_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-setter", 0, sexp_make_setter_op), +#endif +#if PLAN9 +#include "opt/plan9-opcodes.c" +#endif +#if SEXP_USE_MODULES +_FN0(_I(SEXP_ENV), "current-environment", 0, sexp_current_environment), +_FN1(SEXP_NULL, _I(SEXP_ENV), "env-exports", 0, sexp_env_exports_op), +_FN1(_I(SEXP_STRING), _I(SEXP_STRING), "find-module-file", 0, sexp_find_module_file_op), +_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load-module-file", 0, sexp_load_module_file_op), +_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_BOOLEAN), "add-module-directory", 0, sexp_add_module_directory_op), +#endif +#if SEXP_USE_GREEN_THREADS +_OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, SEXP_VOID, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, 0, "thread-yield!", 0, NULL), +#endif +}; + + diff --git a/opt/bignum.c b/opt/bignum.c new file mode 100644 index 00000000..767d8898 --- /dev/null +++ b/opt/bignum.c @@ -0,0 +1,775 @@ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_INIT_BIGNUM_SIZE 2 + +#define sexp_negate(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_fixnump(x)) \ + x = sexp_fx_neg(x); + +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { + sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + sexp_bignum_length(res) = len; + sexp_bignum_sign(res) = 1; + return res; +} + +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { + sexp res = sexp_make_bignum(ctx, 1); + sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a)); + sexp_bignum_sign(res) = sexp_fx_sign(a); + return res; +} + +sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { + sexp res; + if ((SEXP_MIN_FIXNUM <= x) && (x <= SEXP_MAX_FIXNUM)) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + if (x < 0) { + sexp_bignum_sign(res) = -1; + sexp_bignum_data(res)[0] = -x; + } else { + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + } + return res; +} + +sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { + sexp res; + if (x <= SEXP_MAX_FIXNUM) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + return res; +} + +#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) +#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) + +sexp sexp_double_to_bignum (sexp ctx, double f) { + int sign; + sexp_gc_var3(res, scale, tmp); + sexp_gc_preserve3(ctx, res, scale, tmp); + res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + sign = (f < 0 ? -1 : 1); + for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { + tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); + res = sexp_bignum_add(ctx, res, res, tmp); + scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); + } + sexp_bignum_sign(res) = sign; + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { + sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size; + size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + if (! dst || sexp_bignum_length(dst) < len) { + dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + memmove(dst, a, size); + sexp_bignum_length(dst) = len; + } else { + memset(dst->value.bignum.data, 0, + sexp_bignum_length(dst)*sizeof(sexp_uint_t)); + memmove(dst->value.bignum.data, a->value.bignum.data, + sexp_bignum_length(a)*sizeof(sexp_uint_t)); + } + return dst; +} + +int sexp_bignum_zerop (sexp a) { + int i; + sexp_uint_t *data = sexp_bignum_data(a); + for (i=sexp_bignum_length(a)-1; i>=0; i--) + if (data[i]) + return 0; + return 1; +} + +sexp_uint_t sexp_bignum_hi (sexp a) { + sexp_uint_t i=sexp_bignum_length(a)-1; + while ((i>0) && ! sexp_bignum_data(a)[i]) + i--; + return i+1; +} + +sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) { + int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b); + sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b); + if (ai != bi) + return ai - bi; + for (--ai; ai >= 0; ai--) { + if (adata[ai] > bdata[ai]) + return 1; + else if (adata[ai] < bdata[ai]) + return -1; + } + return 0; +} + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { + if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) + return sexp_bignum_sign(a); + return sexp_bignum_compare_abs(a, b); +} + +sexp sexp_bignum_normalize (sexp a) { + sexp_uint_t *data; + if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) + return a; + data = sexp_bignum_data(a); + if ((data[0] > SEXP_MAX_FIXNUM) + && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1))) + return a; + return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a)); +} + +double sexp_bignum_to_double (sexp a) { + double res = 0; + sexp_sint_t i; + sexp_uint_t *data=sexp_bignum_data(a); + for (i=sexp_bignum_hi(a)-1; i>=0; i--) + res = res * ((double)SEXP_UINT_T_MAX+1) + data[i]; + return res * sexp_bignum_sign(a); +} + +sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), + carry=b, i=0, n; + do { n = data[i]; + data[i] += carry; + carry = (n > (SEXP_UINT_T_MAX - carry)); + } while (++i> (sizeof(sexp_uint_t)*8); + } + if (carry) { + if (sexp_bignum_length(d)+offset <= len) + d = sexp_copy_bignum(ctx, NULL, d, len+offset+1); + sexp_bignum_data(d)[len+offset] = carry; + } + sexp_gc_release1(ctx); + return d; +} + +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0; + int i; + sexp_luint_t n = 0; + for (i=len-1; i>=offset; i--) { + n = (n << sizeof(sexp_uint_t)*8) + data[i]; + q = n / b; + r = n - (sexp_luint_t)q * b; + data[i] = q; + n = r; + } + return r; +} + +sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, + char sign, sexp_uint_t base) { + int c, digit; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE); + sexp_bignum_sign(res) = sign; + sexp_bignum_data(res)[0] = init; + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + res = sexp_bignum_fxmul(ctx, res, res, base, 0); + res = sexp_bignum_fxadd(ctx, res, digit); + } + if (c=='.' || c=='e' || c=='E') { + if (base != 10) { + res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + } else { + if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */ + res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); + } + } else if ((c!=EOF) && ! is_separator(c)) { + res = sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + } else { + sexp_push_char(ctx, c, in); + } + sexp_gc_release1(ctx); + return sexp_bignum_normalize(res); +} + +static int log2i(int v) { + int i; + for (i = 0; i < sizeof(v)*8; i++) + if ((1<<(i+1)) > v) + break; + return i; +} + +sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { + int i, str_len, lg_base = log2i(base); + char *data; + sexp_gc_var2(b, str); + sexp_gc_preserve2(ctx, b, str); + b = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(b) = 1; + i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) + / lg_base + 1; + str = sexp_make_string(ctx, sexp_make_fixnum(str_len), + sexp_make_character(' ')); + data = sexp_string_data(str); + while (! sexp_bignum_zerop(b)) + data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0)); + if (i == str_len) + data[--i] = '0'; + else if (sexp_bignum_sign(a) == -1) + data[--i] = '-'; + sexp_write_string(ctx, data + i, out); + sexp_gc_release2(ctx); + return SEXP_VOID; +} + +/****************** bignum arithmetic *************************/ + +sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(c); + sexp_gc_preserve1(ctx, c); + c = sexp_copy_bignum(ctx, NULL, a, 0); + if (sexp_bignum_sign(c) == sexp_fx_sign(b)) + c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + else + c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + sexp_gc_release1(ctx); + return c; +} + +sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), + borrow=0, i, *adata, *bdata, *cdata; + sexp_gc_var1(c); + if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) + return sexp_bignum_sub_digits(ctx, dst, b, a); + sexp_gc_preserve1(ctx, c); + c = ((dst && sexp_bignum_hi(dst) >= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0); + } + for ( ; carry && (i= 0 ? a : b); + } + return res; +} + +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { + sexp res; + if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { + res = sexp_bignum_sub_digits(ctx, dst, a, b); + sexp_bignum_sign(res) + = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a) + : -sexp_bignum_sign(a)); + } else { + res = sexp_bignum_add_digits(ctx, dst, a, b); + sexp_bignum_sign(res) = sexp_bignum_sign(a); + } + return res; +} + +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, + *bdata=sexp_bignum_data(b); + sexp_gc_var2(c, d); + if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); + sexp_gc_preserve2(ctx, c, d); + c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); + d = sexp_make_bignum(ctx, alen+blen+1); + for (i=0; i 0) { + *rem = a; + return sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + } + sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); + k2 = sexp_bignum_double(ctx, k); + i2 = sexp_bignum_double(ctx, i); + x = quot_step(ctx, rem, a, b, k2, i2); + prod = sexp_bignum_mul(ctx, NULL, x, b); + diff = sexp_bignum_sub_digits(ctx, NULL, a, prod); + if (sexp_bignum_compare(diff, k) >= 0) { + *rem = sexp_bignum_sub_digits(ctx, NULL, diff, k); + res = sexp_bignum_add_digits(ctx, NULL, x, i); + } else { + *rem = diff; + res = x; + } + sexp_gc_release5(ctx); + return res; +} + +sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { + sexp res; + sexp_gc_var4(k, i, a1, b1); + sexp_gc_preserve4(ctx, k, i, a1, b1); + a1 = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(a1) = 1; + b1 = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_bignum_sign(b1) = 1; + k = sexp_copy_bignum(ctx, NULL, b1, 0); + i = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + res = quot_step(ctx, rem, a1, b1, k, i); + sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); + if (sexp_bignum_sign(a) < 0) { + sexp_negate(*rem); + } + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { + sexp res; + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + res = sexp_bignum_quot_rem(ctx, &rem, a, b); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */ + sexp_gc_release1(ctx); + return rem; +} + +sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { + sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b)); + sexp_gc_var2(res, acc); + sexp_gc_preserve2(ctx, res, acc); + res = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + acc = sexp_copy_bignum(ctx, NULL, a, 0); + for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) + if (e & 1) + res = sexp_bignum_mul(ctx, NULL, res, acc); + sexp_gc_release2(ctx); + return res; +} + +/****************** generic arithmetic ************************/ + +enum sexp_number_types { + SEXP_NUM_NOT = 0, + SEXP_NUM_FIX, + SEXP_NUM_FLO, + SEXP_NUM_BIG +}; + +enum sexp_number_combs { + SEXP_NUM_NOT_NOT = 0, + SEXP_NUM_NOT_FIX, + SEXP_NUM_NOT_FLO, + SEXP_NUM_NOT_BIG, + SEXP_NUM_FIX_NOT, + SEXP_NUM_FIX_FIX, + SEXP_NUM_FIX_FLO, + SEXP_NUM_FIX_BIG, + SEXP_NUM_FLO_NOT, + SEXP_NUM_FLO_FIX, + SEXP_NUM_FLO_FLO, + SEXP_NUM_FLO_BIG, + SEXP_NUM_BIG_NOT, + SEXP_NUM_BIG_FIX, + SEXP_NUM_BIG_FLO, + SEXP_NUM_BIG_BIG +}; + +static int sexp_number_types[] = + {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0}; + +static int sexp_number_type (sexp a) { + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] +#if SEXP_USE_IMMEDIATE_FLONUMS + : sexp_flonump(a) ? 2 +#endif + : sexp_fixnump(a); +} + +sexp sexp_add (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_add(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_add(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_add(ctx, NULL, b, a)); + break; + } + return r; +} + +sexp sexp_sub (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_sub(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + tmp = sexp_fixnum_to_bignum(ctx, a); + r = sexp_bignum_sub(ctx, NULL, b, tmp); + sexp_negate(r); + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)+sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_sub(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + tmp = sexp_fixnum_to_bignum(ctx, b); + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, tmp)); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) - sexp_flonum_value(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_mul (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_mul(a, b); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0); + sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_mul(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_mul(ctx, NULL, a, b); + break; + } + return r; +} + +sexp sexp_div (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + double f; + sexp r=SEXP_VOID; + sexp_gc_var2(tmp, rem); + sexp_gc_preserve2(ctx, tmp, rem); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: + f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b); + r = ((f == trunc(f)) ? sexp_make_fixnum((sexp_sint_t)f) + : sexp_make_flonum(ctx, f)); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_flonum_value(a)/sexp_fixnum_to_double(b)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_div(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_quot_rem(ctx, &rem, a, b); + if (sexp_bignum_normalize(rem) != SEXP_ZERO) + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) + / sexp_bignum_to_double(b)); + else + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b)); + break; + } + sexp_gc_release2(ctx); + return r; +} + +sexp sexp_quotient (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_div(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = SEXP_ZERO; + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_remainder (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_rem(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = a; + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_compare (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + double f; + if (at > bt) { + r = sexp_compare(ctx, b, a); + sexp_negate(r); + } else { + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); + break; + case SEXP_NUM_FIX_FLO: + f = sexp_fixnum_to_double(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(-1); + break; + case SEXP_NUM_FLO_FLO: + f = sexp_flonum_value(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FLO_BIG: + f = sexp_flonum_value(a) - sexp_bignum_to_double(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_make_fixnum(sexp_bignum_compare(a, b)); + break; + } + } + return r; +} + diff --git a/opt/fcall.c b/opt/fcall.c new file mode 100644 index 00000000..c38cc3fe --- /dev/null +++ b/opt/fcall.c @@ -0,0 +1,33 @@ + +typedef sexp (*sexp_proc8) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc9) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc10) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc11) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc12) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc13) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc14) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc15) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc16) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc17) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); + +#define _A(i) stack[top-i] + +sexp sexp_fcall (sexp ctx, sexp self, sexp_sint_t n, sexp f) { + sexp *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx); + switch (n) { + case 5: return ((sexp_proc6)sexp_opcode_func(f))(ctx, f, 5, _A(1), _A(2), _A(3), _A(4), _A(5)); + case 6: return ((sexp_proc7)sexp_opcode_func(f))(ctx, f, 6, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6)); + case 7: return ((sexp_proc8)sexp_opcode_func(f))(ctx, f, 7, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7)); + case 8: return ((sexp_proc9)sexp_opcode_func(f))(ctx, f, 8, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8)); + case 9: return ((sexp_proc10)sexp_opcode_func(f))(ctx, f, 9, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9)); + case 10: return ((sexp_proc11)sexp_opcode_func(f))(ctx, f, 10, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10)); + case 11: return ((sexp_proc12)sexp_opcode_func(f))(ctx, f, 11, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11)); + case 12: return ((sexp_proc13)sexp_opcode_func(f))(ctx, f, 12, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12)); + case 13: return ((sexp_proc14)sexp_opcode_func(f))(ctx, f, 13, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13)); + case 14: return ((sexp_proc15)sexp_opcode_func(f))(ctx, f, 14, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14)); + case 15: return ((sexp_proc16)sexp_opcode_func(f))(ctx, f, 15, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15)); + case 16: return ((sexp_proc17)sexp_opcode_func(f))(ctx, f, 16, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16)); + default: return sexp_user_exception(ctx, self, "too many FFI arguments", f); + } +} diff --git a/opt/opcode_names.h b/opt/opcode_names.h new file mode 100644 index 00000000..a87aeb1c --- /dev/null +++ b/opt/opcode_names.h @@ -0,0 +1,21 @@ + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALLN", + "JUMP-UNLESS", "JUMP", "PUSH", "DROP", + "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", + "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", + "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", + "BYTES-REF", "BYTES-SET", "BYTES-LENGTH", + "STRING-REF", "STRING-SET", "STRING-LENGTH", + "MAKE-PROCEDURE", "MAKE-VECTOR", + "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", + "ISA?", "SLOTN-REF", "SLOTN-SET", + "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", + "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", + "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", + "YIELD", "RET", "DONE", + }; diff --git a/opt/plan9-opcodes.c b/opt/plan9-opcodes.c new file mode 100644 index 00000000..9f7cac33 --- /dev/null +++ b/opt/plan9-opcodes.c @@ -0,0 +1,19 @@ +_FN0("random-integer", 0, sexp_rand), +_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), +_FN0("current-directory", 0, sexp_getwd), +_FN0("current-user", 0, sexp_getuser), +_FN0("system-name", 0, sexp_sysname), +_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), +_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), +_FN0("fork", 0, sexp_fork), +_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), +_FN1(SEXP_STRING, "exits", 0, sexp_exits), +_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), +_FN0("pipe", 0, sexp_pipe), +_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), +_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), +_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), +_FN0("wait", 0, sexp_wait), +_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), +_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), +_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), diff --git a/opt/plan9.c b/opt/plan9.c new file mode 100644 index 00000000..ca25afba --- /dev/null +++ b/opt/plan9.c @@ -0,0 +1,351 @@ +/* plan9.c -- extended Plan 9 system utils */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +sexp sexp_rand (sexp ctx sexp_api_params(self, n)) { + return sexp_make_fixnum(rand()); +} + +sexp sexp_srand (sexp ctx sexp_api_params(self, n), sexp seed) { + srand(sexp_unbox_fixnum(seed)); + return SEXP_VOID; +} + +sexp sexp_file_exists_p (sexp ctx sexp_api_params(self, n), sexp path) { + int res; + uchar statbuf[STATMAX]; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "file-exists?: not a string", path); + res = stat(sexp_string_data(path), statbuf, sizeof(statbuf)); + return (res < 0) ? SEXP_FALSE : SEXP_TRUE; +} + +sexp sexp_fdopen (sexp ctx sexp_api_params(self, n), sexp fd, sexp mode) { + FILE *f; + if (! sexp_integerp(fd)) + return sexp_type_exception(ctx, "fdopen: not an integer", fd); + if (! sexp_stringp(mode)) + return sexp_type_exception(ctx, "fdopen: not a mode string", mode); + f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode)); + if (! f) + return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd); + /* maybe use fd2path to get the name of the fd */ + if (sexp_string_data(mode)[0] == 'w') + return sexp_make_output_port(ctx, f, SEXP_FALSE); + else + return sexp_make_input_port(ctx, f, SEXP_FALSE); +} + +sexp sexp_fileno (sexp ctx sexp_api_params(self, n), sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "fileno: not a port", port); + return sexp_make_fixnum(fileno(sexp_port_stream(port))); +} + +sexp sexp_fork (sexp ctx sexp_api_params(self, n)) { + return sexp_make_fixnum(fork()); +} + +sexp sexp_exec (sexp ctx sexp_api_params(self, n), sexp name, sexp args) { + int i, len = sexp_unbox_fixnum(sexp_length(ctx, args)); + char **argv = malloc((len+1)*sizeof(char*)); + for (i=0; imsg, -1); + res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg); + sexp_gc_release(ctx, msg, s_msg); + return res; +} + +sexp sexp_postnote (sexp ctx sexp_api_params(self, n), sexp pid, sexp note) { + if (! sexp_integerp(pid)) + return sexp_type_exception(ctx, "postnote: not an integer", pid); + if (! sexp_stringp(note)) + return sexp_type_exception(ctx, "postnote: not a string", note); + postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note)); + return SEXP_VOID; +} + +/**********************************************************************/ +/* 9p interface */ + +typedef struct sexp_plan9_srv { + sexp context, auth, attach, walk, walk1, clone, open, create, remove, + read, write, stat, wstat, flush, destroyfid, destroyreq, end; +} *sexp_plan9_srv; + +void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) { + s->context = ctx; + s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open + = s->create = s->remove = s->read = s->write = s->stat = s->wstat + = s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE; + for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) { + if (sexp_car(ls) == sexp_intern(ctx, "auth:", -1)) { + s->auth = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "attach:", -1)) { + s->attach = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk:", -1)) { + s->walk = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:", -1)) { + s->walk1 = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "clone:", -1)) { + s->clone = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "open:", -1)) { + s->open = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "create:", -1)) { + s->create = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "remove:", -1)) { + s->remove = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "read:", -1)) { + s->read = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "write:", -1)) { + s->write = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "stat:", -1)) { + s->stat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:", -1)) { + s->wstat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "flush:", -1)) { + s->flush = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:", -1)) { + s->destroyfid = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:", -1)) { + s->destroyreq = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "end:", -1)) { + s->end = sexp_cadr(ls); + } + } +} + +void sexp_run_9p_handler (Req *r, sexp handler) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, handler, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +#define sexp_def_9p_handler(name, field) \ + void name (Req *r) { \ + sexp_run_9p_handler(r, ((sexp_plan9_srv)r->srv->aux)->field); \ + } + +sexp_def_9p_handler(sexp_9p_auth, auth) +sexp_def_9p_handler(sexp_9p_attach, attach) +sexp_def_9p_handler(sexp_9p_walk, walk) +sexp_def_9p_handler(sexp_9p_open, open) +sexp_def_9p_handler(sexp_9p_create, create) +sexp_def_9p_handler(sexp_9p_remove, remove) +sexp_def_9p_handler(sexp_9p_read, read) +sexp_def_9p_handler(sexp_9p_write, write) +sexp_def_9p_handler(sexp_9p_stat, stat) +sexp_def_9p_handler(sexp_9p_wstat, wstat) +sexp_def_9p_handler(sexp_9p_flush, flush) + +char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_c_string(ctx, name, -1); + args = sexp_cons(ctx, ptr, args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->walk1, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +char* sexp_9p_clone (Fid *oldfid, Fid *newfid) { + sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->clone, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +void sexp_9p_destroyfid (Fid *fid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyfid, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_destroyreq (Req *r) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyreq, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_end (Srv *srv) { + sexp_plan9_srv s = (sexp_plan9_srv)srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->end, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +sexp sexp_postmountsrv (sexp ctx sexp_api_params(self, n), sexp ls, sexp name, sexp mtpt, sexp flags) { + Srv s; + struct sexp_plan9_srv p9s; + if (! sexp_listp(ctx, ls)) + return sexp_type_exception(ctx, "postmountsrv: not a list", ls); + if (! sexp_stringp(name)) + return sexp_type_exception(ctx, "postmountsrv: not a string", name); + if (! sexp_stringp(mtpt)) + return sexp_type_exception(ctx, "postmountsrv: not a string", mtpt); + if (! sexp_integerp(flags)) + return sexp_type_exception(ctx, "postmountsrv: not an integer", flags); + sexp_build_srv(ctx, &p9s, ls); + s.aux = &p9s; + s.auth = &sexp_9p_auth; + s.attach = &sexp_9p_attach; + s.walk = &sexp_9p_walk; + s.walk1 = &sexp_9p_walk1; + s.clone = &sexp_9p_clone; + s.open = &sexp_9p_open; + s.create = &sexp_9p_create; + s.remove = &sexp_9p_remove; + s.read = &sexp_9p_read; + s.write = &sexp_9p_write; + s.stat = &sexp_9p_stat; + s.wstat = &sexp_9p_wstat; + s.flush = &sexp_9p_flush; + s.destroyfid = &sexp_9p_destroyfid; + s.destroyreq = &sexp_9p_destroyreq; + s.end = &sexp_9p_end; + postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt), + sexp_unbox_fixnum(flags)); + return SEXP_UNDEF; +} + +sexp sexp_9p_req_offset (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset); +} + +sexp sexp_9p_req_count (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count); +} + +#if 0 +sexp sexp_9p_req_path (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1); +} +#endif + +sexp sexp_9p_req_fid (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0); +} + +sexp sexp_9p_req_newfid (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0); +} + +sexp sexp_9p_respond (sexp ctx sexp_api_params(self, n), sexp req, sexp err) { + char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil; + respond(sexp_cpointer_value(req), cerr); + return SEXP_VOID; +} + +sexp sexp_9p_responderror (sexp ctx sexp_api_params(self, n), sexp req) { + responderror(sexp_cpointer_value(req)); + return SEXP_VOID; +} + 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/opt/simplify.c b/opt/simplify.c new file mode 100644 index 00000000..4217a1bb --- /dev/null +++ b/opt/simplify.c @@ -0,0 +1,143 @@ +/* simplify.c -- basic simplification pass */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda)) + +static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { + int check; + sexp ls1, ls2, p1, p2, sv, ctx2; + sexp_gc_var4(res, substs, tmp, app); + sexp_gc_preserve4(ctx, res, substs, tmp, app); + res = ast; /* return the ast as-is by default */ + substs = init_substs; + + loop: + switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) { + + case SEXP_PAIR: + /* don't simplify the operator if it's a lambda because we + simplify that as a special case below, with the appropriate + substs list */ + app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res) + : (tmp=simplify(ctx, sexp_car(res), substs, lambda))); + for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); + app = sexp_nreverse(ctx, app); + /* app now holds a copy of the list, and is the default result + (res = app below) if we don't replace it with a simplification */ + if (sexp_opcodep(sexp_car(app))) { + /* opcode app - right now we just constant fold arithmetic */ + if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) { + for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { + if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { + check = 0; + break; + } + } + if (check) { + ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0); + generate(ctx2, app); + res = finalize_bytecode(ctx2); + if (! sexp_exceptionp(res)) { + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp); + if (! sexp_exceptionp(tmp)) { + tmp = sexp_apply(ctx2, tmp, SEXP_NULL); + if (! sexp_exceptionp(tmp)) + app = sexp_make_lit(ctx2, tmp); + } + } + } + } + } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */ + p1 = NULL; + p2 = sexp_lambda_params(sexp_car(app)); + ls1 = app; + ls2 = sexp_cdr(app); + sv = sexp_lambda_sv(sexp_car(app)); + for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) { + if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv)) + && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2)) + || (sexp_refp(sexp_car(ls2)) + && sexp_lambdap(sexp_ref_loc(sexp_car(ls2))) + && sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)), + sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) { + tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2)); + tmp = sexp_cons(ctx, sexp_car(p2), tmp); + sexp_push(ctx, substs, tmp); + sexp_cdr(ls1) = sexp_cdr(ls2); + if (p1) + sexp_cdr(p1) = sexp_cdr(p2); + else + sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2); + } else { + p1 = p2; + ls1 = ls2; + } + } + sexp_lambda_body(sexp_car(app)) + = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app)); + if (sexp_nullp(sexp_cdr(app)) + && sexp_nullp(sexp_lambda_params(sexp_car(app))) + && sexp_nullp(sexp_lambda_defs(sexp_car(app)))) + app = sexp_lambda_body(sexp_car(app)); + } + res = app; + break; + + case SEXP_LAMBDA: + sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res); + break; + + case SEXP_CND: + tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda); + if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) { + res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp)) + ? sexp_cnd_fail(res) : sexp_cnd_pass(res); + goto loop; + } else { + sexp_cnd_test(res) = tmp; + simplify_it(sexp_cnd_pass(res)); + simplify_it(sexp_cnd_fail(res)); + } + break; + + case SEXP_REF: + tmp = sexp_ref_name(res); + for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) { + res = sexp_cddar(ls1); + break; + } + break; + + case SEXP_SET: + simplify_it(sexp_set_value(res)); + break; + + case SEXP_SEQ: + app = SEXP_NULL; + for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { + tmp = simplify(ctx, sexp_car(ls2), substs, lambda); + if (! (sexp_pairp(sexp_cdr(ls2)) + && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) + || sexp_lambdap(tmp)))) + sexp_push(ctx, app, tmp); + } + if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app))) + res = sexp_car(app); + else + sexp_seq_ls(res) = sexp_nreverse(ctx, app); + break; + + } + + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_simplify (sexp ctx sexp_api_params(self, n), sexp ast) { + return simplify(ctx, ast, SEXP_NULL, NULL); +} + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..db4c91fe --- /dev/null +++ b/sexp.c @@ -0,0 +1,1842 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* optional huffman-compressed immediate symbols */ +struct sexp_huff_entry { + unsigned char len; + unsigned short bits; +}; + +#if SEXP_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; + +sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp); + +static const 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 (int c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int hex_digit (int n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + +static int is_separator(int c) { + return 0= SEXP_MAXIMUM_TYPES) { + res = sexp_user_exception(ctx, self, "register-type: exceeded maximum type limit", name); + } else if (! sexp_stringp(name)) { + res = sexp_type_exception(ctx, self, SEXP_STRING, name); + } else { + if (num_types >= type_array_size) { + len = type_array_size*2; + if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES; +#if SEXP_USE_GLOBAL_TYPES + new = malloc(len * sizeof(_sexp_type_specs[0])); + for (i=0; i num_types) free(tmp); + sexp_type_array_size = len; +#else + res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID); + v1 = sexp_vector_data(res); + v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)); + for (i=0; ivalue), &(_sexp_type_specs[i]), sizeof(_sexp_type_specs[0])); + vec[i] = type; + } +#endif +} + +#if ! SEXP_USE_GLOBAL_HEAP +sexp sexp_bootstrap_context (sexp_uint_t size) { + sexp dummy_ctx, ctx; + sexp_heap heap; + if (size < SEXP_MINIMUM_HEAP_SIZE) size = SEXP_INITIAL_HEAP_SIZE; + heap = sexp_make_heap(sexp_heap_align(size)); + dummy_ctx = (sexp) malloc(sexp_sizeof(context)); + sexp_pointer_tag(dummy_ctx) = SEXP_CONTEXT; + sexp_context_saves(dummy_ctx) = NULL; + sexp_context_heap(dummy_ctx) = heap; + ctx = sexp_alloc_type(dummy_ctx, context, SEXP_CONTEXT); + sexp_context_heap(dummy_ctx) = NULL; + sexp_context_heap(ctx) = heap; + free(dummy_ctx); + return ctx; +} +#endif + +sexp sexp_make_context (sexp ctx, size_t size) { + sexp_gc_var1(res); + if (ctx) sexp_gc_preserve1(ctx, res); +#if ! SEXP_USE_GLOBAL_HEAP + if (! ctx) res = sexp_bootstrap_context(size); + else +#endif + { + res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); +#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC + sexp_context_heap(res) = sexp_context_heap(ctx); +#endif + } + sexp_context_parent(res) = ctx; + sexp_context_lambda(res) = SEXP_FALSE; + sexp_context_name(res) = sexp_context_specific(res) = SEXP_FALSE; + sexp_context_fv(res) = SEXP_NULL; + sexp_context_saves(res) = NULL; + sexp_context_depth(res)=sexp_context_tracep(res)=sexp_context_pos(res)=0; + sexp_context_tailp(res) = 1; +#if SEXP_USE_GREEN_THREADS + sexp_context_refuel(res) = SEXP_DEFAULT_QUANTUM; +#endif + if (ctx) { + sexp_context_globals(res) = sexp_context_globals(ctx); + sexp_gc_release1(ctx); + } else { + sexp_init_context_globals(res); + } + return res; +} + +#if ! SEXP_USE_GLOBAL_HEAP +void sexp_destroy_context (sexp ctx) { + sexp_heap heap, tmp; + size_t sum_freed; + if (sexp_context_heap(ctx)) { + heap = sexp_context_heap(ctx); + sexp_sweep(ctx, &sum_freed); /* sweep w/o mark to run finalizers */ + sexp_context_heap(ctx) = NULL; + for ( ; heap; heap=tmp) { + tmp = heap->next; +#if SEXP_USE_MMAP_GC + munmap(heap, sexp_heap_pad_size(heap->size)); +#else + free(heap); +#endif + } + } +} +#endif + +/***************************** exceptions *****************************/ + +sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, + 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_source(exn) = source; + return exn; +} + +sexp sexp_string_cat3 (sexp ctx, char *pre, char *mid, char* suf) { + int plen=strlen(pre), mlen=strlen(mid), slen=strlen(suf); + char *s; + sexp str; + str = sexp_make_string(ctx, sexp_make_fixnum(plen+mlen+slen), SEXP_VOID); + memcpy(s=sexp_string_data(str), pre, plen); + memcpy(s+plen, mid, mlen); + memcpy(s+plen+mlen, suf, slen); + return str; +} + +sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { + sexp res; + sexp_gc_var3(sym, str, irr); + sexp_gc_preserve3(ctx, sym, str, irr); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user", -1), + str = sexp_c_string(ctx, ms, -1), + ((sexp_pairp(ir) || sexp_nullp(ir)) + ? ir : (irr = sexp_list1(ctx, ir))), + self, SEXP_FALSE); + sexp_gc_release3(ctx); + return res; +} + +static sexp type_exception (sexp ctx, sexp self, sexp str, sexp obj, sexp src) { + sexp_gc_var2(res, sym); + sexp_gc_preserve2(ctx, res, sym); + sym = sexp_intern(ctx, "type", -1); + res = sexp_make_exception(ctx, sym, str, obj, self, src); + sexp_exception_irritants(res)=sexp_list1(ctx, sexp_exception_irritants(res)); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_c_string(ctx, msg, -1); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_string_cat3(ctx, "invalid type, expected ", + sexp_type_name_by_index(ctx, type_id), ""); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { + sexp_gc_var2(res, msg); + sexp_gc_preserve2(ctx, res, 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", -1), msg, res, + SEXP_FALSE, SEXP_FALSE); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out) { + sexp ls; + if (! sexp_oportp(out)) + out = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_write_string(ctx, "ERROR", out); + if (sexp_exceptionp(exn)) { + if (sexp_exception_procedure(exn)) { + if (sexp_procedurep(sexp_exception_procedure(exn))) { + ls = sexp_bytecode_name( + sexp_procedure_code(sexp_exception_procedure(exn))); + if (ls && sexp_symbolp(ls)) { + sexp_write_string(ctx, " in ", out); + sexp_write(ctx, ls, out); + } + } else if (sexp_opcodep(sexp_exception_procedure(exn))) { + sexp_write_string(ctx, " in ", out); + sexp_write_string(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out); + } + } + ls = sexp_exception_source(exn); + if ((! (ls && sexp_pairp(ls))) + && sexp_exception_procedure(exn) + && sexp_procedurep(sexp_exception_procedure(exn))) + ls = sexp_bytecode_source(sexp_procedure_code(sexp_exception_procedure(exn))); + if (ls && sexp_pairp(ls)) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(sexp_exception_message(exn))) + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); + else + sexp_write(ctx, 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, const char *msg, sexp ir, sexp port) { + sexp res; + sexp_gc_var4(sym, name, str, irr); + sexp_gc_preserve4(ctx, sym, name, str, irr); + name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); + name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port))); + str = sexp_c_string(ctx, msg, -1); + irr = ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir)); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read", -1), + str, irr, SEXP_FALSE, name); + sexp_gc_release4(ctx); + return res; +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons_op (sexp ctx sexp_api_params(self, n), sexp head, sexp tail) { + sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); + if (sexp_exceptionp(pair)) return 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_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_listp_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(ctx, sexp_car(ls), res); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp a, b, tmp; + if (ls == SEXP_NULL) return ls; + sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, ls); + 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_copy_list_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp tmp; + sexp_gc_var1(res); + if (! sexp_pairp(ls)) return ls; + sexp_gc_preserve1(ctx, res); + tmp = res = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + for (ls=sexp_cdr(ls); sexp_pairp(ls); ls=sexp_cdr(ls), tmp=sexp_cdr(tmp)) + sexp_cdr(tmp) = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_append2_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + sexp_gc_var2(a1, b1); + sexp_gc_preserve2(ctx, a1, 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_release2(ctx); + return b1; +} + +sexp sexp_length_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp_uint_t res=0; + for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) + ; + return sexp_make_fixnum(res); +} + +sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + sexp_uint_t size; + sexp_sint_t i, len; + sexp t, *p, *q; + char *p0, *q0; + + loop: + if (a == b) + return SEXP_TRUE; + else if ((! sexp_pointerp(a)) || (! sexp_pointerp(b)) + || (sexp_pointer_tag(a) != sexp_pointer_tag(b))) + return SEXP_FALSE; + + /* a and b are both pointers of the same type */ +#if SEXP_USE_BIGNUMS + if (sexp_pointer_tag(a) == SEXP_BIGNUM) + return sexp_make_boolean(!sexp_bignum_compare(a, b)); +#endif +#if SEXP_USE_FLONUMS && ! SEXP_USE_IMMEDIATE_FLONUMS + if (sexp_pointer_tag(a) == SEXP_FLONUM) + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); +#endif + t = sexp_object_type(ctx, a); + p0 = ((char*)a) + offsetof(struct sexp_struct, value); + p = (sexp*) (((char*)a) + sexp_type_field_base(t)); + q0 = ((char*)b) + offsetof(struct sexp_struct, value); + q = (sexp*) (((char*)b) + sexp_type_field_base(t)); + if ((sexp)p == a) {p=(sexp*)p0; q=(sexp*)q0;} + /* check preliminary non-object data */ + if ((p0 < (char*)p) && memcmp(p0, q0, ((char*)p - p0))) + return SEXP_FALSE; + /* check trailing non-object data */ + size = sexp_type_size_of_object(t, a) - offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,a)*sizeof(sexp)); + if (((char*)a + size) > p0) { + q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp)); + if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value)) + return SEXP_FALSE; + if (memcmp(p0, q0, size)) + return SEXP_FALSE; + } + /* check eq-object slots */ + len = sexp_type_num_eq_slots_of_object(t, a); + if (len > 0) { + for (i=0; i> 32; + return r.flonum; +} +sexp sexp_make_flonum (sexp ctx, float f) { + union sexp_flonum_conv x; + x.flonum = f; + return (sexp)(((sexp_uint_t)(x.bits) << 32) + SEXP_IFLONUM_TAG); +} +#endif +#endif + +sexp sexp_make_bytes_op (sexp ctx sexp_api_params(self, n), sexp len, sexp i) { + sexp_sint_t clen = sexp_unbox_fixnum(len); + sexp s; + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len); + if (clen < 0) return sexp_xtype_exception(ctx, self, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(bytes)+clen+1); + if (sexp_exceptionp(s)) return s; + sexp_pointer_tag(s) = SEXP_BYTES; +#if SEXP_USE_HEADER_MAGIC + sexp_pointer_magic(s) = SEXP_POINTER_MAGIC; +#endif + sexp_bytes_length(s) = clen; + if (sexp_fixnump(i)) + memset(sexp_bytes_data(s), sexp_unbox_fixnum(i), clen); + sexp_bytes_data(s)[clen] = '\0'; + return s; +} + +sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) +{ + sexp i = (sexp_charp(ch) ? sexp_make_fixnum(sexp_unbox_character(ch)) : ch); + sexp_gc_var2(b, s); + b = sexp_make_bytes_op(ctx sexp_api_pass(self, n), len, i); + if (sexp_exceptionp(b)) return b; +#if SEXP_USE_PACKED_STRINGS + sexp_pointer_tag(b) = SEXP_STRING; + return b; +#else + sexp_gc_preserve2(ctx, b, s); + s = sexp_alloc_type(ctx, string, SEXP_STRING); + sexp_string_bytes(s) = b; + sexp_string_offset(s) = 0; + sexp_string_length(s) = sexp_unbox_fixnum(len); + sexp_gc_release2(ctx); + return s; +#endif +} + +sexp sexp_c_string (sexp ctx, const char *str, sexp_sint_t slen) { + sexp_sint_t len = ((slen >= 0) ? slen : strlen(str)); + sexp s = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID); + memcpy(sexp_string_data(s), str, len); + sexp_string_data(s)[len] = '\0'; + return s; +} + +sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start); + if (sexp_not(end)) + end = sexp_make_fixnum(sexp_string_length(str)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end); + if ((sexp_unbox_fixnum(start) < 0) + || (sexp_unbox_fixnum(start) > sexp_string_length(str)) + || (sexp_unbox_fixnum(end) < 0) + || (sexp_unbox_fixnum(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_fixnum(start), + sexp_string_length(res)); + sexp_string_data(res)[sexp_string_length(res)] = '\0'; + return res; +} + +sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep) { + sexp res, ls; + sexp_uint_t len=0, i=0, sep_len=0; + char *p, *csep; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception(ctx, self, SEXP_STRING, sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + if (sexp_stringp(sep) && ((sep_len=sexp_string_length(sep)) > 0)) { + csep = sexp_string_data(sep); + len += sep_len*(i-1); + } + res = sexp_make_string(ctx, sexp_make_fixnum(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; + if (sep_len && sexp_pairp(sexp_cdr(ls))) { + memcpy(p, csep, sep_len); + p += sep_len; + } + } + *p = '\0'; + return res; +} + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#if SEXP_USE_HASH_SYMS + +static sexp_uint_t sexp_string_hash(const char *str, sexp_sint_t len, + sexp_uint_t acc) { + for ( ; len; len--) {acc *= FNV_PRIME; acc ^= *str++;} + return acc; +} + +#endif + +sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { +#if SEXP_USE_HUFF_SYMS + struct sexp_huff_entry he; + sexp_uint_t space=3, newbits; + char c; +#endif + sexp_uint_t res=FNV_OFFSET_BASIS, bucket, i=0; + const char *p=str; + sexp ls, tmp; + sexp_gc_var1(sym); + + if (len < 0) len = strlen(str); + +#if SEXP_USE_HUFF_SYMS + res = 0; + for ( ; i 127) + goto normal_intern; + 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); + + normal_intern: +#endif +#if SEXP_USE_HASH_SYMS + bucket = (sexp_string_hash(p, len-i, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if ((sexp_symbol_length(tmp=sexp_car(ls)) == len) + && ! strncmp(str, sexp_symbol_data(tmp), len)) + return sexp_car(ls); + + /* not found, make a new symbol */ + sexp_gc_preserve1(ctx, sym); + sym = sexp_c_string(ctx, str, len); + if (sexp_exceptionp(sym)) return sym; +#if ! SEXP_USE_PACKED_STRINGS + sym = sexp_string_bytes(sym); +#endif + sexp_pointer_tag(sym) = SEXP_SYMBOL; + sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); + sexp_gc_release1(ctx); + return sym; +} + +sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); +} + +sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt) { + sexp vec, *x; + int i, clen = sexp_unbox_fixnum(len); + if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR); + vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); + if (sexp_exceptionp(vec)) return vec; + x = sexp_vector_data(vec); + 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_fixnum(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_fixnum(sexp_stream_size(vec)); + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_stream_ctx(vec), + sexp_make_fixnum(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_fixnum(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_fixnum(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_fixnum(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_fixnum(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_fixnum(pos); + return pos; +} + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + FILE *in; + sexp res; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = str; + sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str)); + sexp_stream_pos(cookie) = SEXP_ZERO; + 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_release1(ctx); + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + FILE *out; + sexp res, size; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + size = sexp_make_fixnum(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(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_ZERO; + 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_release1(ctx); + return res; +} + +sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(ctx, + sexp_stream_buf(cookie), + SEXP_ZERO, + sexp_stream_pos(cookie)); +} + +#else + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + FILE *in; + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + if (sexp_string_length(str) == 0) + in = fopen("/dev/null", "r"); + else + in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + if (in) { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + if (sexp_string_length(str) == 0) + sexp_port_name(res) = sexp_c_string(ctx, "/dev/null", -1); + sexp_port_cookie(res) = str; /* for gc preservation */ + } else { + res = sexp_user_exception(ctx, SEXP_FALSE, "couldn't open string", str); + } + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + 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_op (sexp ctx sexp_api_params(self, n), 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, const 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, const 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_var1(tmp); + if (! sexp_oportp(p)) + return sexp_type_exception(ctx, NULL, SEXP_OPORT, p); + 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_preserve1(ctx, tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_gc_release1(ctx); + } + sexp_port_offset(p) = 0; + return SEXP_VOID; + } +} + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + 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_op (sexp ctx sexp_api_params(self, n)) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + 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_op (sexp ctx sexp_api_params(self, n), sexp out) { + sexp res; + sexp_gc_var2(ls, tmp); + sexp_gc_preserve2(ctx, ls, 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_FALSE); + sexp_gc_release2(ctx); + return res; +} + +#endif + +sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { + sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); + if (sexp_exceptionp(p)) return p; + 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_no_closep(p) = 0; + sexp_port_sourcep(p) = 0; + 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); + if (sexp_exceptionp(p)) return p; + sexp_pointer_tag(p) = SEXP_OPORT; + return p; +} + +#define NUMBUF_LEN 32 + +sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { +#if SEXP_USE_HUFF_SYMS + unsigned long res, c; +#endif + unsigned long len; + long i=0; + double f; + sexp x, *elts; + char *str=NULL, numbuf[NUMBUF_LEN]; + + 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_one(ctx, sexp_car(obj), out); + for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { + sexp_write_char(ctx, ' ', out); + sexp_write_one(ctx, sexp_car(x), out); + } + if (! sexp_nullp(x)) { + sexp_write_string(ctx, " . ", out); + sexp_write_one(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_one(ctx, elts[0], out); + for (i=1; i", out); + break; + case SEXP_SYNCLO: + sexp_write_string(ctx, "#", out); + break; + case SEXP_TYPE: + sexp_write_string(ctx, "#", 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_symbol_length(obj); + str = sexp_symbol_data(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; +#if SEXP_USE_BIGNUMS + case SEXP_BIGNUM: + sexp_write_bignum(ctx, obj, out, 10); + break; +#endif + case SEXP_OPCODE: + sexp_write_string(ctx, "#', out); + break; + default: + i = sexp_pointer_tag(obj); + sexp_write_string(ctx, "#<", out); + sexp_write_string(ctx, + (i < sexp_context_num_types(ctx)) + ? sexp_type_name_by_index(ctx, i) : "invalid", + out); + sexp_write_char(ctx, '>', out); + break; + } + } else if (sexp_fixnump(obj)) { + snprintf(numbuf, NUMBUF_LEN, "%ld", (long)sexp_unbox_fixnum(obj)); + sexp_write_string(ctx, numbuf, out); +#if SEXP_USE_IMMEDIATE_FLONUMS + } else if (sexp_flonump(obj)) { + f = sexp_flonum_value(obj); +#if SEXP_USE_INFINITIES + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else +#endif + { + i = snprintf(numbuf, NUMBUF_LEN, "%.8g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + 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); + c = sexp_unbox_character(obj); + if (c >= 0x100) { + if (c >= 0x10000) { + sexp_write_char(ctx, hex_digit((c>>20)&0x0F), out); + sexp_write_char(ctx, hex_digit((c>>16)&0x0F), out); + } + sexp_write_char(ctx, hex_digit((c>>12)&0x0F), out); + sexp_write_char(ctx, hex_digit((c>>8)&0x0F), out); + } + sexp_write_char(ctx, hex_digit((c>>4)&0x0F), out); + sexp_write_char(ctx, hex_digit(c&0x0F), out); + } + } else if (sexp_symbolp(obj)) { + +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(obj)) { + 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); + } + } + return SEXP_VOID; +} + +sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + return sexp_write_one(ctx, obj, out); +} + +sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { + sexp res=SEXP_VOID; + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + if (sexp_stringp(obj)) + sexp_write_string(ctx, sexp_string_data(obj), out); + else if (sexp_charp(obj)) + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else + res = sexp_write_one(ctx, obj, out); + return res; +} + +sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), sexp out) { + sexp_flush(ctx, out); + return SEXP_VOID; +} + +#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 'r': c = '\r'; break; + case 't': c = '\t'; break; + case 'x': + c = sexp_read_char(ctx, in); + if (isxdigit(c)) { + c = digit_value(c)*16 + digit_value(sexp_read_char(ctx, in)); + } else { + sexp_push_char(ctx, c, in); c = 'x'; + } + } + } + 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, i) : 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, double whole, int negp) { + sexp exponent=SEXP_VOID; + 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; + if (c=='e' || c=='E') { + exponent = sexp_read_number(ctx, in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(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); + } else { + sexp_push_char(ctx, c, in); + } + res = (whole + res) * pow(10, e); + if (negp) res *= -1; + return sexp_make_flonum(ctx, res); +} + +sexp sexp_read_number (sexp ctx, sexp in, int base) { + sexp den; + sexp_uint_t res = 0, tmp; + int c, digit, negativep = 0; + + c = sexp_read_char(ctx, in); + if (c == '-') { + negativep = 1; + c = sexp_read_char(ctx, in); + } + + for ( ; isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + tmp = res * base + digit; +#if SEXP_USE_BIGNUMS + if ((tmp < res) || (tmp > SEXP_MAX_FIXNUM)) { + sexp_push_char(ctx, c, in); + return sexp_read_bignum(ctx, in, res, (negativep ? -1 : 1), base); + } +#endif + res = tmp; + } + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + return sexp_read_float_tail(ctx, in, res, negativep); + } else if (c=='/') { + den = sexp_read_number(ctx, in, base); + if (! sexp_fixnump(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_fixnum(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_fixnum(negativep ? -res : res); +} + +sexp sexp_read_raw (sexp ctx, sexp in) { + char *str; + int c1, c2, line; + sexp tmp2; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + + scan_loop: + switch (c1 = sexp_read_char(ctx, in)) { + case EOF: + if (sexp_at_eofp(in)) + res = SEXP_EOF; + else + goto scan_loop; + 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); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res); + break; + case '`': + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res); + break; + case ',': + if ((c1 = sexp_read_char(ctx, in)) == '@') { + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_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)) { + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } + res = sexp_cons(ctx, tmp, res); + if (sexp_port_sourcep(in) && (line >= 0)) + sexp_pair_source(res) + = sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line)); + tmp = sexp_read_raw(ctx, in); + } + 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_fixnum(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_fixnum((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(ctx, in); + if (sexp_fixnump(res)) + res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res)); + break; + case 'f': case 'F': + case 't': case 'T': + c2 = sexp_read_char(ctx, in); + if (c2 == EOF || is_separator(c2)) { + res = (tolower(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; + break; + case '!': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + sexp_port_line(in)++; + 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); + sexp_push_char(ctx, c1, in); + if (c1 == EOF || is_separator(c1)) { + res = SEXP_RAWDOT; + } else if (isdigit(c1)) { + res = sexp_read_float_tail(ctx, in, 0, 0); + } else { + 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 SEXP_USE_FLONUMS + if (sexp_flonump(res)) +#if SEXP_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 +#if SEXP_USE_BIGNUMS + if (sexp_bignump(res)) { + if ((sexp_bignum_hi(res) == 1) + && (sexp_bignum_data(res)[0] == (SEXP_MAX_FIXNUM+1))) + res = sexp_make_fixnum(-sexp_bignum_data(res)[0]); + else + sexp_bignum_sign(res) = -sexp_bignum_sign(res); + } else +#endif + res = sexp_fx_mul(res, SEXP_NEG_ONE); + } + } else { + sexp_push_char(ctx, c2, in); + res = sexp_read_symbol(ctx, in, c1, 1); +#if SEXP_USE_INFINITIES + if (res == sexp_intern(ctx, "+inf.0", -1)) + res = sexp_make_flonum(ctx, sexp_pos_infinity); + else if (res == sexp_intern(ctx, "-inf.0", -1)) + res = sexp_make_flonum(ctx, sexp_neg_infinity); + else if (res == sexp_intern(ctx, "+nan.0", -1)) + res = sexp_make_flonum(ctx, sexp_nan); +#endif + } + 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_release2(ctx); + return res; +} + +sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in) { + sexp res; + sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in); + res = sexp_read_raw(ctx, in); + if (res == SEXP_CLOSE) + res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); + if (res == SEXP_RAWDOT) + res = sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); + return res; +} + +sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) { + sexp res; + sexp_gc_var2(s, in); + sexp_gc_preserve2(ctx, s, in); + s = sexp_c_string(ctx, str, len); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b) { + int base; + sexp_gc_var1(in); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b); + if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36)) + return sexp_user_exception(ctx, self, "invalid numeric base", b); + sexp_gc_preserve1(ctx, in); + in = sexp_make_input_string_port(ctx, str); + in = ((sexp_string_data(str)[0] == '#') ? + sexp_read(ctx, in) : sexp_read_number(ctx, in, base)); + sexp_gc_release1(ctx); + return sexp_numberp(in) ? in : SEXP_FALSE; +} + +sexp sexp_write_to_string (sexp ctx, sexp obj) { + sexp str; + sexp_gc_var1(out); + sexp_gc_preserve1(ctx, out); + out = sexp_make_output_string_port(ctx); + str = sexp_write(ctx, obj, out); + if (! sexp_exceptionp(str)) + str = sexp_get_output_string(ctx, out); + sexp_gc_release1(ctx); + return str; +} + +void sexp_init (void) { +#if SEXP_USE_GLOBAL_SYMBOLS + int i; +#endif + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if SEXP_USE_BOEHM + GC_init(); +#if SEXP_USE_GLOBAL_SYMBOLS + GC_add_roots((char*)&sexp_symbol_table, + ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); +#endif +#elif ! SEXP_USE_MALLOC + sexp_gc_init(); +#endif +#if SEXP_USE_GLOBAL_SYMBOLS + 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..820020c1 --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,48 @@ + +(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)))) 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/build/build-opts.txt b/tests/build/build-opts.txt new file mode 100644 index 00000000..e6bcd056 --- /dev/null +++ b/tests/build/build-opts.txt @@ -0,0 +1,21 @@ +CPPFLAGS=-DSEXP_USE_MODULES=0 +CPPFLAGS=-DSEXP_USE_DL=0 +CPPFLAGS=-DSEXP_USE_SIMPLIFY=0 +CPPFLAGS=-DSEXP_USE_TYPE_DEFS=0 +SEXP_USE_BOEHM=1 +CPPFLAGS=-DSEXP_USE_DEBUG_GC=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_HEAP=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_TYPES=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_SYMBOLS=1 +CPPFLAGS=-DSEXP_USE_FLONUMS=0 +CPPFLAGS=-DSEXP_USE_IMMEDIATE_FLONUMS=1 +CPPFLAGS=-DSEXP_USE_BIGNUMS=0 +CPPFLAGS=-DSEXP_USE_MATH=0 +CPPFLAGS=-DSEXP_WARN_UNDEFS=0 +CPPFLAGS=-DSEXP_USE_HUFF_SYMS=0 +CPPFLAGS=-DSEXP_USE_HASH_SYMS=0 +CPPFLAGS=-DSEXP_USE_STRING_STREAMS=0 +CPPFLAGS=-DSEXP_USE_AUTOCLOSE_PORTS=0 +CPPFLAGS=-DSEXP_USE_2010_EPOCH=0 +CPPFLAGS=-DSEXP_USE_CHECK_STACK=0 +CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 diff --git a/tests/build/build-tests.sh b/tests/build/build-tests.sh new file mode 100755 index 00000000..1d239629 --- /dev/null +++ b/tests/build/build-tests.sh @@ -0,0 +1,37 @@ +#! /bin/bash + +# test basic build options + +# for bootstrapping reasons this is a shell script, instead of a +# scheme script using (chibi process) + +# we just check each build against r5rs-tests.scm - +# some of the libraries will fail to build (notably +# if modules or user-defined types are disabled). + +BUILDDIR=tests/build +FAILURES=0 +i=0 + +for opts in `cat ${BUILDDIR}/build-opts.txt`; do + make cleaner 2>&1 >/dev/null + if make $opts chibi-scheme 2>&1 >${BUILDDIR}/build${i}-make.out; then + if make test 2>&1 | tee ${BUILDDIR}/build${i}-test.out | grep -q -E 'FAIL|ERROR'; then + echo "[FAIL] ${i}: tests failed with $opts" + FAILURES=$((FAILURES + 1)) + else + echo "[PASS] ${i}: tests passed with $opts" + fi + else + echo "[FAIL] ${i}: couldn't build with $opts" + FAILURES=$((FAILURES + 1)) + fi + i=$((i+1)) +done + +if (( FAILURES == 0 )); then + echo "build-tests: all tests passed" +else + echo "build-tests: ${FAILURES} tests failed" +fi + diff --git a/tests/flonum-tests.scm b/tests/flonum-tests.scm new file mode 100644 index 00000000..5abe4772 --- /dev/null +++ b/tests/flonum-tests.scm @@ -0,0 +1,21 @@ +;;;; these will fail when compiled either without flonums or trig funcs + +(import (chibi test)) + +(test-begin "floating point") + +(test-assert (= -5 (floor -4.3))) +(test-assert (= -4 (ceiling -4.3))) +(test-assert (= -4 (truncate -4.3))) +(test-assert (= -4 (round -4.3))) +(test-assert (= 3 (floor 3.5))) +(test-assert (= 4 (ceiling 3.5))) +(test-assert (= 3 (truncate 3.5))) +(test-assert (= 4 (round 3.5))) + +(test 1124378190243790143.0 (exact->inexact 1124378190243790143)) + +;; (test "1124378190243790143.0" +;; (number->string (exact->inexact 1124378190243790143))) + +(test-end) diff --git a/tests/hash-tests.scm b/tests/hash-tests.scm new file mode 100644 index 00000000..09792c5e --- /dev/null +++ b/tests/hash-tests.scm @@ -0,0 +1,37 @@ + +(import (srfi 69) (chibi test)) + +(test-begin "hash") + +(test + 'white + (let ((ht (make-hash-table eq?))) + (hash-table-set! ht 'cat 'black) + (hash-table-set! ht 'dog 'white) + (hash-table-set! ht 'elephant 'pink) + (hash-table-ref/default ht 'dog #f))) + +(test + 'white + (let ((ht (make-hash-table equal?))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "dog" #f))) + +(test + 'white + (let ((ht (make-hash-table string-ci=? string-ci-hash))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "DOG" #f))) + +(test 625 + (let ((ht (make-hash-table))) + (do ((i 0 (+ i 1))) ((= i 1000)) + (hash-table-set! ht i (* i i))) + (hash-table-ref/default ht 25 #f))) + +(test-end) + diff --git a/tests/install/install-tests.pl b/tests/install/install-tests.pl new file mode 100755 index 00000000..63681324 --- /dev/null +++ b/tests/install/install-tests.pl @@ -0,0 +1,57 @@ +#! /usr/bin/env perl + +use strict; +use warnings; + +my $ROOT="tests/install/root"; +my $USER=$ENV{USER}; + +my $ignore = qr!/lib\d*/modules|/X11|alsa-lib|aspell|dosemu|emacs|erlang|/perl|python|ruby|lisp|sbcl|/ghc-|ocaml|evolution|office|gimp|gtk|mysql|postgres|wordnet|xulrunner!; + +sub linkdir ($$$) { + my ($FROM, $TO, $DEPTH) = @_; + mkdir $TO; + for my $f (`ls $FROM`) { + chomp $f; + if (-d "$FROM/$f") { + if (($DEPTH > 0) && ($FROM !~ $ignore)) { + linkdir("$FROM/$f", "$TO/$f", $DEPTH-1); + } + } else { + link "$FROM/$f", "$TO/$f"; + } + } +} + +mkdir "$ROOT"; +mkdir "$ROOT/bin"; +mkdir "$ROOT/sbin"; +mkdir "$ROOT/dev"; +mkdir "$ROOT/etc"; +mkdir "$ROOT/etc/alternatives"; +mkdir "$ROOT/lib"; +mkdir "$ROOT/lib64"; +mkdir "$ROOT/usr"; +mkdir "$ROOT/usr/bin"; +mkdir "$ROOT/usr/include"; +mkdir "$ROOT/usr/lib"; +mkdir "$ROOT/usr/lib/gcc"; + +linkdir "/bin", "$ROOT/bin", 1; +linkdir "/sbin", "$ROOT/sbin", 1; +link "/etc/passwd", "$ROOT/etc/passwd"; +linkdir "/etc/alternatives", "$ROOT/etc/alternatives", 1; +linkdir "/lib", "$ROOT/lib", 3; +linkdir "/lib64", "$ROOT/lib64", 3; +linkdir "/usr/bin", "$ROOT/usr/bin", 3; +linkdir "/usr/include", "$ROOT/usr/include", 2; +linkdir "/usr/lib", "$ROOT/usr/lib", 3; +linkdir "/usr/lib/gcc", "$ROOT/usr/lib/gcc", 3; + +`make dist`; +my $VERSION=`cat VERSION`; +chomp $VERSION; +`cp chibi-scheme-$VERSION.tgz $ROOT/`; +`sed -e 's/\@VERSION\@/$VERSION/g' $ROOT/bin/run-install-test.sh`; +`chmod 755 $ROOT/bin/run-install-test.sh`; +exec "sudo chroot $ROOT run-install-test.sh"; diff --git a/tests/install/run-install-test.sh b/tests/install/run-install-test.sh new file mode 100755 index 00000000..c558e7cd --- /dev/null +++ b/tests/install/run-install-test.sh @@ -0,0 +1,12 @@ +#! /bin/bash + +export PATH=/usr/local/bin:$PATH +export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH + +tar xzvf chibi-scheme-@VERSION@.tgz +cd chibi-scheme-@VERSION@ +make +make install +cp tests/r5rs-tests.scm .. +cd .. +chibi-scheme r5rs-tests.scm | tee r5rs-tests.out diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm new file mode 100644 index 00000000..fbd8ae0a --- /dev/null +++ b/tests/lib-tests.scm @@ -0,0 +1,13 @@ + +(import (chibi test)) + +(test-begin "libraries") + +(load "tests/flonum-tests.scm") +(load "tests/numeric-tests.scm") +(load "tests/hash-tests.scm") +(load "tests/sort-tests.scm") +(load "tests/loop-tests.scm") +(load "tests/match-tests.scm") + +(test-end) diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm new file mode 100644 index 00000000..f259245c --- /dev/null +++ b/tests/loop-tests.scm @@ -0,0 +1,168 @@ + +(import (chibi loop) (chibi test)) + +(test-begin "loops") + +(test + "stepping" + '(0 1 2) + (loop lp ((with i 0 (+ i 1)) + (with res '() (cons i res))) + (if (= i 3) + (reverse res) + (lp)))) + +(test + "basic in-list" + '(c b a) + (let ((res '())) + (loop ((for x (in-list '(a b c)))) + (set! res (cons x res))) + res)) + +(test + "in-list with result" + '(c b a) + (loop ((for x (in-list '(a b c))) + (with res '() (cons x res))) + => res)) + +(test + "in-list with listing" + '(a b c) + (loop ((for x (in-list '(a b c))) (for res (listing x))) => res)) + +(test + "in-list with listing-reverse" + '(c b a) + (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res)) + +(test + "uneven length in-list's" + '((a . 1) (b . 2) (c . 3)) + (loop ((for x (in-list '(a b c))) + (for y (in-list '(1 2 3 4))) + (for res (listing (cons x y)))) + => res)) + +(test + "in-lists" + '((a 1) (b 2) (c 3)) + (loop ((for ls (in-lists '((a b c) (1 2 3)))) + (for res (listing ls))) + => res)) + +(define (flatten ls) + (reverse + (loop lp ((for x ls (in-list ls)) (with res '())) + => res + (if (pair? x) + (lp (=> res (lp (=> ls x)))) + (lp (=> res (cons x res))))))) + +(test + "flatten (recursion test)" + '(1 2 3 4 5 6 7) + (flatten '(1 (2) (3 (4 (5)) 6) 7))) + +(test + "in-string" + '(#\h #\e #\l #\l #\o) + (loop ((for c (in-string "hello")) (for res (listing c))) => res)) + +(test + "in-string with start" + '(#\l #\o) + (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res)) + +(test + "in-string with start and end" + '(#\h #\e #\l #\l) + (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res)) + +(test + "in-string with start, end and step" + '(#\e #\l) + (loop ((for c (in-string "hello" 1 4 2)) (for res (listing c))) => res)) + +(test + "in-string-reverse" + '(#\o #\l #\l #\e #\h) + (loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res)) + +(test + "in-vector" + '(1 2 3) + (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res)) + +(test "up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 8))) + (for res (listing i))) + => res)) + +(test "up-from by" '(5 10 15) + (loop ((for i (up-from 5 (to 20) (by 5))) + (for res (listing i))) + => res)) + +(test "up-from listing if" '(10 12 14 16 18) + (loop ((for i (up-from 10 (to 20))) + (for res (listing i (if (even? i))))) + => res)) + +(test "down-from" '(7 6 5) + (loop ((for i (down-from 8 (to 5))) + (for res (listing i))) + => res)) + +(test "down-from by" '(15 10 5) + (loop ((for i (down-from 20 (to 5) (by 5))) + (for res (listing i))) + => res)) + +(test "down-from listing if" '(18 16 14 12 10) + (loop ((for i (down-from 20 (to 10))) + (for res (listing i (if (even? i))))) + => res)) + +(test "appending" '(1 2 3 4 5 6 7 8 9) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending ls))) + => res)) + +(test "appending-reverse" '(9 8 7 6 5 4 3 2 1) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending-reverse ls))) + => res)) + +(test "while + up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 10))) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "up-from by, open-ended" '(5 7 9) + (loop ((for i (up-from 5 (by 2))) + (while (< i 10)) + (for res (listing i))) + => res)) + +(test "up-from open-ended" '(5 6 7) + (loop ((for i (up-from 5)) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "down-from by, open-ended" '(5 3 1) + (loop ((for i (down-from 7 (by 2))) + (until (< i 1)) + (for res (listing i))) + => res)) + +(test "down-from open-ended" '(4 3 2) + (loop ((for i (down-from 5)) + (until (< i 2)) + (for res (listing i))) + => res)) + +(test-end) diff --git a/tests/match-tests.scm b/tests/match-tests.scm new file mode 100644 index 00000000..911dd831 --- /dev/null +++ b/tests/match-tests.scm @@ -0,0 +1,135 @@ + +(import (chibi match) (chibi test)) + +(test-begin "match") + +(test "any" 'ok (match 'any (_ 'ok))) +(test "symbol" 'ok (match 'ok (x x))) +(test "number" 'ok (match 28 (28 'ok))) +(test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok))) +(test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok))) +(test "null" 'ok (match '() (() 'ok))) +(test "pair" 'ok (match '(ok) ((x) x))) +(test "vector" 'ok (match '#(ok) (#(x) x))) +(test "any doubled" 'ok (match '(1 2) ((_ _) 'ok))) +(test "and empty" 'ok (match '(o k) ((and) 'ok))) +(test "and single" 'ok (match 'ok ((and x) x))) +(test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok))) +(test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok))) +(test "or single" 'ok (match 'ok ((or x) 'ok))) +(test "or double" 'ok (match 'ok ((or (? symbol? y) y) y))) +(test "not" 'ok (match 28 ((not (a . b)) 'ok))) +(test "pred" 'ok (match 28 ((? number?) 'ok))) +(test "named pred" 29 (match 28 ((? number? x) (+ x 1)))) + +(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x))) +(test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok))) +(test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x))) + +(test "ellipses" '((a b c) (1 2 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ___) (list x y)))) + +(test "real ellipses" '((a b c) (1 2 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ...) (list x y)))) + +(test "vector ellipses" '(1 2 3 (a b c) (1 2 3)) + (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) + (#(a b c (hd . tl) ...) (list a b c hd tl)))) + +(test "pred ellipses" '(1 2 3) + (match '(1 2 3) + (((? odd? n) ___) n) + (((? number? n) ___) n))) + +(test "failure continuation" 'ok + (match '(1 2) + ((a . b) (=> next) (if (even? a) 'fail (next))) + ((a . b) 'ok))) + +(test "let" '(o k) + (match-let ((x 'ok) (y '(o k))) y)) + +(test "let*" '(f o o f) + (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w))) + +(test "getter car" '(1 2) + (match '(1 . 2) (((get! a) . b) (list (a) b)))) + +(test "getter cdr" '(1 2) + (match '(1 . 2) ((a . (get! b)) (list a (b))))) + +(test "getter vector" '(1 2 3) + (match '#(1 2 3) (#((get! a) b c) (list (a) b c)))) + +(test "setter car" '(3 . 2) + (let ((x (cons 1 2))) + (match x (((set! a) . b) (a 3))) + x)) + +(test "setter cdr" '(1 . 3) + (let ((x (cons 1 2))) + (match x ((a . (set! b)) (b 3))) + x)) + +(test "setter vector" '#(1 0 3) + (let ((x (vector 1 2 3))) + (match x (#(a (set! b) c) (b 0))) + x)) + +(test "single tail" '((a b) (1 2) (c . 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ... last) (list x y last)))) + +(test "single tail 2" '((a b) (1 2) 3) + (match '((a . 1) (b . 2) 3) + (((x . y) ... last) (list x y last)))) + +(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5)) + (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) + (((x . y) ... u v w) (list x y u v w)))) + +(test "Riastradh quasiquote" '(2 3) + (match '(1 2 3) (`(1 ,b ,c) (list b c)))) + +(test "trivial tree search" '(1 2 3) + (match '(1 2 3) ((_ *** (a b c)) (list a b c)))) + +(test "simple tree search" '(1 2 3) + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c)))) + +(test "deep tree search" '(1 2 3) + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c)))) + +(test "non-tail tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c)))) + +(test "restricted tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c)))) + +(test "fail restricted tree search" #f + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f))) + +(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "failed sxml tree search" #f + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "collect tree search" + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f))) + +(test-end) diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm new file mode 100644 index 00000000..43b16cb4 --- /dev/null +++ b/tests/numeric-tests.scm @@ -0,0 +1,120 @@ + +;; these tests are only valid if chibi-scheme is compiled with full +;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) + +(import (chibi test)) + +(test-begin "numbers") + +(define (integer-neighborhoods x) + (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) + +(test '(536870912 536870913 536870911 -536870912 -536870911 -536870913) + (integer-neighborhoods (expt 2 29))) + +(test '(1073741824 1073741825 1073741823 -1073741824 -1073741823 -1073741825) + (integer-neighborhoods (expt 2 30))) + +(test '(2147483648 2147483649 2147483647 -2147483648 -2147483647 -2147483649) + (integer-neighborhoods (expt 2 31))) + +(test '(4294967296 4294967297 4294967295 -4294967296 -4294967295 -4294967297) + (integer-neighborhoods (expt 2 32))) + +(test '(4611686018427387904 4611686018427387905 4611686018427387903 + -4611686018427387904 -4611686018427387903 -4611686018427387905) + (integer-neighborhoods (expt 2 62))) + +(test '(9223372036854775808 9223372036854775809 9223372036854775807 + -9223372036854775808 -9223372036854775807 -9223372036854775809) + (integer-neighborhoods (expt 2 63))) + +(test '(18446744073709551616 18446744073709551617 18446744073709551615 + -18446744073709551616 -18446744073709551615 -18446744073709551617) + (integer-neighborhoods (expt 2 64))) + +(test '(85070591730234615865843651857942052864 + 85070591730234615865843651857942052865 + 85070591730234615865843651857942052863 + -85070591730234615865843651857942052864 + -85070591730234615865843651857942052863 + -85070591730234615865843651857942052865) + (integer-neighborhoods (expt 2 126))) + +(test '(170141183460469231731687303715884105728 + 170141183460469231731687303715884105729 + 170141183460469231731687303715884105727 + -170141183460469231731687303715884105728 + -170141183460469231731687303715884105727 + -170141183460469231731687303715884105729) + (integer-neighborhoods (expt 2 127))) + +(test '(340282366920938463463374607431768211456 + 340282366920938463463374607431768211457 + 340282366920938463463374607431768211455 + -340282366920938463463374607431768211456 + -340282366920938463463374607431768211455 + -340282366920938463463374607431768211457) + (integer-neighborhoods (expt 2 128))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-arithmetic-combinations a b) + (list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b))) + +(define (sign-combinations a b) + (list (integer-arithmetic-combinations a b) + (integer-arithmetic-combinations (- a) b) + (integer-arithmetic-combinations a (- b)) + (integer-arithmetic-combinations (- a) (- b)))) + +;; fix x fix +(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0)) + (sign-combinations 0 1)) +(test '((2 0 1 1 0) (0 -2 -1 -1 0) (0 2 -1 -1 0) (-2 0 1 1 0)) + (sign-combinations 1 1)) +(test '((59 25 714 2 8) (-25 -59 -714 -2 -8) + (25 59 -714 -2 8) (-59 -25 714 2 -8)) + (sign-combinations 42 17)) + +;; fix x big +(test '((4294967338 -4294967254 180388626432 0 42) + (4294967254 -4294967338 -180388626432 0 -42) + (-4294967254 4294967338 -180388626432 0 42) + (-4294967338 4294967254 180388626432 0 -42)) + (sign-combinations 42 (expt 2 32))) + +;; big x fix +(test '((4294967338 4294967254 180388626432 102261126 4) + (-4294967254 -4294967338 -180388626432 -102261126 -4) + (4294967254 4294967338 -180388626432 -102261126 4) + (-4294967338 -4294967254 180388626432 102261126 -4)) + (sign-combinations (expt 2 32) 42)) + +;; big x bigger +(test '((12884901889 -4294967297 36893488151714070528 0 4294967296) + (4294967297 -12884901889 -36893488151714070528 0 -4294967296) + (-4294967297 12884901889 -36893488151714070528 0 4294967296) + (-12884901889 4294967297 36893488151714070528 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) + +(test '((18446744078004518913 -18446744069414584321 79228162514264337597838917632 0 4294967296) + (18446744069414584321 -18446744078004518913 -79228162514264337597838917632 0 -4294967296) + (-18446744069414584321 18446744078004518913 -79228162514264337597838917632 0 4294967296) + (-18446744078004518913 18446744069414584321 79228162514264337597838917632 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 64)))) + +;; bigger x big +(test '((12884901889 4294967297 36893488151714070528 2 1) + (-4294967297 -12884901889 -36893488151714070528 -2 -1) + (4294967297 12884901889 -36893488151714070528 -2 1) + (-12884901889 -4294967297 36893488151714070528 2 -1)) + (sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) + +(test '((18446744078004518913 18446744069414584321 79228162514264337597838917632 4294967296 1) + (-18446744069414584321 -18446744078004518913 -79228162514264337597838917632 -4294967296 -1) + (18446744069414584321 18446744078004518913 -79228162514264337597838917632 -4294967296 1) + (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1)) + (sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) + +(test-end) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..a9197fb1 --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,465 @@ + +(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) + (write *tests-run*) + (display ". ") + (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 -2 (let () + (define x 2) + (define f (lambda () (- x))) + (f))) + +(define let*-def 1) +(let* () (define let*-def 2) #f) +(test 1 let*-def) + +(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 4 16 9 8) + `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 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 #f (eqv? 2 2.0)) + +;;(test #f (equal? 2.0 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 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 127 (string->number "177" 8)) + +(test 5 (string->number "101" 2)) + +(test 100.0 (string->number "1e2")) + +(test "100" (number->string 100)) + +(test "100" (number->string 256 16)) + +(test "FF" (number->string 255 16)) + +(test "177" (number->string 127 8)) + +(test "101" (number->string 5 2)) + +(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 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + +(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 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad)))) + +(test 'ok (let ((=> 1)) (cond (#t => 'ok)))) + +(test '(,foo) (let ((unquote 1)) `(,foo))) + +(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) + +(test 'ok + (let ((... 2)) + (let-syntax ((s (syntax-rules () + ((_ x ...) 'bad) + ((_ . r) 'ok)))) + (s a b c)))) + +(test 'ok (let () + (let-syntax () + (define internal-def 'ok)) + internal-def)) + +(test 'ok (let () + (letrec-syntax () + (define internal-def 'ok)) + internal-def)) + +(test '(2 1) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y)))))) + +(test '(2 2) + ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y)))))) + +(test '(1 2) + ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y)))))) + +(test '(2 3) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) + +(test '(a b c) + (let* ((path '()) + (add (lambda (s) (set! path (cons s path))))) + (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) + (reverse path))) + +(test '(connect talk1 disconnect connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + +(test 2 (let-syntax + ((foo (syntax-rules ::: () + ((foo ... args :::) + (args ::: ...))))) + (foo 3 - 5))) + +(test '(5 4 1 2 3) + (let-syntax + ((foo (syntax-rules () + ((foo args ... penultimate ultimate) + (list ultimate penultimate args ...))))) + (foo 1 2 3 4 5))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm new file mode 100644 index 00000000..f506baca --- /dev/null +++ b/tests/sort-tests.scm @@ -0,0 +1,40 @@ + +(import (srfi 95) (chibi test)) + +(test-begin "sorting") + +(test "sort null" '() (sort '())) +(test "sort null <" '() (sort '() <)) +(test "sort null < car" '() (sort '() < car)) +(test "sort ordered list" '(1 2 3 4 5 6 7 8 9) (sort '(1 2 3 4 5 6 7 8 9))) +(test "sort reversed list" '(1 2 3 4 5 6 7 8 9) (sort '(9 8 7 6 5 4 3 2 1))) +(test "sort random list 1" '(1 2 3 4 5 6 7 8 9) (sort '(7 5 2 8 1 6 4 9 3))) +(test "sort random list 2" '(1 2 3 4 5 6 7 8) (sort '(5 3 4 1 7 6 8 2))) +(test "sort random list 3" '(1 2 3 4 5 6 7 8 9) (sort '(5 3 4 1 7 9 6 8 2))) +(test "sort numeric list <" '(1 2 3 4 5 6 7 8 9) + (sort '(7 5 2 8 1 6 4 9 3) <)) +(test "sort numeric list < car" '((1) (2) (3) (4) (5) (6) (7) (8) (9)) + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car)) +(test "sort list (lambda (a b) (< (car a) (car b)))" + '((1) (2) (3) (4) (5) (6) (7) (8) (9)) + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) + (lambda (a b) (< (car a) (car b))))) +(test "sort 1-char symbols" '(a b c d e f g h i j k) + (sort '(h b k d a c j i e g f))) +(test "sort short symbols" '(a aa b c d e ee f g h i j k) + (sort '(h b aa k d a ee c j i e g f))) +(test "sort long symbol" + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz c d e ee f g h i j k) + (sort '(h b aa k d a ee c j i bzzzzzzzzzzzzzzzzzzzzzzz e g f))) +(test "sort long symbols" + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz czzzzzzzzzzzzz dzzzzzzzz e ee f g h i j k) + (sort '(h b aa k dzzzzzzzz a ee czzzzzzzzzzzzz j i bzzzzzzzzzzzzzzzzzzzzzzz e g f))) +(test "sort strings" + '("ape" "bear" "cat" "dog" "elephant" "fox" "goat" "hawk") + (sort '("elephant" "cat" "dog" "ape" "goat" "fox" "hawk" "bear"))) +(test "sort strings string-cistring x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (path-relative path dir) + (let ((p-len (string-length path)) + (d-len (string-length dir))) + (and (> p-len d-len) + (string=? dir (substring path 0 d-len)) + (cond + ((eqv? #\/ (string-ref path d-len)) + (substring path (+ d-len 1) p-len)) + ((eqv? #\/ (string-ref path (- d-len 1))) + (substring path d-len p-len)) + (else #f))))) + +(define (path-split file) + (let ((len (string-length file))) + (let lp ((i 0) (res '())) + (let ((j (string-scan #\/ file i))) + (cond + (j (lp (+ j 1) (cons (substring file i j) res))) + (else (reverse (if (= i len) + res + (cons (substring file i len) res))))))))) + +(define (init-name mod) + (string-append "sexp_init_lib_" + (string-concatenate (map mangle mod) "_"))) + +(define (find-c-libs basedir) + (define (process-dir dir) + (directory-fold + dir + (lambda (f x) + (if (and (not (equal? "" f)) (not (eqv? #\. (string-ref f 0)))) + (process (string-append dir "/" f)))) + #f)) + (define (process file) + (cond + ((file-directory? file) + (process-dir file)) + ((equal? "module" (path-extension file)) + (let* ((mod-path (path-strip-extension (path-relative file basedir))) + (mod-name (map (lambda (x) (or (string->number x) (string->symbol x))) + (path-split mod-path)))) + (cond + ((eval `(find-module ',mod-name) *config-env*) + => (lambda (mod) + (cond + ((assq 'include-shared (vector-ref mod 2)) + => (lambda (x) + (set! c-libs + (cons (cons (string-append + (path-directory file) + "/" + (cadr x) + ".c") + (init-name mod-name)) + c-libs)))))))))))) + (process-dir basedir)) + +(define (include-c-lib lib) + (display "#define sexp_init_library ") + (display (cdr lib)) + (newline) + (display "#include \"") + (display (car lib)) + (display "\"") + (newline) + (display "#undef sexp_init_library") + (newline) + (newline)) + +(define (init-c-lib lib) + (display " ") + (display (cdr lib)) + (display "(ctx, env);\n")) + +(define (main args) + (find-c-libs (if (pair? (cdr args)) (cadr args) "lib")) + (newline) + (for-each include-c-lib c-libs) + (newline) + (display "static sexp sexp_init_all_libraries (sexp ctx, sexp env) {\n") + (for-each init-c-lib c-libs) + (display " return SEXP_VOID;\n") + (display "}\n\n")) + diff --git a/tools/genstubs.scm b/tools/genstubs.scm new file mode 100755 index 00000000..e75d9a92 --- /dev/null +++ b/tools/genstubs.scm @@ -0,0 +1,1280 @@ +#! /usr/bin/env chibi-scheme + +;; Note: this evolved as a throw-away script to provide certain core +;; modules, and so is a mess. Tread carefully. + +;; Simple C FFI. "genstubs.scm file.stub" will read in the C function +;; FFI definitions from file.stub and output the appropriate C +;; wrappers into file.c. You can then compile that file with: +;; +;; cc -fPIC -shared file.c -lchibi-scheme +;; +;; (or using whatever flags are appropriate to generate shared libs on +;; your platform) and then the generated .so file can be loaded +;; directly with load, or portably using (include-shared "file") in a +;; module definition (note that include-shared uses no suffix). + +;; The goal of this interface is to make access to C types and +;; functions easy, without requiring the user to write any C code. +;; That means the stubber needs to be intelligent about various C +;; calling conventions and idioms, such as return values passed in +;; actual parameters. Writing C by hand is still possible, and +;; several of the core modules provide C interfaces directly without +;; using the stubber. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Struct Interface +;; +;; (define-c-struct struct-name +;; [predicate: predicate-name] +;; [constructor: constructor-name] +;; [finalizer: c_finalizer_name] +;; (type c_field_name getter-name setter-name) ...) +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Function Interface +;; +;; (define-c return-type name-spec (arg-type ...)) +;; +;; where name-space is either a symbol name, or a list of +;; (scheme-name c_name). If just a symbol, the C name is taken +;; to be the same with -'s replaced by _'s. +;; +;; arg-type is a type suitable for input validation and conversion. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Types +;; +;; Types +;; +;; Basic Types +;; void +;; boolean +;; char +;; sexp (no conversions) +;; +;; Integer Types: +;; signed-char short int long +;; unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t +;; time_t (in seconds, but using the chibi epoch of 2010/01/01) +;; errno (as a return type returns #f on error) +;; +;; Float Types: +;; float double long-double +;; +;; String Types: +;; string - a null-terminated char* +;; env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme +;; in addition you can use (array char) as a string +;; +;; Port Types: +;; input-port output-port +;; port-or-fd - an fd-backed port or a fixnum +;; +;; Struct Types: +;; +;; Struct types are by default just referred to by the bare +;; struct-name from define-c-struct, and it is assumed you want a +;; pointer to that type. To refer to the full struct, use the struct +;; modifier, as in (struct struct-name). + +;; Type modifiers +;; +;; Any type may also be written as a list of modifiers followed by the +;; type itself. The supported modifiers are: +;; +;; const: prepends the "const" C type modifier +;; * as a return or result parameter, makes non-immediates immutable +;; +;; free: it's Scheme's responsibility to "free" this resource +;; * as a return or result parameter, registers the freep flag +;; this causes the type finalizer to be run when GCed +;; +;; maybe-null: this pointer type may be NULL +;; * as a result parameter, NULL is translated to #f +;; normally this would just return a wrapped NULL pointer +;; * as an input parameter, #f is translated to NULL +;; normally this would be a type error +;; +;; pointer: create a pointer to this type +;; * as a return parameter, wraps the result in a vanilla cpointer +;; * as a result parameter, boxes then unboxes the value +;; +;; struct: treat this struct type as a struct, not a pointer +;; * as an input parameter, dereferences the pointer +;; * as a type field, indicates a nested struct +;; +;; link: add a gc link +;; * as a field getter, link to the parent object, so the +;; parent won't be GCed so long as we have a reference +;; to the child. this behavior is automatic for nested +;; structs. +;; +;; result: return a result in this parameter +;; * if there are multiple results (including the return type), +;; they are all returned in a list +;; * if there are any result parameters, a return type +;; of errno returns #f on failure, and as eliminated +;; from the list of results otherwise +;; +;; (value ): specify a fixed value +;; * as an input parameter, this parameter is not provided +;; in the Scheme API but always passed as +;; +;; (default ): specify a default value +;; * as the final input parameter, makes the Scheme parameter +;; optional, defaulting to +;; +;; (array []) an array type +;; * length must be specified for return and result parameters +;; * if specified, length can be any of +;; ** an integer, for a fixed size +;; ** the symbol null, indicating a NULL-terminated array + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; globals + +(define *types* '()) +(define *funcs* '()) +(define *consts* '()) +(define *inits* '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type objects + +(define (parse-type type . o) + (cond + ((vector? type) + type) + (else + (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) + (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f) + (value #f) (default? #f)) + (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) + (case (and (pair? type) (car type)) + ((free) + (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) + ((const) + (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) + ((maybe-null) + (lp (next) free? const? #t ptr? struct? link? result? array value default?)) + ((pointer) + (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) + ((struct) + (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) + ((link) + (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) + ((result) + (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) + ((array) + (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) + ((value) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) + ((default) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) + (else + (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) + +(define (type-base type) (vector-ref type 0)) +(define (type-free? type) (vector-ref type 1)) +(define (type-const? type) (vector-ref type 2)) +(define (type-null? type) (vector-ref type 3)) +(define (type-pointer? type) (vector-ref type 4)) +(define (type-struct? type) (vector-ref type 5)) +(define (type-link? type) (vector-ref type 6)) +(define (type-result? type) (vector-ref type 7)) +(define (type-array type) (vector-ref type 8)) +(define (type-value type) (vector-ref type 9)) +(define (type-default? type) (vector-ref type 10)) +(define (type-index type) (vector-ref type 11)) + +(define (type-auto-expand? type) + (and (pair? (type-array type)) + (memq 'auto-expand (type-array type)))) + +(define (type-index-string type) + (if (integer? (type-index type)) + (number->string (type-index type)) + "")) + +(define (struct-fields ls) + (let lp ((ls ls) (res '())) + (cond ((null? ls) (reverse res)) + ((symbol? (car ls)) (lp (cddr ls) res)) + (else (lp (cdr ls) (cons (car ls) res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type predicates + +(define (signed-int-type? type) + (memq type '(signed-char short int long boolean))) + +(define (unsigned-int-type? type) + (memq type '(unsigned-char unsigned-short unsigned unsigned-int unsigned-long + size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t + uid_t gid_t pid_t blksize_t blkcnt_t sigval_t))) + +(define (int-type? type) + (or (signed-int-type? type) (unsigned-int-type? type))) + +(define (float-type? type) + (memq type '(float double long-double long-long-double))) + +(define (string-type? type) + (or (memq type '(char* string env-string non-null-string)) + (and (vector? type) + (type-array type) + (not (type-pointer? type)) + (eq? 'char (type-base type))))) + +(define (port-type? type) + (memq type '(port input-port output-port))) + +(define (error-type? type) + (memq type '(errno non-null-string non-null-pointer))) + +(define (array-type? type) + (and (type-array type) (not (eq? 'char (type-base type))))) + +(define (basic-type? type) + (let ((type (parse-type type))) + (and (not (type-array type)) + (not (void-pointer-type? type)) + (not (assq (type-base type) *types*))))) + +(define (void-pointer-type? type) + (or (and (eq? 'void (type-base type)) (type-pointer? type)) + (eq? 'void* (type-base type)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; function objects + +(define (parse-func func) + (if (not (and (= 3 (length func)) + (or (identifier? (cadr func)) (list (cadr func))) + (list (caddr func)))) + (error "bad function definition" func)) + (let* ((ret-type (parse-type (car func))) + (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) + (c-name (if (pair? (cadr func)) + (cadadr func) + (mangle scheme-name))) + (stub-name (if (and (pair? (cadr func)) (pair? (cddadr func))) + (car (cddadr func)) + (generate-stub-name scheme-name)))) + (let lp ((ls (caddr func)) + (i 0) + (results '()) + (c-args '()) + (s-args '())) + (cond + ((null? ls) + (vector scheme-name c-name stub-name ret-type + (reverse results) (reverse c-args) (reverse s-args))) + (else + (let ((type (parse-type (car ls) i))) + (cond + ((type-result? type) + (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) + ((and (type-value type) (not (type-default? type))) + (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) + (else + (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) + ))))))) + +(define (func-scheme-name func) (vector-ref func 0)) +(define (func-c-name func) (vector-ref func 1)) +(define (func-stub-name func) (vector-ref func 2)) +(define (func-ret-type func) (vector-ref func 3)) +(define (func-results func) (vector-ref func 4)) +(define (func-c-args func) (vector-ref func 5)) +(define (func-scheme-args func) (vector-ref func 6)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (cat . args) + (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (filter pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (cons (car ls) (filter pred (cdr ls)))) + (else (filter pred (cdr ls))))) + +(define (remove pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (filter pred (cdr ls))) + (else (cons (car ls) (filter pred (cdr ls)))))) + +(define (strip-extension path) + (let lp ((i (- (string-length path) 1))) + (cond ((<= i 0) path) + ((eq? #\. (string-ref path i)) (substring path 0 i)) + (else (lp (- i 1)))))) + +(define (string-concatenate-reverse ls) + (cond ((null? ls) "") + ((null? (cdr ls)) (car ls)) + (else (string-concatenate (reverse ls))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase str) + (list->string (map char-downcase (string->list str)))) + +(define (with-output-to-string thunk) + (call-with-output-string + (lambda (out) + (let ((old-out (current-output-port))) + (current-output-port out) + (thunk) + (current-output-port old-out))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; naming + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +(define (generate-stub-name sym) + (string-append "sexp_" (mangle sym) "_stub")) + +(define (type-id-name sym) + (string-append "sexp_" (mangle sym) "_type_id")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; .stub file interface + +(define (c-declare . args) + (apply cat args) + (newline)) + +(define (c-include header) + (cat "\n#include \"" header "\"\n")) + +(define (c-system-include header) + (cat "\n#include <" header ">\n")) + +(define (c-init x) + (set! *inits* (cons x *inits*))) + +(define (parse-struct-like ls) + (let lp ((ls ls) (res '())) + (cond + ((null? ls) + (reverse res)) + ((symbol? (car ls)) + (lp (cddr ls) (cons (cadr ls) (cons (car ls) res)))) + ((pair? (car ls)) + (lp (cdr ls) (cons (cons (parse-type (caar ls)) (cdar ls)) res))) + (else + (lp (cdr ls) (cons (car ls) res)))))) + +(define-syntax define-struct-like + (er-macro-transformer + (lambda (expr rename compare) + (set! *types* + `((,(cadr expr) + ,@(parse-struct-like (cddr expr))) + ,@*types*)) + `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) + +(define-syntax define-c-struct + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr))))) + +(define-syntax define-c-class + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) + +(define-syntax define-c-union + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: union ,@(cddr expr))))) + +(define-syntax define-c-type + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) ,@(cddr expr))))) + +(define-syntax define-c + (er-macro-transformer + (lambda (expr rename compare) + (set! *funcs* (cons (parse-func (cdr expr)) *funcs*)) + #f))) + +(define-syntax define-c-const + (er-macro-transformer + (lambda (expr rename compare) + (let ((type (parse-type (cadr expr)))) + (for-each (lambda (x) (set! *consts* (cons (list type x) *consts*))) + (cddr expr)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; C code generation + +(define (c->scheme-converter type val . o) + (let ((base (type-base type))) + (cond + ((and (eq? base 'void) (not (type-pointer? type))) + (cat "((" val "), SEXP_VOID)")) + ((or (eq? base 'sexp) (error-type? base)) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_make_boolean(" val ")")) + ((eq? base 'time_t) + (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) + ((unsigned-int-type? base) + (cat "sexp_make_unsigned_integer(ctx, " val ")")) + ((signed-int-type? base) + (cat "sexp_make_integer(ctx, " val ")")) + ((eq? base 'char) + (if (type-array type) + (cat "sexp_c_string(ctx, " val ", -1)") + (cat "sexp_make_character(ctx, " val ")"))) + ((eq? 'env-string base) + (cat "(p=strchr(" val ", '=') ? " + "sexp_cons(ctx, str=sexp_c_string(ctx, " val ", p - " val "), str=sexp_c_string(ctx, p, -1))" + " : sexp_cons(ctx, str=" val ", SEXP_FALSE)")) + ((string-type? base) + (cat "sexp_c_string(ctx, " val ", -1)")) + ((eq? 'input-port base) + (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)")) + ((eq? 'output-port base) + (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) + (else + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) + (cond + ((or ctype void*?) + (cat "sexp_make_cpointer(ctx, " + (if void*? "SEXP_CPOINTER" (type-id-name base)) ", " + val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " + (if (or (type-free? type) + (and (type-result? type) (not (basic-type? type)))) + 1 + 0) + ")")) + (else + (error "unknown type" base)))))))) + +(define (scheme->c-converter type val) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'sexp) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_truep(" val ")")) + ((eq? base 'time_t) + (cat "sexp_unshift_epoch(sexp_uint_value(" val "))")) + ((signed-int-type? base) + (cat "sexp_sint_value(" val ")")) + ((unsigned-int-type? base) + (cat "sexp_uint_value(" val ")")) + ((eq? base 'char) + (cat "sexp_unbox_character(" val ")")) + ((eq? base 'env-string) + (cat "sexp_concat_env_string(" val ")")) + ((string-type? base) + (cat "sexp_string_data(" val ")")) + ((eq? base 'port-or-fd) + (cat "(sexp_portp(" val ") ? fileno(sexp_port_stream(" val "))" + " : sexp_unbox_fixnum(" val "))")) + ((port-type? base) + (cat "sexp_port_stream(" val ")")) + (else + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) + (cond + ((or ctype void*?) + (cat "(" (type-c-name type) ")" + (if (type-null? type) + "sexp_cpointer_maybe_null_value" + "sexp_cpointer_value") + "(" val ")")) + (else + (error "unknown type" base)))))))) + +(define (type-predicate type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "sexp_exact_integerp") + ((float-type? base) "sexp_flonump") + ((string-type? base) "sexp_stringp") + ((eq? base 'char) "sexp_charp") + ((eq? base 'boolean) "sexp_booleanp") + ((eq? base 'port) "sexp_portp") + ((eq? base 'input-port) "sexp_iportp") + ((eq? base 'output-port) "sexp_oportp") + (else #f)))) + +(define (type-name type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "integer") + ((float-type? base) "flonum") + ((eq? 'boolean base) "int") + (else base)))) + +(define (base-type-c-name base) + (case base + ((string env-string non-null-string) "char*") + (else (symbol->string base)))) + +(define (type-struct-type type) + (let ((type-spec (assq (if (vector? type) (type-base type) type) *types*))) + (cond ((and type-spec (memq 'type: type-spec)) => cadr) + (else #f)))) + +(define (type-c-name type) + (let* ((type (parse-type type)) + (base (type-base type)) + (type-spec (assq base *types*)) + (struct-type (type-struct-type type))) + (string-append + (if (type-const? type) "const " "") + (if struct-type (string-append (symbol->string struct-type) " ") "") + (string-replace (base-type-c-name base) #\- " ") + (if struct-type "*" "") + (if (type-pointer? type) "*" "")))) + +(define (check-type arg type) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'env-string) + (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg + ")) && sexp_stringp(sexp_cdr(" arg ")))")) + ((or (int-type? base) (float-type? base) + (string-type? base) (port-type? base)) + (cat (type-predicate type) "(" arg ")")) + ((or (assq base *types*) (void-pointer-type? type)) + (cat + (if (type-null? type) "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " + (if (void-pointer-type? type) "SEXP_CPOINTER" (type-id-name base)) "))" + (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) + (else + (display "WARNING: don't know how to check: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (cat "1"))))) + +(define (type-id-number type) + (let ((base (type-base type))) + (cond + ((int-type? base) "SEXP_FIXNUM") + ((float-type? base) "SEXP_FLONUM") + ((string-type? base) "SEXP_STRING") + ((eq? base 'char) "SEXP_CHAR") + ((eq? base 'boolean) "SEXP_BOOLEAN") + ((eq? base 'port) "SEXP_IPORT") + ((eq? base 'input-port) "SEXP_IPORT") + ((eq? base 'output-port) "SEXP_OPORT") + ((void-pointer-type? type) "SEXP_CPOINTER") + (else (type-id-name base))))) + +(define (write-validator arg type) + (let* ((type (parse-type type)) + (array (type-array type)) + (base-type (type-base type))) + (cond + ((and array (not (string-type? type))) + (cond + ((number? array) + (cat " if (!sexp_listp(ctx, " arg ")" + " || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n" + " return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n"))) + (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" + " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" + " return sexp_xtype_exception(ctx, self, \"not a list of " + (type-name type) "s\", " arg ");\n") + (if (not (number? array)) + (cat " if (! sexp_nullp(res))\n" + " return sexp_xtype_exception(ctx, self, \"not a list of " + (type-name type) "s\", " arg ");\n"))) + ((eq? base-type 'port-or-fd) + (cat " if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" + " return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n")) + ((or (int-type? base-type) + (float-type? base-type) + (string-type? base-type) + (port-type? base-type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) + ((or (assq base-type *types*) (void-pointer-type? type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) + ((eq? 'sexp base-type)) + ((string-type? type) + (write-validator arg 'string)) + (else + (display "WARNING: don't know how to validate: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)))))) + +(define (write-parameters args) + (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) + +(define (get-array-length func x) + (let ((len (if (pair? (type-array x)) + (car (reverse (type-array x))) + (type-array x)))) + (if (number? len) + len + (and (symbol? len) + (let* ((str (symbol->string len)) + (len2 (string-length str))) + (and (> len2 3) + (string=? "arg" (substring str 0 3)) + (let ((i (string->number (substring str 3 len2)))) + (if i + (let ((y (list-ref (func-c-args func) i))) + (or (type-value y) len)))))))))) + +(define (write-locals func) + (define (arg-res x) + (string-append "res" (type-index-string x))) + (let* ((ret-type (func-ret-type func)) + (results (func-results func)) + (scheme-args (func-scheme-args func)) + (return-res? (not (error-type? (type-base ret-type)))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons ret-type results))) + (gc-vars (map arg-res results)) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (sexps (if preserve-res? '() '("res"))) + (num-gc-vars (length gc-vars)) + (ints (if (or return-res? + (memq (type-base ret-type) + '(non-null-string non-null-pointer))) + '() + '("err"))) + (ints (if (or (array-type? ret-type) + (any array-type? results) + (any array-type? scheme-args)) + (cons "i" ints) + ints))) + (case (type-base ret-type) + ((non-null-string) (cat " char *err;\n")) + ((non-null-pointer) (cat " void *err;\n"))) + (cond + ((pair? ints) + (cat " int " (car ints)) + (for-each (lambda (x) (display ", ") (display x)) (cdr ints)) + (cat ";\n"))) + (if (any (lambda (a) (eq? 'env-string (type-base a))) + (cons ret-type results)) + (cat " char *p;\n")) + (for-each + (lambda (x) + (let ((len (get-array-length func x))) + (cat " " (type-c-name (type-base x)) " ") + (if (or (and (type-array x) (not (number? len))) (type-pointer? x)) + (cat "*")) + (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) + (if (number? len) + (cat "[" len "]")) + (cat ";\n") + (if (or (vector? len) (type-auto-expand? x)) + (cat " int len" (type-index x) ";\n")) + (if (type-auto-expand? x) + (cat " " (type-c-name (type-base x)) + " *tmp" (type-index-string x) ";\n")))) + (append (if (or (type-array ret-type) (type-pointer? ret-type)) + (list ret-type) + '()) + results + (remove type-result? (filter type-array scheme-args)))) + (for-each + (lambda (arg) + (cond + ((and (type-pointer? arg) (basic-type? arg)) + (cat " " (type-c-name (type-base arg)) + " tmp" (type-index arg) ";\n")))) + scheme-args) + (cond + ((pair? sexps) + (cat " sexp " (car sexps)) + (for-each (lambda (x) (display ", ") (display x)) (cdr sexps)) + (cat ";\n"))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_var" num-gc-vars "(") + (display (car gc-vars)) + (for-each (lambda (x) (display ", ") (display x)) (cdr gc-vars)) + (cat ");\n") + (cat " sexp_gc_preserve" num-gc-vars "(ctx") + (for-each (lambda (x) (display ", ") (display x)) gc-vars) + (cat ");\n"))))) + +(define (write-validators args) + (for-each + (lambda (a) + (write-validator (string-append "arg" (type-index-string a)) a)) + args)) + +(define (write-temporaries func) + (for-each + (lambda (a) + (let ((len (and (type-array a) (get-array-length func a)))) + (cond + ((and (type-array a) (or (vector? len) (type-auto-expand? a))) + (cat " len" (type-index a) " = " + (lambda () + (if (number? len) (cat len) (scheme->c-converter 'int len))) + ";\n" + " tmp" (type-index a) " = buf" (type-index a) ";\n"))) + (cond + ((and (not (type-result? a)) (type-array a) (not (string-type? a))) + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) + " = (" (type-c-name (type-base a)) "*) malloc(" + "(sexp_unbox_fixnum(sexp_length(ctx, arg" (type-index a) + "))+1) * sizeof(tmp" (type-index a) "[0]));\n")) + (cat " for (i=0, res=arg" (type-index a) + "; sexp_pairp(res); res=sexp_cdr(res), i++) {\n" + " tmp" (type-index a) "[i] = " + (lambda () (scheme->c-converter (type-base a) "sexp_car(res)")) + ";\n" + " }\n") + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) "[i] = NULL;\n"))) + ((and (type-result? a) (not (basic-type? a)) + (not (type-free? a)) ;;(not (type-pointer? a)) + (not (type-auto-expand? a)) + (or (not (type-array a)) + (not (integer? len)))) + (cat " tmp" (type-index a) " = malloc(" + (if (and (symbol? len) (not (eq? len 'null))) + (lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len)) + "*sizeof(tmp" (type-index a) "[0])")) + (lambda () (cat "sizeof(tmp" (type-index a) "[0])"))) + ");\n")) + ((and (type-pointer? a) (basic-type? a)) + (cat " tmp" (type-index a) " = " + (lambda () + (scheme->c-converter + a + (string-append "arg" (type-index-string a)))) + ";\n"))))) + (func-c-args func))) + +(define (write-actual-parameter func arg) + (cond + ((and (not (type-default? arg)) (type-value arg)) + => (lambda (x) + (cond + ((any (lambda (y) + (and (type-array y) + (type-auto-expand? y) + (eq? x (get-array-length func y)))) + (func-c-args func)) + => (lambda (y) (cat "len" (type-index y)))) + (else (write x))))) + ((or (type-result? arg) (type-array arg)) + (cat (if (or (type-free? arg) (basic-type? arg)) ;; (type-pointer? arg) + "&" + "") + "tmp" (type-index arg))) + ((and (type-pointer? arg) (basic-type? arg)) + (cat "&tmp" (type-index arg))) + (else + (scheme->c-converter + arg + (string-append "arg" (type-index-string arg)))))) + +(define (write-call func) + (let ((ret-type (func-ret-type func)) + (c-name (func-c-name func)) + (c-args (func-c-args func))) + (if (any type-auto-expand? (func-c-args func)) + (cat " loop:\n")) + (cat (cond ((error-type? (type-base ret-type)) " err = ") + ((type-array ret-type) " tmp = ") + (else " res = "))) + ((if (type-array ret-type) + (lambda (t f x) (f)) + c->scheme-converter) + ret-type + (lambda () + (cat c-name "(") + (for-each + (lambda (arg) + (if (> (type-index arg) 0) (cat ", ")) + (write-actual-parameter func arg)) + c-args) + (cat ")")) + (cond + ((any type-link? (func-c-args func)) + => (lambda (a) (string-append "arg" (type-index-string a)))) + (else #f))) + (cat ";\n") + (if (type-array ret-type) + (write-result ret-type)))) + +(define (write-result result) + (let ((res (string-append "res" (type-index-string result))) + (tmp (string-append "tmp" (type-index-string result)))) + (cond + ((and (type-array result) (eq? 'char (type-base result))) + (cat " " res " = " (lambda () (c->scheme-converter result tmp)) ";\n")) + ((type-array result) + (cat " " res " = SEXP_NULL;\n") + (let ((auto-expand? + (and (pair? (type-array result)) + (memq 'auto-expand (type-array result)))) + (len (if (pair? (type-array result)) + (car (reverse (type-array result))) + (type-array result)))) + (cond + ((eq? 'null len) + (cat " for (i=0; " tmp "[i]; i++) {\n" + " sexp_push(ctx, " res ", " + (if (eq? 'string (type-base result)) + "str=" + (lambda () (cat "SEXP_VOID);\n sexp_car(" res ") = "))) + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ");\n" + " }\n" + " " res " = sexp_nreverse(ctx, " res ");\n")) + (else + (cat " for (i=" len "-1; i>=0; i--) {\n" + " sexp_push(ctx, " res ", SEXP_VOID);\n" + " sexp_car(" res ") = " + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ";\n" + " }\n"))))) + (else + (cat " " res " = ") + (c->scheme-converter + result + (string-append "tmp" (type-index-string result))) + (cat ";\n"))))) + +(define (write-results func) + (let ((error-res? (error-type? (type-base (func-ret-type func)))) + (results (func-results func))) + (if error-res? + (cat " if (" + (if (memq (type-base (func-ret-type func)) + '(non-null-string non-null-pointer)) + "!" + "") + "err) {\n" + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (lambda () + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")) + (cat " len" i " *= 2;\n" + " tmp" i + " = malloc(len" i "*sizeof(tmp" i "[0]));\n" + " goto loop;\n"))))) + (else + " res = SEXP_FALSE;\n")) + " } else {\n")) + (if (null? results) + (if error-res? + (cat " res = SEXP_TRUE;\n")) + (for-each write-result results)) + (cond + ((> (length results) (if error-res? 1 0)) + (if error-res? + (cat " res = SEXP_NULL;\n") + (cat " res = sexp_cons(ctx, res, SEXP_NULL);\n")) + (for-each + (lambda (x) + (if error-res? + (cat " sexp_push(ctx, res, res" (type-index x) ");\n") + (cat " sexp_push(ctx, res, sexp_car(res));\n" + " sexp_cadr(res) = res" (type-index x) ";\n"))) + (reverse results))) + ((pair? results) + (cat " res = res" (type-index (car results)) ";\n"))) + (if error-res? + (cat " }\n")))) + +(define (write-free type) + (if (type-array type) + (cat " free(tmp" (type-index-string type) ");\n"))) + +(define (write-cleanup func) + (for-each write-free (func-scheme-args func)) + (for-each + (lambda (a) + (cond + ((type-auto-expand? a) + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")))) + ((and (type-result? a) (not (basic-type? a)) + (not (assq (type-base a) *types*)) + (not (type-free? a)) (not (type-pointer? a)) + (or (not (type-array a)) + (not (integer? (get-array-length func a))))) + ;; the above is hairy - basically this frees temporary strings + (cat " free(tmp" (type-index a) ");\n")))) + (func-c-args func)) + (let* ((results (func-results func)) + (return-res? (not (error-type? (type-base (func-ret-type func))))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons (func-ret-type func) + (func-results func)))) + (gc-vars results) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (num-gc-vars (length gc-vars))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_release" num-gc-vars "(ctx);\n"))))) + +(define (write-func func) + (cat "static sexp " (func-stub-name func) + " (sexp ctx sexp_api_params(self, n)" + (write-parameters (func-scheme-args func)) ") {\n") + (write-locals func) + (write-validators (func-scheme-args func)) + (write-temporaries func) + (write-call func) + (write-results func) + (write-cleanup func) + (cat " return res;\n" + "}\n\n")) + +(define (parameter-default? x) + (and (pair? x) + (member x '((current-input-port) + (current-output-port) + (current-error-port))))) + +(define (write-default x) ;; this is a hack but very convenient + (lambda () + (let ((value (type-value x))) + (cond + ((equal? value '(current-input-port)) + (cat "\"*current-input-port*\"")) + ((equal? value '(current-output-port)) + (cat "\"*current-output-port*\"")) + ((equal? value '(current-error-port)) + (cat "\"*current-error-port*\"")) + (else + (c->scheme-converter x value)))))) + +(define (write-func-binding func) + (let ((default (and (pair? (func-scheme-args func)) + (type-default? (car (reverse (func-scheme-args func)))) + (car (reverse (func-scheme-args func)))))) + (cat (if default + (if (parameter-default? (type-value default)) + " sexp_define_foreign_param(ctx, env, " + " sexp_define_foreign_opt(ctx, env, ") + " sexp_define_foreign(ctx, env, ") + (lambda () (write (symbol->string (func-scheme-name func)))) + ", " (length (func-scheme-args func)) ", " + (if default "(sexp_proc1)" "") + (func-stub-name func) + (if default ", " "") + (if default (write-default default) "") + ");\n"))) + +(define (write-type type) + (let ((name (car type)) + (type (cdr type))) + (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" + " " (type-id-name name) + " = sexp_unbox_fixnum(sexp_type_tag(sexp_register_c_type(ctx, name, " + (cond ((memq 'finalizer: type) + => (lambda (x) (generate-stub-name (cadr x)))) + (else "sexp_finalize_c_type")) + ")));\n") + (cond + ((memq 'predicate: type) + => (lambda (x) + (let ((pred (cadr x))) + (cat " tmp = sexp_make_type_predicate(ctx, name, " + "sexp_make_fixnum(" (type-id-name name) "));\n" + " name = sexp_intern(ctx, \"" pred "\", " + (string-length (x->string pred)) ");\n" + " sexp_env_define(ctx, env, name, tmp);\n"))))))) + +(define (type-getter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_get_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-getter type name field) + (cat "static sexp " (type-getter-name type name field) + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" + (lambda () (write-validator "x" name)) + " return " + (lambda () + (c->scheme-converter + (car field) + (string-append (if (type-struct? (car field)) "&" "") + "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" "->" + (x->string (cadr field))) + (and (or (type-struct? (car field)) (type-link? (car field))) "x"))) + ";\n" + "}\n\n")) + +(define (type-setter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_set_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-setter-assignment type name field dst val) + (cond + ((type-struct? (car field)) + ;; assign to a nested struct - copy field-by-field + (let ((field-type + (cond ((assq (type-name (car field)) *types*) => cdddr) + (else (cdr field))))) + (lambda () + (for-each + (lambda (subfield) + (let ((subname (x->string (cadr subfield)))) + (cat + " " + (string-append dst "." (x->string (cadr subfield))) + " = " + (string-append + "((" (x->string (or (type-struct-type (type-name (car field))) "")) + " " (mangle (type-name (car field))) "*)" "sexp_cpointer_value(" val "))" + "->" (x->string (cadr subfield))) + ";\n"))) + (struct-fields field-type))))) + (else + (lambda () + (cat " " dst " = " (lambda () (scheme->c-converter (car field) val)) ";\n"))))) + +(define (write-type-setter type name field) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx sexp_api_params(self, n), sexp x, sexp v) {\n" + (lambda () (write-validator "x" name)) + (lambda () (write-validator "v" (car field))) + (write-type-setter-assignment + type name field + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" "sexp_cpointer_value(x))" + "->" (x->string (cadr field))) + "v") + " return SEXP_VOID;\n" + "}\n\n")) + +(define (write-type-funcs orig-type) + (let ((name (car orig-type)) + (type (cdr orig-type))) + ;; maybe write finalizer + (cond + ((memq 'finalizer: type) + => (lambda (x) + (cat "static sexp " (generate-stub-name (cadr x)) + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" + " if (sexp_cpointer_freep(x))\n" + " " (cadr x) "(sexp_cpointer_value(x));\n" + " return SEXP_VOID;\n" + "}\n\n")))) + ;; maybe write constructor + (cond + ((memq 'constructor: type) + => (lambda (x) + (let ((make (caadr x)) + (args (cdadr x))) + (cat "static sexp " (generate-stub-name make) + " (sexp ctx sexp_api_params(self, n)" + (lambda () + (let lp ((ls args) (i 0)) + (cond ((pair? ls) + (cat ", sexp arg" i) + (lp (cdr ls) (+ i 1)))))) + ") {\n" + " " (or (type-struct-type name) "") " " (type-name name) " *r;\n" + " sexp_gc_var1(res);\n" + " sexp_gc_preserve1(ctx, res);\n" + ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + ;; (type-id-name name) + ;; ");\n" + ;; " r = sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), " + (type-id-name name) + ");\n" + " r = sexp_cpointer_value(res) = malloc(sizeof(" + (or (type-struct-type name) "") " " (type-name name) "));\n" + " sexp_freep(res) = 1;\n" + (lambda () + (let lp ((ls args) (i 0)) + (cond + ((pair? ls) + (let* ((a (car ls)) + (field + (any (lambda (f) (and (pair? f) (eq? a (cadr f)))) + (cddr x)))) + (if field + (cat " r->" (cadr field) " = " + (lambda () + (scheme->c-converter + (car field) + (string-append "arg" + (number->string i)))) + ";\n")) + (lp (cdr ls) (+ i 1))))))) + " sexp_gc_release1(ctx);\n" + " return res;\n" + "}\n\n") + (set! *funcs* + (cons (parse-func `(void ,make ,args)) *funcs*)))))) + ;; write field accessors + (for-each + (lambda (field) + (cond + ((and (pair? field) (pair? (cdr field))) + (cond + ((and (pair? (cddr field)) (caddr field)) + (write-type-getter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(caddr field) + #f + ,(type-getter-name type name field)) + (,name))) + *funcs*)))) + (cond + ((and (pair? (cddr field)) + (pair? (cdddr field)) + (car (cdddr field))) + (write-type-setter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(car (cdddr field)) + #f + ,(type-setter-name type name field)) + (,name ,(car field)))) + *funcs*))))))) + (struct-fields type)))) + +(define (write-const const) + (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) + (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) + (cat " name = sexp_intern(ctx, \"" scheme-name "\", " + (string-length (x->string scheme-name)) ");\n" + " sexp_env_define(ctx, env, name, tmp=" + (lambda () (c->scheme-converter (car const) c-name)) ");\n"))) + +(define (write-utilities) + (define (input-env-string? x) + (and (eq? 'env-string (type-base x)) (not (type-result? x)))) + (cond + ((any (lambda (f) + (or (any input-env-string? (func-results f)) + (any input-env-string? (func-scheme-args f)))) + *funcs*) + (cat "static char* sexp_concat_env_string (sexp x) {\n" + " int klen=sexp_string_length(sexp_car(x)), vlen=sexp_string_length(sexp_cdr(x));\n" + " char *res = (char*) malloc(klen+vlen+2);\n" + " strncpy(res, sexp_string_data(sexp_car(x)), klen);\n" + " res[sexp_string_length(sexp_car(x))] = '=';\n" + " strncpy(res+sexp_string_length(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n" + " res[len-1] = '\\0';\n" + " return res;\n" + "}\n\n")))) + +(define (write-init) + (newline) + (write-utilities) + (for-each write-func *funcs*) + (for-each write-type-funcs *types*) + (cat "sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {\n" + " sexp_gc_var2(name, tmp);\n" + " sexp_gc_preserve2(ctx, name, tmp);\n") + (for-each write-const *consts*) + (for-each write-type *types*) + (for-each write-func-binding *funcs*) + (for-each (lambda (x) (cat " " x "\n")) (reverse *inits*)) + (cat " sexp_gc_release2(ctx);\n" + " return SEXP_VOID;\n" + "}\n\n")) + +(define (generate file) + (display "/* automatically generated by chibi genstubs */\n") + (c-system-include "chibi/eval.h") + (load file) + (write-init)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main + +(define (main args) + (case (length args) + ((1) + (with-output-to-file (string-append (strip-extension (car args)) ".c") + (lambda () (generate (car args))))) + ((2) + (if (equal? "-" (cadr args)) + (generate (car args)) + (with-output-to-file (cadr args) (lambda () (generate (car args)))))) + (else + (error "usage: genstubs []")))) diff --git a/vm.c b/vm.c new file mode 100644 index 00000000..acbea8b2 --- /dev/null +++ b/vm.c @@ -0,0 +1,1391 @@ +/* vm.c -- stack-based virtual machine backend */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#if SEXP_USE_DEBUG_VM > 1 +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { + int i; + if (! sexp_oportp(out)) out = sexp_current_error_port(ctx); + for (i=0; i4; i=sexp_unbox_fixnum(stack[i+3])) { + self = stack[i+2]; + if (sexp_procedurep(self)) { + sexp_write_string(ctx, " called from ", out); + bc = sexp_procedure_code(self); + if (sexp_truep(sexp_bytecode_name(bc))) + sexp_write(ctx, sexp_bytecode_name(bc), out); + else + sexp_write_string(ctx, "", out); + if ((ls=sexp_bytecode_source(bc)) && sexp_pairp(ls)) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_char(ctx, '\n', out); + } + } +} + +/************************* code generation ****************************/ + +static void emit_word (sexp ctx, sexp_uint_t val) { + unsigned char *data; + expand_bcode(ctx, sizeof(sexp)); + data = sexp_bytecode_data(sexp_context_bc(ctx)); + sexp_context_align_pos(ctx); + *((sexp_uint_t*)(&(data[sexp_context_pos(ctx)]))) = val; + sexp_context_pos(ctx) += sizeof(sexp); +} + +static void emit_push (sexp ctx, sexp obj) { + emit(ctx, SEXP_OP_PUSH); + emit_word(ctx, (sexp_uint_t)obj); + if (sexp_pointerp(obj) && ! sexp_symbolp(obj)) + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); +} + +static void emit_enter (sexp ctx) {return;} +static void bless_bytecode (sexp ctx, sexp bc) {return;} + +static void emit_return (sexp ctx) { + emit(ctx, SEXP_OP_RET); +} + +static sexp_sint_t sexp_context_make_label (sexp ctx) { + sexp_sint_t label; + sexp_context_align_pos(ctx); + 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 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, SEXP_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, SEXP_OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, SEXP_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, SEXP_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, SEXP_OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, SEXP_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) + ? SEXP_OP_GLOBAL_REF : SEXP_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, SEXP_OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, SEXP_OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, SEXP_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, inv_default=0; + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); + + num_args = sexp_unbox_fixnum(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_data(op) + && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { + if (sexp_opcode_inverse(op)) { + inv_default = 1; + } else { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + } + + /* push the arguments onto the stack in reverse order */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC)) + ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the default for inverse opcodes */ + if (inv_default) { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case SEXP_OPC_ARITHMETIC: + /* fold variadic arithmetic operators */ + for (i=num_args-1; i>0; i--) + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + emit(ctx, SEXP_OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_FOREIGN: + emit(ctx, sexp_opcode_code(op)); + emit_word(ctx, (sexp_uint_t)op); + break; + case SEXP_OPC_TYPE_PREDICATE: + case SEXP_OPC_GETTER: + case SEXP_OPC_SETTER: + case SEXP_OPC_CONSTRUCTOR: + emit(ctx, sexp_opcode_code(op)); + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE) { + if (sexp_opcode_data(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); + if (sexp_opcode_data2(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + } + break; + case SEXP_OPC_PARAMETER: + emit_push(ctx, sexp_opcode_data(op)); + emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + sexp_context_depth(ctx) -= (num_args-1); + sexp_gc_release1(ctx); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, 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 ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); + + sexp_context_tailp(ctx) = tailp; + sexp_context_depth(ctx) -= len; + sexp_gc_release1(ctx); +} + +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_var2(tmp, bc); + sexp_gc_preserve2(ctx, tmp, 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_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); + 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, SEXP_OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, SEXP_OP_CONS); + emit(ctx2, SEXP_OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, SEXP_OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_fixnum((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); + sexp_bytecode_source(bc) = sexp_lambda_source(lambda); + if (sexp_nullp(fv)) { + /* shortcut, no free vars */ + tmp = sexp_make_vector(ctx2, SEXP_ZERO, 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, SEXP_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_fixnum(k)); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_VECTOR_SET); + emit(ctx, SEXP_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, SEXP_OP_MAKE_PROCEDURE); + } + sexp_gc_release2(ctx); +} + +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 make_param_list (sexp ctx, sexp_uint_t i) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_fixnum(i), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ls, bc, res, env; + sexp_gc_var5(params, ref, refs, lambda, ctx2); + if (i == sexp_opcode_num_args(op)) { /* return before preserving */ + if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); + } else if (i < sexp_opcode_num_args(op)) { + return sexp_compile_error(ctx, "not enough args for opcode", op); + } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ + return sexp_compile_error(ctx, "too many args for opcode", op); + } + sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = sexp_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), sexp_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_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + sexp_gc_release5(ctx); + 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_fixnum(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= SEXP_INIT_STACK_SIZE) { + _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); + goto end_loop; + } +#endif + _ALIGN_IP(); + i = sexp_unbox_fixnum(_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_fixnum(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_fixnum(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_fixnum(i); + stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + stack[top+1] = self; + stack[top+2] = sexp_make_fixnum(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 SEXP_OP_FCALL0: + tmp1 = _WORD0; + _ALIGN_IP(); + sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = fp; + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 0))); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL1: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 1), _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL2: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 2), _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL3: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 3), _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL4: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 4), _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; +#if SEXP_USE_EXTENDED_FCALL + case SEXP_OP_FCALLN: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + i = sexp_opcode_num_args(_WORD0); + tmp1 = sexp_fcall(ctx, self, i, _WORD0); + top -= (i-1); + _ARG1 = tmp1; + ip += sizeof(sexp); + sexp_check_exception(); + break; +#endif + case SEXP_OP_JUMP_UNLESS: + _ALIGN_IP(); + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case SEXP_OP_JUMP: + _ALIGN_IP(); + ip += _SWORD0; + break; + case SEXP_OP_PUSH: + _ALIGN_IP(); + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case SEXP_OP_DROP: + top--; + break; + case SEXP_OP_GLOBAL_REF: + _ALIGN_IP(); + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case SEXP_OP_GLOBAL_KNOWN_REF: + _ALIGN_IP(); + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_STACK_REF: /* `pick' in forth */ + _ALIGN_IP(); + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_REF: + _ALIGN_IP(); + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_SET: + _ALIGN_IP(); + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case SEXP_OP_CLOSURE_REF: + _ALIGN_IP(); + _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); + ip += sizeof(sexp); + break; + case SEXP_OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_VECTOR_LENGTH: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); + break; + case SEXP_OP_BYTES_REF: + case SEXP_OP_STRING_REF: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + if (ip[-1] == SEXP_OP_BYTES_REF) + _ARG2 = sexp_bytes_ref(_ARG1, _ARG2); + else +#if SEXP_USE_UTF8_STRINGS + _ARG2 = sexp_string_utf8_ref(ctx, _ARG1, _ARG2); +#else + _ARG2 = sexp_string_ref(_ARG1, _ARG2); +#endif + top--; + break; + case SEXP_OP_BYTES_SET: + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2)); + else if (! sexp_charp(_ARG3)) + sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + if (ip[-1] == SEXP_OP_BYTES_SET) + sexp_bytes_set(_ARG1, _ARG2, _ARG3); + else +#if SEXP_USE_UTF8_STRINGS + sexp_string_utf8_set(ctx, _ARG1, _ARG2, _ARG3); +#else + sexp_string_set(_ARG1, _ARG2, _ARG3); +#endif + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_BYTES_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("bytes-length: not a byte-vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_bytes_length(_ARG1)); + break; + case SEXP_OP_STRING_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_UTF8_STRINGS + _ARG1 = sexp_make_fixnum(sexp_string_utf8_length((unsigned char*)sexp_string_data(_ARG1), sexp_string_length(_ARG1))); +#else + _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); +#endif + break; + case SEXP_OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; + _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case SEXP_OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; + if (! sexp_fixnump(_ARG1)) + sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); + _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_MAKE_EXCEPTION: + _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + break; + case SEXP_OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case SEXP_OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case SEXP_OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case SEXP_OP_FIXNUMP: + _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; + case SEXP_OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case SEXP_OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case SEXP_OP_TYPEP: + _ALIGN_IP(); + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_MAKE: + _ALIGN_IP(); + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_REF: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_SET: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); + sexp_slot_set(_ARG1, _UWORD1, _ARG2); + _ARG2 = SEXP_VOID; + ip += sizeof(sexp)*2; + top--; + break; + case SEXP_OP_ISA: + _ARG2 = sexp_make_boolean(sexp_isa(_ARG1, _ARG2)); + top--; + break; + case SEXP_OP_SLOTN_REF: + if (! sexp_typep(_ARG1)) + sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + else if (! sexp_isa(_ARG2, _ARG1)) + sexp_raise("slot-ref: bad type", sexp_list1(ctx, _ARG2)); + else if (! sexp_fixnump(_ARG3)) + sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + _ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3)); + top-=2; + break; + case SEXP_OP_SLOTN_SET: + if (! sexp_typep(_ARG1)) + sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + else if (! sexp_isa(_ARG2, _ARG1)) + sexp_raise("slot-set!: bad type", sexp_list1(ctx, _ARG2)); + else if (sexp_immutablep(_ARG2)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG2)); + else if (! sexp_fixnump(_ARG3)) + sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4); + _ARG4 = SEXP_VOID; + top-=3; + break; + case SEXP_OP_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case SEXP_OP_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case SEXP_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 SEXP_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 SEXP_OP_CONS: + sexp_context_top(ctx) = top; + _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_ADD: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(j); + } + else { + _ARG1 = sexp_add(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_add(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_add(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) + (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) + sexp_flonum_value(tmp2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_SUB: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(j); + } + else { + _ARG1 = sexp_sub(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_sub(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_sub(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) - (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) - sexp_flonum_value(tmp2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_MUL: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); + if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(prod); + } + else { + _ARG1 = sexp_mul(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_mul(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_mul(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) * (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) * sexp_flonum_value(tmp2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_DIV: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (tmp2 == SEXP_ZERO) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(tmp1) && sexp_flonum_value(tmp1) == 0.0) + _ARG1 = sexp_make_flonum(ctx, 0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { +#if SEXP_USE_FLONUMS + tmp1 = sexp_fixnum_to_flonum(ctx, tmp1); + tmp2 = sexp_fixnum_to_flonum(ctx, tmp2); + _ARG1 = sexp_fp_div(ctx, tmp1, tmp2); + if (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1))) + _ARG1 = sexp_make_fixnum(sexp_flonum_value(_ARG1)); +#else + _ARG1 = sexp_fx_div(tmp1, tmp2); +#endif + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_div(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_div(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) / (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) / sexp_flonum_value(tmp2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_QUOTIENT: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + if (tmp2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG1 = sexp_fx_div(tmp1, tmp2); + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_quotient(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, tmp2)); +#endif + break; + case SEXP_OP_REMAINDER: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + if (tmp2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG1 = sexp_fx_rem(tmp1, tmp2); + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_remainder(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, tmp2)); +#endif + break; + case SEXP_OP_LT: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = (sexp_sint_t)tmp1 < (sexp_sint_t)tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) < 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) < sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) < sexp_flonum_value(tmp2); +#endif + } else sexp_raise("<: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_LE: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = (sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) <= 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) <= sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) <= (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) <= sexp_flonum_value(tmp2); +#endif + } else sexp_raise("<=: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_EQN: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = tmp1 == tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) == 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) == sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) == (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) == sexp_flonum_value(tmp2); +#endif + } else sexp_raise("=: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case SEXP_OP_FIX2FLO: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); +#endif + else if (! sexp_flonump(_ARG1)) + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case SEXP_OP_FLO2FIX: + if (sexp_flonump(_ARG1)) { + if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { + sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_BIGNUMS + } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { + _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); +#endif + } else { + _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); + } + } else if (! sexp_fixnump(_ARG1) && ! sexp_bignump(_ARG1)) { + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + } + break; + case SEXP_OP_CHAR2INT: + if (! sexp_charp(_ARG1)) + sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); + break; + case SEXP_OP_INT2CHAR: + if (! sexp_fixnump(_ARG1)) + sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); + break; + case SEXP_OP_CHAR_UPCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_CHAR_DOWNCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_WRITE_CHAR: + if (! sexp_charp(_ARG1)) + sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); + if (! sexp_oportp(_ARG2)) + sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2)); +#if SEXP_USE_UTF8_STRINGS + if (sexp_unbox_character(_ARG1) >= 0x80) + sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + else +#endif + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_NEWLINE: + if (! sexp_oportp(_ARG1)) + sexp_raise("newline: not an output-port", sexp_list1(ctx, _ARG1)); + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case SEXP_OP_READ_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); +#if SEXP_USE_UTF8_STRINGS + if (i >= 0x80) + _ARG1 = sexp_read_utf8_char(ctx, _ARG1, i); + else +#endif + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_PEEK_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); + sexp_push_char(ctx, i, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_YIELD: + fuel = 0; + _PUSH(SEXP_VOID); + break; + case SEXP_OP_RET: + i = sexp_unbox_fixnum(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_fixnum(stack[fp+1]); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_fixnum(stack[fp+3]); + break; + case SEXP_OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); + } + goto loop; + + end_loop: +#if SEXP_USE_GREEN_THREADS + if (ctx != root_thread) { + if (sexp_context_refuel(root_thread) <= 0) { + /* the root already terminated */ + _ARG1 = SEXP_VOID; + } else { + /* don't return from child threads */ + sexp_context_refuel(ctx) = fuel = 0; + goto loop; + } + } +#endif + sexp_gc_release3(ctx); + sexp_context_top(ctx) = top; + return _ARG1; +} + +/******************************* apply ********************************/ + +sexp sexp_apply1 (sexp ctx, sexp f, sexp x) { + sexp res; + sexp_gc_var1(args); + if (sexp_opcodep(f)) { + res = ((sexp_proc2)sexp_opcode_func(f))(ctx sexp_api_pass(f, 1), x); + } else { + sexp_gc_preserve1(ctx, args); + res = sexp_apply(ctx, f, args=sexp_list1(ctx, x)); + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_apply (sexp ctx, sexp proc, sexp args) { + sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx), len, offset; + len = sexp_unbox_fixnum(sexp_length(ctx, args)); + if (sexp_opcodep(proc)) + proc = make_opcode_procedure(ctx, proc, len); + if (! sexp_procedurep(proc)) { + res = sexp_exceptionp(proc) ? proc : + sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); + } else { + offset = top + len; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) + stack[--offset] = sexp_car(ls); + stack[top++] = sexp_make_fixnum(len); + stack[top++] = SEXP_ZERO; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + stack[top++] = SEXP_ZERO; + sexp_context_top(ctx) = top; + res = sexp_vm(ctx, proc); + if (! res) res = SEXP_VOID; /* shouldn't happen */ + } + return res; +} From c9beeccae39fdfd177b20a441ebcd3c24bfac707 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 17 Aug 2010 20:46:27 +0900 Subject: [PATCH 512/535] commenting out ECHOPRT and PENDIN --- lib/chibi/stty.stub | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/chibi/stty.stub b/lib/chibi/stty.stub index 3c5939c5..d51d3e9e 100644 --- a/lib/chibi/stty.stub +++ b/lib/chibi/stty.stub @@ -70,7 +70,7 @@ (define-c-const unsigned-long ECHOE) (define-c-const unsigned-long ECHO) (define-c-const unsigned-long ECHONL) -(define-c-const unsigned-long ECHOPRT) +;; (define-c-const unsigned-long ECHOPRT) (define-c-const unsigned-long ECHOCTL) (define-c-const unsigned-long ISIG) (define-c-const unsigned-long ICANON) @@ -80,7 +80,7 @@ (define-c-const unsigned-long TOSTOP) (define-c-const unsigned-long FLUSHO) ;; (define-c-const unsigned-long NOKERNINFO) -(define-c-const unsigned-long PENDIN) +;; (define-c-const unsigned-long PENDIN) (define-c-const unsigned-long NOFLSH) (define-c-const unsigned-long VEOF) From 7dd6be4b21b893be4cf8f431d62703a8b0f0c556 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 17 Aug 2010 20:56:55 +0900 Subject: [PATCH 513/535] removing sexp_printf uses --- lib/chibi/disasm.c | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index d193e3a7..3a04b3c6 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -8,6 +8,12 @@ #define SEXP_DISASM_MAX_DEPTH 8 #define SEXP_DISASM_PAD_WIDTH 4 +static void sexp_write_pointer (sexp ctx, void *p, sexp out) { + char buf[32]; + sprintf(buf, "%p", p); + sexp_write_string(ctx, buf, out); +} + static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { sexp tmp; unsigned char *ip, opcode, i; @@ -15,7 +21,8 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { if (sexp_procedurep(bc)) { bc = sexp_procedure_code(bc); } else if (sexp_opcodep(bc)) { - sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); + sexp_write_string(ctx, sexp_opcode_name(bc), out); + sexp_write_string(ctx, " is a primitive\n", out); return SEXP_VOID; } else if (! sexp_bytecodep(bc)) { return sexp_type_exception(ctx, self, SEXP_BYTECODE, bc); @@ -31,7 +38,8 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { sexp_write(ctx, sexp_bytecode_name(bc), out); sexp_write_char(ctx, ' ', out); } - sexp_printf(ctx, out, "%p\n", bc); + sexp_write_pointer(ctx, bc, out); + sexp_newline(ctx, out); ip = sexp_bytecode_data(bc); @@ -40,9 +48,13 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { sexp_write_char(ctx, ' ', out); opcode = *ip++; if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { - sexp_printf(ctx, out, " %s ", reverse_opcode_names[opcode]); + sexp_write_char(ctx, ' ', out); + sexp_write_string(ctx, reverse_opcode_names[opcode], out); + sexp_write_char(ctx, ' ', out); } else { - sexp_printf(ctx, out, " %d ", opcode); + sexp_write_string(ctx, " ", out); + sexp_write(ctx, sexp_make_fixnum(opcode), out); + sexp_write_char(ctx, ' ', out); } switch (opcode) { case SEXP_OP_STACK_REF: @@ -57,7 +69,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { case SEXP_OP_FCALL2: case SEXP_OP_FCALL3: case SEXP_OP_FCALL4: - sexp_printf(ctx, out, "%ld", (long) ((sexp*)ip)[0]); + sexp_write_pointer(ctx, ((sexp*)ip)[0], out); ip += sizeof(sexp); break; case SEXP_OP_SLOT_REF: From 69a4dc97d5a9cb1e8dd4a10155c23d2a659b89f5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 17 Aug 2010 12:01:49 +0000 Subject: [PATCH 514/535] removing sexp_printf use --- .hgignore | 30 + AUTHORS | 29 + COPYING | 24 + Makefile | 246 ++++ README | 440 ++++++ RELEASE | 1 + TODO | 165 +++ VERSION | 1 + chibi-scheme.vcproj | 206 +++ doc/chibi-scheme.1 | 133 ++ eval.c | 1758 ++++++++++++++++++++++ gc.c | 346 +++++ include/chibi/bignum.h | 43 + include/chibi/eval.h | 203 +++ include/chibi/features.h | 469 ++++++ include/chibi/sexp.h | 1065 ++++++++++++++ lib/chibi/ast.c | 248 ++++ lib/chibi/ast.module | 33 + lib/chibi/ast.scm | 91 ++ lib/chibi/base64.module | 7 + lib/chibi/base64.scm | 351 +++++ lib/chibi/disasm.c | 99 ++ lib/chibi/disasm.module | 5 + lib/chibi/filesystem.module | 27 + lib/chibi/filesystem.scm | 43 + lib/chibi/filesystem.stub | 118 ++ lib/chibi/heap-stats.c | 129 ++ lib/chibi/heap-stats.module | 6 + lib/chibi/io.module | 13 + lib/chibi/io/io.scm | 170 +++ lib/chibi/io/io.stub | 27 + lib/chibi/io/port.c | 196 +++ lib/chibi/loop.module | 9 + lib/chibi/loop/loop.scm | 365 +++++ lib/chibi/match.module | 6 + lib/chibi/match/match.scm | 683 +++++++++ lib/chibi/mime.module | 7 + lib/chibi/mime.scm | 410 ++++++ lib/chibi/modules.module | 8 + lib/chibi/modules.scm | 103 ++ lib/chibi/net.module | 11 + lib/chibi/net.scm | 32 + lib/chibi/net.stub | 25 + lib/chibi/net/http.module | 7 + lib/chibi/net/http.scm | 180 +++ lib/chibi/pathname.module | 7 + lib/chibi/pathname.scm | 180 +++ lib/chibi/process.module | 18 + lib/chibi/process.stub | 73 + lib/chibi/quoted-printable.module | 7 + lib/chibi/quoted-printable.scm | 157 ++ lib/chibi/repl.module | 9 + lib/chibi/repl.scm | 41 + lib/chibi/scribble.module | 5 + lib/chibi/scribble.scm | 247 ++++ lib/chibi/signal.c | 76 + lib/chibi/stty.module | 11 + lib/chibi/stty.scm | 235 +++ lib/chibi/stty.stub | 106 ++ lib/chibi/system.module | 15 + lib/chibi/system.stub | 34 + lib/chibi/term/edit-line.module | 5 + lib/chibi/term/edit-line.scm | 505 +++++++ lib/chibi/test.module | 14 + lib/chibi/test.scm | 662 +++++++++ lib/chibi/time.module | 12 + lib/chibi/time.stub | 46 + lib/chibi/type-inference.module | 7 + lib/chibi/type-inference.scm | 272 ++++ lib/chibi/uri.module | 10 + lib/chibi/uri.scm | 306 ++++ lib/config.scm | 179 +++ lib/init.scm | 875 +++++++++++ lib/srfi/1.module | 31 + lib/srfi/1/alists.scm | 14 + lib/srfi/1/constructors.scm | 36 + lib/srfi/1/deletion.scm | 25 + lib/srfi/1/fold.scm | 115 ++ lib/srfi/1/lset.scm | 51 + lib/srfi/1/misc.scm | 54 + lib/srfi/1/predicates.scm | 42 + lib/srfi/1/search.scm | 54 + lib/srfi/1/selectors.scm | 59 + lib/srfi/11.module | 28 + lib/srfi/16.module | 24 + lib/srfi/18.module | 24 + lib/srfi/18/interface.scm | 63 + lib/srfi/18/threads.c | 421 ++++++ lib/srfi/18/types.scm | 24 + lib/srfi/2.module | 16 + lib/srfi/26.module | 24 + lib/srfi/27.module | 11 + lib/srfi/27/constructors.scm | 10 + lib/srfi/27/rand.c | 204 +++ lib/srfi/33.module | 17 + lib/srfi/33/bit.c | 303 ++++ lib/srfi/33/bitwise.scm | 61 + lib/srfi/38.module | 6 + lib/srfi/38.scm | 255 ++++ lib/srfi/39.module | 25 + lib/srfi/6.module | 5 + lib/srfi/69.module | 17 + lib/srfi/69/hash.c | 242 ++++ lib/srfi/69/interface.scm | 115 ++ lib/srfi/69/type.scm | 12 + lib/srfi/8.module | 10 + lib/srfi/9.module | 90 ++ lib/srfi/95.module | 7 + lib/srfi/95/qsort.c | 228 +++ lib/srfi/95/sort.scm | 70 + lib/srfi/98.module | 5 + lib/srfi/98/env.c | 48 + main.c | 219 +++ mkfile | 28 + opcodes.c | 178 +++ opt/bignum.c | 775 ++++++++++ opt/fcall.c | 33 + opt/opcode_names.h | 21 + opt/plan9-opcodes.c | 19 + opt/plan9.c | 351 +++++ opt/sexp-huff.c | 128 ++ opt/sexp-hufftabs.c | 92 ++ opt/sexp-unhuff.c | 71 + opt/simplify.c | 143 ++ sexp.c | 1842 ++++++++++++++++++++++++ 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 | 48 + tests/basic/test10-unhygiene.res | 6 + tests/basic/test10-unhygiene.scm | 49 + tests/build/build-opts.txt | 21 + tests/build/build-tests.sh | 37 + tests/flonum-tests.scm | 21 + tests/hash-tests.scm | 37 + tests/install/install-tests.pl | 57 + tests/install/run-install-test.sh | 12 + tests/lib-tests.scm | 13 + tests/loop-tests.scm | 168 +++ tests/match-tests.scm | 135 ++ tests/numeric-tests.scm | 120 ++ tests/r5rs-tests.scm | 465 ++++++ tests/sort-tests.scm | 40 + tests/thread-tests.scm | 25 + tools/genstatic.scm | 135 ++ tools/genstubs.scm | 1280 ++++++++++++++++ vm.c | 1394 ++++++++++++++++++ 163 files changed, 23653 insertions(+) create mode 100644 .hgignore create mode 100644 AUTHORS create mode 100644 COPYING create mode 100644 Makefile create mode 100644 README create mode 100644 RELEASE create mode 100644 TODO create mode 100644 VERSION create mode 100644 chibi-scheme.vcproj create mode 100644 doc/chibi-scheme.1 create mode 100644 eval.c create mode 100644 gc.c create mode 100644 include/chibi/bignum.h create mode 100644 include/chibi/eval.h create mode 100644 include/chibi/features.h create mode 100644 include/chibi/sexp.h create mode 100644 lib/chibi/ast.c create mode 100644 lib/chibi/ast.module create mode 100644 lib/chibi/ast.scm create mode 100644 lib/chibi/base64.module create mode 100644 lib/chibi/base64.scm create mode 100644 lib/chibi/disasm.c create mode 100644 lib/chibi/disasm.module create mode 100644 lib/chibi/filesystem.module create mode 100644 lib/chibi/filesystem.scm create mode 100644 lib/chibi/filesystem.stub create mode 100644 lib/chibi/heap-stats.c create mode 100644 lib/chibi/heap-stats.module create mode 100644 lib/chibi/io.module create mode 100644 lib/chibi/io/io.scm create mode 100644 lib/chibi/io/io.stub create mode 100644 lib/chibi/io/port.c create mode 100644 lib/chibi/loop.module create mode 100644 lib/chibi/loop/loop.scm create mode 100644 lib/chibi/match.module create mode 100644 lib/chibi/match/match.scm create mode 100644 lib/chibi/mime.module create mode 100644 lib/chibi/mime.scm create mode 100644 lib/chibi/modules.module create mode 100644 lib/chibi/modules.scm create mode 100644 lib/chibi/net.module create mode 100644 lib/chibi/net.scm create mode 100644 lib/chibi/net.stub create mode 100644 lib/chibi/net/http.module create mode 100644 lib/chibi/net/http.scm create mode 100644 lib/chibi/pathname.module create mode 100644 lib/chibi/pathname.scm create mode 100644 lib/chibi/process.module create mode 100644 lib/chibi/process.stub create mode 100644 lib/chibi/quoted-printable.module create mode 100644 lib/chibi/quoted-printable.scm create mode 100644 lib/chibi/repl.module create mode 100644 lib/chibi/repl.scm create mode 100644 lib/chibi/scribble.module create mode 100644 lib/chibi/scribble.scm create mode 100644 lib/chibi/signal.c create mode 100644 lib/chibi/stty.module create mode 100644 lib/chibi/stty.scm create mode 100644 lib/chibi/stty.stub create mode 100644 lib/chibi/system.module create mode 100644 lib/chibi/system.stub create mode 100644 lib/chibi/term/edit-line.module create mode 100644 lib/chibi/term/edit-line.scm create mode 100644 lib/chibi/test.module create mode 100644 lib/chibi/test.scm create mode 100644 lib/chibi/time.module create mode 100644 lib/chibi/time.stub create mode 100644 lib/chibi/type-inference.module create mode 100644 lib/chibi/type-inference.scm create mode 100644 lib/chibi/uri.module create mode 100644 lib/chibi/uri.scm create mode 100644 lib/config.scm create mode 100644 lib/init.scm create mode 100644 lib/srfi/1.module create mode 100644 lib/srfi/1/alists.scm create mode 100644 lib/srfi/1/constructors.scm create mode 100644 lib/srfi/1/deletion.scm create mode 100644 lib/srfi/1/fold.scm create mode 100644 lib/srfi/1/lset.scm create mode 100644 lib/srfi/1/misc.scm create mode 100644 lib/srfi/1/predicates.scm create mode 100644 lib/srfi/1/search.scm create mode 100644 lib/srfi/1/selectors.scm create mode 100644 lib/srfi/11.module create mode 100644 lib/srfi/16.module create mode 100644 lib/srfi/18.module create mode 100644 lib/srfi/18/interface.scm create mode 100644 lib/srfi/18/threads.c create mode 100644 lib/srfi/18/types.scm create mode 100644 lib/srfi/2.module create mode 100644 lib/srfi/26.module create mode 100644 lib/srfi/27.module create mode 100644 lib/srfi/27/constructors.scm create mode 100644 lib/srfi/27/rand.c create mode 100644 lib/srfi/33.module create mode 100644 lib/srfi/33/bit.c create mode 100644 lib/srfi/33/bitwise.scm create mode 100644 lib/srfi/38.module create mode 100644 lib/srfi/38.scm create mode 100644 lib/srfi/39.module create mode 100644 lib/srfi/6.module create mode 100644 lib/srfi/69.module create mode 100644 lib/srfi/69/hash.c create mode 100644 lib/srfi/69/interface.scm create mode 100644 lib/srfi/69/type.scm create mode 100644 lib/srfi/8.module create mode 100644 lib/srfi/9.module create mode 100644 lib/srfi/95.module create mode 100644 lib/srfi/95/qsort.c create mode 100644 lib/srfi/95/sort.scm create mode 100644 lib/srfi/98.module create mode 100644 lib/srfi/98/env.c create mode 100644 main.c create mode 100644 mkfile create mode 100644 opcodes.c create mode 100644 opt/bignum.c create mode 100644 opt/fcall.c create mode 100644 opt/opcode_names.h create mode 100644 opt/plan9-opcodes.c create mode 100644 opt/plan9.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 opt/simplify.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/build/build-opts.txt create mode 100755 tests/build/build-tests.sh create mode 100644 tests/flonum-tests.scm create mode 100644 tests/hash-tests.scm create mode 100755 tests/install/install-tests.pl create mode 100755 tests/install/run-install-test.sh create mode 100644 tests/lib-tests.scm create mode 100644 tests/loop-tests.scm create mode 100644 tests/match-tests.scm create mode 100644 tests/numeric-tests.scm create mode 100644 tests/r5rs-tests.scm create mode 100644 tests/sort-tests.scm create mode 100644 tests/thread-tests.scm create mode 100755 tools/genstatic.scm create mode 100755 tools/genstubs.scm create mode 100644 vm.c diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..e8b8b309 --- /dev/null +++ b/.hgignore @@ -0,0 +1,30 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dylib +*.class +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +clibs.c +chibi-scheme +chibi-scheme-static +include/chibi/install.h +lib/chibi/filesystem.c +lib/chibi/io/io.c +lib/chibi/net.c +lib/chibi/process.c +lib/chibi/system.c +lib/chibi/time.c +lib/chibi/stty.c diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 00000000..fc0b8224 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,29 @@ +Alex Shinn wrote the initial version of chibi-scheme and all +distributed modules. + +The `dynamic-wind' implementation is adapted from the implementation +in the appendix to the Scheme48 reference manual, reportedly first +written by Chris Hanson and John Lamping. + +Thanks to the following people for patches and bug reports: + + * Alexander Shendi + * Andreas Rottman + * Bruno Deferrari + * Derrick Eddington + * Eduardo Cavazos + * Felix Winkelmann + * Gregor Klinke + * Jeremy Wolff + * Jeronimo Pellegrini + * John Cowan + * John Samsa + * Lars J Aas + * Lorenzo Campedelli + * Michal Kowalski (sladegen) + * Taylor Venable + +If you would prefer not to be listed, or are one of the users listed +without a full name, please contact me. If you've made a contribution +and are not listed, please accept my apologies and contact me +immediately! diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..1fcee28e --- /dev/null +++ b/COPYING @@ -0,0 +1,24 @@ +Copyright (c) 2009 Alex Shinn +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..131a73d2 --- /dev/null +++ b/Makefile @@ -0,0 +1,246 @@ +# -*- makefile-gmake -*- + +.PHONY: all libs doc dist clean cleaner dist-clean test install uninstall +.PRECIOUS: %.c + +# install configuration + +CC ?= cc +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +SOLIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi +LIBDIR ?= $(PREFIX)/lib/chibi +MANDIR ?= $(PREFIX)/share/man/man1 + +DESTDIR ?= + +GENSTUBS ?= ./tools/genstubs.scm +GENSTATIC ?= ./tools/genstatic.scm + +######################################################################## +# system configuration - if not using GNU make, set PLATFORM and the +# following flags as necessary. + +# +LIBDL = -ldl + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +ifeq ($(shell uname -o),Cygwin) +PLATFORM=cygwin +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +PLATFORM=unix +endif +endif +endif +endif + +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0 +else +ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +STATICFLAGS = -DSEXP_USE_DL=0 +LIBDL = +else +ifeq ($(PLATFORM),cygwin) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static -DSEXP_USE_DL=0 +endif +endif +endif + +ifeq ($(USE_BOEHM),1) +SEXP_USE_BOEHM = 1 +endif + +ifeq ($(SEXP_USE_BOEHM),1) +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DSEXP_USE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude +endif + +ifeq ($(SEXP_USE_DL),0) +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS) +else +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm +XCFLAGS := -Wall -g3 $(CFLAGS) +endif + +######################################################################## + +all: chibi-scheme$(EXE) libs + +COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \ + lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \ + lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/net$(SO) \ + lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \ + lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \ + lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + +libs: $(COMPILED_LIBS) + +INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h + +include/chibi/install.h: Makefile + echo '#define sexp_so_extension "'$(SO)'"' > $@ + echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@ + echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ + echo '#define sexp_version "'`cat VERSION`'"' >> $@ + echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@ + +sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +eval.o: eval.c opcodes.c vm.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< + +libchibi-sexp$(SO): sexp.o + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) + +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 $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm + +clibs.c: $(GENSTATIC) lib lib/chibi lib/srfi + make chibi-scheme$(EXE) + make libs + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTATIC) $< > $@ + +%.c: %.stub $(GENSTUBS) + make chibi-scheme$(EXE) + -LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTUBS) $< + +lib/%$(SO): lib/%.c $(INCLUDES) + -$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +clean: + rm -f *.o *.i *.s *.8 + find lib -name \*$(SO) -exec rm -f '{}' \; + rm -f tests/basic/*.out tests/basic/*.err + +cleaner: clean + rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h + rm -rf *.dSYM + +dist-clean: cleaner + for f in `find lib -name \*.stub`; do rm -f $${f%.stub}.c; done + +test-basic: chibi-scheme$(EXE) + @for f in tests/basic/*.scm; do \ + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + +test-build: + ./tests/build/build-tests.sh + +test-threads: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/thread-tests.scm + +test-numbers: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/numeric-tests.scm + +test-flonums: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/flonum-tests.scm + +test-hash: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/hash-tests.scm + +test-match: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/match-tests.scm + +test-loop: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/loop-tests.scm + +test-sort: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm + +test-libs: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/lib-tests.scm + +test: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/r5rs-tests.scm + +install: chibi-scheme$(EXE) + mkdir -p $(DESTDIR)$(BINDIR) + cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ + cp tools/genstubs.scm $(DESTDIR)$(BINDIR)/ + mkdir -p $(DESTDIR)$(MODDIR) + cp -r lib/* $(DESTDIR)$(MODDIR)/ + mkdir -p $(DESTDIR)$(INCDIR) + cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ + mkdir -p $(DESTDIR)$(LIBDIR) + mkdir -p $(DESTDIR)$(SOLIBDIR) + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + -cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/ + mkdir -p $(DESTDIR)$(MANDIR) + cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/ + -if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + +uninstall: + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) + rm -f $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE) + rm -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO) + rm -f $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a + cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -rf $(DESTDIR)$(MODDIR) + +dist: dist-clean + 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` + +mips-dist: dist-clean + rm -f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz + mkdir chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + for f in `hg manifest`; do mkdir -p chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/$$f; done + tar cphzvf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + rm -rf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` diff --git a/README b/README new file mode 100644 index 00000000..6e5b00a6 --- /dev/null +++ b/README @@ -0,0 +1,440 @@ + + 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. + +------------------------------------------------------------------------ +INSTALLING + +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 chibi/features.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 CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 + +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 features.h file, or +directly from make with: + + make SEXP_USE_BOEHM=1 + +To compile a static executable, use + + make chibi-scheme-static SEXP_USE_DL=0 + +To compile a static executable with all C libraries statically +included, first you need to create a clibs.c file, which can be done +with: + + make clibs.c + +or edited manually. Be sure to run this with a non-static +chibi-scheme. Then you can make the static executable with: + + make cleaner + make chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS + +------------------------------------------------------------------------ +CHIBI-SCHEME LANGUAGE + +The default language is mostly compatible with the R5RS, with all +differences made by design, not through difficulty of implementation. +The following procedures are omitted: + + transcript-on and transcript-off (because they're silly) + rationalize (pending the addition of rational numbers) + +Apart from this, chibi-scheme is case-sensitive, unlike the R5RS. +The default configuration includes fixnums, flonums and bignums +but no exact rationals or complex numbers. + +Full continuations are supported, but currently continuations don't +take C code into account. The only higher-order C functions in the +standard environment are LOAD and EVAL. + +LOAD is extended to accept an optional environment argument, like +EVAL. You can also LOAD shared libraries in addition to Scheme source +files - in this case the function sexp_init_library is automatically +called with the following signature: + + sexp_init_library(sexp context, sexp environment) + +SYNTAX-RULES macros are provided by default, with the extensions from +SRFI-46. In addition, low-level hygienic macros are provided with +a syntactic-closures interface, including SC-MACRO-TRANSFORMER, +RSC-MACRO-TRANSFORMER, and ER-MACRO-TRANSFORMER. A good introduction +to syntactic-closures can be found at: + + http://community.schemewiki.org/?syntactic-closures + +IDENTIFIER?, IDENTIFIER->SYMBOL, IDENTIFIER=?, and +MAKE-SYNTACTIC-CLOSURE and STRIP-SYNTACTIC-CLOSURES are provided. + +SRFI-0's COND-EXPAND is provided, with the feature `chibi'. + +STRING-CONCATENATE concatenates a list of strings. + +------------------------------------------------------------------------ +TYPES + +You can define new data types with SRFI-9. This is just syntactic +sugar for the following more primitive type constructors: + +(register-simple-type ) + => ; a fixnum + +(make-type-predicate ) + => ; takes 1 arg, returns #t iff that arg is of the type + +(make-constructor ) + => ; takes 0 args, returns a newly allocated instance of type + +(make-getter ) + => ; takes 1 args, retrieves the field located at the index + +(make-setter ) + => ; takes 2 args, sets the field located at the index + +------------------------------------------------------------------------ +MODULE SYSTEM + +A configurable module system, in the style of the Scheme48 module +system, is provided by default. + +Modules names are hierarchical lists of symbols or numbers. The +definition of the module (foo bar baz) is searched for in the file +foo/bar/baz.module. This file should contain an expression of the +form: + + (define-module (foo bar baz) + ...) + +where can be any of + + (export ...) - specify an export list + (import ...) - specify one or more imports + (import-immutable ...) - specify an immutable import + (body ...) - inline Scheme code + (include ...) - load one or more files + (include-shared ...) - dynamic load a library + + can either be a module name or any of + + (only ...) + (except ...) + (rename ( ) ...) + (prefix ) + +The can be composed and perform basic selection and renaming of +individual identifiers from the given module. + +Files are loaded relative to the .module file, and are written with +their extension (so you can use whatever suffix you prefer - .scm, +.ss, .sls, etc.). + +Shared modules, on the other hand, should be specified _without_ the +extension - the correct suffix will be added portably (e.g. .so for +Unix and .dylib for OS X). + +You may also use COND-EXPAND and arbitrary macro expansions in a +module definition to generate . + +------------------------------------------------------------------------ +MODULES + +The default environment is (scheme) - you almost always want to import +this. + +Currently you can load the following SRFIs with (import (srfi N)): + + (srfi 0) - cond-expand + (srfi 1) - list library + (srfi 2) - and-let* + (srfi 6) - basic string ports + (srfi 8) - receive + (srfi 9) - define-record-type + (srfi 11) - let-values/let*-values + (srfi 16) - case-lambda + (srfi 22) - running scheme scripts on Unix + (srfi 23) - error reporting mechanism + (srfi 26) - cut/cute partial application + (srfi 27) - sources of random bits + (srfi 33) - bitwise operators + (srfi 39) - prameter objects + (srfi 46) - basic syntax-rules extensions + (srfi 62) - s-expression comments + (srfi 69) - basic hash tables + (srfi 95) - sorting and merging + (srfi 98) - environment access + +although 0, 22, 23, 46 and 62 are built into the default environment +so there's no need to import them. + +Included non-standard modules are put in the (chibi) module namespace. +The following additional modules are available: + + (chibi net) - networking interface + (chibi filesystem) - local filesystem and file descriptor interface + (chibi process) - processes and signals + (chibi system) - host system and user information + (chibi time) - time and date library + (chibi match) - pattern-matching library + (chibi loop) - extensible loop syntax + (chibi pathname) - pathname manipulation utilities + (chibi uri) - URI parsing and construction utilities + (chibi macroexpand) - macro expansion utility + (chibi ast) - interface to the internal Abstract Syntax Tree + (chibi disasm) - disassembly utility for the chibi VM + (chibi heap-stats) - debugging tool to analyze or dump the heap + +------------------------------------------------------------------------ +C INTERFACE + +See the file main.c for an example of using chibi-scheme as a library. + +The basic usage involves creating a context for evaluation and loading +or evaluating Scheme source with it. Begin by including the eval.h +header file: + + #include + +then call + + sexp_scheme_init(); + +with no parameters to initialize any globals (this actually does +nothing in the standard configuration but is a good idea to call +anyway). + +Then you can use the following to create and manipulate contexts: + + sexp_make_eval_context(context, stack, environment, heap_size) + Creates a new context with the given stack and environment. + If context is non-NULL, this will be the "parent" context and + the two contexts will share a heap. Otherwise, a new heap + will be allocated with heap_size, or a default size if heap_size + is zero. stack and environment may both also be NULL (and _must_ + be NULL if context is NULL) and will be given standard defaults. + + Thus to create your first context you generally call: + + sexp_make_eval_context(NULL, NULL, NULL, 0) + + You can create as many contexts as you want, and other than those + sharing a heap they are all independent and thread-safe. + + sexp_load_standard_env(context, env, version) + Loads the init.scm file in the environment env. Version refers + to the RnRS version number and should always be SEXP_FIVE. The + environment created with sexp_make_eval_context only contains + core syntactic forms and C primitives (thus for example it has + CAR but not CADR or LIST), so to get a full featured + environment, plus a module system with which to load additional + modules, you want to use this. + + sexp_destroy_context(context) + Signals that you no longer need context, or any other context + sharing the heap. It will thus free() the context and heap and + all associated memory. Does nothing if using the Boehm GC. + +Environments can be handled with the following: + + sexp_context_env(context) + A macro returning the default environment associated with context. + + sexp_env_define(context, env, symbol, value) + Define a variable in an environment. + + sexp_env_ref(env, symbol, dflt) + Fetch the binding for symbol from the environment env, + returning the default dflt if the symbol is unbound. + +You can evaluate code with the following utility: + + sexp_eval(context, expr, env) + Evaluates an s-expression in an environment. + env can be NULL to use the context's default env. + + sexp_eval_string(context, str, env) + Reads an s-expression from str and evaluates it in env. + + sexp_load(context, file, env) + Read and eval all top-level forms from file in environment env. + As described in LOAD above, file may be a shared library. + +To define new primitive functions from C, use sexp_define_foreign, +which takes a Scheme environment, a name, a number of arguments the C +function takes (not counting the context argument), and a C function. + + /* sexp_define_foreign(context, env, name, num_args, f) */ + + sexp add (sexp context, sexp x, sexp y) { + return sexp_fx_add(x, y); + } + + sexp_define_foreign(context, env, "add", 2, add); + +You can also define functions with a single optional argument: + + sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); + +See the SRFI-69 implementation for more detailed examples of this. + +------------------------------------------------------------------------ +FFI + +Simple C FFI. "genstubs.scm file.stub" will read in the C function +FFI definitions from file.stub and output the appropriate C +wrappers into file.c. You can then compile that file with: + + cc -fPIC -shared file.c -lchibi-scheme + +(or using whatever flags are appropriate to generate shared libs on +your platform) and then the generated .so file can be loaded +directly with LOAD, or portably using (include-shared "file") in a +module definition (note that include-shared uses no suffix). + +The goal of this interface is to make access to C types and +functions easy, without requiring the user to write any C code. +That means the stubber needs to be intelligent about various C +calling conventions and idioms, such as return values passed in +actual parameters. Writing C by hand is still possible, and +several of the core modules provide C interfaces directly without +using the stubber. + +================================ + +Struct Interface + +(define-c-struct struct-name + [predicate: predicate-name] + [constructor: constructor-name] + [finalizer: c_finalizer_name] + (type c_field_name getter-name setter-name) ...) + + +================================ + + +Function Interface + +(define-c return-type name-spec (arg-type ...)) + +where name-space is either a symbol name, or a list of +(scheme-name c_name). If just a symbol, the C name is taken +to be the same with -'s replaced by _'s. + +arg-type is a type suitable for input validation and conversion. + +================================ + + +Types + +Types + +Basic Types + void + boolean + char + sexp (no conversions) + +Integer Types: + signed-char short int long + unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t + time_t (in seconds, but using the chibi epoch of 2010/01/01) + errno (as a return type returns #f on error) + +Float Types: + float double long-double + +String Types: + string - a null-terminated char* + env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme + in addition you can use (array char) as a string + +Port Types: + input-port output-port + +Struct Types: + +Struct types are by default just referred to by the bare +struct-name from define-c-struct, and it is assumed you want a +pointer to that type. To refer to the full struct, use the struct +modifier, as in (struct struct-name). + +Type modifiers + +Any type may also be written as a list of modifiers followed by the +type itself. The supported modifiers are: + +const: prepends the "const" C type modifier + * as a return or result parameter, makes non-immediates immutable + +free: it's Scheme's responsibility to "free" this resource + * as a return or result parameter, registers the freep flag + this causes the type finalizer to be run when GCed + +maybe-null: this pointer type may be NULL + * as a result parameter, NULL is translated to #f + normally this would just return a wrapped NULL pointer + * as an input parameter, #f is translated to NULL + normally this would be a type error + +pointer: create a pointer to this type + * as a return parameter, wraps the result in a vanilla cpointer + * as a result parameter, boxes then unboxes the value + +struct: treat this struct type as a struct, not a pointer + * as an input parameter, dereferences the pointer + * as a type field, indicates a nested struct + +link: add a gc link + * as a field getter, link to the parent object, so the + parent won't be GCed so long as we have a reference + to the child. this behavior is automatic for nested + structs. + +result: return a result in this parameter + * if there are multiple results (including the return type), + they are all returned in a list + * if there are any result parameters, a return type + of errno returns #f on failure, and as eliminated + from the list of results otherwise + +(value ): specify a fixed value + * as an input parameter, this parameter is not provided + in the Scheme API but always passed as + +(default ): specify a default value + * as the final input parameter, makes the Scheme parameter + optional, defaulting to + +(array []) an array type + * length must be specified for return and result parameters + * if specified, length can be any of + ** an integer, for a fixed size + ** the symbol null, indicating a NULL-terminated array diff --git a/RELEASE b/RELEASE new file mode 100644 index 00000000..35f6fb33 --- /dev/null +++ b/RELEASE @@ -0,0 +1 @@ +lithium diff --git a/TODO b/TODO new file mode 100644 index 00000000..161ca82c --- /dev/null +++ b/TODO @@ -0,0 +1,165 @@ +-*- org -*- + +* compiler +** DONE ast rewrite + - State "DONE" [2009-04-09 Thu 14:32] +** DONE call/cc support + - State "DONE" [2009-04-09 Thu 14:36] +** DONE exceptions + - State "DONE" [2009-04-09 Thu 14:45] +** TODO native x86 backend + API redesign in preparation complete, initial + tests on native factorial and closures working. +** TODO fasl/image files + sexp_copy_context() can form the basis for images, + FASL for arbitrary modules will need additional + help with resolving external references. +** DONE shared stack on EVAL + - State "DONE" [2009-12-26 Sat 08:22] + +* compiler optimizations +** DONE constant folding + - State "DONE" [2009-12-16 Wed 23:25] +** DONE simplification pass, dead-code elimination + - State "DONE" [2009-12-18 Fri 14:14] + This is important in particular for the output generated by + syntax-rules. +** TODO lambda lift + The current closure representation is not very efficient, so this + would help a lot. +** TODO inlining (and disabling primitive inlining) + Being able to redefine procedures is important though. +** TODO unsafe operations + Possibly, don't want to make things too complicated or unstable. +** TODO plugin infrastructure +** TODO type inference with warnings + +* macros +** DONE hygiene + - State "DONE" [2009-04-09 Thu 14:41] +** DONE hygienic nested let-syntax + - State "DONE" [2009-12-08 Tue 14:41] +** DONE macroexpand utility + - State "DONE" [2009-12-08 Tue 14:41] +** DONE SRFI-46 basic syntax-rules extensions + - State "DONE" [2009-12-26 Sat 07:59] +** DONE (... ...) support + - State "DONE" [2009-12-26 Sat 02:06] +** TODO compiler macros +** TODO syntax-rules common pattern reduction +** TODO syntax-rules loop optimization + +* garbage collection +** DONE precise gc rewrite + - State "DONE" [2009-06-22 Mon 14:27] +** DONE fix heap growing + - State "DONE" [2009-06-22 Mon 14:29] +** DONE separate gc heaps + - State "DONE" [2009-12-08 Tue 14:29] +** DONE add finalizers + - State "DONE" [2009-12-08 Tue 14:29] +** TODO support weak references + +* runtime +** DONE bignums + - State "DONE" [2009-07-07 Tue 14:42] +** DONE unicode + - State "DONE" from "TODO" [2010-07-11 Sun 23:58] + Supported with UTF-8 strings, string-ref is O(n) and + string-set! may need to reallocate the whole string. + string-cursor-ref can be used for O(1) string access. +** DONE threads + - State "DONE" from "TODO" [2010-07-11 Sun 15:31] + VM now supports an optional hook for green threads, + and a SRFI-18 interface is provided as a separate module. + I/O operations will currently block all threads though, + this needs to be addressed. +** DONE virtual ports + - State "DONE" [2010-01-02 Sat 20:12] +** DONE dynamic-wind + - State "DONE" [2009-12-26 Sat 01:51] + Adapted a version from Scheme48. +** DONE recursive disasm + - State "DONE" [2009-12-18 Fri 14:15] + +* FFI +** DONE libdl support + - State "DONE" [2009-12-08 Tue 14:45] +** DONE opcode generation interface + - State "DONE" [2009-11-15 Sun 14:45] +** DONE stub generator + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE define-c-struct + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE define-c + - State "DONE" [2009-11-29 Sun 14:48] +*** DONE array return types + - State "DONE" [2009-12-26 Sat 01:49] +*** DONE pre-buffered string types (like getcwd) + - State "DONE" [2009-12-26 Sat 01:49] + +* module system +** DONE scheme48-like config language + - State "DONE" [2009-10-13 Tue 14:38] +** DONE shared library includes + - State "DONE" [2009-12-08 Tue 14:39] +** DONE only/except/rename/prefix modifiers + - State "DONE" [2009-12-16 Wed 18:57] +** TODO scheme-complete.el support +** DONE access individual modules from repl + - State "DONE" [2009-12-26 Sat 01:49] + +* core modules +** DONE SRFI-0 cond-expand + - State "DONE" [2009-12-16 Wed 20:12] +** DONE SRFI-9 define-record-type + - State "DONE" [2009-12-08 Tue 14:50] +** DONE SRFI-69 hash-tables + - State "DONE" [2009-11-15 Sun 14:50] +** DONE match library + - State "DONE" [2009-12-08 Tue 14:54] +** DONE loop library + - State "DONE" [2009-12-08 Tue 14:54] +** TODO network interface +** DONE posix interface + - State "DONE" from "TODO" [2010-07-11 Sun 15:36] + Splitting this into several parts. +*** DONE filesystem interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE process interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE time interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE host system interface + - State "DONE" [2010-01-02 Sat 20:12] +** DONE pathname library + - State "DONE" [2009-12-16 Wed 18:58] +** DONE uri library + - State "DONE" [2009-12-16 Wed 18:58] +** TODO http library +** TODO show (formatting) library +** TODO zip library +** TODO tar library +** TODO md5sum library + +* ports +** DONE basic mingw support + - State "DONE" [2009-06-22 Mon 14:36] +** DONE Plan 9 support + - State "DONE" [2009-08-10 Mon 14:37] +** DONE 64-bit support + - State "DONE" [2009-11-01 Sun 14:37] +** TODO iPhone support +** TODO bare-metal support + +* miscellaneous +** TODO overall cleanup +** TODO user documentation +** TODO thorough source documentation +** TODO full test suite for libraries + +* distribution +** TODO packaging format +** TODO code repository with fetch+install tool +** TODO translator to/from other implementations + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..be586341 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.3 diff --git a/chibi-scheme.vcproj b/chibi-scheme.vcproj new file mode 100644 index 00000000..86bd69e9 --- /dev/null +++ b/chibi-scheme.vcproj @@ -0,0 +1,206 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1 new file mode 100644 index 00000000..b84620d5 --- /dev/null +++ b/doc/chibi-scheme.1 @@ -0,0 +1,133 @@ +.TH "chibi-scheme" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-scheme \- a tiny Scheme interpreter + +.SH SYNOPSIS +.B chibi-scheme +[-qV] +[-I +.I path +] +[-A +.I path +] +[-m +.I module +] +[-l +.I file +] +[-e +.I expr +] +[-p +.I expr +] +[--] +[ +.I script argument ... +] +.br +.sp 0.3 + +.SH DESCRIPTION +.I chibi-scheme +is a sample interactive Scheme interpreter for the +.I chibi-scheme +library. It serves as an example of how to embed +.I chibi-scheme +in applications, and can be useful on its own for writing +scripts and interactive development. + +When +.I script +is given, the script will be loaded with SRFI-22 semantics, +calling the procedure +.I main +(if defined) with a single parameter as a list of the +command-line arguments beginning with the script name. + +Otherwise, if no script is given and no -e or -p options +are given an interactive repl is entered, reading, evaluating, +then printing expressions until EOF is reached. The repl +provided is very minimal - if you want readline +completion you may want to wrap it with the +.I rlwrap(1) +program. Signals aren't caught either - to enable handling keyboard +interrupts you can use the (chibi process) module. + +.SH OPTIONS +.TP 5 +.BI -V +Prints the version information and exits. +.TP +.BI -q +Don't load the initialization file. The resulting +environment will only contain the core syntactic forms +and primitives coded in C. +.TP +.BI -h size +Specifies the initial size of the heap, in bytes. +.I size +can be any integer value, optionally suffixed by +"K" for kilobytes, or "M" for megabytes. +.I -h +must be specified before any options which load or +evaluate Scheme code. +.TP +.BI -I path +Inserts +.I path +on front of the load path list. +.TP +.BI -A path +Appends +.I path +to the load path list. +.TP +.BI -m module +Imports +.I module +as though "(import +.I module +)" were evaluated. However, to reduce the need for shell +escapes, modules are written in a dot notation, so that the module +.I (foo bar) +is written as +.I foo.bar +.TP +.BI -l file +Loads the Scheme source from the file +.I file +searched for in the default load path. +.TP +.BI -e expr +Evaluates the Scheme expression +.I expr. +.TP +.BI -p expr +Evaluates the Scheme expression +.I expr +then prints the result to stdout. + +.SH ENVIRONMENT +.TP +.B CHIBI_MODULE_PATH +.TQ +A colon separated list of directories to search for module +files, inserted before the system default load paths. + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +More detailed information can be found in the README file +included in the distribution. + +The chibi-scheme home-page: +.br +http://code.google.com/p/chibi-scheme/ diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..c0c7e166 --- /dev/null +++ b/eval.c @@ -0,0 +1,1758 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +static sexp analyze (sexp ctx, sexp x); +static void generate (sexp ctx, sexp x); + +#if SEXP_USE_MODULES +sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env); +sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file); +sexp sexp_current_environment (sexp ctx sexp_api_params(self, n)); +#endif + +sexp sexp_compile_error (sexp ctx, const char *message, sexp o) { + sexp exn; + sexp_gc_var3(sym, irritants, msg); + sexp_gc_preserve3(ctx, sym, irritants, msg); + irritants = sexp_list1(ctx, o); + msg = sexp_c_string(ctx, message, -1); + exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile", -1), + msg, irritants, SEXP_FALSE, + (sexp_pairp(o)?sexp_pair_source(o):SEXP_FALSE)); + sexp_gc_release3(ctx); + return exn; +} + +static void sexp_warn (sexp ctx, char *msg, sexp x) { + sexp out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) { + sexp_write_string(ctx, "WARNING: ", out); + sexp_write_string(ctx, msg, out); + sexp_write(ctx, x, out); + sexp_write_char(ctx, '\n', out); + } +} + +void sexp_warn_undefs (sexp ctx, sexp from, sexp to) { + sexp x; + for (x=from; sexp_pairp(x) && x!=to; x=sexp_env_next_cell(x)) + if (sexp_cdr(x) == SEXP_UNDEF) + sexp_warn(ctx, "reference to undefined variable: ", sexp_car(x)); +} + + +/********************** environment utilities ***************************/ + +static sexp sexp_env_cell_loc (sexp env, sexp key, sexp *varenv) { + sexp ls; + + do { + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + if (sexp_car(ls) == key) { + if (varenv) *varenv = env; + return ls; + } + env = sexp_env_parent(env); + } while (env); + + return NULL; +} + +sexp sexp_env_cell (sexp env, sexp key) { + return sexp_env_cell_loc(env, key, NULL); +} + +static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, + sexp value, sexp *varenv) { + sexp_gc_var1(cell); + cell = sexp_env_cell_loc(env, key, varenv); + if (! cell) { + sexp_gc_preserve1(ctx, cell); + while (sexp_env_lambda(env) || sexp_env_syntactic_p(env)) + env = sexp_env_parent(env); + sexp_env_push(ctx, env, cell, key, value); + if (varenv) *varenv = env; + sexp_gc_release1(ctx); + } + return cell; +} + +sexp sexp_env_ref (sexp env, sexp key, sexp dflt) { + sexp cell = sexp_env_cell(env, key); + return (cell ? sexp_cdr(cell) : dflt); +} + +sexp sexp_env_global_ref (sexp env, sexp key, sexp dflt) { + while (sexp_env_lambda(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); + return sexp_env_ref(env, key, dflt); +} + +sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { + sexp cell=SEXP_FALSE, res=SEXP_VOID; + sexp_gc_var1(tmp); + for (tmp=sexp_env_bindings(env); sexp_pairp(tmp); tmp=sexp_env_next_cell(tmp)) + if (sexp_car(tmp) == key) { + cell = tmp; + break; + } + if (sexp_immutablep(env)) { + res = sexp_user_exception(ctx, NULL, "immutable binding", key); + } else { + sexp_gc_preserve1(ctx, tmp); + if (sexp_truep(cell)) { + if (sexp_immutablep(cell)) + res = sexp_user_exception(ctx, NULL, "immutable binding", key); + else + sexp_cdr(cell) = value; + } else { + sexp_env_push(ctx, env, tmp, key, value); + } + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_env_exports_op (sexp ctx sexp_api_params(self, n), sexp env) { + sexp ls; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_push(ctx, res, sexp_car(ls)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { + sexp_gc_var2(e, tmp); + sexp_gc_preserve2(ctx, e, 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_env_push(ctx, e, tmp, sexp_car(vars), value); + sexp_gc_release2(ctx); + return e; +} + +static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(ctx, res, sexp_car(ls)); + sexp_gc_release1(ctx); + return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res)); +} + +static sexp sexp_flatten_dot (sexp ctx, sexp ls) { + return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls)); +} + +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 ctx, sexp_uint_t i) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) { + tmp = sexp_alloc_bytecode(ctx, i); + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); + sexp_bytecode_length(tmp) = i; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(ctx)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(ctx)), + i); + sexp_context_bc(ctx) = tmp; + } +} + +static void expand_bcode (sexp ctx, sexp_uint_t size) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(ctx)) + < (sexp_context_pos(ctx))+size) { + tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2); + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); + sexp_bytecode_length(tmp) + = sexp_bytecode_length(sexp_context_bc(ctx))*2; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(ctx)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(ctx)), + sexp_bytecode_length(sexp_context_bc(ctx))); + sexp_context_bc(ctx) = tmp; + } +} + +static void emit_enter (sexp ctx); +static void emit_return (sexp ctx); +static void bless_bytecode (sexp ctx, sexp bc); + +static sexp finalize_bytecode (sexp ctx) { + sexp bc; + emit_return(ctx); + shrink_bcode(ctx, sexp_context_pos(ctx)); + bc = sexp_context_bc(ctx); + if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */ + if (sexp_nullp(sexp_cdr(sexp_bytecode_literals(bc)))) + sexp_bytecode_literals(bc) = sexp_car(sexp_bytecode_literals(bc)); + else if (sexp_nullp(sexp_cddr(sexp_bytecode_literals(bc)))) + sexp_cdr(sexp_bytecode_literals(bc)) = sexp_cadr(sexp_bytecode_literals(bc)); + else + sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc)); + } + bless_bytecode(ctx, bc); + return bc; +} + +static void emit (sexp ctx, unsigned char c) { + expand_bcode(ctx, 1); + sexp_bytecode_data(sexp_context_bc(ctx))[sexp_context_pos(ctx)++] = c; +} + +sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp flags, + sexp num_args, sexp bc, sexp vars) { + 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; + sexp_procedure_vars(proc) = vars; + return proc; +} + +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_op (sexp ctx sexp_api_params(self, n), sexp env, sexp fv, sexp expr) { + sexp res; + if (! (sexp_symbolp(expr) || sexp_pairp(expr))) + return expr; + res = sexp_alloc_type(ctx, 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 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; + sexp_lambda_sv(res) = SEXP_NULL; + sexp_lambda_locals(res) = SEXP_NULL; + sexp_lambda_defs(res) = SEXP_NULL; + sexp_lambda_return_type(res) = SEXP_FALSE; + sexp_lambda_param_types(res) = SEXP_NULL; + return res; +} + +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 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 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 ctx, sexp value) { + sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT); + sexp_lit_value(res) = value; + return res; +} + +/****************************** contexts ******************************/ + +#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) + +static void sexp_add_path (sexp ctx, const char *str) { + const char *colon; + if (str && *str) { + colon = strchr(str, ':'); + if (colon) + sexp_add_path(ctx, colon+1); + else + colon = str + strlen(str); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), SEXP_VOID); + sexp_car(sexp_global(ctx, SEXP_G_MODULE_PATH)) + = sexp_c_string(ctx, str, colon-str); + } +} + +void sexp_init_eval_context_globals (sexp ctx) { + sexp_gc_var3(tmp, vec, ctx2); + ctx = sexp_make_child_context(ctx, NULL); + sexp_gc_preserve3(ctx, tmp, vec, ctx2); + vec = sexp_intern(ctx, "*current-exception-handler*", -1); + sexp_global(ctx, SEXP_G_ERR_HANDLER) + = sexp_env_cell_create(ctx, sexp_context_env(ctx), vec, SEXP_FALSE, NULL); +#if ! SEXP_USE_NATIVE_X86 + emit(ctx, SEXP_OP_RESUMECC); + sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); + ctx2 = sexp_make_child_context(ctx, NULL); + emit(ctx2, SEXP_OP_DONE); + tmp = finalize_bytecode(ctx2); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + sexp_global(ctx, SEXP_G_FINAL_RESUMER) + = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); + sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) + = sexp_intern(ctx, "final-resumer", -1); +#endif + sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL; + sexp_add_path(ctx, sexp_default_module_dir); + sexp_add_path(ctx, getenv(SEXP_MODULE_PATH_VAR)); + tmp = sexp_c_string(ctx, "./lib", 5); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); + tmp = sexp_c_string(ctx, ".", 1); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO; + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = SEXP_FALSE; +#endif + sexp_gc_release3(ctx); +} + +sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size) { + sexp_gc_var1(res); + if (ctx) sexp_gc_preserve1(ctx, res); + res = sexp_make_context(ctx, size); + sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE); + sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; + sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE; + sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; + if ((! stack) || (stack == SEXP_FALSE)) { + stack = sexp_alloc_tagged(res, SEXP_STACK_SIZE, SEXP_STACK); + sexp_stack_length(stack) = SEXP_INIT_STACK_SIZE; + sexp_stack_top(stack) = 0; + } + sexp_context_stack(res) = stack; + sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_FIVE)); + if (! ctx) sexp_init_eval_context_globals(res); + if (ctx) { + sexp_context_tracep(res) = sexp_context_tracep(ctx); + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_make_child_context (sexp ctx, sexp lambda) { + sexp res = sexp_make_eval_context(ctx, + sexp_context_stack(ctx), + sexp_context_env(ctx), + 0); + if (! sexp_exceptionp(res)) { + sexp_context_lambda(res) = lambda; + sexp_context_top(res) = sexp_context_top(ctx); + sexp_context_fv(res) = sexp_context_fv(ctx); + sexp_context_tracep(res) = sexp_context_tracep(ctx); + } + return res; +} + +/**************************** identifiers *****************************/ + +static sexp sexp_identifierp_op (sexp ctx sexp_api_params(self, n), sexp x) { + return sexp_make_boolean(sexp_idp(x)); +} + +static sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), sexp x) { + return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); +} + +static sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) { + sexp res; + sexp_gc_var2(kar, kdr); + sexp_gc_preserve2(ctx, kar, kdr); + loop: + if (sexp_synclop(x)) { + x = sexp_synclo_expr(x); + goto loop; + } else if (sexp_pairp(x)) { + kar = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_car(x)); + kdr = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_cdr(x)); + res = sexp_cons(ctx, kar, kdr); + sexp_immutablep(res) = 1; + } else { + res = x; + } + sexp_gc_release2(ctx); + return res; +} + +static sexp sexp_identifier_eq_op (sexp ctx sexp_api_params(self, n), 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 = sexp_env_cell(e1, id1); + if (cell && sexp_lambdap(sexp_cdr(cell))) + lam1 = sexp_cdr(cell); + cell = sexp_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 analyze_app (sexp ctx, sexp x) { + sexp p; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, 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 { + sexp_car(res) = tmp; + } + } + if (sexp_pairp(res)) { /* fill in lambda names */ + res = sexp_nreverse(ctx, res); + if (sexp_lambdap(sexp_car(res))) { + p=sexp_lambda_params(sexp_car(res)); + for (tmp=sexp_cdr(res); sexp_pairp(tmp)&&sexp_pairp(p); tmp=sexp_cdr(tmp), p=sexp_cdr(p)) + if (sexp_lambdap(sexp_car(tmp))) + sexp_lambda_name(sexp_car(tmp)) = sexp_car(p); + } + } + sexp_gc_release2(ctx); + return res; +} + +static sexp analyze_seq (sexp ctx, sexp ls) { + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + if (sexp_nullp(ls)) + res = SEXP_VOID; + else if (sexp_nullp(sexp_cdr(ls))) + res = analyze(ctx, sexp_car(ls)); + else { + 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_release2(ctx); + return res; +} + +static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) { + sexp env = sexp_context_env(ctx), res; + sexp_gc_var1(cell); + sexp_gc_preserve1(ctx, cell); + cell = sexp_env_cell_loc(env, x, varenv); + if (! cell) { + if (sexp_synclop(x)) { + if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_context_fv(ctx))) + && sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_synclo_free_vars(x)))) + env = sexp_synclo_env(x); + x = sexp_synclo_expr(x); + } + cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF, varenv); + } + if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) + res = sexp_compile_error(ctx, "invalid use of syntax as value", x); + else + res = sexp_make_ref(ctx, x, cell); + sexp_gc_release1(ctx); + return res; +} + +static sexp analyze_set (sexp ctx, sexp x) { + sexp res, varenv; + sexp_gc_var2(ref, value); + sexp_gc_preserve2(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), &varenv); + 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 if (sexp_immutablep(sexp_ref_cell(ref)) + || (varenv && sexp_immutablep(varenv))) + res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x)); + else + res = sexp_make_set(ctx, ref, value); + } + sexp_gc_release2(ctx); + 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, ctx3; + sexp_gc_var6(res, body, tmp, value, defs, ctx2); + sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2); + /* verify syntax */ + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(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))) + sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x)); + 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, tmp=sexp_copy_list(ctx, sexp_cadr(x))); + sexp_lambda_source(res) = sexp_pair_source(x); + if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res)))) + sexp_lambda_source(res) = sexp_pair_source(sexp_cdr(x)); + if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res)))) + sexp_lambda_source(res) = sexp_pair_source(sexp_cddr(x)); + ctx2 = sexp_make_child_context(ctx, res); + tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); + sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); + sexp_env_lambda(sexp_context_env(ctx2)) = res; + body = analyze_seq(ctx2, sexp_cddr(x)); + 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)) { + tmp = sexp_car(ls); + ctx3 = sexp_cdr(tmp); + if (sexp_pairp(sexp_caar(tmp))) { + name = sexp_caaar(tmp); + tmp = sexp_cons(ctx3, sexp_cdaar(tmp), sexp_cdar(tmp)); + tmp = sexp_cons(ctx3, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(sexp_caar(ls)); + value = analyze_lambda(ctx3, tmp); + } else { + name = sexp_caar(tmp); + value = analyze(ctx3, sexp_cadar(tmp)); + } + if (sexp_exceptionp(value)) sexp_return(res, value); + if (sexp_lambdap(value)) sexp_lambda_name(value) = name; + sexp_push(ctx3, defs, + sexp_make_set(ctx3, analyze_var_ref(ctx3, name, NULL), value)); + } + if (sexp_pairp(defs)) { + if (! sexp_seqp(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(ctx2, defs, sexp_seq_ls(body)); + } + sexp_lambda_body(res) = body; + cleanup: + sexp_gc_release6(ctx); + return res; +} + +static sexp analyze_if (sexp ctx, sexp x) { + sexp res, fail_expr; + sexp_gc_var3(test, pass, fail); + sexp_gc_preserve3(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_release3(ctx); + return res; +} + +static sexp analyze_define (sexp ctx, sexp x) { + sexp name, res, varenv; + sexp_gc_var4(ref, value, tmp, env); + sexp_gc_preserve4(ctx, ref, value, tmp, env); + env = sexp_context_env(ctx); + while (sexp_env_syntactic_p(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(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_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))) { + sexp_env_push(ctx, env, tmp, 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); + tmp = sexp_cons(ctx, sexp_cdr(x), ctx); + sexp_pair_source(sexp_cdr(x)) = sexp_pair_source(x); + sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp); + res = SEXP_VOID; + } else { + if (sexp_synclop(name)) name = sexp_synclo_expr(name); + sexp_env_cell_create(ctx, env, name, SEXP_VOID, NULL); + if (sexp_pairp(sexp_cadr(x))) { + tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); + tmp = sexp_cons(ctx, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(x); + value = analyze_lambda(ctx, tmp); + } else + value = analyze(ctx, sexp_caddr(x)); + ref = analyze_var_ref(ctx, name, &varenv); + if (sexp_exceptionp(ref)) { + res = ref; + } else if (sexp_exceptionp(value)) { + res = value; + } else if (varenv && sexp_immutablep(varenv)) { + res = sexp_compile_error(ctx, "immutable binding", name); + } else { + if (sexp_lambdap(value)) sexp_lambda_name(value) = name; + res = sexp_make_set(ctx, ref, value); + } + } + } + sexp_gc_release4(ctx); + return res; +} + +static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { + sexp res = SEXP_VOID, name; + sexp_gc_var2(proc, mac); + sexp_gc_preserve2(eval_ctx, proc, mac); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + 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 = sexp_eval(eval_ctx, sexp_cadar(ls), NULL); + if (sexp_procedurep(proc)) { + name = sexp_caar(ls); + if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) + name = sexp_synclo_expr(name); + mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(bind_ctx)); + sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac); + } else { + res = (sexp_exceptionp(proc) ? proc + : sexp_compile_error(eval_ctx, "non-procedure macro:", proc)); + break; + } + } + } + sexp_gc_release2(eval_ctx); + return res; +} + +static sexp analyze_define_syntax (sexp ctx, sexp x) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_list1(ctx, sexp_cdr(x)); + res = analyze_bind_syntax(tmp, ctx, ctx); + sexp_gc_release1(ctx); + return res; +} + +static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp) { + sexp res; + sexp_gc_var3(env, ctx2, tmp); + sexp_gc_preserve3(ctx, env, ctx2, tmp); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad let(rec)-syntax", x); + } else { + env = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_syntactic_p(env) = 1; + 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), (recp ? ctx2 : ctx), ctx2); + res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x))); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp analyze_let_syntax (sexp ctx, sexp x) { + return analyze_let_syntax_aux(ctx, x, 0); +} + +static sexp analyze_letrec_syntax (sexp ctx, sexp x) { + return analyze_let_syntax_aux(ctx, x, 1); +} + +static sexp analyze (sexp ctx, sexp object) { + sexp op; + sexp_gc_var4(res, tmp, x, cell); + sexp_gc_preserve4(ctx, res, tmp, x, cell); + x = object; + loop: + if (sexp_pairp(x)) { + 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 = sexp_env_cell(sexp_context_env(ctx), sexp_car(x)); + if (! cell && sexp_synclop(sexp_car(x))) + cell = sexp_env_cell(sexp_synclo_env(sexp_car(x)), + sexp_synclo_expr(sexp_car(x))); + if (! cell) { + res = analyze_app(ctx, x); + } else { + op = sexp_cdr(cell); + if (sexp_corep(op)) { + switch (sexp_core_code(op)) { + case SEXP_CORE_DEFINE: + res = analyze_define(ctx, x); break; + case SEXP_CORE_SET: + res = analyze_set(ctx, x); break; + case SEXP_CORE_LAMBDA: + res = analyze_lambda(ctx, x); break; + case SEXP_CORE_IF: + res = analyze_if(ctx, x); break; + case SEXP_CORE_BEGIN: + res = analyze_seq(ctx, sexp_cdr(x)); break; + case SEXP_CORE_QUOTE: + case SEXP_CORE_SYNTAX_QUOTE: + if (! (sexp_pairp(sexp_cdr(x)) && sexp_nullp(sexp_cddr(x)))) + res = sexp_compile_error(ctx, "bad quote form", x); + else + res = sexp_make_lit(ctx, + (sexp_core_code(op) == SEXP_CORE_QUOTE) ? + sexp_strip_synclos(ctx sexp_api_pass(NULL, 1), sexp_cadr(x)) : + sexp_cadr(x)); + break; + case SEXP_CORE_DEFINE_SYNTAX: + res = analyze_define_syntax(ctx, x); break; + case SEXP_CORE_LET_SYNTAX: + res = analyze_let_syntax(ctx, x); break; + case SEXP_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)) { + 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_make_child_context(ctx, sexp_context_lambda(ctx)); + x = sexp_apply(x, sexp_macro_proc(op), tmp); + if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x))) + sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp)); + goto loop; + } else if (sexp_opcodep(op)) { + res = sexp_length(ctx, sexp_cdr(x)); + if (sexp_unbox_fixnum(res) < sexp_opcode_num_args(op)) { + res = sexp_compile_error(ctx, "not enough args for opcode", x); + } else if ((sexp_unbox_fixnum(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)); + 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))))))) + sexp_warn(ctx, "invalid operand in application: ", x); + res = analyze_app(ctx, x); + } + } else if (sexp_idp(x)) { + res = analyze_var_ref(ctx, x, NULL); + } else if (sexp_synclop(x)) { + tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(tmp) = sexp_synclo_env(x); + sexp_context_fv(tmp) = sexp_append2(tmp, + sexp_synclo_free_vars(x), + sexp_context_fv(tmp)); + x = sexp_synclo_expr(x); + res = analyze(tmp, x); + } else { + res = x; + } + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res)) + && sexp_pairp(x)) + sexp_exception_source(res) = sexp_pair_source(x); + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} + +/********************** free varable analysis *************************/ + +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_var1(res); + if (sexp_nullp(fv2)) + return fv1; + sexp_gc_preserve1(ctx, res); + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, 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_release1(ctx); + return res; +} + +sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) { + sexp_gc_var2(fv1, fv2); + sexp_gc_preserve2(ctx, fv1, fv2); + fv1 = fv; + if (sexp_lambdap(x)) { + fv1 = sexp_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 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_cndp(x)) { + fv1 = sexp_free_vars(ctx, sexp_cnd_test(x), fv); + fv1 = sexp_free_vars(ctx, sexp_cnd_pass(x), fv1); + fv1 = sexp_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 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_setp(x)) { + fv1 = sexp_free_vars(ctx, sexp_set_value(x), fv); + fv1 = sexp_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 = sexp_free_vars(ctx, sexp_synclo_expr(x), fv); + } + sexp_gc_release2(ctx); + return fv1; +} + +/************************ library procedures **************************/ + +static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) { + sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn); + return sexp_exception_kind(exn); +} + +static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) { + FILE *in; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + in = fopen(sexp_string_data(path), "r"); + if (! in) + return sexp_user_exception(ctx, self, "couldn't open input file", path); + return sexp_make_input_port(ctx, in, path); +} + +static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) { + FILE *out; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + out = fopen(sexp_string_data(path), "w"); + if (! out) + return sexp_user_exception(ctx, self, "couldn't open output file", path); + return sexp_make_output_port(ctx, out, path); +} + +static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) { + sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port); + if (! sexp_port_openp(port)) + return sexp_user_exception(ctx, self, "port already closed", port); + return sexp_finalize_port(ctx sexp_api_pass(self, n), port); +} + +#if SEXP_USE_DL +#ifdef __MINGW32__ +#include +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + HINSTANCE handle = LoadLibraryA(sexp_string_data(file)); + if(!handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = (sexp_proc2) GetProcAddress(handle, "sexp_init_library"); + if(!init) { + FreeLibrary(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx sexp_api_pass(NULL, 1), env); +} +#else +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_proc2 init; + void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); + if (! handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = dlsym(handle, "sexp_init_library"); + if (! init) { + dlclose(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + return init(ctx sexp_api_pass(NULL, 1), env); +} +#endif +#endif + +sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { +#if SEXP_USE_DL + char *suffix; +#endif + sexp tmp, out=SEXP_FALSE; + sexp_gc_var4(ctx2, x, in, res); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); +#if SEXP_USE_DL + suffix = sexp_string_data(source) + + sexp_string_length(source) - strlen(sexp_so_extension); + if (strcmp(suffix, sexp_so_extension) == 0) { + res = sexp_load_dl(ctx, source, env); + } else { +#endif + sexp_gc_preserve4(ctx, ctx2, x, in, res); + res = SEXP_VOID; + in = sexp_open_input_file(ctx, source); + out = sexp_current_error_port(ctx); + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0); + sexp_context_parent(ctx2) = ctx; + tmp = sexp_env_bindings(env); + sexp_context_tailp(ctx2) = 0; + if (sexp_exceptionp(in)) { + if (sexp_not(out)) out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) + 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, env); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); + } +#if SEXP_USE_WARN_UNDEFS + if (! sexp_exceptionp(res)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + sexp_gc_release4(ctx); +#if SEXP_USE_DL + } +#endif + return res; +} + +#if SEXP_USE_MATH + +#if SEXP_USE_BIGNUMS +#define maybe_convert_bignum(z) \ + else if (sexp_bignump(z)) d = sexp_bignum_to_double(z); +#else +#define maybe_convert_bignum(z) +#endif + +#define define_math_op(name, cname) \ + static sexp name (sexp ctx sexp_api_params(self, n), sexp z) { \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_fixnump(z)) \ + d = (double)sexp_unbox_fixnum(z); \ + maybe_convert_bignum(z) \ + else \ + return sexp_type_exception(ctx, self, SEXP_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_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) { + double d, r; + if (sexp_flonump(z)) + d = sexp_flonum_value(z); + else if (sexp_fixnump(z)) + d = (double)sexp_unbox_fixnum(z); + maybe_convert_bignum(z) /* XXXX add bignum sqrt */ + else + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); + r = sqrt(d); + if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z))) + return sexp_make_fixnum(round(r)); + else + return sexp_make_flonum(ctx, r); +} + +#endif + +static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { + long double f, x1, e1; + sexp res; +#if SEXP_USE_BIGNUMS + if (sexp_bignump(e)) { /* bignum exponent needs special handling */ + if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) + res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ + else if (x == SEXP_ONE) + res = SEXP_ONE; /* 1.0 */ + else if (sexp_flonump(x)) + res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); + else + res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */ + } else if (sexp_bignump(x)) { + res = sexp_bignum_expt(ctx, x, e); + } else { +#endif + if (sexp_fixnump(x)) + x1 = sexp_unbox_fixnum(x); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + if (sexp_fixnump(e)) + e1 = sexp_unbox_fixnum(e); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, e); + f = pow(x1, e1); + if ((f > SEXP_MAX_FIXNUM) || (f < SEXP_MIN_FIXNUM) +#if SEXP_USE_FLONUMS + || (! sexp_fixnump(x)) || (! sexp_fixnump(e)) +#endif + ) { +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(x) && sexp_fixnump(e)) + res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); + else +#endif +#if SEXP_USE_FLONUMS + res = sexp_make_flonum(ctx, f); +#else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#endif + } else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#if SEXP_USE_BIGNUMS + } +#endif + return res; +} + +static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, sexp str2, sexp ci) { + sexp_sint_t len1, len2, len, diff; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2); + len1 = sexp_string_length(str1); + len2 = sexp_string_length(str2); + len = ((len1>4)&1)+3; +} + +static int sexp_utf8_char_byte_count(int c) { + if (c < 0x80) return 1; + if (c < 0x800) return 2; + if (c < 0x10000) return 3; + return 4; +} + +static int sexp_string_utf8_length (unsigned char *p, int len) { + unsigned char *q = p+len; + int i; + for (i=0; p0 && j0) + return sexp_user_exception(ctx, self, "string-index->offset: index out of range", index); + return sexp_make_fixnum(j); +} + +sexp sexp_string_utf8_ref (sexp ctx, sexp str, sexp i) { + unsigned char *p=(unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(i); + if (*p < 0x80) + return sexp_make_character(*p); + else if ((*p < 0xC0) || (*p > 0xF7)) + return sexp_user_exception(ctx, NULL, "string-ref: invalid utf8 byte", i); + else if (*p < 0xE0) + return sexp_make_character(((p[0]&0x3F)<<6) + (p[1]&0x3F)); + else if (*p < 0xF0) + return sexp_make_character(((p[0]&0x1F)<<12) + ((p[1]&0x3F)<<6) + (p[2]&0x3F)); + else + return sexp_make_character(((p[0]&0x0F)<<16) + ((p[1]&0x3F)<<6) + ((p[2]&0x3F)<<6) + (p[2]&0x3F)); +} + +sexp sexp_string_utf8_index_ref (sexp ctx sexp_api_params(self, n), sexp str, sexp i) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + off = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, i); + if (sexp_exceptionp(off)) return off; + return sexp_string_utf8_ref(ctx, str, off); +} + +void sexp_utf8_encode_char (unsigned char* p, int len, int c) { + switch (len) { + case 4: *p++ = (0xF0 + ((c)>>18)); *p++ = (0x80 + ((c>>12)&0x3F)); + *p++ = (0x80 + ((c>>6)&0x3F)); *p = (0x80 + (c&0x3F)); break; + case 3: *p++ = (0xE0 + ((c)>>12)); *p++ = (0x80 + ((c>>6)&0x3F)); + *p = (0x80 + (c&0x3F)); break; + case 2: *p++ = (0xC0 + ((c)>>6)); *p = (0x80 + (c&0x3F)); break; + default: *p = c; break; + } +} + +void sexp_write_utf8_char (sexp ctx, int c, sexp out) { + unsigned char buf[8]; + int len = sexp_utf8_char_byte_count(c); + sexp_utf8_encode_char(buf, len, c); + buf[len+1] = 0; + sexp_write_string(ctx, (char*)buf, out); +} + +sexp sexp_read_utf8_char (sexp ctx, sexp port, int i) { + if (i >= 0x80) { + if ((i < 0xC0) || (i > 0xF7)) { + return sexp_user_exception(ctx, NULL, "read-char: invalid utf8 byte", sexp_make_fixnum(i)); + } else if (i < 0xE0) { + i = ((i&0x3F)<<6) + (sexp_read_char(ctx, port)&0x3F); + } else if (i < 0xF0) { + i = ((i&0x1F)<<12) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += sexp_read_char(ctx, port)&0x3F; + } else { + i = ((i&0x0F)<<16) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += (sexp_read_char(ctx, port)&0x3F)<<6; + i += sexp_read_char(ctx, port)&0x3F; + } + } + return sexp_make_character(i); +} + +#if SEXP_USE_MUTABLE_STRINGS + +void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) { + sexp b; + unsigned char *p, *q; + int i = sexp_unbox_fixnum(index), c = sexp_unbox_character(ch), + old_len, new_len, len; + p = (unsigned char*)sexp_string_data(str) + i; + old_len = sexp_utf8_initial_byte_count(*p); + new_len = sexp_utf8_char_byte_count(c); + if (old_len != new_len) { /* resize bytes if needed */ + len = sexp_string_length(str)+(new_len-old_len); + b = sexp_make_bytes(ctx, sexp_make_fixnum(len), SEXP_VOID); + if (! sexp_exceptionp(b)) { + q = (unsigned char*)sexp_bytes_data(b); + memcpy(q, sexp_string_data(str), i); + memcpy(q+i+new_len, p+old_len, len-i-new_len+1); + sexp_string_bytes(str) = b; + p = q + i; + } + sexp_string_length(str) += new_len - old_len; + } + sexp_utf8_encode_char(p, new_len, c); +} + +sexp sexp_string_utf8_index_set (sexp ctx sexp_api_params(self, n), sexp str, sexp i, sexp ch) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch); + off = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, i); + if (sexp_exceptionp(off)) return off; + sexp_string_utf8_set(ctx, str, off, ch); + return SEXP_VOID; +} + +#endif +#endif + +#ifdef PLAN9 +#include "opt/plan9.c" +#endif + +/************************** optimizations *****************************/ + +#if SEXP_USE_SIMPLIFY +#include "opt/simplify.c" +#endif + +/***************************** opcodes ********************************/ + +#include "opcodes.c" + +static sexp sexp_copy_core (sexp ctx, struct sexp_core_form_struct *core) { + sexp res = sexp_alloc_type(ctx, core, SEXP_CORE); + memcpy(&(res->value), core, sizeof(core[0])); + return res; +} + +static sexp sexp_copy_opcode (sexp ctx, struct sexp_opcode_struct *op) { + sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + memcpy(&(res->value), op, sizeof(op[0])); + return res; +} + +sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code, + sexp num_args, sexp flags, sexp arg1t, sexp arg2t, + sexp invp, sexp data, sexp data2, sexp_proc1 func) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, num_args); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, flags); + if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0) + || (sexp_unbox_fixnum(op_class) >= SEXP_OPC_NUM_OP_CLASSES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode class", op_class); + else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) + || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code); + else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_arg1_type(res) = arg1t; + sexp_opcode_arg2_type(res) = arg2t; + sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_data(res) = data; + sexp_opcode_data2(res) = data2; + sexp_opcode_func(res) = func; + sexp_opcode_name(res) = strdup(sexp_string_data(name)); + } + return res; +} + +sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res; +#if ! SEXP_USE_EXTENDED_FCALL + if (num_args > 4) + return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); +#endif + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; +#if SEXP_USE_EXTENDED_FCALL + if (num_args > 4) + sexp_opcode_code(res) = SEXP_OP_FCALLN; + else +#endif + sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1; + if (flags & 1) num_args--; + sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; + sexp_opcode_name(res) = name; + sexp_opcode_data(res) = data; + sexp_opcode_func(res) = f; + return res; +} + +sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp res = SEXP_VOID; + sexp_gc_var1(op); + sexp_gc_preserve1(ctx, op); + op = sexp_make_foreign(ctx, name, num_args, flags, f, data); + if (sexp_exceptionp(op)) + res = op; + else + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), op); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, + sexp_proc1 f, const char *param) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_intern(ctx, param, -1); + tmp = sexp_env_cell(env, tmp); + res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_TYPE_DEFS + +sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), + sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL); +} + +sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + sexp_uint_t type_size; + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); + type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); + return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), + sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, + sexp_make_fixnum(type_size), NULL); +} + +sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); + return + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER), + sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, index); + return + sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER), + sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO, + type, SEXP_ZERO, SEXP_ZERO, type, index, NULL); +} + +#endif + +#if SEXP_USE_STATIC_LIBS +#include "clibs.c" +#endif + +/*********************** standard environment *************************/ + +static struct sexp_core_form_struct core_forms[] = { + {SEXP_CORE_DEFINE, "define"}, + {SEXP_CORE_SET, "set!"}, + {SEXP_CORE_LAMBDA, "lambda"}, + {SEXP_CORE_IF, "if"}, + {SEXP_CORE_BEGIN, "begin"}, + {SEXP_CORE_QUOTE, "quote"}, + {SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}, + {SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}, + {SEXP_CORE_LET_SYNTAX, "let-syntax"}, + {SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}, +}; + +sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) { + 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; + return e; +} + +sexp sexp_make_null_env_op (sexp ctx sexp_api_params(self, n), sexp version) { + sexp_uint_t i; + sexp e = sexp_make_env(ctx), core; + for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) { + core = sexp_copy_core(ctx, &core_forms[i]); + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(core), -1), core); + } + return e; +} + +sexp sexp_make_primitive_env (sexp ctx, sexp version) { + int i; + sexp_gc_var3(e, op, sym); + sexp_gc_preserve3(ctx, e, op, sym); + e = sexp_make_null_env(ctx, version); + for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { + op = sexp_copy_opcode(ctx, &opcodes[i]); + if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1); + sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); + } + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op), -1), op); + } + sexp_gc_release3(ctx); + return e; +} + +sexp sexp_find_module_file (sexp ctx, const char *file) { + sexp res=SEXP_FALSE, ls; + char *dir, *path; + sexp_uint_t slash, dirlen, filelen, len; +#ifdef PLAN9 +#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0) + unsigned char buf[128]; +#else +#define file_exists_p(path, buf) (! stat(path, buf)) + struct stat buf_str; + struct stat *buf = &buf_str; +#endif + + filelen = strlen(file); + + ls = sexp_global(ctx, SEXP_G_MODULE_PATH); + for ( ; sexp_pairp(ls) && sexp_not(res); ls=sexp_cdr(ls)) { + dir = sexp_string_data(sexp_car(ls)); + dirlen = sexp_string_length(sexp_car(ls)); + slash = dir[dirlen-1] == '/'; + len = dirlen+filelen+2-slash; + path = (char*) malloc(len); + memcpy(path, dir, dirlen); + if (! slash) path[dirlen] = '/'; + memcpy(path+len-filelen-1, file, filelen); + path[len-1] = '\0'; + if (file_exists_p(path, buf)) + res = sexp_c_string(ctx, path, len-1); + free(path); + } + + return res; +} + +#define sexp_file_not_found "couldn't find file in module path" + +sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { + sexp res; + sexp_gc_var1(path); + sexp_gc_preserve1(ctx, path); + path = sexp_find_module_file(ctx, file); + if (sexp_stringp(path)) { + res = sexp_load(ctx, path, env); + } else { + path = sexp_c_string(ctx, file, -1); + res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path); + } + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_MODULES +sexp sexp_find_module_file_op (sexp ctx sexp_api_params(self, n), sexp file) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + return sexp_find_module_file(ctx, sexp_string_data(file)); +} +sexp sexp_load_module_file_op (sexp ctx sexp_api_params(self, n), sexp file, sexp env) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + return sexp_load_module_file(ctx, sexp_string_data(file), env); +} +sexp sexp_current_environment (sexp ctx sexp_api_params(self, n)) { + return sexp_context_env(ctx); +} +#endif + +sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp) { + sexp ls; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dir); + if (sexp_truep(appendp)) { + if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { + for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) + ; + sexp_cdr(ls) = sexp_list1(ctx, dir); + } else { + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir); + } + } else { + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir); + } + return SEXP_VOID; +} + +sexp sexp_load_standard_parameters (sexp ctx, sexp e) { + /* add io port and interaction env parameters */ + sexp p = sexp_make_input_port(ctx, stdin, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p); + p = sexp_make_output_port(ctx, stdout, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p); + p = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_port_no_closep(p) = 1; + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); + return SEXP_VOID; +} + +sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { + sexp_gc_var3(op, tmp, sym); + sexp_gc_preserve3(ctx, op, tmp, sym); + sexp_load_standard_parameters(ctx, e); +#if SEXP_USE_DL + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1), + tmp=sexp_c_string(ctx, sexp_so_extension, -1)); +#endif + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform, -1)); +#if SEXP_USE_DL + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading", -1)); +#endif +#if SEXP_USE_MODULES + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules", -1)); +#endif +#if SEXP_USE_BOEHM + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); +#endif +#if SEXP_USE_UTF8_STRINGS + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "utf-8", -1)); +#endif +#if SEXP_USE_GREEN_THREADS + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "threads", -1)); +#endif + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); + sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; +#if SEXP_USE_SIMPLIFY + op = sexp_make_foreign(ctx, "simplify", 1, 0, + (sexp_proc1)sexp_simplify, SEXP_VOID); + tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); +#endif + /* load init.scm */ + tmp = sexp_load_module_file(ctx, sexp_init_file, e); + /* load and bind config env */ +#if SEXP_USE_MODULES + if (! sexp_exceptionp(tmp)) { + sym = sexp_intern(ctx, "*config-env*", -1); + if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { + tmp = sexp_make_env(ctx); + if (! sexp_exceptionp(tmp)) { + sexp_global(ctx, SEXP_G_CONFIG_ENV) = tmp; + sexp_env_parent(tmp) = e; + op = sexp_load_module_file(ctx, sexp_config_file, tmp); + if (sexp_exceptionp(op)) + sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); + sexp_env_define(ctx, tmp, sym, tmp); + } + } + sexp_env_define(ctx, e, sym, tmp); + } +#endif +#if SEXP_USE_STATIC_LIBS + sexp_init_all_libraries(ctx, e); +#endif + sexp_gc_release3(ctx); + return sexp_exceptionp(tmp) ? tmp : e; +} + +sexp sexp_make_standard_env_op (sexp ctx sexp_api_params(self, n), sexp version) { + sexp_gc_var1(env); + sexp_gc_preserve1(ctx, env); + env = sexp_make_primitive_env(ctx, version); + if (! sexp_exceptionp(env)) sexp_load_standard_env(ctx, env, version); + sexp_gc_release1(ctx); + return env; +} + +sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) { + sexp oldname, newname, value; + if (! sexp_envp(to)) to = sexp_context_env(ctx); + if (! sexp_envp(from)) from = sexp_context_env(ctx); + if (sexp_not(ls)) { + if (sexp_truep(immutp)) { + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_parent(to) = value; + sexp_immutablep(value) = 1; + sexp_env_bindings(value) = sexp_env_bindings(from); + } else { + for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_env_define(ctx, to, sexp_car(ls), sexp_cdr(ls)); + } + } else { + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (sexp_pairp(sexp_car(ls))) { + newname = sexp_caar(ls); oldname = sexp_cdar(ls); + } else { + newname = oldname = sexp_car(ls); + } + value = sexp_env_ref(from, oldname, SEXP_UNDEF); + if (value != SEXP_UNDEF) { + sexp_env_define(ctx, to, newname, value); +#if SEXP_USE_WARN_UNDEFS + } else { + sexp_warn(ctx, "importing undefined variable: ", oldname); +#endif + } + } + } + return SEXP_VOID; +} + +/************************* backend ***************************/ + +#if SEXP_USE_NATIVE_X86 +#include "opt/x86.c" +#else +#include "vm.c" +#endif + +/************************** eval interface ****************************/ + +sexp sexp_compile (sexp ctx, sexp x) { + sexp_gc_var3(ast, vec, res); + sexp_gc_preserve3(ctx, ast, vec, res); + ast = sexp_analyze(ctx, x); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(res); res=sexp_cdr(res)) + ast = sexp_apply1(ctx, sexp_cdar(res), ast); + sexp_free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + emit_enter(ctx); + generate(ctx, ast); + res = finalize_bytecode(ctx); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, vec); + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_eval_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp env) { + sexp_sint_t top; + sexp ctx2; + sexp_gc_var2(res, err_handler); + if (! env) env = sexp_context_env(ctx); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_gc_preserve2(ctx, res, err_handler); + top = sexp_context_top(ctx); + err_handler = sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)); + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = SEXP_FALSE; + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0); + sexp_context_child(ctx) = ctx2; + res = sexp_compile(ctx2, obj); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_context_child(ctx) = SEXP_FALSE; + sexp_cdr(sexp_global(ctx, SEXP_G_ERR_HANDLER)) = err_handler; + sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_eval_string (sexp ctx, const char *str, sexp_sint_t len, sexp env) { + sexp res; + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); + obj = sexp_read_from_string(ctx, str, len); + res = sexp_eval(ctx, obj, env); + sexp_gc_release1(ctx); + return res; +} + +void sexp_scheme_init (void) { + if (! scheme_initialized_p) { + scheme_initialized_p = 1; + sexp_init(); + } +} diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..af7b3986 --- /dev/null +++ b/gc.c @@ -0,0 +1,346 @@ +/* gc.c -- simple mark&sweep garbage collector */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +#if SEXP_USE_MMAP_GC +#include +#endif + +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(sexp_sizeof(pair))) + +#if SEXP_USE_GLOBAL_HEAP +sexp_heap sexp_global_heap; +#endif + +#if SEXP_USE_CONSERVATIVE_GC +static sexp* stack_base; +#endif + +static sexp_heap sexp_heap_last (sexp_heap h) { + while (h->next) h = h->next; + return h; +} + +sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) { + sexp_uint_t res; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) + return sexp_heap_align(1); + t = sexp_object_type(ctx, x); + res = sexp_type_size_of_object(t, x); + return res; +} + +#if SEXP_USE_SAFE_GC_MARK +static int sexp_in_heap(sexp ctx, sexp_uint_t x) { + sexp_heap h; + if (x & (sexp_heap_align(1)-1)) { + fprintf(stderr, "invalid heap alignment: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; + } + for (h=sexp_context_heap(ctx); h; h=h->next) + if (((sexp_uint_t)h < x) && (x < (sexp_uint_t)(h->data + h->size))) + return 1; + fprintf(stderr, "invalid object outside heap: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; +} +#endif + +#if SEXP_USE_DEBUG_GC +#include "opt/gc_debug.c" +#endif + +void sexp_mark (sexp ctx, sexp x) { + 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; +#if SEXP_USE_SAFE_GC_MARK + if (! sexp_in_heap(ctx, (sexp_uint_t)x)) + return; +#endif +#if SEXP_USE_HEADER_MAGIC + if (sexp_pointer_magic(x) != SEXP_POINTER_MAGIC && sexp_pointer_tag(x) != SEXP_TYPE + && sexp_pointer_tag(x) != SEXP_OPCODE && sexp_pointer_tag(x) != SEXP_CORE + && sexp_pointer_tag(x) != SEXP_STACK) + return; +#endif + sexp_gc_mark(x) = 1; + if (sexp_contextp(x)) + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) sexp_mark(ctx, *(saves->var)); + t = sexp_object_type(ctx, x); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len = sexp_type_num_slots_of_object(t, x) - 1; + if (len >= 0) { + for (i=0; inext) { + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); + q = h->free_list; + end = (sexp) ((char*)h->data + h->size - sexp_heap_align(sexp_sizeof(pair))); + while (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) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + r->size); + continue; + } + size = sexp_heap_align(sexp_allocated_bytes(ctx, p)); + if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + /* free p */ + finalizer = sexp_type_finalize(sexp_object_type(ctx, p)); + if (finalizer) finalizer(ctx sexp_api_pass(NULL, 1), 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); + } + } + } + if (sum_freed_ptr) *sum_freed_ptr = sum_freed; + return sexp_make_fixnum(max_freed); +} + +sexp sexp_gc (sexp ctx, size_t *sum_freed) { + sexp res; +#if SEXP_USE_GLOBAL_SYMBOLS + int i; + 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(sexp_context_heap(ctx)); + 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=sexp_context_heap(ctx); 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, total_size; + sexp_heap h; + size = sexp_heap_align(size); + res = sexp_try_alloc(ctx, size); + if (! res) { + max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed)); + for (total_size=0, h=sexp_context_heap(ctx); h->next; h=h->next) + total_size += h->size; + total_size += h->size; + if (((max_freed < size) + || ((total_size > sum_freed) + && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO))) + && ((!SEXP_MAXIMUM_HEAP_SIZE) || (total_size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); + if (! res) + res = sexp_global(ctx, SEXP_G_OOM_ERROR); + } + return res; +} + +#if ! SEXP_USE_GLOBAL_HEAP + +sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { + sexp_sint_t i, off, len, freep; + sexp_heap to, from = sexp_context_heap(ctx); + sexp_free_list q; + sexp p, p2, t, end, *v; + freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP); + + /* validate input, creating a new heap if needed */ + if (from->next) { + return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx); + } else if (! dst || sexp_not(dst)) { + to = sexp_make_heap(from->size); + dst = (sexp) ((char*)ctx + ((char*)to - (char*)from)); + } else if (! sexp_contextp(dst)) { + return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst); + } else if (sexp_context_heap(dst)->size < from->size) { + return sexp_user_exception(ctx, NULL, "destination context too small", dst); + } else { + to = sexp_context_heap(dst); + } + + /* copy the raw data */ + off = (char*)to - (char*)from; + memcpy(to, from, sexp_heap_pad_size(from->size)); + to->free_list = (sexp_free_list) ((char*)to->free_list + off); + to->data += off; + end = (sexp) (from->data + from->size); + + /* adjust the free list */ + for (q=to->free_list; q->next; q=q->next) + q->next = (sexp_free_list) ((char*)q->next + off); + + /* adjust if the destination is larger */ + if (from->size < to->size) { + if (((char*)q + q->size - off) >= (char*)end) { + q->size += (to->size - from->size); + } else { + q->next = (sexp_free_list) ((char*)end + off); + q->next->next = NULL; + q->next->size = (to->size - from->size); + } + } + + /* adjust data by traversing over the _original_ heap */ + p = (sexp) (from->data + sexp_heap_align(sexp_sizeof(pair))); + q = from->free_list; + while (p < end) { + /* find the next free list pointer */ + for ( ; q && ((char*)q < (char*)p); q=q->next) + ; + if ((char*)q == (char*)p) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + q->size); + } else { + t = sexp_object_type(ctx, p); + len = sexp_type_num_slots_of_object(t, p); + p2 = (sexp)((char*)p + off); + v = (sexp*) ((char*)p2 + sexp_type_field_base(t)); + /* offset any pointers in the _destination_ heap */ + for (i=0; i 6 args */ +/* #define SEXP_USE_EXTENDED_FCALL 0 */ + +/* uncomment this if you don't need flonum support */ +/* This is only for EVAL - you'll still be able to read */ +/* and write flonums directly through the sexp API. */ +/* #define SEXP_USE_FLONUMS 0 */ + +/* uncomment this to disable reading/writing IEEE infinities */ +/* By default you can read/write +inf.0, -inf.0 and +nan.0 */ +/* #define SEXP_USE_INFINITIES 0 */ + +/* uncomment this if you want immediate flonums */ +/* This is experimental, enable at your own risk. */ +/* #define SEXP_USE_IMMEDIATE_FLONUMS 1 */ + +/* uncomment this if you don't want bignum support */ +/* Bignums are implemented with a small, custom library */ +/* in opt/bignum.c. */ +/* #define SEXP_USE_BIGNUMS 0 */ + +/* uncomment this if you don't need extended math operations */ +/* This includes the trigonometric and expt functions. */ +/* Automatically disabled if you've disabled flonums. */ +/* #define SEXP_USE_MATH 0 */ + +/* uncomment this to disable the self and n parameters to primitives */ +/* This is the old style API. */ +/* #define SEXP_USE_SELF_PARAMETER 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* This is something of a hack, but can be quite useful. */ +/* It's very fast and doesn't involve any separate analysis */ +/* passes. */ +/* #define SEXP_USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* By default (this may change) small symbols are represented */ +/* as immediates using a simple huffman encoding. This keeps */ +/* the symbol table small, and minimizes hashing when doing a */ +/* lot of reading. */ +/* #define SEXP_USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* You can trade off some space in exchange for longer read */ +/* times by disabling hashing and just putting all */ +/* non-immediate symbols in a single list. */ +/* #define SEXP_USE_HASH_SYMS 0 */ + +/* uncomment this to disable UTF-8 string support */ +/* The default settings store strings in memory as UTF-8, */ +/* and assumes strings passed to/from the C FFI are UTF-8. */ +/* #define SEXP_USE_UTF8_STRINGS 0 */ + +/* uncomment this to disable the string-set! opcode */ +/* By default (non-literal) strings are mutable. */ +/* Making them immutable allows for packed UTF-8 strings. */ +/* #define SEXP_USE_MUTABLE_STRINGS 0 */ + +/* uncomment this to disable string ports */ +/* If disabled some basic functionality such as number->string */ +/* will not be available by default. */ +/* #define SEXP_USE_STRING_STREAMS 0 */ + +/* uncomment this to disable automatic closing of ports */ +/* If enabled, the underlying FILE* for file ports will be */ +/* automatically closed when they're garbage collected. Doesn't */ +/* apply to stdin/stdout/stderr. */ +/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */ + +/* uncomment this to use the normal 1970 unix epoch */ +/* By default chibi uses an datetime epoch starting at */ +/* 2010/01/01 00:00:00 in order to be able to represent */ +/* more common times as fixnums. */ +/* #define SEXP_USE_2010_EPOCH 0 */ + +/* uncomment this to disable stack overflow checks */ +/* By default stacks are fairly small, so it's good to leave */ +/* this enabled. */ +/* #define SEXP_USE_CHECK_STACK 0 */ + +/* #define SEXP_USE_DEBUG_VM 0 */ +/* Experts only. */ +/* For *very* verbose output on every VM operation. */ + +/* uncomment this to make the VM adhere to alignment rules */ +/* This is required on some platforms, e.g. ARM */ +/* #define SEXP_USE_ALIGNED_BYTECODE */ + +/************************************************************************/ +/* These settings are configurable but only recommended for */ +/* experienced users, and only apply when using the native GC. */ +/************************************************************************/ + +/* the initial heap size in bytes */ +#ifndef SEXP_INITIAL_HEAP_SIZE +#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) +#endif + +/* the maximum heap size in bytes - if 0 there is no limit */ +#ifndef SEXP_MAXIMUM_HEAP_SIZE +#define SEXP_MAXIMUM_HEAP_SIZE 0 +#endif +#ifndef SEXP_MINIMUM_HEAP_SIZE +#define SEXP_MINIMUM_HEAP_SIZE 8*1024 +#endif + +/* if after GC more than this percentage of memory is still in use, */ +/* and we've not exceeded the maximum size, grow the heap */ +#ifndef SEXP_GROW_HEAP_RATIO +#define SEXP_GROW_HEAP_RATIO 0.75 +#endif + +/* the default number of opcodes to run each thread for */ +#ifndef SEXP_DEFAULT_QUANTUM +#define SEXP_DEFAULT_QUANTUM 500 +#endif + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#ifndef SEXP_64_BIT +#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) +#define SEXP_64_BIT 1 +#else +#define SEXP_64_BIT 0 +#endif +#endif + +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 +#if ! defined(_GNU_SOURCE) && ! defined(_WIN32) && ! defined(PLAN9) +#define _GNU_SOURCE +#endif +#endif + +#ifndef SEXP_USE_NO_FEATURES +#define SEXP_USE_NO_FEATURES 0 +#endif + +#ifndef SEXP_USE_GREEN_THREADS +#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_NATIVE_X86 +#define SEXP_USE_NATIVE_X86 0 +#endif + +#ifndef SEXP_USE_MODULES +#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_TYPE_DEFS +#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_MAXIMUM_TYPES +#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1) +#endif + +#ifndef SEXP_USE_DL +#if defined(PLAN9) || defined(_WIN32) +#define SEXP_USE_DL 0 +#else +#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_STATIC_LIBS +#define SEXP_USE_STATIC_LIBS 0 +#endif + +#ifndef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 0 +#endif + +#ifndef SEXP_USE_MALLOC +#define SEXP_USE_MALLOC 0 +#endif + +#ifndef SEXP_USE_MMAP_GC +#define SEXP_USE_MMAP_GC 0 +#endif + +#ifndef SEXP_USE_DEBUG_GC +#define SEXP_USE_DEBUG_GC 0 +#endif + +#ifndef SEXP_USE_SAFE_GC_MARK +#define SEXP_USE_SAFE_GC_MARK 0 +#endif + +#ifndef SEXP_USE_CONSERVATIVE_GC +#define SEXP_USE_CONSERVATIVE_GC 0 +#endif + +#ifndef SEXP_USE_HEADER_MAGIC +#define SEXP_USE_HEADER_MAGIC 0 +#endif + +#ifndef SEXP_USE_GLOBAL_HEAP +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_HEAP 1 +#else +#define SEXP_USE_GLOBAL_HEAP 0 +#endif +#endif + +#ifndef SEXP_USE_GLOBAL_TYPES +#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS) +#endif + +#ifndef SEXP_USE_GLOBAL_SYMBOLS +#if SEXP_USE_BOEHM || SEXP_USE_MALLOC +#define SEXP_USE_GLOBAL_SYMBOLS 1 +#else +#define SEXP_USE_GLOBAL_SYMBOLS 0 +#endif +#endif + +#ifndef SEXP_USE_EXTENDED_FCALL +#define SEXP_USE_EXTENDED_FCALL ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_INFINITIES +#if defined(PLAN9) || ! SEXP_USE_FLONUMS +#define SEXP_USE_INFINITIES 0 +#else +#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_IMMEDIATE_FLONUMS +#define SEXP_USE_IMMEDIATE_FLONUMS 0 +#endif + +#ifndef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MATH +#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_SELF_PARAMETER +#define SEXP_USE_SELF_PARAMETER 1 +#endif + +#ifndef SEXP_USE_WARN_UNDEFS +#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HUFF_SYMS +#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_HASH_SYMS +#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_DEBUG_VM +#define SEXP_USE_DEBUG_VM 0 +#endif + +#ifndef SEXP_USE_UTF8_STRINGS +#define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MUTABLE_STRINGS +#define SEXP_USE_MUTABLE_STRINGS 1 +#endif + +#if (SEXP_USE_UTF8_STRINGS && SEXP_USE_MUTABLE_STRINGS) +#define SEXP_USE_PACKED_STRINGS 0 +#endif +#ifndef SEXP_USE_PACKED_STRINGS +#define SEXP_USE_PACKED_STRINGS 1 +#endif + +#ifndef SEXP_USE_STRING_STREAMS +#ifdef _WIN32 +#define SEXP_USE_STRING_STREAMS 0 +#else +#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES +#endif +#endif + +#ifndef SEXP_USE_AUTOCLOSE_PORTS +#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_2010_EPOCH +#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_EPOCH_OFFSET +#if SEXP_USE_2010_EPOCH +#define SEXP_EPOCH_OFFSET 1262271600 +#else +#define SEXP_EPOCH_OFFSET 0 +#endif +#endif + +#ifndef SEXP_USE_CHECK_STACK +#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES +#endif + +#if SEXP_USE_NATIVE_X86 +#undef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 1 +#undef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS 0 +#undef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS 0 +#undef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY 0 +#endif + +#ifndef SEXP_USE_ALIGNED_BYTECODE +#if defined(__arm__) +#define SEXP_USE_ALIGNED_BYTECODE 1 +#else +#define SEXP_USE_ALIGNED_BYTECODE 0 +#endif +#endif + +#ifdef PLAN9 +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#elif defined(_WIN32) +#define snprintf(buf, len, fmt, val) sprintf(buf, fmt, val) +#define strcasecmp lstrcmpi +#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2) +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#define isnan(x) (x!=x) +#define isinf(x) (x > DBL_MAX || x < -DBL_MAX) +#endif + +#ifdef _WIN32 +#define sexp_pos_infinity (DBL_MAX*DBL_MAX) +#define sexp_neg_infinity -sexp_pos_infinity +#define sexp_nan log(-2) +#else +#define sexp_pos_infinity (1.0/0.0) +#define sexp_neg_infinity -sexp_pos_infinity +#define sexp_nan (0.0/0.0) +#endif + +#ifdef __MINGW32__ +#ifdef BUILDING_DLL +#define SEXP_API __declspec(dllexport) +#else +#define SEXP_API __declspec(dllimport) +#endif +#else +#define SEXP_API +#endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h new file mode 100644 index 00000000..7484d9c6 --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,1065 @@ +/* sexp.h -- header for sexp library */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_H +#define SEXP_H + +#ifdef __cplusplus +extern "C" { +#endif + +#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH" + +#include "chibi/features.h" +#include "chibi/install.h" + +#if defined(_WIN32) || defined(__MINGW32__) +#include +#else +#if SEXP_USE_DL +#include +#endif +#if SEXP_USE_GREEN_THREADS +#include +#endif +#endif + +#ifdef PLAN9 +#include +#include +#include +#include +#include <9p.h> +typedef unsigned long size_t; +#else +#include +#include +#include +#include +#include +#include +#include +#if SEXP_USE_FLONUMS +#include +#include +#endif +#endif + +#include +#include + +/* tagging system + * bits end in 00: pointer + * 01: fixnum + * 011: immediate flonum (optional) + * 111: immediate symbol (optional) + * 000110: char + * 001110: unique immediate (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 6 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 63 + +#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 + +#ifndef SEXP_POINTER_MAGIC +#define SEXP_POINTER_MAGIC 0xFDCA9764uL /* arbitrary */ +#endif + +#if SEXP_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_NUMBER, + SEXP_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_BYTES, + SEXP_STRING, + SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, + SEXP_CPOINTER, + 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_CORE_TYPES +}; + +#ifdef _WIN32 +typedef unsigned short sexp_tag_t; +typedef SIZE_T sexp_uint_t; +typedef SSIZE_T sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#elif SEXP_64_BIT +typedef unsigned int sexp_tag_t; +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#elif defined(__CYGWIN__) +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#else +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +typedef struct sexp_struct *sexp; + +#define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1)) + +#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2)) +#define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type)) +#define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type)) + +#define SEXP_UINT_T_MAX ((sexp_uint_t)-1) +#define SEXP_UINT_T_MIN (0) +#define SEXP_SINT_T_MAX __MAX_SIGNED(sexp_sint_t) +#define SEXP_SINT_T_MIN __MIN_SIGNED(sexp_sint_t) + +#define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1) +#define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1) + +#if SEXP_USE_SELF_PARAMETER +#define sexp_api_params(self, n) , sexp self, long n +#define sexp_api_pass(self, n) , self, n +#else +#define sexp_api_params(self, n) +#define sexp_api_pass(self, n) +#endif + +/* procedure types */ +typedef sexp (*sexp_proc1) (sexp sexp_api_params(self, n)); +typedef sexp (*sexp_proc2) (sexp sexp_api_params(self, n), sexp); +typedef sexp (*sexp_proc3) (sexp sexp_api_params(self, n), sexp, sexp); +typedef sexp (*sexp_proc4) (sexp sexp_api_params(self, n), sexp, sexp, sexp); +typedef sexp (*sexp_proc5) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc6) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc7) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp); + +typedef struct sexp_free_list_t *sexp_free_list; +struct sexp_free_list_t { + sexp_uint_t size; + sexp_free_list next; +}; + +typedef struct sexp_heap_t *sexp_heap; +struct sexp_heap_t { + sexp_uint_t size; + sexp_free_list free_list; + sexp_heap next; + /* note this must be aligned on a proper heap boundary, */ + /* so we can't just use char data[] */ + char *data; +}; + +struct sexp_gc_var_t { + sexp *var; +#if SEXP_USE_DEBUG_GC + char *name; +#endif + struct sexp_gc_var_t *next; +}; + +struct sexp_type_struct { + sexp_tag_t tag; + short field_base, field_eq_len_base, field_len_base, field_len_off; + unsigned short field_len_scale; + short size_base, size_off; + unsigned short size_scale; + char *name; + sexp_proc2 finalize; +}; + +struct sexp_opcode_struct { + unsigned char op_class, code, num_args, flags, inverse; + const char *name; + sexp data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type; + sexp_proc1 func; +}; + +struct sexp_core_form_struct { + char code; + const char *name; +}; + +struct sexp_struct { + sexp_tag_t tag; + char gc_mark; + unsigned int immutablep:1; + unsigned int freep:1; + unsigned int syntacticp:1; +#if SEXP_USE_HEADER_MAGIC + unsigned int magic; +#endif + union { + /* basic types */ + double flonum; + struct sexp_type_struct type; + struct { + sexp car, cdr; + sexp source; + } pair; + struct { + sexp_uint_t length; + sexp data[]; + } vector; + struct { + sexp_uint_t length; + char data[]; + } bytes; + struct { +#if SEXP_USE_PACKED_STRINGS + sexp_uint_t length; + char data[]; +#else + sexp_uint_t offset, length; + sexp bytes; +#endif + } string; + struct { + sexp_uint_t length; + char data[]; + } symbol; + struct { + FILE *stream; + char *buf; + char openp, no_closep, sourcep; + sexp_uint_t offset, line; + size_t size; + sexp name; + sexp cookie; + } port; + struct { + sexp kind, message, irritants, procedure, source; + } exception; + struct { + signed char sign; + sexp_uint_t length; + sexp_uint_t data[]; + } bignum; + struct { + sexp_uint_t length; + void *value; + sexp parent; + char body[]; + } cpointer; + /* runtime types */ + struct { + sexp parent, lambda, bindings; + } env; + struct { + sexp_uint_t length; + sexp name, literals, source; + 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 sexp_opcode_struct opcode; + struct sexp_core_form_struct core; + /* ast types */ + struct { + sexp name, params, body, defs, locals, flags, fv, sv, ret, types, source; + } lambda; + struct { + sexp test, pass, fail, source; + } cnd; + struct { + sexp var, value, source; + } set; + struct { + sexp name, cell, source; + } ref; + struct { + sexp ls, source; + } seq; + struct { + sexp value, source; + } lit; + /* compiler state */ + struct { + sexp_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp_heap heap; + struct sexp_gc_var_t *saves; +#if SEXP_USE_GREEN_THREADS + sexp_sint_t refuel; + unsigned char* ip; + struct timeval tval; +#endif + char tailp, tracep, timeoutp, waitp; + sexp_uint_t pos, depth, last_fp; + sexp bc, lambda, stack, env, fv, parent, child, globals, + proc, name, specific, event; + } 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_offsetof_slot0 (offsetof(struct sexp_struct, value)) + +#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double)) + +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) +#define sexp_alloc_bytecode(ctx, i) sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE) + +#if SEXP_USE_BIGNUMS +#include "chibi/bignum.h" +#endif + +/***************************** 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_fixnump(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_flags(x) ((x)->flags) +#define sexp_immutablep(x) ((x)->immutablep) +#define sexp_freep(x) ((x)->freep) +#define sexp_pointer_magic(x) ((x)->magic) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) +#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) + +#define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b))) + +#if SEXP_USE_IMMEDIATE_FLONUMS +union sexp_flonum_conv { + float flonum; + unsigned int bits; +}; +#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x); +#if SEXP_64_BIT +SEXP_API float sexp_flonum_value (sexp x); +SEXP_API sexp sexp_make_flonum(sexp ctx, float f); +#else +#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)(((unsigned int)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) +#endif +#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_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) +#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER)) +#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_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x)) + +#if SEXP_USE_HUFF_SYMS +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +#else +#define sexp_symbolp(x) (sexp_lsymbolp(x)) +#endif + +#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_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) + +#define SEXP_NEG_ONE sexp_make_fixnum(-1) +#define SEXP_ZERO sexp_make_fixnum(0) +#define SEXP_ONE sexp_make_fixnum(1) +#define SEXP_TWO sexp_make_fixnum(2) +#define SEXP_THREE sexp_make_fixnum(3) +#define SEXP_FOUR sexp_make_fixnum(4) +#define SEXP_FIVE sexp_make_fixnum(5) +#define SEXP_SIX sexp_make_fixnum(6) +#define SEXP_SEVEN sexp_make_fixnum(7) +#define SEXP_EIGHT sexp_make_fixnum(8) +#define SEXP_NINE sexp_make_fixnum(9) +#define SEXP_TEN sexp_make_fixnum(10) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) + +#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x))) +#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x)) +#else +#define _or_integer_flonump(x) +#endif + +#if SEXP_USE_BIGNUMS +SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x); +SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); +#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x)) +#else +#define sexp_make_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_make_unsigned_integer(ctx, x) sexp_make_fixnum(x) +#define sexp_exact_integerp(x) sexp_fixnump(x) +#endif + +#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x)) + +#if SEXP_USE_FLONUMS +#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) +#define sexp_numberp(x) (sexp_exact_integerp(x) || sexp_flonump(x)) +#else +#define sexp_fixnum_to_flonum(ctx, x) (x) +#define sexp_numberp(x) sexp_exact_integerp(x) +#endif + +#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS +#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0])) +#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0])) +#else +#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x)) +#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x)) +#endif + +#define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET) +#define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET) + +/*************************** 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_fixnum(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_fixnum(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_fixnum(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_bytes_length(x) ((x)->value.bytes.length) +#define sexp_bytes_data(x) ((x)->value.bytes.data) + +#define sexp_string_length(x) ((x)->value.string.length) +#if SEXP_USE_PACKED_STRINGS +#define sexp_string_data(x) ((x)->value.string.data) +#else +#define sexp_string_bytes(x) ((x)->value.string.bytes) +#define sexp_string_offset(x) ((x)->value.string.offset) +#define sexp_string_data(x) (sexp_bytes_data(sexp_string_bytes(x))+sexp_string_offset(x)) +#endif + +#define sexp_bytes_ref(x, i) (sexp_make_fixnum((unsigned char)sexp_bytes_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_bytes_set(x, i, v) (sexp_bytes_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_fixnum(v)) + +#define sexp_string_ref(x, i) (sexp_make_character((unsigned char)sexp_string_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_character(v)) + +#define sexp_symbol_data(x) ((x)->value.symbol.data) +#define sexp_symbol_length(x) ((x)->value.symbol.length) +#define sexp_symbol_string(x) (x) + +#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_no_closep(p) ((p)->value.port.no_closep) +#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_cpointer_freep(p) (sexp_freep(p)) +#define sexp_cpointer_length(p) ((p)->value.cpointer.length) +#define sexp_cpointer_body(p) ((p)->value.cpointer.body) +#define sexp_cpointer_parent(p) ((p)->value.cpointer.parent) +#define sexp_cpointer_value(p) ((p)->value.cpointer.value) +#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p)) + +#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_source(x) ((x)->value.bytecode.source) +#define sexp_bytecode_data(x) ((x)->value.bytecode.data) + +#define sexp_env_syntactic_p(x) ((x)->syntacticp) +#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_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_data2(x) ((x)->value.opcode.data2) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) +#define sexp_opcode_return_type(x) ((x)->value.opcode.ret_type) +#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_arg3_type(x) ((x)->value.opcode.arg3_type) +#define sexp_opcode_func(x) ((x)->value.opcode.func) + +#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_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) + +#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_lambda_return_type(x) ((x)->value.lambda.ret) +#define sexp_lambda_param_types(x) ((x)->value.lambda.types) +#define sexp_lambda_source(x) ((x)->value.lambda.source) + +#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_cnd_source(x) ((x)->value.cnd.source) + +#define sexp_set_var(x) ((x)->value.set.var) +#define sexp_set_value(x) ((x)->value.set.value) +#define sexp_set_source(x) ((x)->value.set.source) + +#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_ref_source(x) ((x)->value.ref.source) + +#define sexp_seq_ls(x) ((x)->value.seq.ls) +#define sexp_seq_source(x) ((x)->value.seq.source) + +#define sexp_lit_value(x) ((x)->value.lit.value) +#define sexp_lit_source(x) ((x)->value.lit.source) + +#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_lambda(x) ((x)->value.context.lambda) +#define sexp_context_parent(x) ((x)->value.context.parent) +#define sexp_context_child(x) ((x)->value.context.child) +#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.tracep) +#define sexp_context_globals(x) ((x)->value.context.globals) +#define sexp_context_last_fp(x) ((x)->value.context.last_fp) +#define sexp_context_refuel(x) ((x)->value.context.refuel) +#define sexp_context_ip(x) ((x)->value.context.ip) +#define sexp_context_proc(x) ((x)->value.context.proc) +#define sexp_context_timeval(x) ((x)->value.context.tval) +#define sexp_context_name(x) ((x)->value.context.name) +#define sexp_context_specific(x) ((x)->value.context.specific) +#define sexp_context_event(x) ((x)->value.context.event) +#define sexp_context_timeoutp(x) ((x)->value.context.timeoutp) +#define sexp_context_waitp(x) ((x)->value.context.waitp) + +#if SEXP_USE_ALIGNED_BYTECODE +#define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx)) +#else +#define sexp_context_align_pos(ctx) +#endif + +#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) + +#if SEXP_USE_GLOBAL_HEAP +#if ! SEXP_USE_BOEHM +SEXP_API sexp_heap sexp_global_heap; +#endif +#define sexp_context_heap(ctx) sexp_global_heap +#else +#define sexp_context_heap(ctx) ((ctx)->value.context.heap) +#endif + +#if SEXP_USE_GLOBAL_SYMBOLS +#define sexp_context_symbols(ctx) sexp_symbol_table +#else +#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) +#endif + +#if SEXP_USE_GLOBAL_TYPES +SEXP_API struct sexp_struct *sexp_type_specs; +#define sexp_context_types(ctx) sexp_type_specs +#define sexp_type_by_index(ctx,i) (&(sexp_context_types(ctx)[i])) +#define sexp_context_num_types(ctx) sexp_num_types +#define sexp_context_type_array_size(ctx) sexp_type_array_size +#else +#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#define sexp_type_by_index(ctx,i) (sexp_context_types(ctx)[i]) +#define sexp_context_num_types(ctx) \ + sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES)) +#define sexp_context_type_array_size(ctx) \ + sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES)) +#endif + +#define sexp_object_type(ctx,x) (sexp_type_by_index(ctx, ((x)->tag))) +#define sexp_object_type_name(ctx,x) (sexp_type_name(sexp_object_type(ctx, x))) +#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i))) + +#define sexp_type_size_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \ + * sexp_type_size_scale(t) \ + + sexp_type_size_base(t)) +#define sexp_type_num_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_len_base(t)) +#define sexp_type_num_eq_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ + * sexp_type_field_len_scale(t) \ + + sexp_type_field_eq_len_base(t)) + +#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_eq_len_base(x) ((x)->value.type.field_eq_len_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_type_finalize(x) ((x)->value.type.finalize) + +#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_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b))) +#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b))) +#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1))) +#define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a)))) +#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a) + +#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 *****************************/ + +enum sexp_context_globals { +#if ! SEXP_USE_GLOBAL_SYMBOLS + SEXP_G_SYMBOLS, +#endif +#if ! SEXP_USE_GLOBAL_TYPES + SEXP_G_TYPES, + SEXP_G_NUM_TYPES, +#endif + SEXP_G_OOM_ERROR, /* out of memory exception object */ + SEXP_G_OOS_ERROR, /* out of stack exception object */ + SEXP_G_OPTIMIZATIONS, + SEXP_G_SIGNAL_HANDLERS, + SEXP_G_CONFIG_ENV, + SEXP_G_MODULE_PATH, + SEXP_G_QUOTE_SYMBOL, + SEXP_G_QUASIQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SPLICING_SYMBOL, + SEXP_G_EMPTY_VECTOR, + SEXP_G_CUR_IN_SYMBOL, + SEXP_G_CUR_OUT_SYMBOL, + SEXP_G_CUR_ERR_SYMBOL, + SEXP_G_INTERACTION_ENV_SYMBOL, + SEXP_G_ERR_HANDLER, + SEXP_G_RESUMECC_BYTECODE, + SEXP_G_FINAL_RESUMER, +#if SEXP_USE_GREEN_THREADS + SEXP_G_THREADS_SCHEDULER, + SEXP_G_THREADS_FRONT, + SEXP_G_THREADS_BACK, + SEXP_G_THREADS_PAUSED, + SEXP_G_THREADS_LOCAL, + SEXP_G_THREADS_SIGNALS, + SEXP_G_THREADS_SIGNAL_RUNNER, +#endif + SEXP_G_NUM_GLOBALS +}; + +#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(ctx, (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 SEXP_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)) + +SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); +SEXP_API sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, const char *str, sexp_uint_t len, sexp p); +SEXP_API sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p); +SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) +#define sexp_at_eofp(p) (feof(sexp_port_stream(p))) + +SEXP_API sexp sexp_make_context(sexp ctx, size_t size); +SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +SEXP_API sexp sexp_cons_op(sexp ctx sexp_api_params(self, n), sexp head, sexp tail); +SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_listp_op(sexp ctx sexp_api_params(self, n), sexp obj); +SEXP_API sexp sexp_reverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_nreverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_copy_list_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_append2_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b); +SEXP_API sexp sexp_memq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_assq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); +SEXP_API sexp sexp_length_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen); +SEXP_API sexp sexp_make_bytes_op(sexp ctx sexp_api_params(self, n), sexp len, sexp i); +SEXP_API sexp sexp_make_string_op(sexp ctx sexp_api_params(self, n), sexp len, sexp ch); +SEXP_API sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end); +SEXP_API sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep); +SEXP_API sexp sexp_intern (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b); +SEXP_API sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt); +SEXP_API sexp sexp_list_to_vector_op (sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); +SEXP_API sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out); +SEXP_API sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp in); +SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_write_to_string (sexp ctx, sexp obj); +SEXP_API sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port); +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_op (sexp ctx sexp_api_params(self, n), sexp str); +SEXP_API sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)); +SEXP_API sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port); +SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); +SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x); +SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +SEXP_API sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out); +SEXP_API void sexp_init(void); + +#define sexp_assert_type(ctx, pred, type_id, obj) if (! pred(obj)) return sexp_type_exception(ctx, self, type_id, obj) + +#define SEXP_COPY_DEFAULT SEXP_ZERO +#define SEXP_COPY_FREEP SEXP_ONE + +#if SEXP_USE_GLOBAL_HEAP +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_destroy_context (sexp ctx); +SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags); +#endif + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots); +SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); +SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj); +#define sexp_register_c_type(ctx, name, finalizer) \ + sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ + SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer) +#endif + +#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) +#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))) + +/* simplify primitive API interface */ + +#define sexp_read(ctx, in) sexp_read_op(ctx sexp_api_pass(NULL, 1), in) +#define sexp_write(ctx, obj, out) sexp_write_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_display(ctx, obj, out) sexp_display_op(ctx sexp_api_pass(NULL, 2), obj, out) +#define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx sexp_api_pass(NULL, 2), e, out) +#define sexp_flush_output(ctx, obj, out) sexp_flush_output_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_listp(ctx, x) sexp_listp_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_length(ctx, x) sexp_length_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_reverse(ctx, x) sexp_reverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_copy_list(ctx, x) sexp_copy_list_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_cons(ctx, a, b) sexp_cons_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_append2(ctx, a, b) sexp_append2_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx sexp_api_pass(NULL, 2), a, b); +#define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_string_to_number(ctx, s, b) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), s, b) +#define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx sexp_api_pass(NULL, 2), l, i) +#define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), l, c) +#define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_substring(ctx, a, b, c) sexp_substring_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx sexp_api_pass(NULL, 2), ls, s) +#define sexp_memq(ctx, a, b) sexp_memq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_assq(ctx, a, b) sexp_assq_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_output_string_port(ctx) sexp_make_output_string_port_op(ctx sexp_api_pass(NULL, 0)) +#define sexp_make_input_string_port(ctx, s) sexp_make_input_string_port_op(ctx sexp_api_pass(NULL, 1), s) +#define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx sexp_api_pass(NULL, 1), out) +#define sexp_expt(ctx, a, b) sexp_expt_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_simple_type(ctx, a, b) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j) sexp_register_type_op(ctx sexp_api_pass(NULL, 10), a, b, c, d, e, f, g, h, i, j) +#define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b) +#define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_make_setter(ctx, a, b, c) sexp_make_setter_op(ctx sexp_api_pass(NULL, 3), a, b, c) + +#ifdef __cplusplus +} /* extern "C" */ +#endif + +#endif /* ! SEXP_H */ + diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c new file mode 100644 index 00000000..8d946273 --- /dev/null +++ b/lib/chibi/ast.c @@ -0,0 +1,248 @@ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); + sexp_gc_release2(ctx); +} + +static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, + sexp_uint_t cindex, char* get, char *set) { + sexp type, index; + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + type = sexp_make_fixnum(ctype); + index = sexp_make_fixnum(cindex); + op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, get, -1), op); + op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); + sexp_env_define(ctx, env, name=sexp_intern(ctx, set, -1), op); + sexp_gc_release2(ctx); +} + +static sexp sexp_get_env_cell (sexp ctx sexp_api_params(self, n), sexp env, sexp id) { + sexp cell = sexp_env_cell(env, id); + while ((! cell) && sexp_synclop(id)) { + env = sexp_synclo_env(id); + id = sexp_synclo_expr(id); + } + return cell ? cell : SEXP_FALSE; +} + +static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + else if (! sexp_opcode_name(op)) + return SEXP_FALSE; + else + return sexp_intern(ctx, sexp_opcode_name(op), -1); +} + +static sexp sexp_translate_opcode_type (sexp ctx, sexp type) { + sexp_gc_var2(res, tmp); + res = type; + if (! res) { + res = sexp_type_by_index(ctx, SEXP_OBJECT); + } if (sexp_fixnump(res)) { + res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); + } else if (sexp_nullp(res)) { /* opcode list types */ + sexp_gc_preserve2(ctx, res, tmp); + tmp = sexp_intern(ctx, "or", -1); + res = sexp_cons(ctx, SEXP_NULL, SEXP_NULL); + res = sexp_cons(ctx, sexp_type_by_index(ctx, SEXP_PAIR), res); + res = sexp_cons(ctx, tmp, res); + sexp_gc_release2(ctx); + } + return res; +} + +static sexp sexp_get_opcode_ret_type (sexp ctx sexp_api_params(self, n), sexp op) { + sexp res; + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + if (sexp_opcode_code(op) == SEXP_OP_RAISE) + return sexp_list1(ctx, sexp_intern(ctx, "error", -1)); + res = sexp_opcode_return_type(op); + if (sexp_fixnump(res)) + res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); + return sexp_translate_opcode_type(ctx, res); +} + +static sexp sexp_get_opcode_param_type (sexp ctx sexp_api_params(self, n), sexp op, sexp k) { + sexp res; + int p = sexp_unbox_fixnum(k); + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + else if (! sexp_fixnump(k)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, k); + if (p > sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op)) + p = sexp_opcode_num_args(op); + switch (p) { + case 0: + res = sexp_opcode_arg1_type(op); + break; + case 1: + res = sexp_opcode_arg2_type(op); + break; + default: + res = sexp_opcode_arg3_type(op); + if (sexp_vectorp(res)) { + if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2)) + res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO)); + else + res = sexp_type_by_index(ctx, SEXP_OBJECT); + } + break; + } + return sexp_translate_opcode_type(ctx, res); +} + +static sexp sexp_get_opcode_num_params (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + return sexp_make_fixnum(sexp_opcode_num_args(op)); +} + +static sexp sexp_get_opcode_variadic_p (sexp ctx sexp_api_params(self, n), sexp op) { + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + return sexp_make_boolean(sexp_opcode_variadic_p(op)); +} + +static sexp sexp_type_of (sexp ctx sexp_api_params(self, n), sexp x) { + if (sexp_pointerp(x)) + return sexp_object_type(ctx, x); + else if (sexp_fixnump(x)) + return sexp_type_by_index(ctx, SEXP_FIXNUM); + else if (sexp_booleanp(x)) + return sexp_type_by_index(ctx, SEXP_BOOLEAN); + else if (sexp_charp(x)) + return sexp_type_by_index(ctx, SEXP_CHAR); +#if SEXP_USE_HUFF_SYMS + else if (sexp_symbolp(x)) + return sexp_type_by_index(ctx, SEXP_SYMBOL); +#endif +#if SEXP_USE_IMMEDIATE_FLONUMS + else if (sexp_flonump(x)) + return sexp_type_by_index(ctx, SEXP_FLONUM); +#endif + else + return sexp_type_by_index(ctx, SEXP_OBJECT); +} + +static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { + sexp ctx2 = ctx; + if (sexp_envp(e)) { + ctx2 = sexp_make_child_context(ctx, NULL); + sexp_context_env(ctx2) = e; + } + return sexp_analyze(ctx2, x); +} + +static sexp sexp_optimize (sexp ctx sexp_api_params(self, n), sexp x) { + sexp_gc_var2(ls, res); + sexp_gc_preserve2(ctx, ls, res); + res = x; + ls = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_apply1(ctx, sexp_cdar(ls), res); + sexp_free_vars(ctx, res, SEXP_NULL); + sexp_gc_release2(ctx); + return res; +} + +#define sexp_define_type(ctx, name, tag) \ + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag)); + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_type(ctx, "", SEXP_OBJECT); + sexp_define_type(ctx, "", SEXP_NUMBER); + sexp_define_type(ctx, "", SEXP_BIGNUM); + sexp_define_type(ctx, "", SEXP_FLONUM); + sexp_define_type(ctx, "", SEXP_FIXNUM); + sexp_define_type(ctx, "", SEXP_SYMBOL); + sexp_define_type(ctx, "", SEXP_CHAR); + sexp_define_type(ctx, "", SEXP_BOOLEAN); + sexp_define_type(ctx, "", SEXP_STRING); + sexp_define_type(ctx, "", SEXP_BYTES); + sexp_define_type(ctx, "", SEXP_PAIR); + sexp_define_type(ctx, "", SEXP_VECTOR); + sexp_define_type(ctx, "", SEXP_OPCODE); + sexp_define_type(ctx, "", SEXP_PROCEDURE); + sexp_define_type(ctx, "", SEXP_BYTECODE); + sexp_define_type(ctx, "", SEXP_ENV); + sexp_define_type(ctx, "", SEXP_MACRO); + sexp_define_type(ctx, "", SEXP_LAMBDA); + sexp_define_type(ctx, "", SEXP_CND); + sexp_define_type(ctx, "", SEXP_SET); + sexp_define_type(ctx, "", SEXP_REF); + sexp_define_type(ctx, "", SEXP_SEQ); + sexp_define_type(ctx, "", SEXP_LIT); + sexp_define_type(ctx, "", SEXP_SYNCLO); + sexp_define_type(ctx, "", SEXP_CONTEXT); + sexp_define_type(ctx, "", SEXP_EXCEPTION); + sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV); + sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE); + sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); + sexp_define_type_predicate(ctx, env, "macro?", SEXP_MACRO); + sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO); + sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA); + sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND); + sexp_define_type_predicate(ctx, env, "set?", SEXP_SET); + sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF); + sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ); + sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT); + sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE); + sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE); + sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT); + sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); + sexp_define_accessors(ctx, env, SEXP_PAIR, 2, "pair-source", "pair-source-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 4, "lambda-locals", "lambda-locals-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 5, "lambda-flags", "lambda-flags-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 6, "lambda-free-vars", "lambda-free-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-set-vars", "lambda-set-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 8, "lambda-return-type", "lambda-return-type-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 9, "lambda-param-types", "lambda-param-types-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 10, "lambda-source", "lambda-source-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!"); + sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!"); + sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!"); + sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!"); + sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!"); + sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); + sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 1, "procedure-code", "procedure-code-set!"); + sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 2, "procedure-vars", "procedure-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-name", "bytecode-name-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", "exception-kind-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", "exception-message-set!"); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 2, "exception-irritants", "exception-irritants-set!"); + sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE); + sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env); + sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell); + sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + sexp_define_foreign(ctx, env, "opcode-variadic?", 1, sexp_get_opcode_variadic_p); + sexp_define_foreign(ctx, env, "opcode-num-params", 1, sexp_get_opcode_num_params); + sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type); + sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type); + sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize); + sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of); + return SEXP_VOID; +} + diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module new file mode 100644 index 00000000..a439bd57 --- /dev/null +++ b/lib/chibi/ast.module @@ -0,0 +1,33 @@ + +(define-module (chibi ast) + (export + analyze optimize env-cell ast->sexp macroexpand type-of + + + + + pair-source pair-source-set! + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? + environment? bytecode? exception? macro? context? exception? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + lambda-name lambda-params lambda-body lambda-defs lambda-locals + lambda-flags lambda-free-vars lambda-set-vars lambda-return-type + lambda-param-types lambda-source + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + lambda-locals-set! lambda-flags-set! lambda-free-vars-set! + lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set! + lambda-source-set! + cnd-test cnd-pass cnd-fail + cnd-test-set! cnd-pass-set! cnd-fail-set! + set-var set-value set-var-set! set-value-set! + ref-name ref-cell ref-name-set! ref-cell-set! + seq-ls seq-ls-set! lit-value lit-value-set! + exception-kind exception-kind-set! exception-message exception-message-set! + exception-irritants exception-irritants-set! + opcode-name opcode-num-params opcode-return-type opcode-param-type + opcode-variadic? + procedure-code procedure-vars procedure-name bytecode-name) + (import-immutable (scheme)) + (include-shared "ast") + (include "ast.scm")) + diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm new file mode 100644 index 00000000..020f257a --- /dev/null +++ b/lib/chibi/ast.scm @@ -0,0 +1,91 @@ +;; ast.scm -- ast utilities +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (macroexpand x) + (ast->sexp (analyze x))) + +(define (procedure-name x) + (bytecode-name (procedure-code x))) + +(define (ast-renames ast) + (define i 0) + (define renames '()) + (define (rename-symbol id) + (set! i (+ i 1)) + (string->symbol + (string-append (symbol->string (identifier->symbol id)) + "." (number->string i)))) + (define (rename-lambda lam) + (or (assq lam renames) + (let ((res (list lam))) + (set! renames (cons res renames)) + res))) + (define (rename! id lam) + (let ((cell (rename-lambda lam))) + (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell))))) + (define (check-ref id lam env) + (let ((sym (identifier->symbol id))) + (let lp1 ((ls env)) + (cond + ((pair? ls) + (let lp2 ((ls2 (car ls)) (found? #f)) + (cond + ((null? ls2) + (if (not found?) (lp1 (cdr ls)))) + ((and (eq? id (caar ls2)) (eq? lam (cdar ls2))) + (lp2 (cdr ls2) #t)) + ((eq? sym (identifier->symbol (caar ls2))) + (rename! (caar ls2) (cdar ls2)) + (lp2 (cdr ls2) found?)) + (else + (lp2 (cdr ls2) found?))))))))) + (define (flatten-dot x) + (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) + ((null? x) x) + (else (list x)))) + (define (extend-env lam env) + (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env)) + (let lp ((x ast) (env '())) + (cond + ((lambda? x) (lp (lambda-body x) (extend-env x env))) + ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env)) + ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env)) + ((set? x) (lp (set-var x) env) (lp (set-value x) env)) + ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x))) + ((pair? x) (for-each (lambda (x) (lp x env)) x)))) + renames) + +(define (get-rename id lam renames) + (let ((ls (assq lam renames))) + (if (not ls) + (identifier->symbol id) + (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id)))))) + +(define (map* f ls) + (cond ((pair? ls) (cons (f (car ls)) (map* f (cdr ls)))) + ((null? ls) '()) + (else (f ls)))) + +(define (ast->sexp ast) + (let ((renames (ast-renames ast))) + (let a2s ((x ast)) + (cond + ((lambda? x) + `(lambda ,(map* (lambda (id) (get-rename id x renames)) (lambda-params x)) + ,@(map (lambda (d) `(define ,(identifier->symbol (caar d)) #f)) + (lambda-defs x)) + ,@(if (seq? (lambda-body x)) + (map a2s (seq-ls (lambda-body x))) + (list (a2s (lambda-body x)))))) + ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x)))) + ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x)))) + ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames)) + ((seq? x) `(begin ,@(map a2s (seq-ls x)))) + ((lit? x) + (let ((v (lit-value x))) + (if (or (pair? v) (null? v) (symbol? v)) `',v v))) + ((pair? x) (cons (a2s (car x)) (a2s (cdr x)))) + ((opcode? x) (or (opcode-name x) x)) + (else x))))) + diff --git a/lib/chibi/base64.module b/lib/chibi/base64.module new file mode 100644 index 00000000..12324e1d --- /dev/null +++ b/lib/chibi/base64.module @@ -0,0 +1,7 @@ + +(define-module (chibi base64) + (export base64-encode base64-encode-string + base64-decode base64-decode-string + base64-encode-header) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "base64.scm")) diff --git a/lib/chibi/base64.scm b/lib/chibi/base64.scm new file mode 100644 index 00000000..3d95ad71 --- /dev/null +++ b/lib/chibi/base64.scm @@ -0,0 +1,351 @@ +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: base64-encode-string str +;; Return a base64 encoded representation of string according to the +;; official base64 standard as described in RFC3548. + +;; Procedure: base64-decode-string str +;; Return a base64 decoded representation of string, also interpreting +;; the alternate 62 & 63 valued characters as described in RFC3548. +;; Other out-of-band characters are silently stripped, and = signals +;; the end of the encoded string. No errors will be raised. + +;; Procedure: base64-encode [port] +;; Procedure: base64-decode [port] +;; Variations of the above which read and write to ports. + +;; Procedure: base64-encode-header enc str [start-col max-col nl] +;; Return a base64 encoded representation of string as above, +;; wrapped in =?ENC?B?...?= as per RFC1522, split across multiple +;; MIME-header lines as needed to keep each lines length less than +;; MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring +;; STR is already encoded according to ENC. The optional argument +;; NL is the newline separator, defaulting to CRLF. + +;; This API is compatible with the Gauche library rfc.base64. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-chop str n) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (+ i n))) + (if (>= j len) + (reverse (cons (substring str i len) res)) + (lp j (cons (substring str i j) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; constants and tables + +(define *default-max-col* 76) + +(define *outside-char* 99) ; luft-balloons +(define *pad-char* 101) ; dalmations + +(define *base64-decode-table* + (let ((res (make-vector #x100 *outside-char*))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res (+ i 65) i) + (vector-set! res (+ i 97) (+ i 26)) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 48) (+ i 52)) + (lp (+ i 1))))) + ;; extras (be liberal for different common base64 formats) + (vector-set! res (char->integer #\+) 62) + (vector-set! res (char->integer #\-) 62) + (vector-set! res (char->integer #\/) 63) + (vector-set! res (char->integer #\_) 63) + (vector-set! res (char->integer #\~) 63) + (vector-set! res (char->integer #\=) *pad-char*) + res)) + +(define (base64-decode-char c) + (vector-ref *base64-decode-table* (char->integer c))) + +(define *base64-encode-table* + (let ((res (make-vector 64))) + (let lp ((i 0)) ; map letters + (cond + ((<= i 25) + (vector-set! res i (integer->char (+ i 65))) + (vector-set! res (+ i 26) (integer->char (+ i 97))) + (lp (+ i 1))))) + (let lp ((i 0)) ; map numbers + (cond + ((<= i 9) + (vector-set! res (+ i 52) (integer->char (+ i 48))) + (lp (+ i 1))))) + (vector-set! res 62 #\+) + (vector-set! res 63 #\/) + res)) + +(define (enc i) + (vector-ref *base64-encode-table* i)) + +;; try to match common boundaries +(define decode-src-length + (lcm 76 78)) + +(define decode-dst-length + (* 3 (arithmetic-shift (+ 3 decode-src-length) -2))) + +(define encode-src-length + (* 3 1024)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; decoding + +;; Create a result buffer with the maximum possible length for the +;; input, and pass it to the internal base64-decode-string! utility. +;; If the resulting length used is exact, we can return that buffer, +;; otherwise we return the appropriate substring. +(define (base64-decode-string src) + (let* ((len (string-length src)) + (dst-len (* 3 (arithmetic-shift (+ 3 len) -2))) + (dst (make-string dst-len))) + (base64-decode-string! + src 0 len dst + (lambda (src-offset res-len b1 b2 b3) + (let ((res-len (base64-decode-finish dst res-len b1 b2 b3))) + (if (= res-len dst-len) + dst + (substring dst 0 res-len))))))) + +;; This is a little funky. +;; +;; We want to skip over "outside" characters (e.g. newlines inside +;; base64-encoded data, as would be passed in mail clients and most +;; large base64 data). This would normally mean two nested loops - +;; one for overall processing the input, and one for looping until +;; we get to a valid character. However, many Scheme compilers are +;; really bad about optimizing nested loops of primitives, so we +;; flatten this into a single loop, using conditionals to determine +;; which character is currently being read. +(define (base64-decode-string! src start end dst kont) + (let lp ((i start) + (j 0) + (b1 *outside-char*) + (b2 *outside-char*) + (b3 *outside-char*)) + (if (>= i end) + (kont i j b1 b2 b3) + (let ((c (base64-decode-char (string-ref src i)))) + (cond + ((eqv? c *pad-char*) + (kont i j b1 b2 b3)) + ((eqv? c *outside-char*) + (lp (+ i 1) j b1 b2 b3)) + ((eqv? b1 *outside-char*) + (lp (+ i 1) j c b2 b3)) + ((eqv? b2 *outside-char*) + (lp (+ i 1) j b1 c b3)) + ((eqv? b3 *outside-char*) + (lp (+ i 1) j b1 b2 c)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (string-set! dst + (+ j 2) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 2 0 b3) 6) + c))) + (lp (+ i 1) (+ j 3) + *outside-char* *outside-char* *outside-char*))))))) + +;; If requested, account for any "partial" results (i.e. trailing 2 or +;; 3 chars) by writing them into the destination (additional 1 or 2 +;; bytes) and returning the adjusted offset for how much data we've +;; written. +(define (base64-decode-finish dst j b1 b2 b3) + (cond + ((eqv? b1 *outside-char*) + j) + ((eqv? b2 *outside-char*) + (string-set! dst j (integer->char (arithmetic-shift b1 2))) + (+ j 1)) + (else + (string-set! dst + j + (integer->char + (bitwise-ior (arithmetic-shift b1 2) + (extract-bit-field 2 4 b2)))) + (cond + ((eqv? b3 *outside-char*) + (+ j 1)) + (else + (string-set! dst + (+ j 1) + (integer->char + (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 4) + (extract-bit-field 4 2 b3)))) + (+ j 2)))))) + +;; General port decoder: work in single blocks at a time to avoid +;; allocating memory (crucial for Scheme implementations that don't +;; allow large strings). +(define (base64-decode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string decode-src-length)) + (dst (make-string decode-dst-length))) + (let lp ((offset 0)) + (let ((src-len (+ offset + (read-string! decode-src-length src in offset)))) + (cond + ((= src-len decode-src-length) + ;; read a full chunk: decode, write and loop + (base64-decode-string! + src 0 decode-src-length dst + (lambda (src-offset dst-len b1 b2 b3) + (cond + ((and (< src-offset src-len) + (eqv? #\= (string-ref src src-offset))) + ;; done + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))) + ((eqv? b1 *outside-char*) + (write-string dst dst-len out) + (lp 0)) + (else + (write-string dst dst-len out) + ;; one to three chars left in buffer + (string-set! src 0 (enc b1)) + (cond + ((eqv? b2 *outside-char*) + (lp 1)) + (else + (string-set! src 1 (enc b2)) + (cond + ((eqv? b3 *outside-char*) + (lp 2)) + (else + (string-set! src 2 (enc b3)) + (lp 3)))))))))) + (else + ;; end of source - just decode and write once + (base64-decode-string! + src 0 src-len dst + (lambda (src-offset dst-len b1 b2 b3) + (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) + (write-string dst dst-len out))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; encoding + +(define (base64-encode-string str) + (let* ((len (string-length str)) + (quot (quotient len 3)) + (rem (- len (* quot 3))) + (res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2)) + (res (make-string res-len))) + (base64-encode-string! str 0 len res) + res)) + +(define (base64-encode-string! str start end res) + (let* ((res-len (string-length res)) + (limit (- end 2))) + (let lp ((i start) (j 0)) + (if (>= i limit) + (case (- end i) + ((1) + (let ((b1 (char->integer (string-ref str i)))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (arithmetic-shift (bitwise-and #b11 b1) 4))) + (string-set! res (+ j 2) #\=) + (string-set! res (+ j 3) #\=))) + ((2) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (arithmetic-shift (extract-bit-field 4 0 b2) + 2))) + (string-set! res (+ j 3) #\=)))) + (let ((b1 (char->integer (string-ref str i))) + (b2 (char->integer (string-ref str (+ i 1)))) + (b3 (char->integer (string-ref str (+ i 2))))) + (string-set! res j (enc (arithmetic-shift b1 -2))) + (string-set! res + (+ j 1) + (enc (bitwise-ior + (arithmetic-shift (bitwise-and #b11 b1) 4) + (extract-bit-field 4 4 b2)))) + (string-set! res + (+ j 2) + (enc (bitwise-ior + (arithmetic-shift (extract-bit-field 4 0 b2) 2) + (extract-bit-field 2 6 b3)))) + (string-set! res (+ j 3) (enc (bitwise-and #b111111 b3))) + (lp (+ i 3) (+ j 4))))))) + +(define (base64-encode . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (out (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (current-output-port)))) + (let ((src (make-string encode-src-length)) + (dst (make-string + (arithmetic-shift (quotient encode-src-length 3) 2)))) + (let lp () + (let ((n (read-string! 2048 src in))) + (base64-encode-string! src 0 n dst) + (write-string dst (* 3 (quotient (+ n 3) 4)) out) + (if (= n 2048) + (lp))))))) + +(define (base64-encode-header encoding str . o) + (define (round4 i) (arithmetic-shift (arithmetic-shift i -2) 2)) + (let ((start-col (if (pair? o) (car o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?B?")) + (prefix-length (+ 2 (string-length prefix))) + (effective-max-col (round4 (- max-col prefix-length))) + (first-max-col (round4 (- effective-max-col start-col))) + (str (base64-encode-string str)) + (len (string-length str))) + (if (<= len first-max-col) + (string-append prefix str "?=") + (string-append + (if (positive? first-max-col) + (string-append + prefix (substring str 0 first-max-col) "?=" nl "\t" prefix) + "") + (string-concatenate (string-chop (substring str first-max-col len) + effective-max-col) + (string-append "?=" nl "\t" prefix)) + "?="))))) + diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c new file mode 100644 index 00000000..d193e3a7 --- /dev/null +++ b/lib/chibi/disasm.c @@ -0,0 +1,99 @@ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" +#include "../../opt/opcode_names.h" + +#define SEXP_DISASM_MAX_DEPTH 8 +#define SEXP_DISASM_PAD_WIDTH 4 + +static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { + sexp tmp; + unsigned char *ip, opcode, i; + + if (sexp_procedurep(bc)) { + bc = sexp_procedure_code(bc); + } else if (sexp_opcodep(bc)) { + sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc)); + return SEXP_VOID; + } else if (! sexp_bytecodep(bc)) { + return sexp_type_exception(ctx, self, SEXP_BYTECODE, bc); + } + if (! sexp_oportp(out)) { + return sexp_type_exception(ctx, self, SEXP_OPORT, out); + } + + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + sexp_write_string(ctx, "-------------- ", out); + if (sexp_truep(sexp_bytecode_name(bc))) { + sexp_write(ctx, sexp_bytecode_name(bc), out); + sexp_write_char(ctx, ' ', out); + } + sexp_printf(ctx, out, "%p\n", bc); + + ip = sexp_bytecode_data(bc); + + loop: + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + 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 SEXP_OP_STACK_REF: + case SEXP_OP_LOCAL_REF: + case SEXP_OP_LOCAL_SET: + case SEXP_OP_CLOSURE_REF: + case SEXP_OP_JUMP: + case SEXP_OP_JUMP_UNLESS: + case SEXP_OP_TYPEP: + case SEXP_OP_FCALL0: + case SEXP_OP_FCALL1: + case SEXP_OP_FCALL2: + case SEXP_OP_FCALL3: + case SEXP_OP_FCALL4: + sexp_printf(ctx, out, "%ld", (long) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case SEXP_OP_SLOT_REF: + case SEXP_OP_SLOT_SET: + case SEXP_OP_MAKE: + ip += sizeof(sexp)*2; + break; + case SEXP_OP_GLOBAL_REF: + case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_TAIL_CALL: + case SEXP_OP_CALL: + case SEXP_OP_PUSH: + tmp = ((sexp*)ip)[0]; + if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF)) + && sexp_pairp(tmp)) + tmp = sexp_car(tmp); + else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp))) + sexp_write_char(ctx, '\'', out); + sexp_write(ctx, tmp, out); + ip += sizeof(sexp); + break; + } + sexp_write_char(ctx, '\n', out); + if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH) + && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) + disasm(ctx, self, tmp, out, depth+1); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +static sexp sexp_disasm (sexp ctx sexp_api_params(self, n), sexp bc, sexp out) { + return disasm(ctx, self, bc, out, 0); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "*current-output-port*"); + return SEXP_VOID; +} diff --git a/lib/chibi/disasm.module b/lib/chibi/disasm.module new file mode 100644 index 00000000..9017a4bc --- /dev/null +++ b/lib/chibi/disasm.module @@ -0,0 +1,5 @@ + +(define-module (chibi disasm) + (export disasm) + (import-immutable (scheme)) + (include-shared "disasm")) diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module new file mode 100644 index 00000000..ecd4af32 --- /dev/null +++ b/lib/chibi/filesystem.module @@ -0,0 +1,27 @@ + +(define-module (chibi filesystem) + (export open-input-file-descriptor open-output-file-descriptor + duplicate-file-descriptor duplicate-file-descriptor-to + close-file-descriptor renumber-file-descriptor + delete-file link-file symbolic-link-file rename-file + directory-files directory-fold create-directory delete-directory + file-status + file-device file-inode + file-mode file-num-links + file-owner file-group + file-represented-device file-size + file-block-size file-num-blocks + file-access-time file-modification-time file-change-time + file-regular? file-directory? file-character? + file-block? file-fifo? file-link? + file-socket? file-exists? + get-file-descriptor-flags set-file-descriptor-flags! + get-file-descriptor-status set-file-descriptor-status! + open/read open/write open/read-write + open/create open/exclusive open/truncate + open/append open/non-block + is-a-tty?) + (import-immutable (scheme)) + (include-shared "filesystem") + (include "filesystem.scm")) + diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm new file mode 100644 index 00000000..aa3fc69f --- /dev/null +++ b/lib/chibi/filesystem.scm @@ -0,0 +1,43 @@ +;; filesystem.scm -- additional filesystem utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (let lp ((res knil)) + (let ((file (readdir dir))) + (if file (lp (kons (dirent-name file) res)) res))))) + +(define (directory-files dir) + (directory-fold dir cons '())) + +(define (renumber-file-descriptor old new) + (and (duplicate-file-descriptor-to old new) + (close-file-descriptor old))) + +(define (file-status file) + (if (string? file) (stat file) (fstat file))) + +(define (file-device x) (stat-dev (if (stat? x) x (file-status x)))) +(define (file-inode x) (stat-ino (if (stat? x) x (file-status x)))) +(define (file-mode x) (stat-mode (if (stat? x) x (file-status x)))) +(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x)))) +(define (file-owner x) (stat-uid (if (stat? x) x (file-status x)))) +(define (file-group x) (stat-gid (if (stat? x) x (file-status x)))) +(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x)))) +(define (file-size x) (stat-size (if (stat? x) x (file-status x)))) +(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x)))) +(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x)))) +(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x)))) +(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x)))) +(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x)))) + +(define (file-regular? x) (S_ISREG (file-mode x))) +(define (file-directory? x) (S_ISDIR (file-mode x))) +(define (file-character? x) (S_ISCHR (file-mode x))) +(define (file-block? x) (S_ISBLK (file-mode x))) +(define (file-fifo? x) (S_ISFIFO (file-mode x))) +(define (file-link? x) (S_ISLNK (file-mode x))) +(define (file-socket? x) (S_ISSOCK (file-mode x))) + +(define (file-exists? x) (and (file-status x) #t)) diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub new file mode 100644 index 00000000..2aa66e50 --- /dev/null +++ b/lib/chibi/filesystem.stub @@ -0,0 +1,118 @@ + +(c-system-include "sys/types.h") +(c-system-include "unistd.h") +(c-system-include "dirent.h") +(c-system-include "fcntl.h") + +(define-c-type DIR + finalizer: closedir) + +(define-c-struct dirent + (string d_name dirent-name)) + +(define-c-struct stat + predicate: stat? + (dev_t st_dev stat-dev) + (ino_t st_ino stat-ino) + (mode_t st_mode stat-mode) + (nlink_t st_nlink stat-nlinks) + (uid_t st_uid stat-uid) + (gid_t st_gid stat-gid) + (dev_t st_rdev stat-rdev) + (off_t st_size stat-size) + (blksize_t st_blksize stat-blksize) + (blkcnt_t st_blocks stat-blocks) + (time_t st_atime stat-atime) + (time_t st_mtime stat-mtime) + (time_t st_ctime stat-ctime)) + +(define-c boolean S_ISREG (mode_t)) +(define-c boolean S_ISDIR (mode_t)) +(define-c boolean S_ISCHR (mode_t)) +(define-c boolean S_ISBLK (mode_t)) +(define-c boolean S_ISFIFO (mode_t)) +(define-c boolean S_ISLNK (mode_t)) +(define-c boolean S_ISSOCK (mode_t)) + +;;(define-c-const int ("S_IFMT")) +(define-c-const int (file/socket "S_IFSOCK")) +(define-c-const int (file/link "S_IFLNK")) +(define-c-const int (file/regular "S_IFREG")) +(define-c-const int (file/block "S_IFBLK")) +(define-c-const int (file/directory "S_IFDIR")) +(define-c-const int (file/character "S_IFCHR")) +(define-c-const int (file/fifo "S_IFIFO")) +(define-c-const int (file/suid "S_ISUID")) +(define-c-const int (file/sgid "S_ISGID")) +(define-c-const int (file/sticky "S_ISVTX")) +;;(define-c-const int ("S_IRWXU")) +(define-c-const int (perm/user-read "S_IRUSR")) +(define-c-const int (perm/user-write "S_IWUSR")) +(define-c-const int (perm/user-execute "S_IXUSR")) +;;(define-c-const int ("S_IRWXG")) +(define-c-const int (perm/group-read "S_IRGRP")) +(define-c-const int (perm/group-write "S_IWGRP")) +(define-c-const int (perm/group-execute "S_IXGRP")) +;;(define-c-const int ("S_IRWXO")) +(define-c-const int (perm/others-read "S_IROTH")) +(define-c-const int (perm/others-write "S_IWOTH")) +(define-c-const int (perm/others-execute "S_IXOTH")) + +(define-c errno stat (string (result stat))) +(define-c errno fstat (int (result stat))) +(define-c errno (file-link-status "lstat") (string (result stat))) + +(define-c input-port (open-input-file-descriptor "fdopen") + (int (value "r" string))) +(define-c output-port (open-output-file-descriptor "fdopen") + (int (value "w" string))) + +(define-c errno (delete-file "unlink") (string)) +(define-c errno (link-file "link") (string string)) +(define-c errno (symbolic-link-file "symlink") (string string)) +(define-c errno (rename-file "rename") (string string)) + +(define-c non-null-string (current-directory "getcwd") + ((result (array char (auto-expand arg1))) (value 256 int))) + +(define-c errno (create-directory "mkdir") (string int)) +(define-c errno (delete-directory "rmdir") (string)) + +(define-c (free DIR) opendir (string)) +(define-c dirent readdir ((link (pointer DIR)))) + +(define-c int (duplicate-file-descriptor "dup") (int)) +(define-c errno (duplicate-file-descriptor-to "dup2") (int int)) +(define-c errno (close-file-descriptor "close") (int)) + +(define-c errno (open-pipe "pipe") ((result (array int 2)))) +(define-c errno (make-fifo "mkfifo") (string (default #o644 int))) + +(define-c int (get-file-descriptor-flags "fcntl") + (int (value F_GETFD int))) +(define-c errno (set-file-descriptor-flags! "fcntl") + (int (value F_SETFD int) long)) + +(define-c int (get-file-descriptor-status "fcntl") + (int (value F_GETFL int))) +(define-c errno (set-file-descriptor-status! "fcntl") + (int (value F_SETFL int) long)) + +;; (define-c int (get-file-descriptor-lock "fcntl") +;; (int (value F_GETLK int) flock)) +;; (define-c errno (set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLK int) flock)) +;; (define-c errno (try-set-file-descriptor-lock! "fcntl") +;; (int (value F_SETLKW int) flock)) + +(define-c-const int (open/read "O_RDONLY")) +(define-c-const int (open/write "O_WRONLY")) +(define-c-const int (open/read-write "O_RDWR")) +(define-c-const int (open/create "O_CREAT")) +(define-c-const int (open/exclusive "O_EXCL")) +(define-c-const int (open/truncate "O_TRUNC")) +(define-c-const int (open/append "O_APPEND")) +(define-c-const int (open/non-block "O_NONBLOCK")) + +(define-c boolean (is-a-tty? "isatty") (port-or-fd)) + diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c new file mode 100644 index 00000000..976b5b27 --- /dev/null +++ b/lib/chibi/heap-stats.c @@ -0,0 +1,129 @@ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define SEXP_HEAP_VECTOR_DEPTH 1 + +#if SEXP_64_BIT +#define sexp_heap_align(n) sexp_align(n, 5) +#else +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); + +#if SEXP_USE_GLOBAL_HEAP +#endif + +static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { + int i; + if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x) + || sexp_flonump(x) || sexp_bignump(x)) { + sexp_write(ctx, x, out); + } else if (depth <= 0) { + goto print_name; + } else if (sexp_synclop(x)) { + sexp_write_string(ctx, "#", out); + } else if (sexp_pairp(x)) { + sexp_write_char(ctx, '(', out); + sexp_print_simple(ctx, sexp_car(x), out, depth-1); + sexp_write_string(ctx, " . ", out); + sexp_print_simple(ctx, sexp_cdr(x), out, depth-1); + sexp_write_char(ctx, ')', out); + } else if (sexp_vectorp(x)) { + sexp_write_string(ctx, "#(", out); + for (i=0; i0) + sexp_write_char(ctx, ' ', out); + sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); + } + if (i", out); + } +} + +static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { + size_t freed; + sexp_uint_t stats[256], hi_type=0, i; + sexp_heap h = sexp_context_heap(ctx); + sexp p, out=SEXP_FALSE; + sexp_free_list q, r; + char *end; + sexp_gc_var3(res, tmp, name); + + if (printp) + out = sexp_env_global_ref(sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), + SEXP_FALSE); + + /* run gc once to remove unused variables */ + sexp_gc(ctx, &freed); + + /* initialize stats */ + for (i=0; i<256; i++) stats[i]=0; + + /* loop over each heap chunk */ + for ( ; h; h=h->next) { + 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) { /* this is a free block, skip */ + p = (sexp) (((char*)p) + r->size); + continue; + } + /* otherwise maybe print, then increment the stat and continue */ + if (sexp_oportp(out)) { + sexp_print_simple(ctx, p, out, depth); + sexp_write_char(ctx, '\n', out); + } + stats[sexp_pointer_tag(p)]++; + if (sexp_pointer_tag(p) > hi_type) + hi_type = sexp_pointer_tag(p); + p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p))); + } + } + + /* build and return results */ + sexp_gc_preserve3(ctx, res, tmp, name); + res = SEXP_NULL; + for (i=hi_type; i>0; i--) + if (stats[i]) { + name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i), -1); + tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); + res = sexp_cons(ctx, tmp, res); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_heap_stats (sexp ctx sexp_api_params(self, n)) { + return sexp_heap_walk(ctx, 0, 0); +} + +static sexp sexp_heap_dump (sexp ctx sexp_api_params(self, n), sexp depth) { + if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0)) + return sexp_xtype_exception(ctx, self, "bad heap-dump depth", depth); + return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats); + sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE); + return SEXP_VOID; +} + diff --git a/lib/chibi/heap-stats.module b/lib/chibi/heap-stats.module new file mode 100644 index 00000000..c1599c35 --- /dev/null +++ b/lib/chibi/heap-stats.module @@ -0,0 +1,6 @@ + +(define-module (chibi heap-stats) + (export heap-stats heap-dump) + (import-immutable (scheme)) + (include-shared "heap-stats")) + diff --git a/lib/chibi/io.module b/lib/chibi/io.module new file mode 100644 index 00000000..ec765c04 --- /dev/null +++ b/lib/chibi/io.module @@ -0,0 +1,13 @@ + +(define-module (chibi io) + (export read-string read-string! write-string read-line write-line + port-fold port-fold-right port-map + port->list port->string-list port->sexp-list port->string + file-position set-file-position! seek/set seek/cur seek/end + make-custom-input-port make-custom-output-port + make-null-output-port make-broadcast-port make-concatenated-port + make-generated-input-port make-filtered-output-port + make-filtered-input-port) + (import-immutable (scheme)) + (include-shared "io/io") + (include "io/io.scm")) diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm new file mode 100644 index 00000000..2d4da555 --- /dev/null +++ b/lib/chibi/io/io.scm @@ -0,0 +1,170 @@ +;; io.scm -- various input/output utilities +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define eof + (call-with-input-string " " + (lambda (in) (read-char in) (read-char in)))) + +(define (string-copy! dst start src from to) + (do ((i from (+ i 1)) (j start (+ j 1))) + ((>= i to)) + (string-set! dst j (string-ref src i)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; reading and writing + +(define (write-line str . o) + (let ((out (if (pair? o) (car o) (current-output-port)))) + (display str out) + (newline out))) + +(define (read-line . o) + (let ((in (if (pair? o) (car o) (current-input-port))) + (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192))) + (let ((res (%read-line n in))) + (if (not res) + eof + (let ((len (string-length res))) + (if (and (> len 0) (eqv? #\newline (string-ref res (- len 1)))) + (if (and (> len 1) (eqv? #\return (string-ref res (- len 2)))) + (substring res 0 (- len 2)) + (substring res 0 (- len 1))) + res)))))) + +(define (read-string n . o) + (let ((in (if (pair? o) (car o) (current-input-port)))) + (let ((res (%read-string n in))) + (if (if (pair? res) (= 0 (car res)) #t) + eof + (cadr res))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; higher order port operations + +(define (port-fold kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp ((acc knil)) + (let ((x (read in))) + (if (eof-object? x) acc (lp (kons x acc))))))) + +(define (port-fold-right kons knil . o) + (let ((read (if (pair? o) (car o) read)) + (in (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (current-input-port)))) + (let lp () + (let ((x (read in))) + (if (eof-object? x) knil (kons x (lp))))))) + +(define (port-map fn . o) + (reverse (apply port-fold (lambda (x ls) (cons (fn x) ls)) '() o))) + +(define (port->list read in) + (port-map (lambda (x) x) read in)) + +(define (port->sexp-list in) + (port->list read in)) + +(define (port->string-list in) + (port->list read-line in)) + +(define (port->string in) + (string-concatenate (port->list (lambda (in) (read-string 1024 in)) in))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; custom port utilities + +(define (make-custom-input-port read . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-input-port read seek close))) + +(define (make-custom-output-port write . o) + (let ((seek (and (pair? o) (car o))) + (close (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (%make-custom-output-port write seek close))) + +(define (make-null-output-port) + (make-custom-output-port (lambda (str n) 0))) + +(define (make-broadcast-port . ports) + (make-custom-output-port + (lambda (str n) + (for-each (lambda (p) (write-string str n p)) ports) + n))) + +(define (make-filtered-output-port filter out) + (make-custom-output-port + (lambda (str n) + (let* ((len (string-length str)) + (s1 (if (= n len) str (substring str 0 n))) + (s2 (filter s1))) + (if (string? s2) + (write-string s2 (string-length s2) out)))))) + +(define (make-concatenated-port . ports) + (make-custom-input-port + (lambda (str n) + (if (null? ports) + 0 + (let lp ((i (read-string! str n (car ports)))) + (cond + ((>= i n) + i) + (else + (set! ports (cdr ports)) + (cond + ((null? ports) + i) + (else + (let* ((s (read-string (- n i) (car ports))) + (len (if (string? s) (string-length s) 0))) + (if (and (string? str) (> len 0)) + (string-copy! str i s 0 len)) + (lp (+ i len)))))))))))) + +(define (make-generated-input-port generator) + (let ((buf "") + (len 0) + (offset 0)) + (make-custom-input-port + (lambda (str n) + (cond + ((>= (- len offset) n) + (string-copy! str 0 buf offset (+ offset n)) + (set! offset (+ offset n)) + n) + (else + (string-copy! str 0 buf offset len) + (let lp ((i (- len offset))) + (set! buf (generator)) + (cond + ((not (string? buf)) + (set! buf "") + (set! len 0) + (set! offset 0) + (- n i)) + (else + (set! len (string-length buf)) + (set! offset 0) + (cond + ((>= (- len offset) (- n i)) + (string-copy! str i buf offset (+ offset (- n i))) + (set! offset (+ offset (- n i))) + n) + (else + (string-copy! str i buf offset len) + (lp (+ i (- len offset)))))))))))))) + +(define (make-filtered-input-port filter in) + (make-generated-input-port + (lambda () + (let ((res (read-string 1024 in))) + (if (string? res) (filter res) res))))) diff --git a/lib/chibi/io/io.stub b/lib/chibi/io/io.stub new file mode 100644 index 00000000..07450dc0 --- /dev/null +++ b/lib/chibi/io/io.stub @@ -0,0 +1,27 @@ + +(define-c non-null-string (%read-line "fgets") + ((result (array char arg1)) int (default (current-input-port) input-port))) + +(define-c size_t (%read-string "fread") + ((result (array char arg2)) (value 1 size_t) size_t (default (current-input-port) input-port))) + +(define-c size_t (read-string! "fread") + (string (value 1 size_t) size_t (default (current-input-port) input-port))) + +(define-c size_t (write-string "fwrite") + (string (value 1 size_t) size_t (default (current-output-port) output-port))) + +(define-c-const int (seek/set "SEEK_SET")) +(define-c-const int (seek/cur "SEEK_CUR")) +(define-c-const int (seek/end "SEEK_END")) + +(define-c long (file-position "ftell") (port)) +(define-c long (set-file-position! "fseek") (port long int)) + +(c-include "port.c") + +(define-c sexp (%make-custom-input-port "sexp_make_custom_input_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) + +(define-c sexp (%make-custom-output-port "sexp_make_custom_output_port") + ((value ctx sexp) (value self sexp) sexp sexp sexp)) diff --git a/lib/chibi/io/port.c b/lib/chibi/io/port.c new file mode 100644 index 00000000..947f3400 --- /dev/null +++ b/lib/chibi/io/port.c @@ -0,0 +1,196 @@ + +#include +#include + +#define SEXP_PORT_BUFFER_SIZE 1024 +#define SEXP_LAST_CONTEXT_CHECK_LIMIT 256 + +#define sexp_cookie_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO) +#define sexp_cookie_buffer(vec) sexp_vector_ref((sexp)vec, SEXP_ONE) +#define sexp_cookie_read(vec) sexp_vector_ref((sexp)vec, SEXP_TWO) +#define sexp_cookie_write(vec) sexp_vector_ref((sexp)vec, SEXP_THREE) +#define sexp_cookie_seek(vec) sexp_vector_ref((sexp)vec, SEXP_FOUR) +#define sexp_cookie_close(vec) sexp_vector_ref((sexp)vec, SEXP_FIVE) + +#if ! SEXP_USE_BOEHM +static int sexp_in_heap_p (sexp_heap h, sexp p) { + for ( ; h; h = h->next) + if (((sexp)h < p) && (p < (sexp)((char*)h + h->size))) + return 1; + return 0; +} +#endif + +static sexp sexp_last_context (sexp ctx, sexp *cstack) { + sexp res=SEXP_FALSE, p; +#if ! SEXP_USE_BOEHM + sexp_sint_t i; + sexp_heap h = sexp_context_heap(ctx); + for (i=0; i sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_read(vec), args); + sexp_gc_release2(ctx); + if (sexp_fixnump(res)) { + memcpy(buffer, sexp_string_data(sexp_cookie_buffer(vec)), sexp_unbox_fixnum(res)); + return sexp_unbox_fixnum(res); + } else { + return -1; + } +} + +#if SEXP_BSD +static int sexp_cookie_writer (void *cookie, const char *buffer, int size) +#else +static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size) +#endif +{ + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_write(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + if (size > sexp_string_length(sexp_cookie_buffer(vec))) + sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID); + memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size); + args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size)); + res = sexp_apply(ctx, sexp_cookie_write(vec), args); + sexp_gc_release2(ctx); + return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1); +} + +#if ! SEXP_BSD +static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1; + sexp_gc_var2(ctx2, args); + ctx = sexp_cookie_ctx(vec); + ctx2 = sexp_last_context(ctx, (sexp*)&cookie); + sexp_gc_preserve2(ctx, ctx2, args); + args = sexp_make_integer(ctx, *position); + args = sexp_list2(ctx, args, sexp_make_fixnum(whence)); + res = sexp_apply(ctx, sexp_cookie_seek(vec), args); + if (sexp_fixnump(res)) + *position = sexp_unbox_fixnum(res); + sexp_gc_release2(ctx); + return sexp_fixnump(res); +} +#endif + +static int sexp_cookie_cleaner (void *cookie) { + sexp vec = (sexp)cookie, ctx, res; + if (! sexp_procedurep(sexp_cookie_close(vec))) return 0; + ctx = sexp_cookie_ctx(vec); + res = sexp_apply(ctx, sexp_cookie_close(vec), SEXP_NULL); + return (sexp_exceptionp(res) ? -1 : sexp_truep(res)); +} + +#if ! SEXP_BSD + +static cookie_io_functions_t sexp_cookie = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = (cookie_seek_function_t*)sexp_cookie_seeker, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +static cookie_io_functions_t sexp_cookie_no_seek = { + .read = (cookie_read_function_t*)sexp_cookie_reader, + .write = (cookie_write_function_t*)sexp_cookie_writer, + .seek = NULL, + .close = (cookie_close_function_t*)sexp_cookie_cleaner, +}; + +#endif + +#if SEXP_USE_STRING_STREAMS + +static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode, + sexp read, sexp write, + sexp seek, sexp close) { + FILE *in; + sexp res; + sexp_gc_var1(vec); + if (sexp_truep(read) && ! sexp_procedurep(read)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read); + if (sexp_truep(write) && ! sexp_procedurep(write)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write); + if (sexp_truep(seek) && ! sexp_procedurep(seek)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek); + if (sexp_truep(close) && ! sexp_procedurep(close)) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close); + sexp_gc_preserve1(ctx, vec); + vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID); + sexp_cookie_ctx(vec) = ctx; + sexp_cookie_buffer(vec) + = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID); + sexp_cookie_read(vec) = read; + sexp_cookie_write(vec) = write; + sexp_cookie_seek(vec) = seek; + sexp_cookie_close(vec) = close; +#if SEXP_BSD + in = funopen(vec, + (sexp_procedurep(read) ? sexp_cookie_reader : NULL), + (sexp_procedurep(write) ? sexp_cookie_writer : NULL), + NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */ + (sexp_procedurep(close) ? sexp_cookie_cleaner : NULL)); +#else + in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek)); +#endif + if (! in) { + res = sexp_user_exception(ctx, self, "couldn't make custom port", read); + } else { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = vec; /* for gc preserving */ + } + sexp_gc_release1(ctx); + return res; +} + +#else + +static sexp sexp_make_custom_port (sexp ctx, sexp self, + char *mode, sexp read, sexp write, + sexp seek, sexp close) { + return sexp_user_exception(ctx, self, "custom ports not supported in this configuration", SEXP_NULL); +} + +#endif + +static sexp sexp_make_custom_input_port (sexp ctx, sexp self, + sexp read, sexp seek, sexp close) { + return sexp_make_custom_port(ctx, self, "r", read, SEXP_FALSE, seek, close); +} + +static sexp sexp_make_custom_output_port (sexp ctx, sexp self, + sexp write, sexp seek, sexp close) { + sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close); + sexp_pointer_tag(res) = SEXP_OPORT; + return res; +} diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module new file mode 100644 index 00000000..5b76daf8 --- /dev/null +++ b/lib/chibi/loop.module @@ -0,0 +1,9 @@ + +(define-module (chibi loop) + (export loop in-list in-lists in-port in-file up-from down-from + listing listing-reverse appending appending-reverse + summing multiplying in-string in-string-reverse + in-vector in-vector-reverse) + (import-immutable (scheme)) + (include "loop/loop.scm")) + diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm new file mode 100644 index 00000000..09e12856 --- /dev/null +++ b/lib/chibi/loop/loop.scm @@ -0,0 +1,365 @@ +;;;; loop.scm - the chibi loop (aka foof-loop) +;; +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; The loop API is compatible with Taylor Campbell's foof-loop, but +;; the iterator API is different and subject to change. All loop +;; variables may be implicitly destructured with MATCH semantics. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (assoc-pred equal elt ls) + (and (pair? ls) + (if (equal elt (car (car ls))) + (car ls) + (assoc-pred equal elt (cdr ls))))) + +(define-syntax let-keyword-form + (syntax-rules () + ((let-keyword-form + ((labeled-arg-macro-name (positional-name . params))) + . body) + (let-syntax + ((labeled-arg-macro-name + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (named '()) (posns '())) + (cond + ((pair? ls) + (if (and (list? (car ls)) (compare (caar ls) (rename '=>))) + (lp (cdr ls) (cons (cdar ls) named) posns) + (lp (cdr ls) named (cons (car ls) posns)))) + (else + (let lp ((ls (syntax-quote params)) + (posns (reverse posns)) + (args '())) + (cond + ((null? ls) + (if (pair? posns) + (error "let-keyword-form: too many args" expr) + (cons (syntax-quote positional-name) (reverse args)))) + ((assoc-pred compare (caar ls) named) + => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args)))) + ((pair? posns) + (lp (cdr ls) (cdr posns) (cons (car posns) args))) + (else + (lp (cdr ls) posns (cons (cadar ls) args)))))))))))) + . body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax loop + (syntax-rules () + ;; unnamed, implicit recursion + ((loop (vars ...) body ...) + (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop))) + ;; named, explicit recursion + ((loop name (vars ...) body ...) + (%loop name () () () () () (vars ...) body ...)))) + +;; Main LOOP macro. Separate the variables from the iterator and +;; parameters, then walk through each parameter expanding the +;; bindings, and build the final form. + +(define-syntax %loop + (syntax-rules (=> for with let while until) + ;; automatic iteration + ((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body) + (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body) + (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body)) + ;; do equivalents, with optional guards + ((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body) + (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init step) rest ...) . body) + (%loop name l (vars ... (var init step)) c r f (rest ...) . body)) + ((_ name l (vars ...) c r f ((with var init) rest ...) . body) + (%loop name l (vars ... (var init var)) c r f (rest ...) . body)) + ;; user-specified terminators + ((_ name l vars (checks ...) r f ((until expr) rest ...) . body) + (%loop name l vars (checks ... expr) r f (rest ...) . body)) + ((_ name l vars (checks ...) r f ((while expr) rest ...) . body) + (%loop name l vars (checks ... (not expr)) r f (rest ...) . body)) + ;; specify a default done? + ((_ name l v c r f ()) + (%loop name l v c r f () (#f #f))) + ((_ name l v c r f () () . body) + (%loop name l v c r f () (#f #f) . body)) + ;; final expansion + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => result + . body) + (let* (lets ...) + (letrec ((tmp (lambda (var ...) + (if (or checks ...) + (let-keyword-form ((name (tmp (var step) ...))) + (let (finals ...) result)) + (let (refs ...) + (let-keyword-form ((name (tmp (var step) ...))) + (if #f #f) + . body)))))) + (tmp init ...)))) + ;; unspecified return value case + ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + . body) + (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) () + => (if #f #f) . body)) + )) + +(define-syntax %loop-next + (syntax-rules () + ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...) + name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...) + . rest) + (%loop name (lets ... new-lets ...) (vars ... new-vars ...) + (checks ... new-checks ...) (refs ... new-refs ...) + (finals ... new-finals ...) + . rest)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Iterators + +;; Each gets passed two lists, those items left of the <- and those to +;; the right, followed by a NEXT and REST continuation. + +;; Should finish with +;; +;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...) +;; (loop-vars ...) (final-vars ...) . rest) +;; +;; OUTER-VARS: bound once outside the loop in a LET* +;; CURSOR-VARS: DO-style bindings of the form (name init update) +;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t +;; LOOP-VARS: inner variables, updated in parallel after the cursors +;; FINAL-VARS: final variables, bound only in the => result + +(define-syntax in-list ; called just "IN" in ITER + (syntax-rules () + ((in-list ((var) source) next . rest) + (in-list ((var cursor) source) next . rest)) + ((in-list ((var cursor) source) next . rest) + (in-list ((var cursor succ) source) next . rest)) + ((in-list ((var cursor succ) (source)) next . rest) + (next () ; outer let bindings + ((cursor source succ)) ; iterator, init, step + ((not (pair? cursor))) ; finish tests for iterator vars + ;; step variables and values + ((var (car cursor)) + (succ (cdr cursor))) + () ; final result bindings + . rest)) + ((in-list ((var cursor succ) (source step)) next . rest) + (next () + ((cursor source succ)) + ((not (pair? cursor))) + ((var (car cursor)) + (succ (step cursor))) + () + . rest)))) + +;; Iterator from Taylor R. Campbell. If you know the number of lists +;; ahead of time it's much more efficient to iterate over each one +;; separately. +(define-syntax in-lists + (syntax-rules () + ((in-lists ((elts) lol) next . rest) + (in-lists ((elts pairs) lol) next . rest)) + ((in-lists ((elts pairs) lol) next . rest) + (in-lists ((elts pairs succ) lol) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol)) next . rest) + (in-lists ((elts pairs succ) (lol cdr)) next . rest)) + ((in-lists ((elts pairs succ) (lol step)) next . rest) + (in-lists ((elts pairs succ) (lol step null?)) next . rest)) + ((in-lists ((elts pairs succ) (lol step done?)) next . rest) + (next () + ((pairs lol succ)) + ((let lp ((ls pairs)) ; an in-lined ANY + (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls)))))) + ((elts (map car pairs)) + (succ (map step pairs))) + () + . rest)) + )) + +(define-syntax define-in-indexed + (syntax-rules () + ((define-in-indexed in-type in-type-reverse length ref) + (begin + (define-syntax in-type + (syntax-rules () + ((in-type ls next . rest) + (%in-idx >= + 0 (length tmp) ref tmp ls next . rest)))) + (define-syntax in-type-reverse + (syntax-rules () + ((in-type-reverse ls next . rest) + (%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest)))) + )))) + +(define-in-indexed in-string in-string-reverse string-length string-ref) +(define-in-indexed in-vector in-vector-reverse vector-length vector-ref) + +;; helper for the above string and vector iterators +(define-syntax %in-idx + (syntax-rules () + ;; cmp inc start end ref + ((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest) + (%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest) + (%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest)) + ((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest) + (next ((tmp-vec vec) (end to)) + ((index from (+ index step))) + ((ge index end)) + ((var (r tmp-vec index))) + () + . rest)) + )) + +(define-syntax in-port + (syntax-rules () + ((in-port ((var) source) next . rest) + (in-port ((var p) source) next . rest)) + ((in-port ((var p) ()) next . rest) + (in-port ((var p) ((current-input-port))) next . rest)) + ((in-port ((var p) (port)) next . rest) + (in-port ((var p) (port read-char)) next . rest)) + ((in-port ((var p) (port read-char)) next . rest) + (in-port ((var p) (port read-char eof-object?)) next . rest)) + ((in-port ((var p) (port reader eof?)) next . rest) + (next ((p port) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + () + . rest)))) + +(define-syntax in-file + (syntax-rules () + ((in-file ((var) source) next . rest) + (in-file ((var p) source) next . rest)) + ((in-file ((var p) (file)) next . rest) + (in-file ((var p) (file read-char)) next . rest)) + ((in-file ((var p) (file reader)) next . rest) + (in-file ((var p) (file reader eof-object?)) next . rest)) + ((in-file ((var p) (file reader eof?)) next . rest) + (next ((p (open-input-file file)) (r reader) (e? eof?)) + ((var (r p) (r p))) + ((e? var)) + () + ((dummy (close-input-port p))) + . rest)))) + +(define-syntax up-from + (syntax-rules (to by) + ((up-from (() . args) next . rest) + (up-from ((var) . args) next . rest)) + ((up-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var s (+ var e))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var s (+ var 1))) + ((>= var l)) + () + () + . rest)) + ((up-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var s (+ var e))) () () () . rest)) + ((up-from ((var) (start)) next . rest) + (next ((s start)) ((var s (+ var 1))) () () () . rest)) + )) + +(define-syntax down-from + (syntax-rules (to by) + ((down-from (() . args) next . rest) + (down-from ((var) . args) next . rest)) + ((down-from ((var) (start (to limit) (by step))) next . rest) + (next ((s start) (l limit) (e step)) + ((var (- s e) (- var e))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (to limit))) next . rest) + (next ((s start) (l limit)) + ((var (- s 1) (- var 1))) + ((< var l)) + () + () + . rest)) + ((down-from ((var) (start (by step))) next . rest) + (next ((s start) (e step)) ((var (- s e) (- var e))) () () () + . rest)) + ((down-from ((var) (start)) next . rest) + (next ((s start)) ((var (- s 1) (- var 1))) () () () + . rest)) + )) + +(define-syntax accumulating + (syntax-rules (initial if) + ((accumulating (kons final init) ((var) . x) next . rest) + (accumulating (kons final init) ((var cursor) . x) next . rest)) + ((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest) + (accumulating (kons final i) ((var cursor) x) n . rest)) + ((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (if check (tmp-kons expr cursor) cursor))) + () + () + ((var (final cursor))) + . rest)) + ((accumulating (kons final init) ((var cursor) (expr)) n . rest) + (n ((tmp-kons kons)) + ((cursor '() (tmp-kons expr cursor))) + () + () + ((var (final cursor))) + . rest)))) + +(define-syntax listing + (syntax-rules () + ((listing args next . rest) + (accumulating (cons reverse '()) args next . rest)))) + +(define-syntax listing-reverse + (syntax-rules () + ((listing-reverse args next . rest) + (accumulating (cons (lambda (x) x) '()) args next . rest)))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define-syntax appending + (syntax-rules () + ((appending args next . rest) + (accumulating (append-reverse reverse '()) args next . rest)))) + +(define-syntax appending-reverse + (syntax-rules () + ((appending-reverse args next . rest) + (accumulating (append-reverse (lambda (x) x) '()) args next . rest)))) + +(define-syntax summing + (syntax-rules () + ((summing args next . rest) + (accumulating (+ (lambda (x) x) 0) args next . rest)))) + +(define-syntax multiplying + (syntax-rules () + ((multiplying args next . rest) + (accumulating (* (lambda (x) x) 1) args next . rest)))) diff --git a/lib/chibi/match.module b/lib/chibi/match.module new file mode 100644 index 00000000..1366176a --- /dev/null +++ b/lib/chibi/match.module @@ -0,0 +1,6 @@ + +(define-module (chibi match) + (export match match-lambda match-lambda* match-let match-letrec match-let*) + (import-immutable (scheme)) + (include "match/match.scm")) + diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm new file mode 100644 index 00000000..f4eb173d --- /dev/null +++ b/lib/chibi/match/match.scm @@ -0,0 +1,683 @@ +;;;; match.scm -- portable hygienic pattern matcher +;; +;; This code is written by Alex Shinn and placed in the +;; Public Domain. All warranties are disclaimed. + +;; This is a full superset of the popular MATCH package by Andrew +;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks +;; in R6RS SYNTAX-RULES), and thus preserving hygiene. + +;; This is a simple generative pattern matcher - each pattern is +;; expanded into the required tests, calling a failure continuation if +;; the tests fail. This makes the logic easy to follow and extend, +;; but produces sub-optimal code in cases where you have many similar +;; clauses due to repeating the same tests. Nonetheless a smart +;; compiler should be able to remove the redundant tests. For +;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance +;; hit. + +;; The original version was written on 2006/11/29 and described in the +;; following Usenet post: +;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd +;; and is still available at +;; http://synthcode.com/scheme/match-simple.scm +;; It's just 80 lines for the core MATCH, and an extra 40 lines for +;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar. +;; +;; A variant of this file which uses COND-EXPAND in a few places for +;; performance can be found at +;; http://synthcode.com/scheme/match-cond-expand.scm +;; +;; 2009/11/25 - adding `***' tree search patterns +;; 2008/03/20 - fixing bug where (a ...) matched non-lists +;; 2008/03/15 - removing redundant check in vector patterns +;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) +;; 2007/09/04 - fixing quasiquote patterns +;; 2007/07/21 - allowing ellipse patterns in non-final list positions +;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse +;; (thanks to Taylor Campbell) +;; 2007/04/08 - clean up, commenting +;; 2006/12/24 - bugfixes +;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; force compile-time syntax errors with useful messages + +(define-syntax match-syntax-error + (syntax-rules () + ((_) (match-syntax-error "invalid match-syntax-error usage")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The basic interface. MATCH just performs some basic syntax +;; validation, binds the match expression to a temporary variable `v', +;; and passes it on to MATCH-NEXT. It's a constant throughout the +;; code below that the binding `v' is a direct variable reference, not +;; an expression. + +(define-syntax match + (syntax-rules () + ((match) + (match-syntax-error "missing match expression")) + ((match atom) + (match-syntax-error "no match clauses")) + ((match (app ...) (pat . body) ...) + (let ((v (app ...))) + (match-next v ((app ...) (set! (app ...))) (pat . body) ...))) + ((match #(vec ...) (pat . body) ...) + (let ((v #(vec ...))) + (match-next v (v (set! v)) (pat . body) ...))) + ((match atom (pat . body) ...) + (match-next atom (atom (set! atom)) (pat . body) ...)) + )) + +;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure +;; thunk, which is expanded by recursing MATCH-NEXT on the remaining +;; clauses. `g+s' is a list of two elements, the get! and set! +;; expressions respectively. + +(define-syntax match-next + (syntax-rules (=>) + ;; no more clauses, the match failed + ((match-next v g+s) + (error 'match "no matching pattern")) + ;; named failure continuation + ((match-next v g+s (pat (=> failure) . body) . rest) + (let ((failure (lambda () (match-next v g+s . rest)))) + ;; match-one analyzes the pattern for us + (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ()))) + ;; anonymous failure continuation, give it a dummy name + ((match-next v g+s (pat . body) . rest) + (match-next v g+s (pat (=> failure) . body) . rest)))) + +;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to +;; MATCH-TWO. + +(define-syntax match-one + (syntax-rules () + ;; If it's a list of two or more values, check to see if the + ;; second one is an ellipse and handle accordingly, otherwise go + ;; to MATCH-TWO. + ((match-one v (p q . r) g+s sk fk i) + (match-check-ellipse + q + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()) + (match-two v (p q . r) g+s sk fk i))) + ;; Go directly to MATCH-TWO. + ((match-one . x) + (match-two . x)))) + +;; This is the guts of the pattern matcher. We are passed a lot of +;; information in the form: +;; +;; (match-two var pattern getter setter success-k fail-k (ids ...)) +;; +;; usually abbreviated +;; +;; (match-two v p g+s sk fk i) +;; +;; where VAR is the symbol name of the current variable we are +;; matching, PATTERN is the current pattern, getter and setter are the +;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding +;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure +;; continuation (which is just a thunk call and is thus safe to expand +;; multiple times) and IDS are the list of identifiers bound in the +;; pattern so far. + +(define-syntax match-two + (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!) + ((match-two v () g+s (sk ...) fk i) + (if (null? v) (sk ... i) fk)) + ((match-two v (quote p) g+s (sk ...) fk i) + (if (equal? v 'p) (sk ... i) fk)) + ((match-two v (quasiquote p) . x) + (match-quasiquote v p . x)) + ((match-two v (and) g+s (sk ...) fk i) (sk ... i)) + ((match-two v (and p q ...) g+s sk fk i) + (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i)) + ((match-two v (or) g+s sk fk i) fk) + ((match-two v (or p) . x) + (match-one v p . x)) + ((match-two v (or p ...) g+s sk fk i) + (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ())) + ((match-two v (not p) g+s (sk ...) fk i) + (match-one v p g+s (match-drop-ids fk) (sk ... i) i)) + ((match-two v (get! getter) (g s) (sk ...) fk i) + (let ((getter (lambda () g))) (sk ... i))) + ((match-two v (set! setter) (g (s ...)) (sk ...) fk i) + (let ((setter (lambda (x) (s ... x)))) (sk ... i))) + ((match-two v (? pred . p) g+s sk fk i) + (if (pred v) (match-one v (and . p) g+s sk fk i) fk)) + ((match-two v (= proc p) . x) + (let ((w (proc v))) (match-one w p . x))) + ((match-two v (p ___ . r) g+s sk fk i) + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())) + ((match-two v (p) g+s sk fk i) + (if (and (pair? v) (null? (cdr v))) + (let ((w (car v))) + (match-one w p ((car v) (set-car! v)) sk fk i)) + fk)) + ((match-two v (p *** q) g+s sk fk i) + (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) + ((match-two v (p *** . q) g+s sk fk i) + (match-syntax-error "invalid use of ***" (p *** . q))) + ((match-two v ($ rec p ...) g+s sk fk i) + (if (is-a? v rec) + (match-record-refs v rec 0 (p ...) g+s sk fk i) + fk)) + ((match-two v (p . q) g+s sk fk i) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-one w p ((car v) (set-car! v)) + (match-one x q ((cdr v) (set-cdr! v)) sk fk) + fk + i)) + fk)) + ((match-two v #(p ...) g+s . x) + (match-vector v 0 () (p ...) . x)) + ((match-two v _ g+s (sk ...) fk i) (sk ... i)) + ;; Not a pair or vector or special literal, test to see if it's a + ;; new symbol, in which case we just bind it, or if it's an + ;; already bound symbol or some other literal, in which case we + ;; compare it with EQUAL?. + ((match-two v x g+s (sk ...) fk (id ...)) + (let-syntax + ((new-sym? + (syntax-rules (id ...) + ((new-sym? x sk2 fk2) sk2) + ((new-sym? y sk2 fk2) fk2)))) + (new-sym? random-sym-to-match + (let ((x v)) (sk ... (id ... x))) + (if (equal? v x) (sk ... (id ...)) fk)))) + )) + +;; QUASIQUOTE patterns + +(define-syntax match-quasiquote + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ v (unquote p) g+s sk fk i) + (match-one v p g+s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g+s sk fk i) + (if (pair? v) + (match-one v + (p . tmp) + (match-quasiquote tmp rest g+s sk fk) + fk + i) + fk)) + ((_ v (quasiquote p) g+s sk fk i . depth) + (match-quasiquote v p g+s sk fk i #f . depth)) + ((_ v (unquote p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (unquote-splicing p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (p . q) g+s sk fk i . depth) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-quasiquote + w p g+s + (match-quasiquote-step x q g+s sk fk depth) + fk i . depth)) + fk)) + ((_ v #(elt ...) g+s sk fk i . depth) + (if (vector? v) + (let ((ls (vector->list v))) + (match-quasiquote ls (elt ...) g+s sk fk i . depth)) + fk)) + ((_ v x g+s sk fk i . depth) + (match-one v 'x g+s sk fk i)))) + +(define-syntax match-quasiquote-step + (syntax-rules () + ((match-quasiquote-step x q g+s sk fk depth i) + (match-quasiquote x q g+s sk fk i . depth)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities + +;; Takes two values and just expands into the first. +(define-syntax match-drop-ids + (syntax-rules () + ((_ expr ids ...) expr))) + +(define-syntax match-drop-first-arg + (syntax-rules () + ((_ arg expr) expr))) + +;; To expand an OR group we try each clause in succession, passing the +;; first that succeeds to the success continuation. On failure for +;; any clause, we just try the next clause, finally resorting to the +;; failure continuation fk if all clauses fail. The only trick is +;; that we want to unify the identifiers, so that the success +;; continuation can refer to a variable from any of the OR clauses. + +(define-syntax match-gen-or + (syntax-rules () + ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...)) + (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) + (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...)))))) + +(define-syntax match-gen-or-step + (syntax-rules () + ((_ v () g+s sk fk . x) + ;; no OR clauses, call the failure continuation + fk) + ((_ v (p) . x) + ;; last (or only) OR clause, just expand normally + (match-one v p . x)) + ((_ v (p . q) g+s sk fk i) + ;; match one and try the remaining on failure + (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) + )) + +;; We match a pattern (p ...) by matching the pattern p in a loop on +;; each element of the variable, accumulating the bound ids into lists. + +;; Look at the body of the simple case - it's just a named let loop, +;; matching each element in turn to the same pattern. The only trick +;; is that we want to keep track of the lists of each extracted id, so +;; when the loop recurses we cons the ids onto their respective list +;; variables, and on success we bind the ids (what the user input and +;; expects to see in the success body) to the reversed accumulated +;; list IDs. + +(define-syntax match-gen-ellipses + (syntax-rules () + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to (p ...), just bind the list + (let ((p v)) + (if (list? p) + (sk ... i) + fk)) + ;; simple case, match all elements of the list + (let loop ((ls v) (id-ls '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) + fk i))) + (else + fk))))) + ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking + (match-verify-no-ellipses + r + (let* ((tail-len (length 'r)) + (ls v) + (len (length ls))) + (if (< len tail-len) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond + ((= n tail-len) + (let ((id (reverse id-ls)) ...) + (match-one ls r (#f #f) (sk ... i) fk i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids + (loop (cdr ls) (- n 1) (cons id id-ls) ...)) + fk + i))) + (else + fk))))))))) + +;; This is just a safety check. Although unlike syntax-rules we allow +;; trailing patterns after an ellipses, we explicitly disable multiple +;; ellipses at the same level. This is because in the general case +;; such patterns are exponential in the number of ellipses, and we +;; don't want to make it easy to construct very expensive operations +;; with simple looking patterns. For example, it would be O(n^2) for +;; patterns like (a ... b ...) because we must consider every trailing +;; element for every possible break for the leading "a ...". + +(define-syntax match-verify-no-ellipses + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipse + x + (match-syntax-error + "multiple ellipse patterns not allowed at same level") + (match-verify-no-ellipses y sk))) + ((_ () sk) + sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipse" x)))) + +;; Matching a tree search pattern is only slightly more complicated. +;; Here we allow patterns of the form +;; +;; (x *** y) +;; +;; to represent the pattern y located somewhere in a tree where the +;; path from the current object to y can be seen as a list of the form +;; (X ...). Y can immediately match the current object in which case +;; the path is the empty list. In a sense it's a 2-dimensional +;; version of the ... pattern. +;; +;; As a common case the pattern (_ *** y) can be used to search for Y +;; anywhere in a tree, regardless of the path used. +;; +;; To implement the search, we use two recursive procedures. TRY +;; attempts to match Y once, and on success it calls the normal SK on +;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we +;; call NEXT which first checks if the current value is a list +;; beginning with X, then calls TRY on each remaining element of the +;; list. Since TRY will recursively call NEXT again on failure, this +;; effects a full depth-first search. +;; +;; The failure continuation throughout is a jump to the next step in +;; the tree search, initialized with the original failure continuation +;; FK. + +(define-syntax match-gen-search + (syntax-rules () + ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) + (letrec ((try (lambda (w fail id-ls ...) + (match-one w q g+s + (match-drop-ids + (let ((id (reverse id-ls)) ...) + sk)) + (next w fail id-ls ...) i))) + (next (lambda (w fail id-ls ...) + (if (not (pair? w)) + (fail) + (let ((u (car w))) + (match-one + u p ((car w) (set-car! w)) + (match-drop-ids + ;; accumulate the head variables from + ;; the p pattern, and loop over the tail + (let ((id-ls (cons id id-ls)) ...) + (let lp ((ls (cdr w))) + (if (pair? ls) + (try (car ls) + (lambda () (lp (cdr ls))) + id-ls ...) + (fail))))) + (fail) i)))))) + ;; the initial id-ls binding here is a dummy to get the right + ;; number of '()s + (let ((id-ls '()) ...) + (try v (lambda () fk) id-ls ...)))))) + +;; Vector patterns are just more of the same, with the slight +;; exception that we pass around the current vector index being +;; matched. + +(define-syntax match-vector + (syntax-rules (___) + ((_ v n pats (p q) . x) + (match-check-ellipse q + (match-gen-vector-ellipses v n pats p . x) + (match-vector-two v n pats (p q) . x))) + ((_ v n pats (p ___) sk fk i) + (match-gen-vector-ellipses v n pats p sk fk i)) + ((_ . x) + (match-vector-two . x)))) + +;; Check the exact vector length, then check each element in turn. + +(define-syntax match-vector-two + (syntax-rules () + ((_ v n ((pat index) ...) () sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (= len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) . x) + (match-vector v (+ n 1) (pats ... (p n)) q . x)))) + +(define-syntax match-vector-step + (syntax-rules () + ((_ v () (sk ...) fk i) (sk ... i)) + ((_ v ((pat index) . rest) sk fk i) + (let ((w (vector-ref v index))) + (match-one w pat ((vector-ref v index) (vector-set! v index)) + (match-vector-step v rest sk fk) + fk i))))) + +;; With a vector ellipse pattern we first check to see if the vector +;; length is at least the required length. + +(define-syntax match-gen-vector-ellipses + (syntax-rules () + ((_ v n ((pat index) ...) p sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (>= len n) + (match-vector-step v ((pat index) ...) + (match-vector-tail v p n len sk fk) + fk i) + fk)) + fk)))) + +(define-syntax match-vector-tail + (syntax-rules () + ((_ v p n len sk fk i) + (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())))) + +(define-syntax match-vector-tail-two + (syntax-rules () + ((_ v p n len (sk ...) fk i ((id id-ls) ...)) + (let loop ((j n) (id-ls '()) ...) + (if (>= j len) + (let ((id (reverse id-ls)) ...) (sk ... i)) + (let ((w (vector-ref v j))) + (match-one w p ((vector-ref v j) (vetor-set! v j)) + (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) + fk i))))))) + +(define-syntax match-record-refs + (syntax-rules () + ((_ v rec n (p . q) g+s sk fk i) + (let ((w (slot-ref rec v n))) + (match-one w p ((slot-ref rec v n) (slot-set! rec v n)) + (match-record-refs v rec (+ n 1) q g+s sk fk) fk i))) + ((_ v rec n () g+s (sk ...) fk i) + (sk ... i)))) + +;; Extract all identifiers in a pattern. A little more complicated +;; than just looking for symbols, we need to ignore special keywords +;; and non-pattern forms (such as the predicate expression in ? +;; patterns), and also ignore previously bound identifiers. +;; +;; Calls the continuation with all new vars as a list of the form +;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely +;; pair with the original variable (e.g. it's used in the ellipse +;; generation for list variables). +;; +;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) + +(define-syntax match-extract-vars + (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!) + ((match-extract-vars (? pred . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars ($ rec . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (= proc p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (quote x) (k ...) i v) + (k ... v)) + ((match-extract-vars (quasiquote x) k i v) + (match-extract-quasiquote-vars x k i v (#t))) + ((match-extract-vars (and . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (or . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (not . p) . x) + (match-extract-vars p . x)) + ;; A non-keyword pair, expand the CAR with a continuation to + ;; expand the CDR. + ((match-extract-vars (p q . r) k i v) + (match-check-ellipse + q + (match-extract-vars (p . r) k i v) + (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) + ((match-extract-vars (p . q) k i v) + (match-extract-vars p (match-extract-vars-step q k i v) i ())) + ((match-extract-vars #(p ...) . x) + (match-extract-vars (p ...) . x)) + ((match-extract-vars _ (k ...) i v) (k ... v)) + ((match-extract-vars ___ (k ...) i v) (k ... v)) + ((match-extract-vars *** (k ...) i v) (k ... v)) + ;; This is the main part, the only place where we might add a new + ;; var if it's an unbound symbol. + ((match-extract-vars p (k ...) (i ...) v) + (let-syntax + ((new-sym? + (syntax-rules (i ...) + ((new-sym? p sk fk) sk) + ((new-sym? x sk fk) fk)))) + (new-sym? random-sym-to-match + (k ... ((p p-ls) . v)) + (k ... v)))) + )) + +;; Stepper used in the above so it can expand the CAR and CDR +;; separately. + +(define-syntax match-extract-vars-step + (syntax-rules () + ((_ p k i v ((v2 v2-ls) ...)) + (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) + )) + +(define-syntax match-extract-quasiquote-vars + (syntax-rules (quasiquote unquote unquote-splicing) + ((match-extract-quasiquote-vars (quasiquote x) k i v d) + (match-extract-quasiquote-vars x k i v (#t . d))) + ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) + (match-extract-quasiquote-vars (unquote x) k i v d)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t)) + (match-extract-vars x k i v)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) + (match-extract-quasiquote-vars x k i v d)) + ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) + (match-extract-quasiquote-vars + x + (match-extract-quasiquote-vars-step y k i v d) i ())) + ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) + (match-extract-quasiquote-vars (x ...) k i v d)) + ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) + (k ... v)) + )) + +(define-syntax match-extract-quasiquote-vars-step + (syntax-rules () + ((_ x k i v d ((v2 v2-ls) ...)) + (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d)) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gimme some sugar baby. + +(define-syntax match-lambda + (syntax-rules () + ((_ clause ...) (lambda (expr) (match expr clause ...))))) + +(define-syntax match-lambda* + (syntax-rules () + ((_ clause ...) (lambda expr (match expr clause ...))))) + +(define-syntax match-let + (syntax-rules () + ((_ (vars ...) . body) + (match-let/helper let () () (vars ...) . body)) + ((_ loop . rest) + (match-named-let loop () . rest)))) + +(define-syntax match-letrec + (syntax-rules () + ((_ vars . body) (match-let/helper letrec () () vars . body)))) + +(define-syntax match-let/helper + (syntax-rules () + ((_ let ((var expr) ...) () () . body) + (let ((var expr) ...) . body)) + ((_ let ((var expr) ...) ((pat tmp) ...) () . body) + (let ((var expr) ...) + (match-let* ((pat tmp) ...) + . body))) + ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((a expr) . rest) . body) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)))) + +(define-syntax match-named-let + (syntax-rules () + ((_ loop ((pat expr var) ...) () . body) + (let loop ((var expr) ...) + (match-let ((pat var) ...) + . body))) + ((_ loop (v ...) ((pat expr) . rest) . body) + (match-named-let loop (v ... (pat expr tmp)) rest . body)))) + +(define-syntax match-let* + (syntax-rules () + ((_ () . body) + (begin . body)) + ((_ ((pat expr) . rest) . body) + (match expr (pat (match-let* rest . body)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Otherwise COND-EXPANDed bits. + +;; This *should* work, but doesn't :( +;; (define-syntax match-check-ellipse +;; (syntax-rules (...) +;; ((_ ... sk fk) sk) +;; ((_ x sk fk) fk))) + +;; This is a little more complicated, and introduces a new let-syntax, +;; but should work portably in any R[56]RS Scheme. Taylor Campbell +;; originally came up with the idea. +(define-syntax match-check-ellipse + (syntax-rules () + ;; these two aren't necessary but provide fast-case failures + ((match-check-ellipse (a . b) success-k failure-k) failure-k) + ((match-check-ellipse #(a ...) success-k failure-k) failure-k) + ;; matching an atom + ((match-check-ellipse id success-k failure-k) + (let-syntax ((ellipse? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipse? (foo id) sk fk) sk) + ((ellipse? other sk fk) fk)))) + ;; this list of three elements will only many the (foo id) list + ;; above if `id' is `...' + (ellipse? (a b c) success-k failure-k))))) + + +;; This is portable but can be more efficient with non-portable +;; extensions. This trick was originally discovered by Oleg Kiselyov. + +(define-syntax match-check-identifier + (syntax-rules () + ;; fast-case failures, lists and vectors are not identifiers + ((_ (x . y) success-k failure-k) failure-k) + ((_ #(x ...) success-k failure-k) failure-k) + ;; x is an atom + ((_ x success-k failure-k) + (let-syntax + ((sym? + (syntax-rules () + ;; if the symbol `abracadabra' matches x, then x is a + ;; symbol + ((sym? x sk fk) sk) + ;; otherwise x is a non-symbol datum + ((sym? y sk fk) fk)))) + (sym? abracadabra success-k failure-k))))) diff --git a/lib/chibi/mime.module b/lib/chibi/mime.module new file mode 100644 index 00000000..2c10dbd1 --- /dev/null +++ b/lib/chibi/mime.module @@ -0,0 +1,7 @@ + +(define-module (chibi mime) + (export mime-ref assoc-ref mime-header-fold mime-headers->list + mime-parse-content-type mime-decode-header + mime-message-fold mime-message->sxml) + (import-immutable (scheme) (chibi base64) (chibi quoted-printable) (chibi io)) + (include "mime.scm")) diff --git a/lib/chibi/mime.scm b/lib/chibi/mime.scm new file mode 100644 index 00000000..e712d7fa --- /dev/null +++ b/lib/chibi/mime.scm @@ -0,0 +1,410 @@ +;; mime.scm -- RFC2045 MIME library +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2822 headers + +;; Procedure: mime-header-fold kons knil [source [limit [kons-from]]] +;; +;; Performs a fold operation on the MIME headers of source which can be +;; either a string or port, and defaults to current-input-port. kons +;; is called on the three values: +;; kons header value accumulator +;; where accumulator begins with knil. Neither the header nor the +;; value are modified, except wrapped lines are handled for the value. +;; +;; The optional procedure KONS-FROM is a procedure to be called when +;; the first line of the headers is an "From
" line, to +;; enable this procedure to be used as-is on mbox files and the like. +;; It defaults to KONS, and if such a line is found the fold will begin +;; with (KONS-FROM "%from"
(KONS-FROM "%date" KNIL)). +;; +;; The optional LIMIT gives a limit on the number of headers to read. + +;; Procedure: mime-headers->list [source] +;; Return an alist of the MIME headers from source with headers all +;; downcased. + +;; Procedure: mime-parse-content-type str +;; Parses STR as a Content-Type style-value returning the list +;; (type (attr . val) ...) +;; For example: +;; (mime-parse-content-type +;; "text/html; CHARSET=US-ASCII; filename=index.html") +;; => ("text/html" ("charset" . "US-ASCII") ("filename" . "index.html")) + +;; Procedure: mime-decode-header str +;; Replace all occurrences of RFC1522 =?ENC?...?= escapes in STR with +;; the appropriate decoded and charset converted value. + +;; Procedure: mime-ref headers str [default] +;; A case-insensitive assoc-ref. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; RFC2045 MIME encoding + +;; Procedure: mime-message-fold src headers kons knil +;; Performs a fold operation on the given string or port SRC as a MIME +;; body corresponding to the headers give in HEADERS. KONS is called +;; on the successive values: +;; +;; KONS part-headers part-body accumulator +;; +;; where part-headers are the headers for the given MIME part (the +;; original headers for single-part MIME), part-body is the +;; appropriately decoded and charset-converted body of the message, +;; and the accumulator begins with KNIL. +;; +;; TODO: Extend mime-message-fold to (optionally?) pass KONS an +;; input-port instead of string for the body to handle very large bodies +;; (this is not much of an issue for SMTP since the messages are in +;; practice limited, but it could be problematic for large HTTP bodies). +;; +;; This does a depth-first search, folding in sequence. It should +;; probably be doing a tree-fold as in html-parser. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define mime-line-length-limit 4096) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; association lists + +(define (assoc* key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (cond + ((null? ls) #f) + ((eq key (caar ls)) (car ls)) + (else (lp (cdr ls))))))) + +(define (assoc-ref ls key . o) + (let ((default (and (pair? o) (car o))) + (eq (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) equal?))) + (cond ((assoc* key ls eq) => cdr) + (else default)))) + +(define (mime-ref ls key . o) + (assoc-ref ls key (and (pair? o) (car o)) string-ci=?)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; simple matching instead of regexps + +(define (match-mbox-from-line line) + (let ((len (string-length line))) + (and (> len 5) + (string=? (substring line 0 5) "From ") + (let lp ((i 6)) + (cond + ((= i len) (list (substring line 5 len) "")) + ((memq (string-ref line i) '(#\space #\tab)) + (list (substring line 5 i) (substring line (+ i 1) len))) + (else (lp (+ i 1)))))))) + +(define (string-scan-colon-or-maybe-equal str) + (let ((len (string-length str))) + (let lp ((i 0) (best #f)) + (if (= i len) + best + (let ((c (string-ref str i))) + (cond ((or (char-alphabetic? c) + (char-numeric? c) + (memv c '(#\- #\_))) + (lp (+ i 1) best)) + ((eq? c #\:) + (if (= i 0) #f i)) + ((eqv? c #\=) + (lp (+ i 1) (or best i))) + (else + best))))))) + +(define (string-skip-white-space str i) + (let ((lim (string-length str))) + (let lp ((i i)) + (cond ((>= i lim) lim) + ((char-whitespace? (string-ref str i)) (lp (+ i 1))) + (else i))))) + +(define (match-mime-header-line line) + (let ((i (string-scan-colon-or-maybe-equal line))) + (and i + (let ((j (string-skip-white-space line (+ i 1)))) + (list (substring line 0 i) + (substring line j (string-length line))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dummy encoder + +(define (ces-convert str . x) + str) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; some srfi-13 & string utils + +(define (string-copy! to tstart from . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length from)))) + (let lp ((i start) (j tstart)) + (cond + ((< i end) + (string-set! to j (string-ref from i)) + (lp (+ i 1) (+ j 1))))))) + +(define (string-concatenate-reverse ls) + (let lp ((ls ls) (rev '()) (len 0)) + (if (null? ls) + (let ((res (make-string len))) + (let lp ((ls rev) (i 0)) + (cond + ((null? ls) + res) + (else + (string-copy! res i (car ls)) + (lp (cdr ls) (+ i (string-length (car ls)))))))) + (lp (cdr ls) (cons (car ls) rev) (+ len (string-length (car ls))))))) + +(define (string-downcase s . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length s)))) + (let* ((len (- end start)) (s2 (make-string len))) + (let lp ((i start) (j 0)) + (cond + ((>= i end) + s2) + (else + (string-set! s2 j (char-downcase (string-ref s i))) + (lp (+ i 1) (+ j 1)))))))) + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-trim-white-space s) + (let ((len (string-length s))) + (let lp ((i 0)) + (cond ((= i len) "") + ((char-whitespace? (string-ref s i)) (lp (+ i 1))) + (else + (let lp ((j (- len 1))) + (cond ((<= j i) "") + ((char-whitespace? (string-ref s j)) (lp (- j 1))) + (else (substring s i (+ j 1)))))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; header parsing + +(define (mime-header-fold kons knil . o) + (let ((src (and (pair? o) (car o))) + (limit (and (pair? o) (pair? (cdr o)) (car (cdr o)))) + (kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (caddr o) kons))) + ((if (string? src) mime-header-fold-string mime-header-fold-port) + kons knil (or src (current-input-port)) limit kons-from))) + +(define (mime-header-fold-string kons knil str limit kons-from) + (call-with-input-string str + (lambda (in) (mime-header-fold-port kons knil in limit kons-from)))) + +(define (mime-header-fold-port kons knil port limit kons-from) + (define (out line acc count) + (cond + ((or (and limit (> count limit)) (eof-object? line) (string=? line "")) + acc) + ((match-mime-header-line line) + => (lambda (m) (in (car m) (list (cadr m)) acc (+ count 1)))) + (else + ;;(warn "invalid header line: ~S\n" line) + (out (read-line port mime-line-length-limit) acc (+ count 1))))) + (define (in header value acc count) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((and limit (> count limit)) + acc) + ((or (eof-object? line) (string=? line "")) + (kons header (string-concatenate-reverse value) acc)) + ((char-whitespace? (string-ref line 0)) + (in header (cons line value) acc (+ count 1))) + (else + (out line + (kons header (string-concatenate-reverse value) acc) + (+ count 1)))))) + (let ((first-line (read-line port mime-line-length-limit))) + (cond + ((eof-object? first-line) + knil) + ((and kons-from (match-mbox-from-line first-line)) + => (lambda (m) ; special case check on first line for mbox files + (out (read-line port mime-line-length-limit) + (kons-from "%from" (car m) + (kons-from "%date" (cadr m) knil)) + 0))) + (else + (out first-line knil 0))))) + +(define (mime-headers->list . o) + (reverse + (apply + mime-header-fold + (lambda (h v acc) (cons (cons (string-downcase h) v) acc)) + '() + o))) + +(define (mime-split-name+value s) + (let ((i (string-char-index s #\=))) + (if i + (cons (string-downcase (string-trim-white-space (substring s 0 i))) + (if (= i (string-length s)) + "" + (if (eqv? #\" (string-ref s (+ i 1))) + (substring s (+ i 2) (- (string-length s) 1)) + (substring s (+ i 1) (string-length s))))) + (cons (string-downcase (string-trim-white-space s)) "")))) + +(define (mime-parse-content-type str) + (map mime-split-name+value (string-split str #\;))) + +(define (mime-decode-header str) + (let* ((len (string-length str)) + (limit (- len 8))) ; need at least 8 chars: "=?Q?X??=" + (let lp ((i 0) (from 0) (res '())) + (if (>= i limit) + (string-concatenate (reverse (cons (substring str from len) res))) + (if (and (eqv? #\= (string-ref str i)) + (eqv? #\? (string-ref str (+ i 1)))) + (let* ((j (string-char-index str #\? (+ i 3))) + (k (string-char-index str #\? (+ j 3)))) + (if (and j k (< (+ k 1) len) + (eqv? #\? (string-ref str (+ j 2))) + (memq (string-ref str (+ j 1)) '(#\Q #\B #\q #\b)) + (eqv? #\= (string-ref str (+ k 1)))) + (let ((decode (if (memq (string-ref str (+ j 1)) '(#\Q #\q)) + quoted-printable-decode-string + base64-decode-string)) + (cset (substring str (+ i 2) j)) + (content (substring str (+ j 3) k)) + (k2 (+ k 2))) + (lp k2 k2 (cons (ces-convert (decode content) cset) + (cons (substring str from i) res)))) + (lp (+ i 2) from res))) + (lp (+ i 1) from res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; message parsing + +(define (mime-read-to-boundary port boundary next final) + (let ((final-boundary (and boundary (string-append boundary "--")))) + (let lp ((res '())) + (let ((line (read-line port mime-line-length-limit))) + (cond + ((or (eof-object? line) (equal? line final-boundary)) + (final (string-concatenate (reverse res) + (call-with-output-string newline)))) + ((equal? line boundary) + (next (string-concatenate (reverse res) + (call-with-output-string newline)))) + (else + (lp (cons line res)))))))) + +(define (mime-convert-part str cte enc) + (let ((str (cond + ((and (string? cte) (string-ci=? cte "quoted-printable")) + (quoted-printable-decode-string str)) + ((and (string? cte) (string-ci=? cte "base64")) + (base64-decode-string str)) + (else + str)))) + (if (string? enc) (ces-convert str enc) str))) + +(define (mime-read-part port cte enc boundary next final) + (mime-read-to-boundary + port boundary + (lambda (x) (next (mime-convert-part x cte enc))) + (lambda (x) (final (mime-convert-part x cte enc))))) + +;; (kons parent-headers part-headers part-body seed) +;; (start headers seed) +;; (end headers parent-seed seed) +(define (mime-message-fold src kons init-seed . o) + (let ((port (if (string? src) (open-input-string src) src))) + (let ((kons-start + (if (pair? o) (car o) (lambda (headers seed) '()))) + (kons-end + (if (and (pair? o) (pair? (cdr o))) + (car (cdr o)) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)))) + (headers + (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o)))) + (car (cdr (cdr o))) + (mime-headers->list port)))) + (let tfold ((parent-headers '()) + (headers headers) + (seed init-seed) + (boundary #f) + (next (lambda (x) x)) + (final (lambda (x) x))) + (let* ((ctype (mime-parse-content-type + (mime-ref headers "Content-Type" "text/plain"))) + (type (string-trim-white-space (caar ctype))) + (enc (string-trim-white-space + (or (mime-ref ctype "charset") + (mime-ref headers "charset" "ASCII")))) + (cte (string-trim-white-space + (or (mime-ref headers "Content-Transfer-Encoding") + (mime-ref headers "Encoding" "7-bit"))))) + (cond + ((and (string-ci=? type "multipart/") + (mime-ref ctype "boundary")) + => (lambda (boundary2) + (let ((boundary2 (string-append "--" boundary2))) + ;; skip preamble + (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x)) + (let lp ((part-seed (kons-start headers seed))) + (let ((part-headers (mime-headers->list port))) + (tfold parent-headers part-headers + part-seed boundary2 + lp + (lambda (x) + ;; skip epilogue + (if boundary + (mime-read-to-boundary port boundary + (lambda (x) x) (lambda (x) x))) + (next (kons-end headers seed x))) + )))))) + (else + (mime-read-part + port cte enc boundary + (lambda (x) (next (kons parent-headers headers x seed))) + (lambda (x) (final (kons parent-headers headers x seed))))))))))) + +;; (mime (^ (header . value) ...) parts ...) +(define (mime-message->sxml . o) + (car + (apply + mime-message-fold + (if (pair? o) (car o) (current-input-port)) + (lambda (parent-headers headers body seed) + `((mime (^ ,@headers) ,body) ,@seed)) + '() + (lambda (headers seed) '()) + (lambda (headers parent-seed seed) + `((mime (^ ,@headers) + ,@(if (pair? seed) (reverse seed) seed)) + ,@parent-seed)) + (if (pair? o) (cdr o) '())))) + diff --git a/lib/chibi/modules.module b/lib/chibi/modules.module new file mode 100644 index 00000000..0d20861e --- /dev/null +++ b/lib/chibi/modules.module @@ -0,0 +1,8 @@ + +(define-module (chibi modules) + (export analyze-module module-ast module-ast-set! + module-ref module-contains? containing-module + procedure-analysis) + (import-immutable (scheme) (config)) + (import (chibi ast)) + (include "modules.scm")) diff --git a/lib/chibi/modules.scm b/lib/chibi/modules.scm new file mode 100644 index 00000000..b9e40e0d --- /dev/null +++ b/lib/chibi/modules.scm @@ -0,0 +1,103 @@ + +(define (file->sexp-list file) + (call-with-input-file file + (lambda (in) + (let lp ((res '())) + (let ((x (read in))) + (if (eof-object? x) + (reverse res) + (lp (cons x res)))))))) + +(define (module? x) (vector? x)) + +(define (module-ast mod) (vector-ref mod 3)) +(define (module-ast-set! mod x) (vector-set! mod 3 x)) + +(define (analyze-module-source name mod recursive?) + (let ((env (module-env mod)) + (dir (if (equal? name '(scheme)) "" (module-name-prefix name)))) + (define (include-source file) + (cond ((find-module-file (string-append dir file)) + => (lambda (x) (cons 'body (file->sexp-list x)))) + (else (error "couldn't find include" file)))) + (let lp ((ls (module-meta-data mod)) (res '())) + (cond + ((not (pair? ls)) + (reverse res)) + (else + (case (and (pair? (car ls)) (caar ls)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2-name (car mod2-name+imports))) + (if recursive? + (analyze-module mod2-name #t)))) + (cdar ls)) + (lp (cdr ls) res)) + ((include) + (lp (append (map include-source (cdar ls)) (cdr ls)) res)) + ((body) + (let lp2 ((ls2 (cdar ls)) (res res)) + (cond + ((pair? ls2) + (lp2 (cdr ls2) (cons (analyze (car ls2) env) res))) + (else + (lp (cdr ls) res))))) + (else + (lp (cdr ls) res)))))))) + +(define (analyze-module name . o) + (let ((recursive? (and (pair? o) (car o))) + (res (load-module name))) + (if (not (module-ast res)) + (module-ast-set! res (analyze-module-source name res recursive?))) + res)) + +(define (module-ref mod var-name . o) + (let ((cell (env-cell (module-env (if (module? mod) mod (load-module mod))) + var-name))) + (if cell + (cdr cell) + (if (pair? o) (car o) (error "no binding in module" mod var-name))))) + +(define (module-contains? mod var-name) + (and (env-cell (module-env (if (module? mod) mod (load-module mod))) var-name) + #t)) + +(define (module-defines? name mod var-name) + (if (not (module-ast mod)) + (module-ast-set! mod (analyze-module-source name mod #f))) + (let lp ((ls (module-ast mod))) + (and (pair? ls) + (or (and (set? (car ls)) + (eq? var-name (ref-name (set-var (car ls)))) + (begin + ;; (write `(found ,var-name in ,name ,(ast->sexp (car ls))) (current-error-port)) + ;; (newline (current-error-port)) + #t)) + (lp (cdr ls)))))) + +(define (containing-module x) + (let lp1 ((ls (reverse *modules*))) + (and (pair? ls) + (let ((env (module-env (cdar ls)))) + (let lp2 ((e-ls (env-exports env))) + (if (null? e-ls) + (lp1 (cdr ls)) + (let ((cell (env-cell env (car e-ls)))) + (if (and (eq? x (cdr cell)) + (module-defines? (caar ls) (cdar ls) (car cell))) + (car ls) + (lp2 (cdr e-ls)))))))))) + +(define (procedure-analysis x) + (let ((mod (containing-module x))) + (and mod + (let lp ((ls (module-ast (analyze-module (car mod))))) + (and (pair? ls) + (if (and (set? (car ls)) + (eq? (procedure-name x) (ref-name (set-var (car ls))))) + (set-value (car ls)) + (lp (cdr ls)))))))) + diff --git a/lib/chibi/net.module b/lib/chibi/net.module new file mode 100644 index 00000000..845a7aa8 --- /dev/null +++ b/lib/chibi/net.module @@ -0,0 +1,11 @@ + +(define-module (chibi net) + (export sockaddr? address-info? get-address-info socket connect + with-net-io open-net-io + address-info-family address-info-socket-type address-info-protocol + address-info-address address-info-address-length address-info-next) + (import-immutable (scheme)) + (import (chibi filesystem)) + (include-shared "net") + (include "net.scm")) + diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm new file mode 100644 index 00000000..5f912cb5 --- /dev/null +++ b/lib/chibi/net.scm @@ -0,0 +1,32 @@ +;; net.scm -- the high-level network interface +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (open-net-io host service) + (let lp ((addr (get-address-info host + (if (integer? service) + (number->string service) + service) + #f))) + (if (not addr) + (error "couldn't find address" host service) + (let ((sock (socket (address-info-family addr) + (address-info-socket-type addr) + (address-info-protocol addr)))) + (if (negative? sock) + (lp (address-info-next addr)) + (if (negative? + (connect sock + (address-info-address addr) + (address-info-address-length addr))) + (lp (address-info-next addr)) + (list (open-input-file-descriptor sock) + (open-output-file-descriptor sock)))))))) + +(define (with-net-io host service proc) + (let ((io (open-net-io host service))) + (if (not (pair? io)) + (error "couldn't find address" host service) + (let ((res (proc (car io) (car (cdr io))))) + (close-input-port (car io)) + res)))) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub new file mode 100644 index 00000000..0d72bc90 --- /dev/null +++ b/lib/chibi/net.stub @@ -0,0 +1,25 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/socket.h") +(c-system-include "netdb.h") + +(define-c-struct sockaddr + predicate: sockaddr?) + +(define-c-struct addrinfo + finalizer: freeaddrinfo + predicate: address-info? + (int ai_family address-info-family) + (int ai_socktype address-info-socket-type) + (int ai_protocol address-info-protocol) + ((link sockaddr) ai_addr address-info-address) + (size_t ai_addrlen address-info-address-length) + ((link addrinfo) ai_next address-info-next)) + +(define-c errno (get-address-info getaddrinfo) + (string string (maybe-null addrinfo) (result free addrinfo))) + +(define-c int bind (int sockaddr int)) +(define-c int listen (int int)) +(define-c int socket (int int int)) +(define-c int connect (int sockaddr int)) diff --git a/lib/chibi/net/http.module b/lib/chibi/net/http.module new file mode 100644 index 00000000..352bf7b4 --- /dev/null +++ b/lib/chibi/net/http.module @@ -0,0 +1,7 @@ + +(define-module (chibi net http) + (export http-get call-with-input-url with-input-from-url + http-parse-request http-parse-form) + (import-immutable (scheme) (srfi 39) (chibi net) (chibi io) + (chibi uri) (chibi mime)) + (include "http.scm")) diff --git a/lib/chibi/net/http.scm b/lib/chibi/net/http.scm new file mode 100644 index 00000000..37cac5e6 --- /dev/null +++ b/lib/chibi/net/http.scm @@ -0,0 +1,180 @@ +;; http.scm -- http client +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils + +(define (string-char-index str c . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond + ((= i end) #f) + ((eq? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-split str ch) + (let ((len (string-length str))) + (let lp ((i 0) (res '())) + (let ((j (string-char-index str ch i))) + (if j + (lp (+ j 1) (cons (substring str i j) res)) + (reverse (cons (substring str i len) res))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; client utils + +(define http-user-agent "chibi") + +(define http-redirect-limit 10) +(define http-chunked-buffer-size 4096) +(define http-chunked-size-limit 409600) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (http-parse-response line) + (let* ((len (string-length line)) + (i (or (string-scan line #\space 0 len) len)) + (j (or (string-scan line #\space (+ i 1) len) len)) + (n (and (< i j) (string->number (substring line (+ i 1) j))))) + (if (not (integer? n)) + (error "bad response" line i j) + (list (substring line 0 i) + n + (if (>= j len) "" (substring line (+ j 1) len)))))) + +(define (http-wrap-chunked-input-port in) + (define (read-chunk in) + (let* ((line (read-line in)) + (n (and (string? line) (string->number line 16)))) + (display "read-chunk ") (write line) (newline) + (cond + ((not (and (integer? n) (<= 0 n http-chunked-size-limit))) + (error "invalid chunked size line" line)) + ((zero? n) "") + (else (read-string n in))))) + (make-generated-input-port + (lambda () (read-chunk in)))) + +(define (http-get/raw url in-headers limit) + (if (<= limit 0) + (error "http-get: redirect limit reached" url) + (let* ((uri (if (uri? url) url (string->uri url))) + (host (and uri (uri-host uri)))) + (if (not host) + (error "invalid url" url) + (let* ((io (open-net-io + host + (or (uri-port uri) + (if (eq? 'https (uri-scheme uri)) 443 80)))) + (in (car io)) + (out (car (cdr io)))) + (display "GET " out) + (display (or (uri-path uri) "/") out) + (display " HTTP/1.0\r\n" out) + (display "Host: " out) (display host out) (display "\r\n" out) + (cond + ((not (mime-ref in-headers "user-agent")) + (display "User-Agent: " out) + (display http-user-agent out) + (display "\r\n" out))) + (for-each + (lambda (x) + (display (car x) out) (display ": " out) + (display (cdr x) out) (display "\r\n" out)) + in-headers) + (display "Connection: close\r\n\r\n" out) + (flush-output out) + (let* ((resp (http-parse-response (read-line in))) + (headers (mime-headers->list in)) + (status (quotient (cadr resp) 100))) + (case status + ((2) + (let ((enc (mime-ref headers "transfer-encoding"))) + (cond + ((equal? enc "chunked") + (http-wrap-chunked-input-port in)) + (else + in)))) + ((3) + (close-input-port in) + (close-output-port out) + (let ((url2 (mime-ref headers "location"))) + (if url2 + (http-get/raw url2 in-headers (- limit 1)) + (error "redirect with no location header")))) + (else + (close-input-port in) + (close-output-port out) + (error "couldn't retrieve url" url resp))))))))) + +(define (http-get url . headers) + (http-get/raw url + (if (pair? headers) (car headers) '()) + http-redirect-limit)) + +(define (call-with-input-url url proc) + (let* ((p (http-get url)) + (res (proc p))) + (close-input-port p) + res)) + +(define (with-input-from-url url thunk) + (let ((p (http-get url))) + (let ((res (parameterize ((current-input-port p)) (thunk)))) + (close-input-port p) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; server utils + +;; read and parse a request line +(define (http-parse-request . o) + (let ((line (string-split + (read-line (if (pair? o) (car o) (current-input-port)) 4096)))) + (cons (string->symbol (car line)) (cdr line)))) + +;; Parse a form body with a given URI and MIME headers (as parsed with +;; mime-headers->list). Returns an alist of (name . value) for every +;; query or form parameter. +(define (http-parse-form uri headers . o) + (let* ((in (if (pair? o) (car o) (current-input-port))) + (type (mime-ref headers + "content-type" + "application/x-www-form-urlencoded")) + (query0 (or (uri-query (if (string? uri) (string->uri uri) uri)) '())) + (query (if (string? query0) (uri-query->alist query0) query0))) + (cond + ((string-ci=? "multipart/" type) + (let ((mime (mime-message->sxml in headers))) + (append + (let lp ((ls (cddr mime)) + (res '())) + (cond + ((null? ls) + res) + ((and (pair? (car ls)) + (eq? 'mime (caar ls)) + (pair? (cdar ls)) + (pair? (cadar ls)) + (memq (caadar ls) '(^ @))) + (let* ((disp0 (mime-ref (cdadar ls) "content-disposition" "")) + (disp (mime-parse-content-type disp0)) + (name (mime-ref disp "name"))) + (if name + (lp (cdr ls) (cons (cons name (caddar ls)) res)) + (lp (cdr ls) res)))) + (else + (lp (cdr ls) res)))) + query))) + (else + query)))) + diff --git a/lib/chibi/pathname.module b/lib/chibi/pathname.module new file mode 100644 index 00000000..765ee189 --- /dev/null +++ b/lib/chibi/pathname.module @@ -0,0 +1,7 @@ + +(define-module (chibi pathname) + (export path-strip-directory path-directory path-extension-pos + path-extension path-strip-extension path-replace-extension + path-absolute? path-relative? path-normalize make-path) + (import-immutable (scheme)) + (include "pathname.scm")) diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm new file mode 100644 index 00000000..de27ad61 --- /dev/null +++ b/lib/chibi/pathname.scm @@ -0,0 +1,180 @@ +;; pathname.scm -- a general, non-host-specific path lib +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-scan-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (- i 1)))))) + +(define (string-skip c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (+ i 1))))))) + +(define (string-skip-right c str . o) + (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) + (cond ((negative? i) #f) + ((not (eqv? c (string-ref str i))) i) + (else (lp (- i 1)))))) + +;; POSIX basename +;; (define (path-strip-directory path) +;; (if (string=? path "") +;; path +;; (let ((end (string-skip-right #\/ path))) +;; (if (not end) +;; "/" +;; (let ((start (string-scan-right #\/ path (- end 1)))) +;; (substring path (if start (+ start 1) 0) (+ end 1))))))) + +;; GNU basename +(define (path-strip-directory path) + (if (string=? path "") + path + (let ((len (string-length path))) + (if (eqv? #\/ (string-ref path (- len 1))) + "" + (let ((slash (string-scan-right #\/ path))) + (if (not slash) + path + (substring path (+ slash 1) len))))))) + +(define (path-directory path) + (if (string=? path "") + "." + (let ((end (string-skip-right #\/ path))) + (if (not end) + "/" + (let ((start (string-scan-right #\/ path (- end 1)))) + (if (not start) + "." + (let ((start (string-skip-right #\/ path start))) + (if (not start) "/" (substring path 0 (+ start 1)))))))))) + +(define (path-extension-pos path) (string-scan-right #\. path)) + +(define (path-extension path) + (let ((i (path-extension-pos path))) + (and i + (let ((start (+ i 1)) (end (string-length path))) + (and (< start end) (substring path start end)))))) + +(define (path-strip-extension path) + (let ((i (path-extension-pos path))) + (if (and i (< (+ i 1) (string-length path))) + (substring path 0 i) + path))) + +(define (path-replace-extension path ext) + (string-append (path-strip-extension path) "." ext)) + +(define (path-absolute? path) + (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0)))) + +(define (path-relative? path) (not (path-absolute? path))) + +;; This looks big and hairy, but it's mutation-free and guarantees: +;; (string=? s (path-normalize s)) <=> (eq? s (path-normalize s)) +;; i.e. fast and simple for already normalized paths. + +(define (path-normalize path) + (let* ((len (string-length path)) (len-1 (- len 1))) + (define (collect i j res) + (if (>= i j) res (cons (substring path i j) res))) + (define (finish i res) + (if (zero? i) + path + (apply string-append (reverse (collect i len res))))) + ;; loop invariants: + ;; - res is a list such that (string-concatenate-reverse res) + ;; is always the normalized string up to j + ;; - the tail of the string from j onward can be concatenated to + ;; the above value to get a partially normalized path referring + ;; to the same location as the original path + (define (inside i j res) + (if (>= j len) + (finish i res) + (if (eqv? #\/ (string-ref path j)) + (boundary i (+ j 1) res) + (inside i (+ j 1) res)))) + (define (boundary i j res) + (if (>= j len-1) + (finish i res) + (case (string-ref path j) + ((#\.) + (case (string-ref path (+ j 1)) + ((#\.) + (if (or (>= j (- len 2)) (eqv? #\/ (string-ref path (+ j 2)))) + (if (>= i (- j 1)) + (if (null? res) + (backup j "" '()) + (backup j (car res) (cdr res))) + (backup j (substring path i j) res)) + (inside i (+ j 2) res))) + ((#\/) + (if (= i j) + (boundary (+ j 2) (+ j 2) res) + (let ((s (substring path i j))) + (boundary (+ j 2) (+ j 2) (cons s res))))) + (else (inside i (+ j 1) res)))) + ((#\/) (boundary (+ j 1) (+ j 1) (collect i j res))) + (else (inside i (+ j 1) res))))) + (define (backup j s res) + (let ((pos (+ j 3))) + (cond + ;; case 1: we're reduced to accumulating parents of the cwd + ((or (string=? s "/..") (string=? s "..")) + (boundary pos pos (cons "/.." (cons s res)))) + ;; case 2: the string isn't a component itself, skip it + ((or (string=? s "") (string=? s ".") (string=? s "/")) + (if (pair? res) + (backup j (car res) (cdr res)) + (boundary pos pos (if (string=? s "/") '("/") '(".."))))) + ;; case3: just take the directory of the string + (else + (let ((d (path-directory s))) + (cond + ((string=? d "/") + (boundary pos pos (if (null? res) '("/") res))) + ((string=? d ".") + (boundary pos pos res)) + (else (boundary pos pos (cons "/" (cons d res)))))))))) + ;; start with boundary if abs path, otherwise inside + (if (zero? len) + path + ((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '())))) + +(define (make-path . args) + (define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "not a valid path component" x)))) + (define (trim-trailing-slash s) + (let ((i (string-skip-right #\/ s))) + (if i (substring s 0 (+ i 1)) ""))) + (if (null? args) + "" + (let ((start (trim-trailing-slash (x->string (car args))))) + (let lp ((ls (cdr args)) + (res (if (string=? "" start) '() (list start)))) + (cond + ((null? ls) + (apply string-append (reverse res))) + ((pair? (car ls)) + (lp (append (car ls) (cdr ls)) res)) + (else + (let ((x (trim-trailing-slash (x->string (car ls))))) + (lp (cdr ls) + (if (string=? x "") res (cons x (cons "/" res))))))))))) diff --git a/lib/chibi/process.module b/lib/chibi/process.module new file mode 100644 index 00000000..372b56e4 --- /dev/null +++ b/lib/chibi/process.module @@ -0,0 +1,18 @@ + +(define-module (chibi process) + (export exit sleep alarm fork kill execute waitpid + set-signal-action! make-signal-set signal-set-contains? + signal-set-fill! signal-set-add! signal-set-delete! + current-signal-mask + signal-mask-block! signal-mask-unblock! signal-mask-set! + signal/hang-up signal/interrupt signal/quit + signal/illegal signal/abort signal/fpe + signal/kill signal/segv signal/pipe + signal/alarm signal/term signal/user1 + signal/user2 signal/child signal/continue + signal/stop signal/tty-stop signal/tty-input + signal/tty-output) + (import-immutable (scheme)) + (cond-expand (threads (import (srfi 18))) (else #f)) + (include-shared "process")) + diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub new file mode 100644 index 00000000..93b08d95 --- /dev/null +++ b/lib/chibi/process.stub @@ -0,0 +1,73 @@ + +(c-system-include "sys/types.h") +(c-system-include "sys/wait.h") +(c-system-include "signal.h") +(c-system-include "unistd.h") + +(define-c-type siginfo_t + predicate: signal-info? + (int si_signo signal-number) + (int si_errno signal-error-number) + (int si_code signal-code) + (pid_t si_pid signal-pid) + (uid_t si_uid signal-uid) + (int si_status signal-status) + ;;(clock_t si_utime signal-user-time) + ;;(clock_t si_stime signal-system-time) + ) + +(define-c-type sigset_t + predicate: signal-set?) + +(define-c-const int (signal/hang-up "SIGHUP")) +(define-c-const int (signal/interrupt "SIGINT")) +(define-c-const int (signal/quit "SIGQUIT")) +(define-c-const int (signal/illegal "SIGILL")) +(define-c-const int (signal/abort "SIGABRT")) +(define-c-const int (signal/fpe "SIGFPE")) +(define-c-const int (signal/kill "SIGKILL")) +(define-c-const int (signal/segv "SIGSEGV")) +(define-c-const int (signal/pipe "SIGPIPE")) +(define-c-const int (signal/alarm "SIGALRM")) +(define-c-const int (signal/term "SIGTERM")) +(define-c-const int (signal/user1"SIGUSR1")) +(define-c-const int (signal/user2 "SIGUSR2")) +(define-c-const int (signal/child "SIGCHLD")) +(define-c-const int (signal/continue "SIGCONT")) +(define-c-const int (signal/stop "SIGSTOP")) +(define-c-const int (signal/tty-stop "SIGTSTP")) +(define-c-const int (signal/tty-input "SIGTTIN")) +(define-c-const int (signal/tty-output "SIGTTOU")) + +(c-include "signal.c") + +(define-c sexp (set-signal-action! "sexp_set_signal_action") + ((value ctx sexp) (value self sexp) sexp sexp)) + +(define-c errno (make-signal-set "sigemptyset") ((pointer result sigset_t))) +(define-c errno (signal-set-fill! "sigfillset") ((pointer sigset_t))) +(define-c errno (signal-set-add! "sigaddset") ((pointer sigset_t) int)) +(define-c errno (signal-set-delete! "sigaddset") ((pointer sigset_t) int)) +(define-c boolean (signal-set-contains? "sigismember") ((pointer sigset_t) int)) + +(define-c errno (signal-mask-block! "sigprocmask") + ((value SIG_BLOCK int) (pointer sigset_t) (pointer value NULL sigset_t))) +(define-c errno (signal-mask-unblock! "sigprocmask") + ((value SIG_UNBLOCK int) (pointer sigset_t) (pointer value NULL sigset_t))) +(define-c errno (signal-mask-set! "sigprocmask") + ((value SIG_SETMASK int) (pointer sigset_t) (pointer value NULL sigset_t))) +(define-c errno (current-signal-mask "sigprocmask") + ((value SIG_BLOCK int) (pointer value NULL sigset_t) (pointer result sigset_t))) + +(define-c unsigned-int alarm (unsigned-int)) +(define-c unsigned-int sleep (unsigned-int)) + +(define-c pid_t fork ()) +;;(define-c pid_t wait ((result int))) +(define-c pid_t waitpid (int (result int) int)) +(define-c errno kill (int int)) +;;(define-c errno raise (int)) +(define-c void exit (int)) +(define-c int (execute execvp) (string (array string))) + +(c-init "sexp_init_signals(ctx, env);") diff --git a/lib/chibi/quoted-printable.module b/lib/chibi/quoted-printable.module new file mode 100644 index 00000000..9cbec430 --- /dev/null +++ b/lib/chibi/quoted-printable.module @@ -0,0 +1,7 @@ + +(define-module (chibi quoted-printable) + (export quoted-printable-encode quoted-printable-encode-string + quoted-printable-encode-header + quoted-printable-decode quoted-printable-decode-string) + (import-immutable (scheme) (srfi 33) (chibi io)) + (include "quoted-printable.scm")) diff --git a/lib/chibi/quoted-printable.scm b/lib/chibi/quoted-printable.scm new file mode 100644 index 00000000..80709026 --- /dev/null +++ b/lib/chibi/quoted-printable.scm @@ -0,0 +1,157 @@ +;; quoted-printable.scm -- RFC2045 implementation +;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Procedure: quoted-printable-encode-string str [start-col max-col] +;; Return a quoted-printable encoded representation of string +;; according to the official standard as described in RFC2045. +;; +;; ? and _ are always encoded for compatibility with RFC1522 encoding, +;; and soft newlines are inserted as necessary to keep each lines +;; length less than MAX-COL (default 76). The starting column may be +;; overridden with START-COL (default 0). + +;; Procedure: quoted-printable-decode-string str [mime?] +;; Return a quoted-printable decoded representation of string. If +;; MIME? is specified and true, _ will be decoded as as space in +;; accordance with RFC1522. No errors will be raised on invalid +;; input. + +;; Procedure: quoted-printable-encode [port start-col max-col] +;; Procedure: quoted-printable-decode [port start-col max-col] +;; Variations of the above which read and write to ports. + +;; Procedure: quoted-printable-encode-header enc str [start-col max-col] +;; Return a quoted-printable encoded representation of string as +;; above, wrapped in =?ENC?Q?...?= as per RFC1522, split across +;; multiple MIME-header lines as needed to keep each lines length less +;; than MAX-COL. The string is encoded as is, and the encoding ENC is +;; just used for the prefix, i.e. you are responsible for ensuring STR +;; is already encoded according to ENC. + +;; Example: + +;; (define (mime-encode-header header value charset) +;; (let ((prefix (string-append header ": ")) +;; (str (ces-convert value "UTF8" charset))) +;; (string-append +;; prefix +;; (quoted-printable-encode-header charset str (string-length prefix))))) + +;; This API is backwards compatible with the Gauche library +;; rfc.quoted-printable. + +(define *default-max-col* 76) + +;; Allow for RFC1522 quoting for headers by always escaping ? and _ +(define (qp-encode str start-col max-col separator) + (define (hex i) (integer->char (+ i (if (<= i 9) 48 55)))) + (let ((end (string-length str)) + (buf (make-string max-col))) + (let lp ((i 0) (col start-col) (res '())) + (cond + ((= i end) + (if (pair? res) + (string-concatenate (reverse (cons (substring buf 0 col) res)) + separator) + (substring buf start-col col))) + ((>= col (- max-col 3)) + (lp i 0 (cons (substring buf (if (pair? res) 0 start-col) col) res))) + (else + (let ((c (char->integer (string-ref str i)))) + (cond + ((and (<= 33 c 126) (not (memq c '(61 63 95)))) + (string-set! buf col (integer->char c)) + (lp (+ i 1) (+ col 1) res)) + (else + (string-set! buf col #\=) + (string-set! buf (+ col 1) (hex (arithmetic-shift c -4))) + (string-set! buf (+ col 2) (hex (bitwise-and c #b1111))) + (lp (+ i 1) (+ col 3) res))))))))) + +(define (quoted-printable-encode-string . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*))) + (qp-encode (if (string? src) src (read-string #f src)) + start-col max-col "=\r\n"))) + +(define (quoted-printable-encode . o) + (display (apply (quoted-printable-encode-string o)))) + +(define (quoted-printable-encode-header encoding . o) + (let ((src (if (pair? o) (car o) (current-input-port))) + (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) + (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) + (caddr o) + *default-max-col*)) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdddr o))) + (cadddr o) + "\r\n"))) + (let* ((prefix (string-append "=?" encoding "?Q?")) + (prefix-length (+ 2 (string-length prefix))) + (separator (string-append "?=" nl "\t" prefix)) + (effective-max-col (- max-col prefix-length))) + (string-append prefix + (qp-encode (if (string? src) src (read-string #f src)) + start-col effective-max-col separator) + "?=")))) + +(define (quoted-printable-decode-string . o) + (define (hex? c) (or (char-numeric? c) (<= 65 (char->integer c) 70))) + (define (unhex1 c) + (let ((i (char->integer c))) (if (>= i 65) (- i 55) (- i 48)))) + (define (unhex c1 c2) + (integer->char (+ (arithmetic-shift (unhex1 c1) 4) (unhex1 c2)))) + (let ((src (if (pair? o) (car o) (current-input-port))) + (mime-header? (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (let* ((str (if (string? src) src (read-string #f src))) + (end (string-length str))) + (call-with-output-string + (lambda (out) + (let lp ((i 0)) + (cond + ((< i end) + (let ((c (string-ref str i))) + (case c + ((#\=) ; = escapes + (cond + ((< (+ i 2) end) + (let ((c2 (string-ref str (+ i 1)))) + (cond + ((eq? c2 #\newline) (lp (+ i 2))) + ((eq? c2 #\return) + (lp (if (eq? (string-ref str (+ i 2)) #\newline) + (+ i 3) + (+ i 2)))) + ((hex? c2) + (let ((c3 (string-ref str (+ i 2)))) + (if (hex? c3) (write-char (unhex c2 c3) out)) + (lp (+ i 3)))) + (else (lp (+ i 3)))))))) + ((#\_) ; maybe translate _ to space + (write-char (if mime-header? #\space c) out) + (lp (+ i 1))) + ((#\space #\tab) ; strip trailing whitespace + (let lp2 ((j (+ i 1))) + (cond + ((not (= j end)) + (case (string-ref str j) + ((#\space #\tab) (lp2 (+ j 1))) + ((#\newline) + (lp (+ j 1))) + ((#\return) + (let ((k (+ j 1))) + (lp (if (and (< k end) + (eqv? #\newline (string-ref str k))) + (+ k 1) k)))) + (else (display (substring str i j) out) (lp j))))))) + (else ; a literal char + (write-char c out) + (lp (+ i 1))))))))))))) + +(define (quoted-printable-decode . o) + (display (apply quoted-printable-decode-string o))) + diff --git a/lib/chibi/repl.module b/lib/chibi/repl.module new file mode 100644 index 00000000..742b9581 --- /dev/null +++ b/lib/chibi/repl.module @@ -0,0 +1,9 @@ + +(define-module (chibi repl) + (export repl) + (import-immutable (scheme)) + (import (chibi ast) + (chibi process) + (chibi term edit-line) + (srfi 18)) + (include "repl.scm")) diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm new file mode 100644 index 00000000..b7ff79bc --- /dev/null +++ b/lib/chibi/repl.scm @@ -0,0 +1,41 @@ +;;;; repl.scm - friendlier repl with line editing and signal handling +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-syntax handle-exceptions + (syntax-rules () + ((handle-exceptions exn handler expr) + (call-with-current-continuation + (lambda (return) + (with-exception-handler (lambda (exn) (return handler)) + (lambda () expr))))))) + +(define (with-signal-handler sig handler thunk) + (let ((old-handler #f)) + (dynamic-wind + (lambda () (set! old-handler (set-signal-action! sig handler))) + thunk + (lambda () (set-signal-action! sig old-handler))))) + +(define (run-repl module env) + (let ((line (edit-line (if module (string-append (symbol->string module) "> ") "> ")))) + (cond + ((or (not line) (eof-object? line))) + ((equal? line "") (run-repl module env)) + (else + (handle-exceptions exn (print-exception exn (current-error-port)) + (let* ((expr (call-with-input-string line read)) + (thread (make-thread (lambda () + (let ((res (eval expr env))) + (if (not (eq? res (if #f #f))) + (write res))))))) + (with-signal-handler + signal/interrupt + (lambda (n) (thread-terminate! thread)) + (lambda () (thread-start! thread) (thread-join! thread))))) + (newline) + (run-repl module env))))) + +(define (repl) + (run-repl #f (interaction-environment))) diff --git a/lib/chibi/scribble.module b/lib/chibi/scribble.module new file mode 100644 index 00000000..b479eb64 --- /dev/null +++ b/lib/chibi/scribble.module @@ -0,0 +1,5 @@ + +(define-module (chibi scribble) + (export scribble-parse scribble-read) + (import-immutable (scheme)) + (include "scribble.scm")) diff --git a/lib/chibi/scribble.scm b/lib/chibi/scribble.scm new file mode 100644 index 00000000..1e4f15cd --- /dev/null +++ b/lib/chibi/scribble.scm @@ -0,0 +1,247 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; general character utils + +(define (char-mirror ch) + (case ch ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else ch))) + +(define (char-delimiter? ch) + (or (eof-object? ch) (char-whitespace? ch) + (memv ch '(#\( #\) #\[ #\] #\{ #\} #\" #\|)))) + +(define (char-punctuation? ch) + (memv ch '(#\- #\+ #\! #\< #\> #\[ #\] #\|))) + +(define (char-digit ch) (- (char->integer ch) (char->integer #\0))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; list utils + +(define (drop ls n) (if (<= n 0) ls (drop (cdr ls) (- n 1)))) + +(define (drop-while pred ls) + (if (or (null? ls) (not (pred (car ls)))) ls (drop-while pred (cdr ls)))) + +(define (list-prefix? prefix ls) + (cond ((null? prefix) #t) + ((null? ls) #f) + ((equal? (car prefix) (car ls)) (list-prefix? (cdr prefix) (cdr ls))) + (else #f))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; scribble reader (standalone, don't use the native reader) + +(define scribble-dot (list ".")) +(define scribble-close (list ")")) + +(define (if-peek-char ch in pass fail) + (cond ((eqv? ch (peek-char in)) (read-char in) pass) (else fail))) + +(define (skip-line in) + (do ((c #f (read-char in))) ((or (eof-object? c) (eqv? c #\newline))))) + +(define (read-float-tail in acc) + (let lp ((res acc) (k 0.1)) + (let ((ch (read-char in))) + (cond ((or (eof-object? ch) (char-delimiter? ch)) res) + ((char-numeric? ch) (lp (+ res (* k (char-digit ch))) (* k 0.1))) + (else (error "invalid numeric syntax")))))) + +(define (read-number in acc base) + (let lp ((acc acc)) + (let ((ch (peek-char in))) + (cond + ((or (eof-object? ch) (char-delimiter? ch)) acc) + ((char-numeric? ch) (read-char in) (lp (+ (* acc base) (char-digit ch)))) + ((eqv? #\. ch) + (read-char in) + (if (= base 10) + (begin (read-char in) (read-float-tail in (exact->inexact acc))) + (error "non-base-10 floating point"))) + (else (error "invalid numeric syntax")))))) + +(define (read-escaped in terminal) + (let lp ((ls '())) + (let ((ch (read-char in))) + (cond + ((or (eof-object? ch) (eqv? ch terminal)) (list->string (reverse ls))) + ((eqv? ch #\\) (lp (cons (read-char in) ls))) + (else (lp (cons ch ls))))))) + +(define (read-symbol in ls) + (do ((ls ls (cons c ls)) (c (peek-char in) (peek-char in))) + ((char-delimiter? c) (string->symbol (list->string (reverse ls)))) + (read-char in))) + +(define (scrib-read in) + (define ch (read-char in)) + (cond + ((eof-object? ch) ch) + ((char-whitespace? ch) (scrib-read in)) + (else + (case ch + ((#\( #\[ #\{) + (let lp ((res '())) + (let ((x (scrib-read in))) + (cond ((eof-object? x) (error "unterminated list" x)) + ((eq? x scribble-close) (reverse res)) + ((eq? x scribble-dot) + (let ((y (scrib-read in))) + (if (or (eof-object? y) (eq? y scribble-close)) + (error "unterminated dotted list") + (let ((z (scrib-read in))) + (if (not (eq? z scribble-close)) + (error "dot in non-terminal position in list" y z) + (append (reverse res) y)))))) + (else (lp (cons x res))))))) + ((#\} #\] #\)) scribble-close) + ((#\.) (if (char-delimiter? (peek-char in)) scribble-dot (read-float-tail in 0.0))) + ((#\') (list 'quote (scrib-read in))) + ((#\`) (list 'quasiquote (scrib-read in))) + ((#\,) (list (if-peek-char #\@ in 'unquote-splicing 'unquote) (scrib-read in))) + ((#\@) (scribble-parse-escape in #\@)) + ((#\;) (skip-line in) (scrib-read in)) + ((#\|) (string->symbol (read-escaped in #\|))) + ((#\") (read-escaped in #\")) + ((#\+ #\-) + (cond ((char-numeric? (peek-char in)) + ((if (eqv? ch #\+) + -) 0 (read-number in 0 10))) + (else (read-symbol in (list ch))))) + ((#\#) + (case (peek-char in) + ((#\t #\f) (eqv? (read-char in) #\t)) + ((#\() (list->vector (scrib-read in))) + ((#\\) + (read-char in) + (if (char-alphabetic? (peek-char in)) + (let ((name (scrib-read in))) + (case name + ((space) #\space) ((newline) #\newline) + (else (string-ref (symbol->string name) 0)))) + (read-char in))) + (else (error "unknown # syntax")))) + (else + (if (char-numeric? ch) + (read-number in (char-digit ch) 10) + (read-symbol in (list ch)))))))) + +(define (scribble-read in) + (let ((res (scrib-read in))) + (cond ((eq? res scribble-dot) (error "invalid . in source")) + ((eq? res scribble-close) (error "too many )'s")) + (else res)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; scribble parser + +(define (read-punctuation in) + (if (not (eqv? #\| (peek-char in))) + '() + (let lp ((ls '())) + (let ((c (peek-char in))) + (cond ((or (eof-object? c) (not(char-punctuation? c))) ls) + (else (lp (cons (char-mirror (read-char in)) ls)))))))) + +(define (read-prefix-wrapper in) + (let lp ((wrap (lambda (x) x))) + (case (peek-char in) + ((#\') (read-char in) (lp (lambda (x) (wrap (list 'quote x))))) + ((#\`) (read-char in) (lp (lambda (x) (wrap (list 'quasiquote x))))) + ((#\,) + (read-char in) + (cond ((eqv? #\@ (peek-char in)) + (read-char in) + (lp (lambda (x) (wrap (list 'unquote-splicing x))))) + (else (lp (lambda (x) (wrap (list 'unquote x))))))) + (else wrap)))) + +(define (scribble-parse-escape in ec) + (define bracket-char #\[) + (define brace-char #\{) + (let* ((wrap (read-prefix-wrapper in)) + (c (peek-char in)) + (cmd (if (or (eqv? c bracket-char) (eqv? c brace-char)) '() (list (scribble-read in)))) + (data? (eqv? (peek-char in) bracket-char)) + (data (if data? (scribble-read in) '())) + (punc (read-punctuation in)) + (body? (eqv? (peek-char in) brace-char)) + (body (cond (body? (read-char in) (scribble-parse in punc ec)) (else '())))) + (wrap (if (or data? body?) (append cmd data body) (car cmd))))) + +(define (scribble-parse in . o) + (define init-punc (if (pair? o) (car o) '())) + (define escape-char (if (and (pair? o) (pair? (cdr o))) (cadr o) #\@)) + (define comment-char #\;) + (define bracket-char #\[) + (define brace-char #\{) + (define close-bracket-char (char-mirror bracket-char)) + (define close-brace-char (char-mirror brace-char)) + (define (collect str res) + (if (pair? str) (cons (list->string (reverse str)) res) res)) + (define (skip-space in) + (let ((ch (peek-char in))) + (cond ((char-whitespace? ch) (read-char in) (skip-space in)) + ((eqv? ch #\;) (skip-line in) (skip-space in))))) + (define (tok str res punc depth) + (let ((c (read-char in))) + (cond + ((eof-object? c) + (if (zero? depth) + (reverse (collect str res)) + (error "unterminated expression" punc))) + ((and (eqv? c escape-char) (list-prefix? punc str)) + (let ((c (peek-char in))) + (cond + ((eof-object? c) + (tok str res punc depth)) + ((char-whitespace? c) + (tok (cons c str) res punc depth)) + ((eqv? c comment-char) + (read-char in) + (cond ((eqv? brace-char (peek-char in)) + (scribble-parse-escape in escape-char)) + (else + (skip-line in) + (let lp () + (cond ((char-whitespace? (peek-char in)) (read-char in) (lp)))))) + (tok str res punc depth)) + ((eqv? c #\|) + (read-char in) + (let lp ((ls (collect str res))) + (skip-space in) + (cond ((eqv? #\| (peek-char in)) (read-char in) (tok '() ls punc depth)) + (else (lp (cons (scribble-read in) ls)))))) + (else + (let ((str (drop str (length punc))) + (x (scribble-parse-escape in escape-char))) + (if (string? x) + (tok (append (reverse (string->list x)) str) res punc depth) + (tok '() (cons x (collect str res)) punc depth))))))) + ((eqv? c brace-char) + (tok (cons c str) res punc (+ depth 1))) + ((eqv? c close-brace-char) + (cond + ((zero? depth) + (let lp ((p punc) (ls '())) + (cond ((null? p) + (reverse (collect str res))) + ((not (eqv? (car p) (peek-char in))) + (tok (append ls (cons c str)) res punc (- depth 1))) + (else + (lp (cdr p) (cons (read-char in) ls)))))) + (else (tok (cons c str) res punc (- depth 1))))) + ((eqv? c #\newline) + (let* ((first? (and (null? res) (null? str))) + (res (collect (drop-while char-whitespace? str) res)) + (res (if (or first? (eqv? #\} (peek-char in))) + res + (cons "\n" res)))) + (let lp ((ls '())) + (let ((c (peek-char in))) + (cond + ((char-whitespace? c) (read-char in) (lp (cons c ls))) + (else (tok (if (eqv? c #\}) ls '()) res punc depth))))))) + (else + (tok (cons c str) res punc depth))))) + ;; begin + (tok '() '() init-punc 0)) diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c new file mode 100644 index 00000000..7202d96e --- /dev/null +++ b/lib/chibi/signal.c @@ -0,0 +1,76 @@ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_MAX_SIGNUM 32 + +static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM]; + +static struct sigaction call_sigaction, call_sigdefault, call_sigignore; + +static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { + sexp ctx; +#if ! SEXP_USE_GREEN_THREADS + sexp sigctx, handler; + sexp_gc_var1(args); +#endif + ctx = sexp_signal_contexts[signum]; + if (ctx) { +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = + (sexp) ((sexp_uint_t)sexp_global(ctx, SEXP_G_THREADS_SIGNALS) + | (sexp_uint_t)sexp_make_fixnum(1UL< 0 + && sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM)) + return sexp_xtype_exception(ctx, self, "not a valid signal number", signum); + if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction) + || sexp_booleanp(newaction))) + return sexp_type_exception(ctx, self, SEXP_PROCEDURE, newaction); + if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS))) + sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS) + = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE); + oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); + res = sigaction(sexp_unbox_fixnum(signum), + (sexp_booleanp(newaction) ? + (sexp_truep(newaction) ? &call_sigdefault : &call_sigignore) + : &call_sigaction), + NULL); + if (res) + return sexp_user_exception(ctx, self, "couldn't set signal", signum); + sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction); + sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx; + return oldaction; +} + +static void sexp_init_signals (sexp ctx, sexp env) { + call_sigaction.sa_sigaction = sexp_call_sigaction; +#if SEXP_USE_GREEN_THREADS + call_sigaction.sa_flags = SA_SIGINFO | SA_RESTART /* | SA_NODEFER */; + sigfillset(&call_sigaction.sa_mask); +#else + call_sigaction.sa_flags = SA_SIGINFO | SA_RESTART | SA_NODEFER; +#endif + call_sigdefault.sa_handler = SIG_DFL; + call_sigignore.sa_handler = SIG_IGN; + memset(sexp_signal_contexts, 0, sizeof(sexp_signal_contexts)); +} diff --git a/lib/chibi/stty.module b/lib/chibi/stty.module new file mode 100644 index 00000000..4540cb18 --- /dev/null +++ b/lib/chibi/stty.module @@ -0,0 +1,11 @@ + +(define-module (chibi stty) + (export stty with-stty with-raw-io + get-terminal-width get-terminal-dimensions + TCSANOW TCSADRAIN TCSAFLUSH) + (import-immutable (scheme) + (srfi 33) + (srfi 69)) + (include-shared "stty") + (include "stty.scm")) + diff --git a/lib/chibi/stty.scm b/lib/chibi/stty.scm new file mode 100644 index 00000000..b4aee004 --- /dev/null +++ b/lib/chibi/stty.scm @@ -0,0 +1,235 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; symbolic representation of attributes + +(define stty-lookup (make-hash-table eq?)) + +(for-each + (lambda (c) + (let ((type (cadr c)) + (value (caddr c))) + (hash-table-set! stty-lookup (car c) (cdr c)))) + + ;; ripped from the stty man page, then trimmed down to what seemed + ;; available on most systems + + `(;; characters + ;;(dsusp char ,VDSUSP) ; CHAR will send a terminal stop signal + (eof char ,VEOF) ; CHAR will send an EOF (terminate input) + (eol char ,VEOL) ; CHAR will end the line + (eol2 char ,VEOL2) ; alternate CHAR for ending the line + (erase char ,VERASE) ; CHAR will erase the last character typed + (intr char ,VINTR) ; CHAR will send an interrupt signal + (kill char ,VKILL) ; CHAR will erase the current line + (lnext char ,VLNEXT) ; CHAR will enter the next character quoted + (quit char ,VQUIT) ; CHAR will send a quit signal + (rprnt char ,VREPRINT) ; CHAR will redraw the current line + (start char ,VSTART) ; CHAR will restart output after stopping it + (stop char ,VSTOP) ; CHAR will stop the output + (susp char ,VSUSP) ; CHAR will send a terminal stop signal + (werase char ,VWERASE) ; CHAR will erase the last word typed + + ;; special settings + (cols special #f) ; tell the kernel that the terminal has N columns + (columns special #f) ; same as cols N + (ispeed special #f) ; set the input speed to N + (line special #f) ; use line discipline N + (min special #f) ; with -icanon, set N characters minimum for a completed read + (ospeed special #f) ; set the output speed to N + (rows special #f) ; tell the kernel that the terminal has N rows + (size special #f) ; print the number of rows and columns according to the kernel + (speed special #f) ; print the terminal speed + (time special #f) ; with -icanon, set read timeout of N tenths of a second + + ;; control settings + (clocal control ,CLOCAL) ; disable modem control signals + (cread control ,CREAD) ; allow input to be received + (crtscts control ,CRTSCTS) ; enable RTS/CTS handshaking + (cs5 control ,CS5) ; set character size to 5 bits + (cs6 control ,CS6) ; set character size to 6 bits + (cs7 control ,CS7) ; set character size to 7 bits + (cs8 control ,CS8) ; set character size to 8 bits + (cstopb control ,CSTOPB) ; use two stop bits per character (one with `-') + (hup control ,HUPCL) ; send a hangup signal when the last process closes the tty + (hupcl control ,HUPCL) ; same as [-]hup + (parenb control ,PARENB) ; generate parity bit in output and expect parity bit in input + (parodd control ,PARODD) ; set odd parity (even with `-') + + ;; input settings + (brkint input ,BRKINT) ; breaks cause an interrupt signal + (icrnl input ,ICRNL) ; translate carriage return to newline + (ignbrk input ,IGNBRK) ; ignore break characters + (igncr input ,IGNCR) ; ignore carriage return + (ignpar input ,IGNPAR) ; ignore characters with parity errors + (imaxbel input ,IMAXBEL) ; * beep and do not flush a full input buffer on a character + (inlcr input ,INLCR) ; translate newline to carriage return + (inpck input ,INPCK) ; enable input parity checking + (istrip input ,ISTRIP) ; clear high (8th) bit of input characters + ;;(iuclc input ,IUCLC) ; * translate uppercase characters to lowercase + (ixany input ,IXANY) ; * let any character restart output, not only start character + (ixoff input ,IXOFF) ; enable sending of start/stop characters + (ixon input ,IXON) ; enable XON/XOFF flow control + (parmrk input ,PARMRK) ; mark parity errors (with a 255-0-character sequence) + (tandem input ,IXOFF) ; same as [-]ixoff + + ;; output settings + ;;(bs0 output ,BS0) ; backspace delay style, N in [0..1] + ;;(bs1 output ,BS1) ; backspace delay style, N in [0..1] + ;;(cr0 output ,CR0) ; carriage return delay style, N in [0..3] + ;;(cr1 output ,CR1) ; carriage return delay style, N in [0..3] + ;;(cr2 output ,CR2) ; carriage return delay style, N in [0..3] + ;;(cr3 output ,CR3) ; carriage return delay style, N in [0..3] + ;;(ff0 output ,FF0) ; form feed delay style, N in [0..1] + ;;(ff1 output ,FF1) ; form feed delay style, N in [0..1] + ;;(nl0 output ,NL0) ; newline delay style, N in [0..1] + ;;(nl1 output ,NL1) ; newline delay style, N in [0..1] + (ocrnl output ,OCRNL) ; translate carriage return to newline + ;;(ofdel output ,OFDEL) ; use delete characters for fill instead of null characters + ;;(ofill output ,OFILL) ; use fill (padding) characters instead of timing for delays + ;;(olcuc output ,OLCUC) ; translate lowercase characters to uppercase + (onlcr output ,ONLCR) ; translate newline to carriage return-newline + (onlret output ,ONLRET) ; newline performs a carriage return + (onocr output ,ONOCR) ; do not print carriage returns in the first column + (opost output ,OPOST) ; postprocess output + (tab0 output #f) ; horizontal tab delay style, N in [0..3] + (tab1 output #f) ; horizontal tab delay style, N in [0..3] + (tab2 output #f) ; horizontal tab delay style, N in [0..3] + (tab3 output #f) ; horizontal tab delay style, N in [0..3] + (tabs output #f) ; same as tab0 + ;;(-tabs output #f) ; same as tab3 + ;;(vt0 output ,VT0) ; vertical tab delay style, N in [0..1] + ;;(vt1 output ,VT1) ; vertical tab delay style, N in [0..1] + + ;; local settings + (crterase local ,ECHOE) ; echo erase characters as backspace-space-backspace + (crtkill local ,ECHOKE) ; kill all line by obeying the echoprt and echoe settings + ;;(-crtkill local #f) ; kill all line by obeying the echoctl and echok settings + (ctlecho local ,ECHOCTL) ; echo control characters in hat notation (`^c') + (echo local ,ECHO) ; echo input characters + (echoctl local ,ECHOCTL) ; same as [-]ctlecho + (echoe local ,ECHOE) ; same as [-]crterase + ;;(echok local ,ECHOK) ; echo a newline after a kill character + (echoke local ,ECHOKE) ; same as [-]crtkill + (echonl local ,ECHONL) ; echo newline even if not echoing other characters + (echoprt local ,ECHOPRT) ; echo erased characters backward, between `\' and '/' + (icanon local ,ICANON) ; enable erase, kill, werase, and rprnt special characters + ;;(iexten local ,IEXTEN) ; enable non-POSIX special characters + (isig local ,ISIG) ; enable interrupt, quit, and suspend special characters + (noflsh local ,NOFLSH) ; disable flushing after interrupt and quit special characters + (prterase local ,ECHOPRT) ; same as [-]echoprt + (tostop local ,TOSTOP) ; stop background jobs that try to write to the terminal + ;;(xcase local ,XCASE) ; with icanon, escape with `\' for uppercase characters + + ;; combination settings + (LCASE combine (lcase)) + (cbreak combine (not icanon)) + (cooked combine (brkint ignpar istrip icrnl ixon opost isig icanon)) + ; also eof and eol characters + ; to their default values + (crt combine (echoe echoctl echoke)) + (dec combine (echoe echoctl echoke (not ixany))) + ; also intr ^c erase 0177 kill ^u + (decctlq combine (ixany)) + (ek combine ()) ; erase and kill characters to their default values + (evenp combine (parenb (not parodd) cs7)) + ;;(-evenp combine #f) ; same as -parenb cs8 + (lcase combine (xcase iuclc olcuc)) + (litout combine (cs8 (not parenb istrip opost))) + ;;(-litout combine #f) ; same as parenb istrip opost cs7 + (nl combine (not icrnl onlcr)) + ;;(-nl combine #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret + (oddp combine (parenb parodd cs7)) + (parity combine (evenp)) ; same as [-]evenp + (pass8 combine (cs8 (not parenb istrip))) + ;;(-pass8 combine #f) ; same as parenb istrip cs7 + (raw combine (not ignbrk brkint ignpar parmrk + inpck istrip inlcr igncr icrnl)) + (ixon combine (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc + ;;(time combine #f) ; 0 + ;;(-raw combine #f) ; same as cooked + (sane combine (cread brkint icrnl imaxbel opost onlcr + isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0 + echo echoe echoctl echoke ;; iexten echok + (not ignbrk igncr ixoff ixany inlcr ;; iuclc + ocrnl onocr onlret ;; olcuc ofill ofdel + echonl noflsh tostop echoprt))) ;; xcase + ; plus all special characters to + ; their default values + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; high-level interface + +(define (port? x) (or (input-port? x) (output-port? x))) + +(define (stty . args) + (let* ((port (if (and (pair? args) (port? (car args))) + (car args) + (current-output-port))) + (attr (get-terminal-attributes port))) + ;; parse change requests + (let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args)) + (iflag (term-attrs-iflag attr)) + (oflag (term-attrs-oflag attr)) + (cflag (term-attrs-cflag attr)) + (lflag (term-attrs-lflag attr)) + (invert? #f) + (return (lambda (iflag oflag cflag lflag) + (term-attrs-iflag-set! attr iflag) + (term-attrs-oflag-set! attr oflag) + (term-attrs-cflag-set! attr cflag) + (term-attrs-lflag-set! attr lflag) + (set-terminal-attributes! port TCSANOW attr)))) + (define (join old new) + (if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new))) + (cond + ((pair? lst) + (let ((command (car lst))) + (cond + ((pair? command) ;; recurse on sub-expr + (lp command iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((eq? command 'not) ;; toggle current setting + (lp (cdr lst) iflag oflag cflag lflag (not invert?) return)) + (else + (let ((x (hash-table-ref/default stty-lookup command #f))) + (case (and x (car x)) + ((input) + (lp (cdr lst) (join iflag (cadr x)) oflag cflag lflag invert? return)) + ((output) + (lp (cdr lst) iflag (join oflag (cadr x)) cflag lflag invert? return)) + ((control) + (lp (cdr lst) iflag oflag (join cflag (cadr x)) lflag invert? return)) + ((local) + (lp (cdr lst) iflag oflag cflag (join lflag (cadr x)) invert? return)) + ((char) + ;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0)) + (lp (cddr lst) iflag oflag cflag lflag invert? return)) + ((combine) + (lp (cadr x) iflag oflag cflag lflag invert? + (lambda (i o c l) (lp (cdr lst) i o c l invert? return)))) + ((special) + (error "special settings not yet supported" command)) + (else + (error "unknown stty command" command)))))))) + (else + (return iflag oflag cflag lflag)))))) + +(define (with-stty setting thunk . o) + (let* ((port (if (pair? o) (car o) (current-input-port))) + (orig-attrs (get-terminal-attributes port))) + (dynamic-wind + (lambda () (stty setting)) + thunk + (lambda () (set-terminal-attributes! port TCSANOW orig-attrs))))) + +(define (with-raw-io port thunk) + (with-stty '(not icanon echo) thunk port)) + +(define (get-terminal-width x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (winsize-col ws)))) + +(define (get-terminal-dimensions x) + (let ((ws (ioctl x TIOCGWINSZ))) + (and ws (list (winsize-col ws) (winsize-row ws))))) diff --git a/lib/chibi/stty.stub b/lib/chibi/stty.stub new file mode 100644 index 00000000..3c5939c5 --- /dev/null +++ b/lib/chibi/stty.stub @@ -0,0 +1,106 @@ + +(c-system-include "termios.h") +(c-system-include "sys/ioctl.h") + +(define-c-struct termios + predicate: term-attrs? + constructor: (make-term-attrs) + (unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!) + (unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!) + (unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!) + (unsigned-long c_lflag term-attrs-lflag term-attrs-lflag-set!) + ;;(unsigned-char (c_cc 22) term-attrs-cc term-attrs-cc-set!) + (unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!) + (unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!)) + +(define-c-struct winsize + predicate: winsize? + (unsigned-short ws_row winsize-row) + (unsigned-short ws_col winsize-col)) + +(define-c errno ioctl (port-or-fd unsigned-long (result winsize))) + +(define-c-const int TIOCGWINSZ) + +(define-c-const int TCSANOW) +(define-c-const int TCSADRAIN) +(define-c-const int TCSAFLUSH) + +(define-c-const unsigned-long IGNBRK) +(define-c-const unsigned-long BRKINT) +(define-c-const unsigned-long IGNPAR) +(define-c-const unsigned-long PARMRK) +(define-c-const unsigned-long INPCK) +(define-c-const unsigned-long ISTRIP) +(define-c-const unsigned-long INLCR) +(define-c-const unsigned-long IGNCR) +(define-c-const unsigned-long ICRNL) +(define-c-const unsigned-long IXON) +(define-c-const unsigned-long IXOFF) +(define-c-const unsigned-long IXANY) +(define-c-const unsigned-long IMAXBEL) +;; (define-c-const unsigned-long IUCLC) + +(define-c-const unsigned-long OPOST) +(define-c-const unsigned-long ONLCR) +;; (define-c-const unsigned-long OXTABS) +;; (define-c-const unsigned-long ONOEOT) +(define-c-const unsigned-long OCRNL) +;; (define-c-const unsigned-long OLCUC) +(define-c-const unsigned-long ONOCR) +(define-c-const unsigned-long ONLRET) + +(define-c-const unsigned-long CSIZE) +(define-c-const unsigned-long CS5) +(define-c-const unsigned-long CS6) +(define-c-const unsigned-long CS7) +(define-c-const unsigned-long CS8) +(define-c-const unsigned-long CSTOPB) +(define-c-const unsigned-long CREAD) +(define-c-const unsigned-long PARENB) +(define-c-const unsigned-long PARODD) +(define-c-const unsigned-long HUPCL) +(define-c-const unsigned-long CLOCAL) +;; (define-c-const unsigned-long CCTS_OFLOW) +(define-c-const unsigned-long CRTSCTS) +;; (define-c-const unsigned-long CRTS_IFLOW) +;; (define-c-const unsigned-long MDMBUF) + +(define-c-const unsigned-long ECHOKE) +(define-c-const unsigned-long ECHOE) +(define-c-const unsigned-long ECHO) +(define-c-const unsigned-long ECHONL) +(define-c-const unsigned-long ECHOPRT) +(define-c-const unsigned-long ECHOCTL) +(define-c-const unsigned-long ISIG) +(define-c-const unsigned-long ICANON) +;; (define-c-const unsigned-long ALTWERASE) +(define-c-const unsigned-long IEXTEN) +;; (define-c-const unsigned-long EXTPROC) +(define-c-const unsigned-long TOSTOP) +(define-c-const unsigned-long FLUSHO) +;; (define-c-const unsigned-long NOKERNINFO) +(define-c-const unsigned-long PENDIN) +(define-c-const unsigned-long NOFLSH) + +(define-c-const unsigned-long VEOF) +(define-c-const unsigned-long VEOL) +(define-c-const unsigned-long VEOL2) +(define-c-const unsigned-long VERASE) +;; (define-c-const unsigned-long VERASE2) +(define-c-const unsigned-long VWERASE) +(define-c-const unsigned-long VINTR) +(define-c-const unsigned-long VKILL) +(define-c-const unsigned-long VQUIT) +(define-c-const unsigned-long VSUSP) +(define-c-const unsigned-long VSTART) +(define-c-const unsigned-long VSTOP) +;; (define-c-const unsigned-long VDSUSP) +(define-c-const unsigned-long VLNEXT) +(define-c-const unsigned-long VREPRINT) +;; (define-c-const unsigned-long VSTATUS) + +(define-c errno (get-terminal-attributes "tcgetattr") + (port-or-fd (result termios))) +(define-c errno (set-terminal-attributes! "tcsetattr") + (port-or-fd int termios)) diff --git a/lib/chibi/system.module b/lib/chibi/system.module new file mode 100644 index 00000000..adc26ddc --- /dev/null +++ b/lib/chibi/system.module @@ -0,0 +1,15 @@ + +(define-module (chibi system) + (export user-information user-name user-password + user-id user-group-id user-gecos user-home user-shell + current-user-id current-group-id + current-effective-user-id current-effective-group-id + set-current-user-id! set-current-effective-user-id! + set-current-group-id! set-current-effective-group-id! + current-session-id create-session + set-root-directory!) + (import-immutable (scheme)) + (include-shared "system") + ;;(include "system.scm") + ) + diff --git a/lib/chibi/system.stub b/lib/chibi/system.stub new file mode 100644 index 00000000..7d4a836f --- /dev/null +++ b/lib/chibi/system.stub @@ -0,0 +1,34 @@ + +(c-system-include "unistd.h") +(c-system-include "pwd.h") +(c-system-include "sys/types.h") + +(define-c-struct passwd + predicate: user? + (string pw_name user-name) + (string pw_passwd user-password) + (uid_t pw_uid user-id) + (gid_t pw_gid user-group-id) + (string pw_gecos user-gecos) + (string pw_dir user-home) + (string pw_shell user-shell)) + +(define-c uid_t (current-user-id "getuid") ()) +(define-c gid_t (current-group-id "getgid") ()) +(define-c uid_t (current-effective-user-id "geteuid") ()) +(define-c gid_t (current-effective-group-id "getegid") ()) + +(define-c errno (set-current-user-id! "setuid") (uid_t)) +(define-c errno (set-current-effective-user-id! "seteuid") (uid_t)) +(define-c errno (set-current-group-id! "setgid") (gid_t)) +(define-c errno (set-current-effective-group-id! "setegid") (gid_t)) + +(define-c pid_t (current-session-id "getsid") ((default 0 pid_t))) +(define-c pid_t (create-session "setsid") ()) + +(define-c errno (set-root-directory! "chroot") (string)) + +;; (define-c errno getpwuid_r +;; (uid_t (result passwd) (result (array char arg3)) +;; (value 256 int) (result pointer passwd))) + diff --git a/lib/chibi/term/edit-line.module b/lib/chibi/term/edit-line.module new file mode 100644 index 00000000..d8116473 --- /dev/null +++ b/lib/chibi/term/edit-line.module @@ -0,0 +1,5 @@ + +(define-module (chibi term edit-line) + (export edit-line edit-line-repl) + (import-immutable (scheme) (chibi stty) (srfi 9)) + (include "edit-line.scm")) diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm new file mode 100644 index 00000000..1c985919 --- /dev/null +++ b/lib/chibi/term/edit-line.scm @@ -0,0 +1,505 @@ +;;;; edit-line.scm - pure scheme line editing tool +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; vt100 terminal utilities + +(define (terminal-escape out ch arg) + (write-char (integer->char 27) out) + (write-char #\[ out) + (if arg (display arg out)) + (write-char ch out)) + +;; we use zero-based columns +(define (terminal-goto-col out n) (terminal-escape out #\G (+ n 1))) +(define (terminal-up out n) (terminal-escape out #\A n)) +(define (terminal-down out n) (terminal-escape out #\B n)) +(define (terminal-clear-below out) (terminal-escape out #\J #f)) +(define (terminal-clear-right out) (terminal-escape out #\K #f)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; history + +(define maximum-history-size 128) + +(define-record-type history + (%make-history remaining past future) + history? + (remaining history-remaining history-remaining-set!) + (past history-past history-past-set!) + (future history-future history-future-set!)) + +(define (make-history . o) + (%make-history (if (pair? o) (car o) maximum-history-size) '() '())) + +(define (history-current h) + (let ((p (history-past h))) + (and (pair? p) (car p)))) + +(define (history->list h) + (let ((past (history-past h)) (future (history-future h))) + (if (pair? past) (cons (car past) (append future (cdr past))) future))) + +(define (history-flatten! h) + (history-past-set! h (history->list h)) + (history-future-set! h '())) + +(define (drop-last ls) (reverse (cdr (reverse ls)))) + +(define (history-past-push! h x) + (if (positive? (history-remaining h)) + (history-remaining-set! h (- (history-remaining h) 1)) + (if (pair? (history-past h)) + (history-past-set! h (drop-last (history-past h))) + (history-future-set! h (drop-last (history-future h))))) + (history-past-set! h (cons x (history-past h)))) + +(define (history-insert! h x) + (history-flatten! h) + (history-past-push! h x)) + +(define (history-commit! h x) + (cond + ((pair? (history-future h)) + (history-past-set! + h (cons x (append (drop-last (history-future h)) (history-past h)))) + (history-future-set! h '())) + (else + (history-insert! h x)))) + +(define (history-prev! h) + (let ((past (history-past h))) + (and (pair? past) + (pair? (cdr past)) + (begin + (history-future-set! h (cons (car past) (history-future h))) + (history-past-set! h (cdr past)) + (cadr past))))) + +(define (history-next! h) + (let ((future (history-future h))) + (and (pair? future) + (begin + (history-past-set! h (cons (car future) (history-past h))) + (history-future-set! h (cdr future)) + (car future))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; char and string utils + +(define (char-word-constituent? ch) + (or (char-alphabetic? ch) (char-numeric? ch) + (memv ch '(#\_ #\- #\+ #\:)))) + +(define (char-non-word-constituent? ch) (not (char-word-constituent? ch))) + +(define (string-copy! dst dstart src start end) + (if (>= start dstart) + (do ((i start (+ i 1)) (j dstart (+ j 1))) + ((= i end)) + (string-set! dst j (string-ref src i))) + (do ((i (- end 1) (- i 1)) (j (+ dstart (- end start 1)) (- j 1))) + ((< i start)) + (string-set! dst j (string-ref src i))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; buffers + +(define-record-type buffer + (%make-buffer refresh? min pos row max-row col gap width string history) + buffer? + (refresh? buffer-refresh? buffer-refresh?-set!) + (min buffer-min buffer-min-set!) + (pos buffer-pos buffer-pos-set!) + (row buffer-row buffer-row-set!) + (max-row buffer-max-row buffer-max-row-set!) + (col buffer-col buffer-col-set!) + (gap buffer-gap buffer-gap-set!) + (width buffer-width buffer-width-set!) + (string buffer-string buffer-string-set!) + (kill-ring buffer-kill-ring buffer-kill-ring-set!) + (history buffer-history buffer-history-set!)) + +(define default-buffer-size 256) +(define default-buffer-width 80) + +(define (make-buffer) + (%make-buffer #f 0 0 0 0 0 default-buffer-size default-buffer-width + (make-string default-buffer-size) '())) + +(define (buffer->string buf) + (let ((str (buffer-string buf))) + (string-append (substring str (buffer-min buf) (buffer-pos buf)) + (substring str (buffer-gap buf) (string-length str))))) + +(define (buffer-right-length buf) + (- (string-length (buffer-string buf)) (buffer-gap buf))) +(define (buffer-length buf) + (+ (buffer-pos buf) (buffer-right-length buf))) +(define (buffer-free-space buf) + (- (buffer-gap buf) (buffer-pos buf))) + +(define (buffer-clamp buf n) + (max (buffer-min buf) (min n (buffer-length buf)))) + +(define (buffer-resize buf n) + (cond ((<= (buffer-free-space buf) n) + (let* ((right-len (buffer-right-length buf)) + (new-len (* 2 (max n (buffer-length buf)))) + (new-gap (- new-len right-len)) + (new (make-string new-len)) + (old (buffer-string buf))) + (string-copy! new 0 old 0 (buffer-pos buf)) + (string-copy! new new-gap old (buffer-gap buf) (string-length old)) + (buffer-string-set! buf new) + (buffer-gap-set! buf new-gap))))) + +(define (buffer-update-position! buf) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (end (string-length (buffer-string buf))) + (width (buffer-width buf))) + (let lp ((i 0) (row 0) (col 0)) ;; update row/col + (cond ((= i pos) + (buffer-row-set! buf row) + (buffer-col-set! buf col) + (lp gap row col)) + ((>= i end) + (buffer-max-row-set! + buf (if (and (zero? col) (> row 0)) (- row 1) row))) + ((= (+ col 1) width) + (lp (+ i 1) (+ row 1) 0)) + (else + (lp (+ i 1) row (+ col 1))))))) + +(define (buffer-draw buf out) + (let* ((gap (buffer-gap buf)) + (str (buffer-string buf)) + (end (string-length str)) + (old-row (buffer-row buf)) + (old-col (buffer-col buf))) + (buffer-update-position! buf) + ;; goto start of input + (terminal-goto-col out 0) + (if (positive? old-row) + (terminal-up out old-row)) + ;; clear and display new buffer + (terminal-clear-below out) + (display (substring str 0 (buffer-pos buf)) out) + (display (substring str (buffer-gap buf) end) out) + ;; move to next line if point at eol + (if (and (zero? (buffer-col buf)) (positive? (buffer-row buf))) + (write-char #\space out)) + ;; move to correct row then col + (if (< (buffer-row buf) (buffer-max-row buf)) + (terminal-up out (- (buffer-max-row buf) (buffer-row buf)))) + (terminal-goto-col out (buffer-col buf)))) + +(define (buffer-refresh buf out) + (cond ((buffer-refresh? buf) + (buffer-draw buf out) + (buffer-refresh?-set! buf #f)))) + +(define (buffer-goto! buf out n) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (n (buffer-clamp buf n))) + (cond ((not (= n pos)) + (buffer-update-position! buf) ;; XXXX shouldn't be needed + (if (< n pos) + (string-copy! str (- gap (- pos n)) str n pos) + (string-copy! str pos str gap (+ gap (- n pos)))) + (buffer-pos-set! buf n) + (buffer-gap-set! buf (+ gap (- n pos))) + (cond + ((not (buffer-refresh? buf)) + (let ((old-row (buffer-row buf))) + (buffer-update-position! buf) + (let ((row-diff (- old-row (buffer-row buf)))) + (cond ((> row-diff 0) (terminal-up out row-diff)) + ((< row-diff 0) (terminal-down out (- row-diff))))) + (terminal-goto-col out (buffer-col buf))))))))) + +(define (buffer-insert! buf out x) + (let ((len (if (char? x) 1 (string-length x))) + (pos (buffer-pos buf))) + (buffer-resize buf len) + (if (char? x) + (string-set! (buffer-string buf) pos x) + (string-copy! (buffer-string buf) pos x 0 len)) + (buffer-pos-set! buf (+ (buffer-pos buf) len)) + (cond + ((buffer-refresh? buf)) + ((and (= (buffer-gap buf) (string-length (buffer-string buf))) + (< (+ (buffer-col buf) len) (buffer-width buf))) + ;; fast path - append to end of buffer w/o wrapping to next line + (display x out) + (buffer-col-set! buf (+ (buffer-col buf) len))) + (else + (buffer-refresh?-set! buf #t))))) + +(define (buffer-delete! buf out start end) + (let ((pos (buffer-pos buf)) + (gap (buffer-gap buf)) + (str (buffer-string buf)) + (start (buffer-clamp buf start)) + (end (buffer-clamp buf end))) + (if (not (buffer-refresh? buf)) + (if (and (= start pos) (>= end (buffer-length buf))) + (terminal-clear-below out) + (buffer-refresh?-set! buf #t))) + (cond ((< end pos) + (string-copy! str start str end pos) + (buffer-pos-set! buf (+ start (- pos end)))) + ((> start gap) + (string-copy! str start str gap (+ gap (- end start))) + (buffer-gap-set! buf (+ gap (- end start)))) + (else + (buffer-pos-set! buf (min pos start)) + (buffer-gap-set! buf (max gap (+ pos (- gap pos) (- end pos)))))))) + +(define (buffer-skip buf pred) + (let* ((str (buffer-string buf)) (end (string-length str))) + (let lp ((i (buffer-gap buf))) + (if (or (>= i end) (not (pred (string-ref str i)))) + (+ (- i (buffer-gap buf)) (buffer-pos buf)) + (lp (+ i 1)))))) + +(define (buffer-skip-reverse buf pred) + (let ((str (buffer-string buf))) + (let lp ((i (- (buffer-pos buf) 1))) + (if (or (< i 0) (not (pred (string-ref str i)))) i (lp (- i 1)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; keymaps + +(define keymap? pair?) + +(define (make-keymap . o) + (cons (make-vector 256 #f) (and (pair? o) (car o)))) + +(define (make-sparse-keymap . o) + (cons '() (and (pair? o) (car o)))) + +(define (make-printable-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (do ((i #x20 (+ i 1))) ((= i #x7F) keymap) + (vector-set! v i command/self-insert)))) + +(define (make-standard-escape-bracket-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 65 command/backward-history) + (vector-set! v 66 command/forward-history) + (vector-set! v 67 command/forward-char) + (vector-set! v 68 command/backward-char) + keymap)) + +(define (make-standard-escape-keymap) + (let* ((keymap (make-keymap)) + (v (car keymap))) + (vector-set! v 8 command/backward-delete-word) + (vector-set! v 91 (make-standard-escape-bracket-keymap)) + (vector-set! v 98 command/backward-word) + (vector-set! v 100 command/forward-delete-word) + (vector-set! v 102 command/forward-word) + (vector-set! v 127 command/backward-delete-word) + keymap)) + +(define (make-standard-keymap) + (let* ((keymap (make-printable-keymap)) + (v (car keymap))) + (vector-set! v 1 command/beggining-of-line) + (vector-set! v 2 command/backward-char) + (vector-set! v 4 command/forward-delete-char) + (vector-set! v 5 command/end-of-line) + (vector-set! v 6 command/forward-char) + (vector-set! v 8 command/backward-delete-char) + (vector-set! v 10 command/enter) + (vector-set! v 11 command/forward-delete-line) + (vector-set! v 12 command/refresh) + (vector-set! v 13 command/enter) + (vector-set! v 21 command/backward-delete-line) + (vector-set! v 27 (make-standard-escape-keymap)) + (vector-set! v 127 command/backward-delete-char) + keymap)) + +(define (keymap-lookup keymap n) + (let ((table (car keymap))) + (or (if (vector? table) + (and (< n (vector-length table)) (vector-ref table n)) + (cond ((assv n table) => cdr) (else #f))) + (if (keymap? (cdr keymap)) + (keymap-lookup (cdr keymap) n) + (cdr keymap))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; commands + +(define (command/self-insert ch buf out return) + (buffer-insert! buf out ch)) + +(define (command/enter ch buf out return) + (command/end-of-line ch buf out return) + (newline out) + (return)) + +(define (command/beep ch buf out return) + (write-char (integer->char 7) out)) + +(define (command/refresh ch buf out return) + (buffer-draw buf out)) + +(define (command/beggining-of-line ch buf out return) + (buffer-goto! buf out 0)) + +(define (command/end-of-line ch buf out return) + (buffer-goto! buf out (buffer-length buf))) + +(define (command/forward-char ch buf out return) + (buffer-goto! buf out (+ (buffer-pos buf) 1))) + +(define (command/backward-char ch buf out return) + (buffer-goto! buf out (- (buffer-pos buf) 1))) + +(define (command/forward-delete-char ch buf out return) + (cond + ((zero? (- (buffer-length buf) (buffer-min buf))) + (newline out) + (return 'eof)) + (else + (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1))))) + +(define (command/backward-delete-char ch buf out return) + (buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf))) + +(define (command/forward-delete-line ch buf out return) + (buffer-delete! buf out (buffer-pos buf) (buffer-length buf))) + +(define (command/backward-delete-line ch buf out return) + (buffer-delete! buf out 0 (buffer-pos buf))) + +(define (command/backward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-past history))) + (if (null? (history-future history)) + (history-insert! history (buffer->string buf))) + (cond + ((pair? (cdr (history-past history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (buffer-insert! buf out (history-prev! history)))))))) + +(define (command/forward-history ch buf out return) + (let ((history (buffer-history buf))) + (cond + ((and (history? history) (pair? (history-future history))) + (buffer-delete! buf out 0 (buffer-length buf)) + (let ((res (buffer-insert! buf out (history-next! history)))) + (if (null? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + res))))) + +(define (command/forward-word ch buf out return) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-goto! buf out (buffer-skip buf char-word-constituent?))) + +(define (command/backward-word ch buf out return) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (buffer-goto! buf out (+ (buffer-skip-reverse buf char-word-constituent?) 1))) + +(define (command/forward-delete-word ch buf out return) + (let ((start (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip buf char-non-word-constituent?)) + (buffer-delete! buf out start (buffer-skip buf char-word-constituent?)))) + +(define (command/backward-delete-word ch buf out return) + (let ((end (buffer-pos buf))) + (buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?)) + (let ((start (buffer-skip-reverse buf char-word-constituent?))) + (buffer-delete! buf out (+ start 1) end)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; line-editing + +(define standard-keymap (make-standard-keymap)) + +(define (get-key ls key . o) + (let ((x (memq key ls))) + (if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o))))) + +(define (with-leading-ports ls proc) + (if (and (pair? ls) (input-port? (car ls))) + (if (and (pair? (cdr ls)) (output-port? (cadr ls))) + (proc (car ls) (cadr ls) (cddr ls)) + (proc (car ls) (current-output-port) (cdr ls))) + (proc (current-input-port) (current-output-port) ls))) + +(define (make-line-editor . args) + (let* ((prompt (get-key args 'prompt: "> ")) + (history (get-key args 'history:)) + (terminal-width (get-key args 'terminal-width:)) + (keymap (get-key args 'keymap: standard-keymap))) + (lambda (in out) + (let* ((width (or terminal-width (get-terminal-width out))) + (buf (make-buffer)) + (done? #f) + (return (lambda o (set! done? (if (pair? o) (car o) #t))))) + (buffer-refresh?-set! buf #t) + (buffer-width-set! buf width) + (buffer-insert! buf out prompt) + (buffer-min-set! buf (string-length prompt)) + (buffer-history-set! buf history) + (buffer-refresh buf out) + (flush-output out) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp ((kmap keymap)) + (let ((ch (read-char in))) + (if (eof-object? ch) + (let ((res (buffer->string buf))) + (if (equal? res "") ch res)) + (let ((x (keymap-lookup kmap (char->integer ch)))) + (cond + ((keymap? x) + (lp x)) + ((procedure? x) + (x ch buf out return) + (buffer-refresh buf out) + (if done? + (and (not (eq? done? 'eof)) (buffer->string buf)) + (lp keymap))) + (else + ;;(command/beep ch buf out return) + (lp keymap))))))))))))) + +(define (edit-line . args) + (with-leading-ports + args + (lambda (in out rest) ((apply make-line-editor rest) in out)))) + +(define (edit-line-repl . args) + (with-leading-ports + args + (lambda (in out rest) + (let ((eval (get-key rest 'eval: (lambda (x) x))) + (print (get-key rest 'write: write)) + (history (or (get-key rest 'history:) (make-history)))) + (let ((edit-line + (apply make-line-editor 'no-stty?: #t 'history: history rest))) + ((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io) + out + (lambda () + (let lp () + (let ((line (edit-line in out))) + (if (pair? (history-future history)) + (history-past-set! history (cdr (history-past history)))) + (history-commit! history line) + (print (eval line) out) + (newline out) + (lp)))))))))) diff --git a/lib/chibi/test.module b/lib/chibi/test.module new file mode 100644 index 00000000..d8b405f1 --- /dev/null +++ b/lib/chibi/test.module @@ -0,0 +1,14 @@ + +(define-module (chibi test) + (export + test test-error test-assert test-values + test-group current-test-group + test-begin test-end test-syntax-error test-info + test-vars test-run ;;test-exit + current-test-verbosity current-test-epsilon current-test-comparator + current-test-applier current-test-handler current-test-skipper + current-test-group-reporter test-failure-count) + (import-immutable (scheme)) + (import (srfi 39) (srfi 98) (chibi time) (chibi ast)) + (include "test.scm")) + diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm new file mode 100644 index 00000000..bfa7429e --- /dev/null +++ b/lib/chibi/test.scm @@ -0,0 +1,662 @@ +;;;; test.scm -- testing framework +;; +;; Easy to use test suite adapted from the Chicken "test" module. +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exception utilities + +;; from SRFI-12, pending stabilization of an exception library for WG1 +(define-syntax handle-exceptions + (syntax-rules () + ((handle-exceptions exn handler body ...) + (call-with-current-continuation + (lambda (return) + (with-exception-handler + (lambda (exn) (return handler)) + (lambda () body ...))))))) + +(define (warning msg . args) + (display msg (current-error-port)) + (for-each (lambda (x) + (write-char #\space (current-error-port)) + (write x (current-error-port))) + args) + (newline (current-error-port))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utilities + +(define (string-search pat str) + (let* ((pat-len (string-length pat)) + (limit (- (string-length str) pat-len))) + (let lp1 ((i 0)) + (cond + ((>= i limit) #f) + (else + (let lp2 ((j i) (k 0)) + (cond ((>= k pat-len) #t) + ((not (eqv? (string-ref str j) (string-ref pat k))) + (lp1 (+ i 1))) + (else (lp2 (+ j 1) (+ k 1)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; time utilities + +(define (timeval-difference tv1 tv2) + (let ((seconds (- (timeval-seconds tv1) (timeval-seconds tv2))) + (ms (- (timeval-microseconds tv1) (timeval-microseconds tv2)))) + (+ (max seconds 0.0) (/ ms 1000000.0)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; test interface + +(define-syntax test + (syntax-rules () + ((test expect expr) + (test #f expect expr)) + ((test name expect (expr ...)) + (test-info name expect (expr ...) ())) + ((test name (expect ...) expr) + (test-syntax-error + 'test + "the test expression should come last " + (test name (expect ...) expr))) + ((test name expect expr) + (test-info name expect expr ())) + ((test a ...) + (test-syntax-error 'test "2 or 3 arguments required" + (test a ...))))) + +(define-syntax test-assert + (syntax-rules () + ((_ expr) + (test-assert #f expr)) + ((_ name expr) + (test-info name #f expr ((assertion . #t)))) + ((test a ...) + (test-syntax-error 'test-assert "1 or 2 arguments required" + (test a ...))))) + +(define-syntax test-values + (syntax-rules () + ((_ expect expr) + (test-values #f expect expr)) + ((_ name expect expr) + (test name (call-with-values (lambda () expect) (lambda results results)) + (call-with-values (lambda () expr) (lambda results results)))))) + +(define-syntax test-error + (syntax-rules () + ((_ expr) + (test-error #f expr)) + ((_ name expr) + (test-info name #f expr ((expect-error . #t)))) + ((test a ...) + (test-syntax-error 'test-error "1 or 2 arguments required" + (test a ...))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; group interface + +(define-syntax test-group + (syntax-rules () + ((_ name-expr body ...) + (let ((name name-expr) + (old-group (current-test-group))) + (if (not (string? name)) + (error "a name is required, got " 'name-expr name)) + (test-begin name) + (handle-exceptions + exn + (begin + (warning "error in group outside of tests") + (print-exception e (current-error-port)) + (test-group-inc! (current-test-group) 'count) + (test-group-inc! (current-test-group) 'ERROR)) + body ...) + (test-end name) + (current-test-group old-group))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define-syntax test-syntax-error + (syntax-rules () + ((_) (syntax-error "invalid use of test-syntax-error")))) + +(define-syntax test-info + (syntax-rules () + ((test-info name expect expr info) + (test-vars () name expect expr ((source . expr) . info))))) + +(define-syntax test-vars + (syntax-rules () + ((_ (vars ...) n expect expr ((key . val) ...)) + (test-run (lambda () expect) + (lambda () expr) + (cons (cons 'name n) + '((source . expr) + ;;(var-names . (vars ...)) + ;;(var-values . ,(list vars)) + (key . val) ...)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; test-group representation + +;; (name (prop value) ...) +(define (make-test-group name) + (list name + (cons 'start-time (get-time-of-day)))) + +(define test-group-name car) + +(define (test-group-ref group field . o) + (apply assq-ref (cdr group) field o)) + +(define (test-group-set! group field value) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x value))) + (else (set-cdr! group (cons (cons field value) (cdr group)))))) + +(define (test-group-inc! group field) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x (+ 1 (cdr x))))) + (else (set-cdr! group (cons (cons field 1) (cdr group)))))) + +(define (test-group-push! group field value) + (cond ((assq field (cdr group)) + => (lambda (x) (set-cdr! x (cons value (cdr x))))) + (else (set-cdr! group (cons (cons field (list value)) (cdr group)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (assq-ref ls key . o) + (cond ((assq key ls) => cdr) + ((pair? o) (car o)) + (else #f))) + +(define (approx-equal? a b epsilon) + (< (abs (- 1 (abs (if (zero? b) (+ 1 a) (/ a b))))) + epsilon)) + +;; partial pretty printing to abbreviate `quote' forms and the like +(define (write-to-string x) + (call-with-output-string + (lambda (out) + (let wr ((x x)) + (if (pair? x) + (cond + ((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x)) + (assq (car x) + '((quote . "'") (quasiquote . "`") + (unquote . ",") (unquote-splicing . ",@")))) + => (lambda (s) (display (cdr s) out) (wr (cadr x)))) + (else + (display "(" out) + (wr (car x)) + (let lp ((ls (cdr x))) + (cond ((pair? ls) + (display " " out) + (wr (car ls)) + (lp (cdr ls))) + ((not (null? ls)) + (display " . " out) + (write ls out)))) + (display ")" out))) + (write x out)))))) + +;; if we need to truncate, try first dropping let's to get at the +;; heart of the expression +(define (truncate-source x width . o) + (let* ((str (write-to-string x)) + (len (string-length str))) + (cond + ((<= len width) + str) + ((and (pair? x) (eq? 'let (car x))) + (if (and (pair? o) (car o)) + (truncate-source (car (reverse x)) width #t) + (string-append "..." + (truncate-source (car (reverse x)) (- width 3) #t)))) + ((and (pair? x) (eq? 'call-with-current-continuation (car x))) + (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o)))) + ((and (pair? x) (eq? 'call-with-values (car x))) + (string-append + "..." + (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (caadr x))) + (car (reverse (cadr x))) + (cadr x)) + (- width 3) + #t))) + (else + (string-append + (substring str 0 (min (max 0 (- width 3)) (string-length str))) + "..."))))) + +(define (test-get-name! info) + (or + (assq-ref info 'name) + (assq-ref info 'gen-name) + (let ((name + (cond + ((assq-ref info 'source) + => (lambda (src) + (truncate-source src (- (current-column-width) 12)))) + ((current-test-group) + => (lambda (g) + (string-append + "test-" + (number->string (test-group-ref g 'count 0))))) + (else "")))) + (if (pair? info) + (set-cdr! info (cons (cons 'gen-name name) (cdr info)))) + name))) + +(define (test-print-name info . indent) + (let ((width (- (current-column-width) + (or (and (pair? indent) (car indent)) 0))) + (name (test-get-name! info))) + (display name) + (display " ") + (let ((diff (- width 9 (string-length name)))) + (cond + ((positive? diff) + (display (make-string diff #\.))))) + (display " ") + (flush-output))) + +(define (test-group-indent-width group) + (let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0) + (test-first-indentation)))))) + (* 4 (min level (test-max-indentation))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ansi tools + +(define (display-to-string x) + (if (string? x) x (call-with-output-string (lambda (out) (display x out))))) + +(define (red x) (string-append "\x1B[31m" (display-to-string x) "\x1B[0m")) +(define (green x) (string-append "\x1B[32m" (display-to-string x) "\x1B[0m")) +(define (yellow x) (string-append "\x1B[33m" (display-to-string x) "\x1B[0m")) +;; (define (blue x) (string-append "\x1B[34m" (display-to-string x) "\x1B[0m")) +;; (define (magenta x) (string-append "\x1B[35m" (display-to-string x) "\x1B[0m")) +;; (define (cyan x) (string-append "\x1B[36m" (display-to-string x) "\x1B[0m")) +(define (bold x) (string-append "\x1B[1m" (display-to-string x) "\x1B[0m")) +(define (underline x) (string-append "\x1B[4m" (display-to-string x) "\x1B[0m")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (test-run expect expr info) + (if (and (cond ((current-test-group) + => (lambda (g) (not (test-group-ref g 'skip-group?)))) + (else #t)) + (every (lambda (f) (f info)) (current-test-filters))) + ((current-test-applier) expect expr info) + ((current-test-skipper) expect expr info))) + +(define (test-default-applier expect expr info) + (let* ((group (current-test-group)) + (indent (and group (test-group-indent-width group)))) + (cond + ((and group + (equal? 0 (test-group-ref group 'count 0)) + (zero? (test-group-ref group 'subgroups-count 0)) + (test-group-ref group 'verbosity)) + (newline) + (print-header-line + (string-append "testing " (or (test-group-name group) "")) + (or indent 0)))) + (if (and indent (positive? indent)) + (display (make-string indent #\space))) + (test-print-name info indent) + (let ((expect-val + (handle-exceptions + exn + (begin + (warning "bad expect value") + (print-exception exn (current-error-port)) + #f) + (expect)))) + (handle-exceptions + exn + (begin + ((current-test-handler) + (if (assq-ref info 'expect-error) 'PASS 'ERROR) + expect + expr + (append `((exception . ,exn)) info))) + (let ((res (expr))) + (let ((status + (if (and (not (assq-ref info 'expect-error)) + (if (assq-ref info 'assertion) + res + ((current-test-comparator) expect-val res))) + 'PASS + 'FAIL)) + (info `((result . ,res) (expected . ,expect-val) ,@info))) + ((current-test-handler) status expect expr info))))))) + +(define (test-default-skipper expect expr info) + ((current-test-handler) 'SKIP expect expr info)) + +(define (test-default-handler status expect expr info) + (define indent + (make-string + (+ 4 (cond ((current-test-group) + => (lambda (group) (or (test-group-indent-width group) 0))) + (else 0))) + #\space)) + ;; update group info + (cond ((current-test-group) + => (lambda (group) + (if (not (eq? 'SKIP status)) + (test-group-inc! group 'count)) + (test-group-inc! group status)))) + (cond + ((or (eq? status 'FAIL) (eq? status 'ERROR)) + (test-failure-count (+ 1 (test-failure-count))))) + (cond + ((not (eq? status 'SKIP)) + ;; display status + (display "[") + (if (not (eq? status 'ERROR)) (display " ")) ; pad + (display ((if (test-ansi?) + (case status + ((ERROR) (lambda (x) (underline (red x)))) + ((FAIL) red) + ((SKIP) yellow) + (else green)) + (lambda (x) x)) + status)) + (display "]") + (newline) + ;; display status explanation + (cond + ((eq? status 'ERROR) + (display indent) + (cond ((assq 'exception info) + => (lambda (e) + (print-exception (cdr e) (current-output-port)))))) + ((and (eq? status 'FAIL) (assq-ref info 'assertion)) + (display indent) + (display "assertion failed\n")) + ((and (eq? status 'FAIL) (assq-ref info 'expect-error)) + (display indent) + (display "expected an error but got ") + (write (assq-ref info 'result)) (newline)) + ((eq? status 'FAIL) + (display indent) + (display "expected ") (write (assq-ref info 'expected)) + (display " but got ") (write (assq-ref info 'result)) (newline))) + ;; display line, source and values info + (cond + ((or (not (current-test-group)) + (test-group-ref (current-test-group) 'verbosity)) + (case status + ((FAIL ERROR) + (cond + ((assq-ref info 'line-number) + => (lambda (line) + (display " in line ") + (write line) + (cond ((assq-ref info 'file-name) + => (lambda (file) (display " of file ") (write file)))) + (newline)))) + (cond + ((assq-ref info 'source) + => (lambda (s) + (cond + ((or (assq-ref info 'name) + (> (string-length (write-to-string s)) + (current-column-width))) + (display (write-to-string s)) + (newline)))))) + (cond + ((assq-ref info 'values) + => (lambda (v) + (for-each + (lambda (v) + (display " ") (display (car v)) + (display ": ") (write (cdr v)) (newline)) + v)))))))))) + status) + +(define (test-default-group-reporter group) + (define (plural word n) + (if (= n 1) word (string-append word "s"))) + (define (percent n d) + (string-append " (" (number->string (/ (round (* 1000 (/ n d))) 10)) "%)")) + (let* ((end-time (get-time-of-day)) + (start-time (test-group-ref group 'start-time)) + (duration (timeval-difference (car end-time) (car start-time))) + (count (or (test-group-ref group 'count) 0)) + (pass (or (test-group-ref group 'PASS) 0)) + (fail (or (test-group-ref group 'FAIL) 0)) + (err (or (test-group-ref group 'ERROR) 0)) + (skip (or (test-group-ref group 'SKIP) 0)) + (subgroups-count (or (test-group-ref group 'subgroups-count) 0)) + (subgroups-pass (or (test-group-ref group 'subgroups-pass) 0)) + (indent (make-string (or (test-group-indent-width group) 0) #\space))) + (cond + ((or (positive? count) (positive? subgroups-count)) + (if (not (= count (+ pass fail err))) + (warning "inconsistent count:" count pass fail err)) + (display indent) + (cond + ((positive? count) + (write count) (display (plural " test" count)))) + (if (and (positive? count) (positive? subgroups-count)) + (display " and ")) + (cond + ((positive? subgroups-count) + (write subgroups-count) + (display (plural " subgroup" subgroups-count)))) + (display " completed in ") (write duration) (display " seconds") + (cond + ((not (zero? skip)) + (display " (") (write skip) (display (plural " test" skip)) + (display " skipped)"))) + (display ".") (newline) + (cond ((positive? fail) + (display indent) + (display + ((if (test-ansi?) red (lambda (x) x)) + (string-append + (number->string fail) (plural " failure" fail) + (percent fail count) "."))) + (newline))) + (cond ((positive? err) + (display indent) + (display + ((if (test-ansi?) (lambda (x) (underline (red x))) (lambda (x) x)) + (string-append + (number->string err) (plural " error" err) + (percent err count) "."))) + (newline))) + (cond + ((positive? count) + (display indent) + (display + ((if (and (test-ansi?) (= pass count)) green (lambda (x) x)) + (string-append + (number->string pass) " out of " (number->string count) + (percent pass count) (plural " test" pass) " passed."))) + (newline))) + (cond + ((positive? subgroups-count) + (display indent) + (display + ((if (and (test-ansi?) (= subgroups-pass subgroups-count)) + green (lambda (x) x)) + (string-append + (number->string subgroups-pass) " out of " + (number->string subgroups-count) + (percent subgroups-pass subgroups-count) + (plural " subgroup" subgroups-pass) " passed."))) + (newline))) + )) + (print-header-line + (string-append "done testing " (or (test-group-name group) "")) + (or (test-group-indent-width group) 0)) + (newline) + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (test-equal? expect res) + (or (equal? expect res) + (and (number? expect) + (inexact? expect) + (approx-equal? expect res (current-test-epsilon))))) + +(define (print-header-line str . indent) + (let* ((header (string-append + (make-string (if (pair? indent) (car indent) 0) #\space) + "-- " str " ")) + (len (string-length header))) + (display (if (test-ansi?) (bold header) header)) + (display (make-string (max 0 (- (current-column-width) len)) #\-)) + (newline))) + +(define (test-begin . o) + (let* ((name (if (pair? o) (car o) "")) + (group (make-test-group name)) + (parent (current-test-group))) + (cond + ((and parent + (equal? 0 (test-group-ref parent 'count 0)) + (zero? (test-group-ref parent 'subgroups-count 0)) + (test-group-ref parent 'verbosity)) + (newline) + (print-header-line + (string-append "testing " (test-group-name parent)) + (or (test-group-indent-width parent) 0)))) + (test-group-set! group 'parent parent) + (test-group-set! group 'verbosity + (if parent + (test-group-ref parent 'verbosity) + (current-test-verbosity))) + (test-group-set! group 'level + (if parent + (+ 1 (test-group-ref parent 'level 0)) + 0)) + (test-group-set! + group + 'skip-group? + (or (and parent (test-group-ref parent 'skip-group?)) + (not (every (lambda (f) (f group)) (current-test-group-filters))))) + (current-test-group group))) + +(define (test-end . o) + (cond + ((current-test-group) + => (lambda (group) + (if (and (pair? o) (not (equal? (car o) (test-group-name group)))) + (warning "mismatched test-end:" (car o) (test-group-name group))) + (let ((parent (test-group-ref group 'parent))) + (cond + ((not (test-group-ref group 'skip-group?)) + ;; only report if there's something to say + ((current-test-group-reporter) group) + (cond + (parent + (test-group-inc! parent 'subgroups-count) + (cond + ((and (zero? (test-group-ref group 'FAIL 0)) + (zero? (test-group-ref group 'ERROR 0)) + (= (test-group-ref group 'subgroups-pass 0) + (test-group-ref group 'subgroups-count 0))) + (test-group-inc! parent 'subgroups-pass))))))) + (current-test-group parent) + group))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parameters + +(define current-test-group (make-parameter #f)) +(define current-test-verbosity + (make-parameter + (cond ((get-environment-variable "TEST_QUIET") + => (lambda (s) (equal? s "0"))) + (else #t)))) +(define current-test-epsilon (make-parameter 1e-5)) +(define current-test-comparator (make-parameter test-equal?)) +(define current-test-applier (make-parameter test-default-applier)) +(define current-test-handler (make-parameter test-default-handler)) +(define current-test-skipper (make-parameter test-default-skipper)) +(define current-test-group-reporter + (make-parameter test-default-group-reporter)) +(define test-failure-count (make-parameter 0)) + +(define test-first-indentation + (make-parameter + (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION") + => string->number) + (else #f)) + 1))) + +(define test-max-indentation + (make-parameter + (or (cond ((get-environment-variable "TEST_MAX_INDENTATION") + => string->number) + (else #f)) + 5))) + +(define (string->info-matcher str) + (lambda (info) + (cond ((test-get-name! info) + => (lambda (n) (string-search str n))) + (else #f)))) + +(define (string->group-matcher str) + (lambda (group) (string-search str (car group)))) + +(define (getenv-filter-list proc name . o) + (cond + ((get-environment-variable name) + => (lambda (s) + (handle-exceptions + exn + (begin + (warning + (string-append "invalid filter '" s + "' from environment variable: " name)) + (print-exception exn (current-error-port)) + '()) + (let ((f (proc s))) + (list (if (and (pair? o) (car o)) + (lambda (x) (not (f x))) + f)))))) + (else '()))) + +(define current-test-filters + (make-parameter + (append (getenv-filter-list string->info-matcher "TEST_FILTER") + (getenv-filter-list string->info-matcher "TEST_REMOVE" #t)))) + +(define current-test-group-filters + (make-parameter + (append (getenv-filter-list string->group-matcher "TEST_GROUP_FILTER") + (getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE" #t)))) + +(define current-column-width + (make-parameter + (or (cond ((get-environment-variable "TEST_COLUMN_WIDTH") + => string->number) + (else #f)) + 78))) + +(define test-ansi? + (make-parameter + (cond + ((get-environment-variable "TEST_USE_ANSI") + => (lambda (s) (not (equal? s "0")))) + (else + (member (get-environment-variable "TERM") + '("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm" + "linux" "screen" "screen-256color" "vt100")))))) diff --git a/lib/chibi/time.module b/lib/chibi/time.module new file mode 100644 index 00000000..8d591100 --- /dev/null +++ b/lib/chibi/time.module @@ -0,0 +1,12 @@ + +(define-module (chibi time) + (export current-seconds get-time-of-day set-time-of-day! + seconds->time seconds->string time->seconds time->string + timeval-seconds timeval-microseconds + timezone-offset timezone-dst-time + time-second time-minute time-hour time-day time-month time-year + time-day-of-week time-day-of-year time-dst? + tm? timeval? timezone?) + (import-immutable (scheme)) + (include-shared "time")) + diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub new file mode 100644 index 00000000..adde486e --- /dev/null +++ b/lib/chibi/time.stub @@ -0,0 +1,46 @@ + +(c-system-include "time.h") +(c-system-include "sys/time.h") + +(define-c-struct tm + predicate: tm? + (int tm_sec time-second) + (int tm_min time-minute) + (int tm_hour time-hour) + (int tm_mday time-day) + (int tm_mon time-month) + (int tm_year time-year) + (int tm_wday time-day-of-week) + (int tm_yday time-day-of-year) + (int tm_isdst time-dst?)) + +(define-c-struct timeval + predicate: timeval? + (time_t tv_sec timeval-seconds) + (int tv_usec timeval-microseconds)) + +(define-c-struct timezone + predicate: timezone? + (int tz_minuteswest timezone-offset) + (int tz_dsttime timezone-dst-time)) + +(define-c time_t (current-seconds "time") ((value NULL))) + +(define-c errno (get-time-of-day "gettimeofday") + ((result timeval) (result timezone))) + +(define-c errno (set-time-of-day! "settimeofday") + (timeval (maybe-null default NULL timezone))) + +(define-c non-null-pointer (seconds->time "localtime_r") + ((pointer time_t) (result tm))) + +(define-c time_t (time->seconds "mktime") + (tm)) + +(define-c non-null-string (seconds->string "ctime_r") + ((pointer time_t) (result (array char 64)))) + +(define-c non-null-string (time->string "asctime_r") + (tm (result (array char 64)))) + diff --git a/lib/chibi/type-inference.module b/lib/chibi/type-inference.module new file mode 100644 index 00000000..2f9534d2 --- /dev/null +++ b/lib/chibi/type-inference.module @@ -0,0 +1,7 @@ + +(define-module (chibi type-inference) + (export type-analyze-module type-analyze procedure-signature) + (import-immutable (scheme)) + (import (srfi 1) (srfi 69) (chibi modules) (chibi ast) (chibi match)) + (include "type-inference.scm")) + diff --git a/lib/chibi/type-inference.scm b/lib/chibi/type-inference.scm new file mode 100644 index 00000000..6b21a230 --- /dev/null +++ b/lib/chibi/type-inference.scm @@ -0,0 +1,272 @@ +;; type-inference.scm -- general type-inference for Scheme +;; +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (typed? x) + (and (lambda? x) + (lambda-return-type x))) + +(define (union-type? a) + (and (pair? a) (equal? (car a) 'or))) + +(define (intersection-type? a) + (and (pair? a) (equal? (car a) 'and))) + +(define (unfinalized-type? a) + (and (pair? a) + (or (memq (car a) '(return-type param-type)) + (and (memq (car a) '(and or)) + (any unfinalized-type? (cdr a)))))) + +(define (finalized-type? a) + (not (unfinalized-type? a))) + +(define (numeric-type? a) + (or (eq? a ) (eq? a ) (eq? a ))) + +(define (procedure-type? a) + (or (eq? a ) + (eq? a ) + (and (pair? a) (eq? (car a) 'lambda)))) + +(define (type-subset? a b) + (or (equal? a b) + (equal? a ) + (equal? b ) + (and (numeric-type? a) (numeric-type? b)) + (and (procedure-type? a) (procedure-type? b)) + (if (union-type? a) + (if (union-type? b) + (lset<= equal? (cdr a) (cdr b)) + (member b (cdr a))) + (and (union-type? b) (member a (cdr b)))))) + +;; XXXX check for type hierarchies +(define (type-union a b) + (cond + ((equal? a b) a) + ((or (equal? a ) (equal? b )) ) + ((union-type? a) + (if (union-type? b) + (cons (car a) (lset-union equal? (cdr a) (cdr b))) + (cons (car a) (lset-adjoin equal? (cdr a) b)))) + (else (list 'or a b)))) + +;; XXXX check for conflicts +(define (type-intersection a b) + (cond + ((equal? a b) a) + ((or (equal? a ) (unfinalized-type? a)) b) + ((or (equal? b ) (unfinalized-type? b)) a) + ((intersection-type? a) + (if (intersection-type? b) + (lset-intersection equal? (cdr a) (cdr b)) + (cons (car a) (lset-adjoin equal? (cdr a) b)))) + (else (list 'and a b)))) + +(define (lambda-param-types-initialize! f) + (lambda-param-types-set! f (map (lambda (p) (list 'param-type f p)) + (lambda-params f)))) + +(define (lambda-param-type-memq f x) + (let lp ((p (lambda-params f)) + (t (lambda-param-types f))) + (and (pair? p) + (pair? t) + (if (eq? x (car p)) + t + (lp (cdr p) (cdr t)))))) + +(define (lambda-param-type-ref f x) + (cond ((lambda-param-type-memq f x) => car) + (else #f))) + +(define (lambda-param-type-set! f x y) + (if (not (pair? (lambda-param-types f))) + (lambda-param-types-initialize! f)) + (cond ((lambda-param-type-memq f x) + => (lambda (cell) (set-car! cell y))))) + +(define (type-analyze-expr x) + (match x + (($ name params body defs) + (cond + ((not (lambda-return-type x)) + (lambda-return-type-set! x (list 'return-type x)) + (lambda-param-types-initialize! x) + (let ((ret-type (type-analyze-expr body))) + (lambda-return-type-set! x ret-type) + (cons 'lambda (cons ret-type (lambda-param-types x))))))) + (($ ref value) + (type-analyze-expr value) + (if #f #f)) + (($ name (value . loc) source) + (cond + ((lambda? loc) (lambda-param-type-ref loc name)) + ((procedure? loc) + (let ((sig (procedure-signature loc))) + (if (and (pair? sig) (car sig)) + (cons 'lambda sig) + (list 'return-type (procedure-analysis loc))))) + (else ))) + (($ test pass fail) + (let ((test-type (type-analyze-expr test)) + (pass-type (type-analyze-expr pass)) + (fail-type (type-analyze-expr fail))) + (type-union pass-type fail-type))) + (($ ls) + (let lp ((ls ls)) + (cond ((null? (cdr ls)) + (type-analyze-expr (car ls))) + (else + (type-analyze-expr (car ls)) + (lp (cdr ls)))))) + ((f args ...) + (cond + ((opcode? f) + (let lp ((p (opcode-param-types f)) + (a args)) + (cond + ((pair? a) + (cond ((or (pair? p) (opcode-variadic? f)) + (let ((p-type + (if (pair? p) + (car p) + (opcode-param-type f (opcode-num-params f))))) + (match (car a) + (($ name (_ . (and g ($ )))) + (let ((t (type-intersection (lambda-param-type-ref g name) + p-type))) + (lambda-param-type-set! g name t))) + (else + (let ((t (type-analyze-expr (car a)))) + (cond + ((and t p-type + (finalized-type? t) + (finalized-type? p-type) + (not (type-subset? t p-type))) + (display "WARNING: incompatible type: " + (current-error-port)) + (write (list x t p-type) (current-error-port)) + (newline (current-error-port)))) + t)))) + (lp (and (pair? p) (cdr p)) (cdr a))) + (else + (for-each type-analyze-expr a)))))) + (opcode-return-type f)) + (else + (let ((f-type (type-analyze-expr f))) + ;; XXXX apply f-type to params + (for-each type-analyze-expr args) + (cond + ((and (pair? f-type) (eq? (car f-type) 'lambda)) + (cadr f-type)) + ((and (pair? f-type) (memq (car f-type) '(return-type param-type))) + f-type) + (else + )))))) + (else + (type-of x)))) + +(define (resolve-delayed-type x) + (let lp ((x x) (seen '()) (default )) + (match x + (('return-type f) + (if (memq f seen) + default + (lp (lambda-return-type f) (cons f seen) default))) + (('param-type f p) + (if (member x seen) + default + (lp (lambda-param-type-ref f p) (cons x seen) default))) + (('or y ...) + (let ((z (find finalized-type? y))) + (if z + (let ((default (if (eq? default ) + (lp z seen default) + (type-union (lp z seen default) default)))) + (fold type-union + default + (map (lambda (y1) (lp y1 seen default)) (delete z y)))) + (fold type-union default (map (lambda (y1) (lp y1 seen default)) y))))) + (('and y ...) + (fold type-intersection default (map (lambda (y1) (lp y1 seen default)) y))) + (('not y) + (list 'not (lp y seen default))) + (else + x)))) + +(define (type-resolve-circularities x) + (match x + (($ name params body defs) + (if (unfinalized-type? (lambda-return-type x)) + (lambda-return-type-set! x (resolve-delayed-type + (lambda-return-type x)))) + (for-each + (lambda (p t) + (if (unfinalized-type? t) + (lambda-param-type-set! x p (resolve-delayed-type t)))) + params + (lambda-param-types x)) + (type-resolve-circularities (lambda-body x))) + (($ ref value) + (type-resolve-circularities value)) + (($ test pass fail) + (type-resolve-circularities test) + (type-resolve-circularities pass) + (type-resolve-circularities fail)) + (($ ls) + (for-each type-resolve-circularities ls)) + ((app ...) + (for-each type-resolve-circularities app)) + (else #f))) + +(define (type-analyze-module-body name ls) + (for-each type-analyze-expr ls) + (for-each type-resolve-circularities ls)) + +(define (type-analyze-module name) + (let* ((mod (analyze-module name)) + (ls (and (vector? mod) (module-ast mod)))) + (and ls + (let ((x (let lp ((ls ls)) ;; first lambda + (and (pair? ls) + (if (and (set? (car ls)) + (lambda? (set-value (car ls)))) + (set-value (car ls)) + (lp (cdr ls))))))) + (if (and x (not (typed? x))) + (type-analyze-module-body name ls)) + ls)))) + +(define (type-analyze sexp . o) + (type-analyze-expr (apply analyze sexp o))) + +(define (opcode-param-types x) + (let lp ((n (- (opcode-num-params x) 1)) (res '())) + (if (< n 0) + res + (lp (- n 1) (cons (opcode-param-type x n) res))))) + +(define (opcode-type x) + (cons 'lambda (cons (opcode-return-type x) (opcode-param-types x)))) + +(define (lambda-type x) + (cons 'lambda (cons (lambda-return-type x) (lambda-param-types x)))) + +(define (procedure-signature x) + (if (opcode? x) + (cdr (opcode-type x)) + (let lp ((count 0)) + (let ((lam (procedure-analysis x))) + (cond + ((and lam (not (typed? lam)) (zero? count) + (containing-module x)) + => (lambda (mod) + (and (type-analyze-module (car mod)) + (lp (+ count 1))))) + ((lambda? lam) + (cdr (lambda-type lam))) + (else + #f)))))) diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module new file mode 100644 index 00000000..46f9e6a6 --- /dev/null +++ b/lib/chibi/uri.module @@ -0,0 +1,10 @@ + +(define-module (chibi uri) + (export uri? uri->string make-uri string->uri + uri-scheme uri-user uri-host uri-port uri-path uri-query uri-fragment + uri-with-scheme uri-with-user uri-with-host uri-with-path + uri-with-query uri-with-fragment + uri-encode uri-decode uri-query->alist uri-alist->query) + (import-immutable (scheme) + (srfi 9)) + (include "uri.scm")) diff --git a/lib/chibi/uri.scm b/lib/chibi/uri.scm new file mode 100644 index 00000000..41507961 --- /dev/null +++ b/lib/chibi/uri.scm @@ -0,0 +1,306 @@ +;; uri.scm -- URI parsing library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URI representation + +(define-record-type uri + (%make-uri scheme user host port path query fragment) + uri? + (scheme uri-scheme) + (user uri-user) + (host uri-host) + (port uri-port) + (path uri-path) + (query uri-query) + (fragment uri-fragment)) + +;; (make-uri scheme [user host port path query fragment]) +(define (make-uri scheme . o) + (let* ((user (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (host (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (port (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (path (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (query (if (pair? o) (car o) #f)) + (o (if (pair? o) (cdr o) '())) + (fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f))) + (%make-uri scheme user host port path query fragment))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string utils (don't feel like using SRFI-13 and these are more +;; specialised) + +(define (string-scan str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (and (< i end) + (if (eqv? ch (string-ref str i)) + i + (lp (+ i 1))))))) + +(define (string-scan-right str ch . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i (- end 1))) + (and (>= i start) + (if (eqv? ch (string-ref str i)) + i + (lp (- i 1))))))) + +(define (string-index-of str pred . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let lp ((i start)) + (cond ((>= i end) #f) + ((pred (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase->symbol str) + (let ((len (string-length str))) + (let lp ((i 0)) + (cond + ((= i len) + (string->symbol str)) + ((char-upper-case? (string-ref str i)) + (let ((res (make-string len))) + (do ((j 0 (+ j 1))) + ((= j i)) + (string-set! res j (string-ref str j))) + (string-set! res i (char-downcase (string-ref str i))) + (do ((j (+ i 1) (+ j 1))) + ((= j len)) + (string-set! res j (char-downcase (string-ref str j)))) + (string->symbol res))) + (else + (lp (+ i 1))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; functional updaters (uses as much shared state as possible) + +(define (uri-with-scheme u scheme) + (%make-uri scheme (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-user u user) + (%make-uri (uri-scheme u) user (uri-host u) (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-host u host) + (%make-uri (uri-scheme u) (uri-user u) host (uri-port u) + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-port u port) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) port + (uri-path u) (uri-query u) (uri-fragment u))) + +(define (uri-with-path u path) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + path (uri-query u) (uri-fragment u))) + +(define (uri-with-query u query) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) query (uri-fragment u))) + +(define (uri-with-fragment u fragment) + (%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u) + (uri-path u) (uri-query u) fragment)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parsing - without :// we just split into scheme & path + +(define (char-uri-scheme-unsafe? ch) + (not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\_ #\-))))) + +(define (string->path-uri scheme str . o) + (define decode? (and (pair? o) (car o))) + (define decode (if decode? uri-decode (lambda (x) x))) + (define decode-query + (if (and (pair? o) (pair? (cdr o)) (cadr o)) + uri-query->alist + decode)) + (if (pair? str) + str + (let* ((len (string-length str)) + (colon0 (string-scan str #\:)) + (colon + (and (not (string-index-of str char-uri-scheme-unsafe? + 0 (or colon0 len))) + colon0))) + (if (or (not colon) (zero? colon)) + (and scheme + (let* ((quest (string-scan str #\? 0)) + (pound (string-scan str #\# (or quest 0)))) + (make-uri scheme #f #f #f + (decode (substring str 0 (or quest pound len))) + (and quest + (decode-query + (substring str (+ quest 1) (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len)))))) + (let ((sc1 (+ colon 1)) + (scheme (string-downcase->symbol (substring str 0 colon)))) + (if (= sc1 len) + (make-uri scheme) + (if (or (>= (+ sc1 1) len) + (not (and (eqv? #\/ (string-ref str sc1)) + (eqv? #\/ (string-ref str (+ sc1 1)))))) + (make-uri scheme #f #f #f (substring str sc1 len)) + (if (>= (+ sc1 2) len) + (make-uri scheme #f "") + (let* ((sc2 (+ sc1 2)) + (slash (string-scan str #\/ sc2)) + (sc3 (or slash len)) + (at (string-scan-right str #\@ sc2 sc3)) + (colon3 (string-scan str #\: (or at sc2) sc3)) + (quest (string-scan str #\? sc3)) + (pound (string-scan str #\# (or quest sc3)))) + (%make-uri + scheme + (and at (decode (substring str sc2 at))) + (decode + (substring str + (if at (+ at 1) sc2) + (or colon3 sc3))) + (and colon3 + (string->number + (substring str (+ colon3 1) sc3))) + (and slash + (decode + (substring str slash (or quest pound len)))) + (and quest + (decode-query + (substring str (+ quest 1) + (or pound len)))) + (and pound + (decode (substring str (+ pound 1) len))) + )))))))))) + +(define (string->uri str . o) + (apply string->path-uri #f str o)) + +(define (uri->string uri . o) + (define encode? (and (pair? o) (car o))) + (define encode (if encode? uri-encode (lambda (x) x))) + (if (string? uri) + uri + (let ((fragment (uri-fragment uri)) + (query (uri-query uri)) + (path (uri-path uri)) + (port (uri-port uri)) + (host (uri-host uri)) + (user (uri-user uri))) + (string-append + (symbol->string (uri-scheme uri)) ":" + (if (or user host port) "//" "") + (if user (encode user) "") (if user "@" "") + (or host "") ; host shouldn't need encoding + (if port ":" "") (if port (number->string port) "") + (if path (encode path) "") + (if query "?" "") + (if (pair? query) (uri-alist->query query) (or query "")) + (if fragment "#" "") (if fragment (encode fragment) ""))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; query encoding and decoding + +(define (uri-safe-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (case ch + ((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t) + (else #f)))) + +(define (collect str from to res) + (if (>= from to) + res + (cons (substring str from to) res))) + +(define (uri-encode str . o) + (define (encode-1-space ch) + (if (eqv? ch #\space) + "+" + (encode-1-normal ch))) + (define (encode-1-normal ch) + (let* ((i (char->integer ch)) + (hex (number->string i 16))) + (if (< i 16) + (string-append "%0" hex) + (string-append "%" hex)))) + (let ((start 0) + (end (string-length str)) + (encode-1 (if (and (pair? o) (car o)) + encode-1-space + encode-1-normal))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (if (uri-safe-char? ch) + (lp from next res) + (lp next next (cons (encode-1 ch) + (collect str from to res))))))))) + +(define (uri-decode str . o) + (let ((space-as-plus? (and (pair? o) (car o))) + (start 0) + (end (string-length str))) + (let lp ((from start) (to start) (res '())) + (if (>= to end) + (if (zero? from) + str + (string-concatenate (reverse (collect str from to res)))) + (let* ((ch (string-ref str to)) + (next (+ to 1))) + (cond + ((eqv? ch #\%) + (if (>= next end) + (lp next next (collect str from to res)) + (let ((next2 (+ next 1))) + (if (>= next2 end) + (lp next2 next2 (collect str from to res)) + (let* ((next3 (+ next2 1)) + (hex (substring str next next3)) + (i (string->number hex 16))) + (lp next3 next3 (cons (string (integer->char i)) + (collect str from to res)))))))) + ((and space-as-plus? (eqv? ch #\+)) + (lp next next (cons " " (collect str from to res)))) + (else + (lp from next res)))))))) + +(define (uri-query->alist str . o) + (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;))) + (let ((len (string-length str)) + (plus? (and (pair? o) (car o)))) + (let lp ((i 0) (res '())) + (if (>= i len) + (reverse res) + (let* ((j (or (string-index-of str split-char? i) len)) + (k (string-scan str #\= i j)) + (cell (if k + (cons (uri-decode (substring str i k) plus?) + (uri-decode (substring str (+ k 1) j) plus?)) + (cons (uri-decode (substring str i j) plus?) #f)))) + (lp (+ j 1) (cons cell res))))))) + +(define (uri-alist->query ls . o) + (define plus? (and (pair? o) (car o))) + (define (encode key val res) + (let ((res (cons (uri-encode key plus?) res))) + (if val (cons (uri-encode val plus?) (cons "=" res)) res))) + (if (null? ls) + "" + (let lp ((x (car ls)) (ls (cdr ls)) (res '())) + (let ((res (encode (car x) (cdr x) res))) + (if (null? ls) + (string-concatenate (reverse res)) + (lp (car ls) (cdr ls) (cons "&" res))))))) diff --git a/lib/config.scm b/lib/config.scm new file mode 100644 index 00000000..55a4e1e0 --- /dev/null +++ b/lib/config.scm @@ -0,0 +1,179 @@ +;; config.scm -- configuration module +;; Copyright (c) 2009-2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *this-module* '()) + +(define (make-module exports env meta) (vector exports env meta #f)) +(define (%module-exports mod) (vector-ref mod 0)) +(define (module-env mod) (vector-ref mod 1)) +(define (module-meta-data mod) (vector-ref mod 2)) +(define (module-env-set! mod env) (vector-set! mod 1 env)) + +(define (module-exports mod) + (or (%module-exports mod) (env-exports (module-env mod)))) + +(define (module-name->strings ls res) + (if (null? ls) + res + (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls))) + ((number? (car ls)) (number->string (car ls))) + ((string? (car ls)) (car ls)) + (else (error "invalid module name" (car ls)))))) + (module-name->strings (cdr ls) (cons "/" (cons str res)))))) + +(define (module-name->file name) + (string-concatenate + (reverse (cons ".module" (cdr (module-name->strings name '())))))) + +(define (module-name-prefix name) + (string-concatenate (reverse (cdr (cdr (module-name->strings name '())))))) + +(define (load-module-definition name) + (let* ((file (module-name->file name)) + (path (find-module-file file))) + (if path (load path *config-env*)))) + +(define (find-module name) + (cond + ((assoc name *modules*) => cdr) + (else + (load-module-definition name) + (cond ((assoc name *modules*) => cdr) + (else #f))))) + +(define (symbol-append a b) + (string->symbol (string-append (symbol->string a) (symbol->string b)))) + +(define (to-id id) (if (pair? id) (car id) id)) +(define (from-id id) (if (pair? id) (cdr id) id)) +(define (id-filter pred ls) + (cond ((null? ls) '()) + ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls)))) + (else (id-filter pred (cdr ls))))) + +(define (resolve-import x) + (cond + ((not (and (pair? x) (list? x))) + (error "invalid module syntax" x)) + ((and (pair? (cdr x)) (pair? (cadr x))) + (if (memq (car x) '(only except rename)) + (let* ((mod-name+imports (resolve-import (cadr x))) + (imp-ids (cdr mod-name+imports)) + (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x)))) + (begin + (set-cdr! mod-name+imports + (module-exports + (find-module (car mod-name+imports)))) + (cdr mod-name+imports)) + imp-ids))) + (cons (car mod-name+imports) + (case (car x) + ((only) + (if (not imp-ids) + (cddr x) + (id-filter (lambda (i) (memq i (cddr x))) imp-ids))) + ((except) + (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids)) + ((rename) + (map (lambda (i) + (let ((rename (assq (to-id i) (cddr x)))) + (if rename (cons (cdr rename) (from-id i)) i))) + imp-ids))))) + (error "invalid import modifier" x))) + ((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x))) + (let ((mod-name+imports (resolve-import (caddr x)))) + (cons (car mod-name+imports) + (map (lambda (i) + (cons (symbol-append (cadr x) (if (pair? i) (car i) i)) + (if (pair? i) (cdr i) i))) + (cdr mod-name+imports))))) + ((find-module x) + => (lambda (mod) (cons x (%module-exports mod)))) + (else + (error "couldn't find import" x)))) + +(define (eval-module name mod) + (let ((env (make-environment)) + (dir (module-name-prefix name))) + (define (load-modules files extension) + (for-each + (lambda (f) + (let ((f (string-append dir f extension))) + (cond ((find-module-file f) => (lambda (x) (load x env))) + (else (error "couldn't find include" f))))) + files)) + (for-each + (lambda (x) + (case (and (pair? x) (car x)) + ((import import-immutable) + (for-each + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) + (mod2 (load-module (car mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports) + (eq? (car x) 'import-immutable)))) + (cdr x))) + ((include) + (load-modules (cdr x) "")) + ((include-shared) + (cond-expand + (dynamic-loading (load-modules (cdr x) *shared-object-extension*)) + (else #f))) + ((body) + (for-each (lambda (expr) (eval expr env)) (cdr x))))) + (module-meta-data mod)) + env)) + +(define (load-module name) + (let ((mod (find-module name))) + (if (and mod (not (module-env mod))) + (module-env-set! mod (eval-module name mod))) + mod)) + +(define-syntax define-module + (er-macro-transformer + (lambda (expr rename compare) + (let ((name (cadr expr)) + (body (cddr expr))) + `(let ((tmp *this-module*)) + (set! *this-module* '()) + ,@body + (set! *this-module* (reverse *this-module*)) + (let ((exports + (cond ((assq 'export *this-module*) => cdr) + (else '())))) + (set! *modules* + (cons (cons ',name (make-module exports #f *this-module*)) + *modules*))) + (set! *this-module* tmp)))))) + +(define-syntax define-config-primitive + (er-macro-transformer + (lambda (expr rename compare) + `(define-syntax ,(cadr expr) + (er-macro-transformer + (lambda (expr rename compare) + `(set! *this-module* (cons ',expr *this-module*)))))))) + +(define-config-primitive import) +(define-config-primitive import-immutable) +(define-config-primitive export) +(define-config-primitive include) +(define-config-primitive include-shared) +(define-config-primitive body) + +(define *modules* + (list (cons '(scheme) (make-module #f (interaction-environment) + '((include "init.scm")))) + (cons '(config) (make-module #f (current-environment) '())) + (cons '(srfi 0) (make-module (list 'cond-expand) + (interaction-environment) + (list (list 'export 'cond-expand)))) + (cons '(srfi 46) (make-module (list 'syntax-rules) + (interaction-environment) + (list (list 'export 'syntax-rules)))))) + diff --git a/lib/init.scm b/lib/init.scm new file mode 100644 index 00000000..62d044ec --- /dev/null +++ b/lib/init.scm @@ -0,0 +1,875 @@ +;; init.scm -- R5RS library procedures +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; 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 (pair? (car lol)) + (mapn proc + (map1 cdr lol '()) + (cons (apply1 proc (map1 car lol '())) res)) + (reverse res))) + (if (null? lol) + (map1 proc ls '()) + (mapn proc (cons ls lol) '()))) + +(define (for-each f ls . lol) + (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls))))) + (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f)))) + +(define (any pred ls) + (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f)) + +(define (every pred ls) + (if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t)) + +(define (delq x ls) + (if (pair? ls) + (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls)))) + '())) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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) + (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 (rename 'else) (car cl)) + (if (pair? (cddr expr)) + (error "non-final else in cond" expr) + (cons (rename 'begin) (cdr cl))) + (if (if (null? (cdr cl)) #t (compare (rename '=>) (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 + ((compare (rename 'unquote) (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((compare (rename '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))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (compare (rename '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 (null? (cdr expr)) (error "empty let" expr)) + (if (null? (cddr expr)) (error "no let body" expr)) + ((lambda (bindings) + (if (list? bindings) #f (error "bad let bindings")) + (if (every (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + bindings) + ((lambda (vars vals) + (if (identifier? (cadr expr)) + `((,(rename 'lambda) ,vars + (,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,vars + ,@(cdddr expr)))) + (,(cadr expr) ,@vars))) + ,@vals) + `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals))) + (map car bindings) + (map cadr bindings)) + (error "bad let syntax" expr))) + (if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let*" expr)) + (if (null? (cddr expr)) (error "no let* body" expr)) + (if (null? (cadr expr)) + `(,(rename 'let) () ,@(cddr expr)) + (if (if (list? (cadr expr)) + (every + (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + (cadr expr)) + #f) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))) + (error "bad let* syntax")))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare (rename '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)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; promises + +(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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exceptions + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f))) + +(define (with-exception-handler handler thunk) + (letrec ((orig-handler (current-exception-handler)) + (self (lambda (exn) + (current-exception-handler orig-handler) + (let ((res (handler exn))) + (current-exception-handler self) + res)))) + (current-exception-handler self) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; library functions + +;; 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 . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (and (pair? ls) (if (eq obj (car ls)) ls (lp (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 (if (bignum? x) #t (flonum? x)))) +(define complex? number?) +(define rational? number?) +(define real? number?) +(define (exact? x) (if (fixnum? x) #t (bignum? x))) +(define inexact? flonum?) +(define (integer? x) + (if (fixnum? x) #t (if (bignum? 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 (numerator x) + (if (integer? x) x (numerator (* x 10)))) +(define (denominator x) + (if (exact? x) + 1 + (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10)))))) + +(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) + (if (<= n 9) + (integer->char (+ n (char->integer #\0))) + (integer->char (+ (- n 10) (char->integer #\A))))) +(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)) 55)))) + +(define (number->string num . o) + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-output-string (lambda (out) (write num out))) + (let lp ((n (abs num)) (d (car o)) (res '())) + (if (> n 0) + (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) + (if (null? res) + "0" + (list->string (if (negative? num) (cons #\- 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 (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-output-port)) + (tmp-out (open-output-file file))) + (current-output-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)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dynamic-wind + +(define *dk* (list #f)) + +(define (dynamic-wind before thunk after) + (let ((dk *dk*)) + (set-dk! (cons (cons before after) dk)) + (let ((res (thunk))) (set-dk! dk) res))) + +(define (set-dk! dk) + (if (not (eq? dk *dk*)) + (begin + (set-dk! (cdr dk)) + (let ((before (car (car dk))) (dk dk)) + (set-car! *dk* (cons (cdr (car dk)) before)) + (set-cdr! *dk* dk) + (set-car! dk #f) + (set-cdr! dk '()) + (set! *dk* dk) + (before))))) + +(define (call-with-current-continuation proc) + (let ((dk *dk*)) + (%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((ellipse-specified? (identifier? (cadr 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 'syntax-quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_len (rename'len)) (_length (rename 'length)) + (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error)) + (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define ellipse (rename (if ellipse-specified? (cadr expr) '...))) + (define lits (if ellipse-specified? (caddr expr) (cadr expr))) + (define forms (if ellipse-specified? (cdddr expr) (cddr expr))) + (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))) + (cond + ((not (list? (cddr p))) + (error "dotted ellipse" p)) + ((any (lambda (x) (and (identifier? x) (compare x ellipse))) + (cddr p)) + (error "multiple ellipses" p)) + (else + (let ((len (length (cdr (cdr p))))) + `(,_let ((,_len (,_length ,v))) + (,_and (,_>= ,_len ,len) + (,_let ,_lp ((,_ls ,v) + (,_i (,_- ,_len ,len)) + (,_res (,_quote ()))) + (,_if (,_>= 0 ,_i) + ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p))) + `(,_append ,_ls (,_reverse ,_res)) + dim + vars + k) + (,_lp (,_cdr ,_ls) + (,_- ,_i 1) + (,_cons (,_car ,_ls) ,_res)))))))))) + ((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-escape? x) (and (pair? x) (compare ellipse (car x)))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare ellipse (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 (any (lambda (lit) (compare x lit)) 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 + ((any (lambda (v) (compare t (car v))) vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (cond + ((ellipse-escape? t) + (if (pair? (cdr t)) + (if (pair? (cddr t)) (cddr t) (cadr t)) + (cdr t))) + ((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))))))) + (else (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 for" + (list (rename 'strip-syntactic-closures) _expr))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; modules + +(define *config-env* #f) + +(define-syntax import + (er-macro-transformer + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (res '())) + (cond + ((null? ls) + (cons 'begin (reverse res))) + (else + (let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*))) + (if (pair? mod+imps) + (lp (cdr ls) + (cons `(%env-copy! + #f + (vector-ref + (eval '(load-module ',(car mod+imps)) *config-env*) + 1) + ',(cdr mod+imps) + #f) + res)) + (error "couldn't find module" (car ls)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SRFI-0 + +(define-syntax cond-expand + (er-macro-transformer + (lambda (expr rename compare) + (define (check x) + (if (pair? x) + (case (car x) + ((and) (every check (cdr x))) + ((or) (any check (cdr x))) + ((not) (not (check (cadr x)))) + (else (error "cond-expand: bad feature" x))) + (memq (identifier->symbol x) *features*))) + (let expand ((ls (cdr expr))) + (cond ((null? ls) (error "cond-expand: no expansions" expr)) + ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) + ((eq? 'else (identifier->symbol (caar ls))) + (if (pair? (cdr ls)) + (error "cond-expand: else in non-final position") + `(,(rename 'begin) ,@(cdar ls)))) + ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) + (else (expand (cdr ls)))))))) + diff --git a/lib/srfi/1.module b/lib/srfi/1.module new file mode 100644 index 00000000..3d3da044 --- /dev/null +++ b/lib/srfi/1.module @@ -0,0 +1,31 @@ + +(define-module (srfi 1) + (export + xcons cons* make-list list-tabulate list-copy circular-list iota + proper-list? circular-list? dotted-list? not-pair? null-list? list= + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr take drop take-right drop-right take! drop-right! split-at split-at! + last last-pair length+ concatenate append! concatenate! reverse! + append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 count + fold unfold pair-fold reduce fold-right unfold-right + pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter partition remove filter! partition! remove! find find-tail any every + list-index take-while drop-while take-while! span break span! break! + delete delete-duplicates delete! delete-duplicates! + alist-cons alist-copy alist-delete alist-delete! + lset<= lset= lset-adjoin lset-union lset-union! lset-intersection + lset-intersection! lset-difference lset-difference! lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection!) + (import (scheme)) + (include "1/predicates.scm" + "1/selectors.scm" + "1/search.scm" + "1/misc.scm" + "1/constructors.scm" + "1/fold.scm" + "1/deletion.scm" + "1/alists.scm" + "1/lset.scm")) + diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm new file mode 100644 index 00000000..a35db42c --- /dev/null +++ b/lib/srfi/1/alists.scm @@ -0,0 +1,14 @@ +;; alist.scm -- association list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (alist-cons key value ls) (cons (cons key value) ls)) + +(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls)) + +(define (alist-delete key ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (remove (lambda (x) (eq (car x) key)) ls))) + +(define alist-delete! alist-delete) + diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm new file mode 100644 index 00000000..1f8a8d5e --- /dev/null +++ b/lib/srfi/1/constructors.scm @@ -0,0 +1,36 @@ +;; constructors.scm -- list construction utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (xcons a b) (cons b a)) + +(define (cons* x . args) + (let lp ((rev '()) (x x) (ls args)) + (if (null? ls) + (append-reverse rev x) + (lp (cons x rev) (car ls) (cdr ls))))) + +(define (make-list n . o) + (let ((default (if (pair? o) (car o)))) + (let lp ((n n) (res '())) + (if (<= n 0) res (lp (- n 1) (cons default res)))))) + +(define (list-tabulate n proc) + (let lp ((n n) (res '())) + (if (< n 0) res (lp (- n 1) (cons (proc n) res))))) + +(define (list-copy ls) (reverse! (reverse ls))) + +(define (circular-list x . args) + (let ((res (cons x args))) + (set-cdr! (last-pair res) res) + res)) + +(define (iota count . o) + (let ((start (if (pair? o) (car o) 0)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1))) + (let lp ((i count) (n (+ start (* (- count 1) step))) (res '())) + (if (<= i 0) + res + (lp (- i 1) (- n step) (cons n res)))))) + diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm new file mode 100644 index 00000000..2d44275a --- /dev/null +++ b/lib/srfi/1/deletion.scm @@ -0,0 +1,25 @@ +;; deletion.scm -- list deletion utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (delete x ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (if (eq? eq eq?) + (let lp ((ls ls) (rev '())) ;; fast path for delq + (let ((tail (memq x ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls)))) + (remove (lambda (y) (eq x y)) ls)))) + +(define delete! delete) + +(define (delete-duplicates ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res))) + (reverse! res))))) + +(define delete-duplicates! delete-duplicates) + diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm new file mode 100644 index 00000000..892b075c --- /dev/null +++ b/lib/srfi/1/fold.scm @@ -0,0 +1,115 @@ +;; fold.scm -- list fold/reduce utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (map-onto car lists (list acc)))) + acc)))) + +(define (fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (map-onto car lists (lp (map cdr lists)))) + knil)))) + +(define (pair-fold kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls) (acc knil)) + (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc)) + (let lp ((lists (cons ls lists)) (acc knil)) + (if (every pair? lists) + (lp (map cdr lists) (apply kons (append lists (list acc)))) + acc)))) + +(define (pair-fold-right kons knil ls . lists) + (if (null? lists) + (let lp ((ls ls)) + (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil)) + (let lp ((lists (cons ls lists))) + (if (every pair? lists) + (apply kons (append lists (lp (map cdr lists)))) + knil)))) + +(define (reduce f identity ls) + (if (null? ls) identity (fold f (car ls) (cdr ls)))) + +(define (reduce-right f identity ls) + (if (null? ls) identity (fold-right f (car ls) (cdr ls)))) + +(define (unfold p f g seed . o) + (let lp ((seed seed)) + (if (p seed) + (if (pair? o) ((car o) seed) '()) + (cons (f seed) (lp (g seed)))))) + +(define (unfold-right p f g seed . o) + (let lp ((seed seed) (res (if (pair? o) (car o) '()))) + (if (p seed) res (lp (g seed) (cons (f seed) res))))) + +(define (append-map-helper append f ls lists) + (if (null? lists) + (if (null? ls) + '() + (let ((rev-ls (reverse ls))) + (let lp ((ls (cdr rev-ls)) (res (car rev-ls))) + (if (null? ls) res (lp (cdr ls) (append (f (car ls) res)))) + ))) + (if (and (pair? ls) (every pair? lists)) + (let lp ((lists (cons ls lists))) + (let ((vals (apply f (map car lists))) + (cdrs (map cdr lists))) + (if (every pair? cdrs) (append vals (lp cdrs)) vals))) + '()))) + +(define (append-map f ls . lists) + (append-map-helper append f ls lists)) + +(define (append-map! f ls . lists) + (append-map-helper append! f ls lists)) + +(define map! map) +(define map-in-order map) + +(define (pair-for-each f ls . lists) + (apply pair-fold (lambda (x _) (f x)) ls lists)) + +(define (filter-map f ls . lists) + (if (null? lists) + (let lp ((ls ls) (res '())) + (if (pair? ls) + (let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res))) + (reverse! res))) + (filter (lambda (x) x) (apply map f ls lists)))) + +(define (take-up-to-reverse from to init) + (if (eq? from to) + init + (take-up-to-reverse (cdr from) to (cons (car from) init)))) + +(define (remove pred ls) + (let lp ((ls ls) (rev '())) + (let ((tail (find-tail pred ls))) + (if tail + (lp (cdr tail) (take-up-to-reverse ls tail rev)) + (if (pair? rev) (append-reverse! rev ls) ls))))) + +(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls)) + +(define (partition pred ls) + (let lp ((ls ls) (good '()) (bad '())) + (cond ((null? ls) (values (reverse! good) (reverse! bad))) + ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad)) + (else (lp (cdr ls) good (cons (car ls) bad)))))) + +(define filter! filter) +(define remove! remove) +(define partition! partition) + diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm new file mode 100644 index 00000000..8565fac3 --- /dev/null +++ b/lib/srfi/1/lset.scm @@ -0,0 +1,51 @@ +;; lset.scm -- list set library +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (lset<= eq . sets) + (if (null? sets) + #t + (let lp1 ((set1 (car sets)) (sets (cdr sets))) + (if (null? sets) + #t + (let ((set2 (car sets))) + (let lp2 ((ls set1)) + (if (pair? ls) + (and (member (car set1) set2 eq) (lp2 (cdr ls))) + (lp1 set2 (cdr sets))))))))) + +(define (lset= eq . sets) + (and (apply lset<= eq sets) (apply lset<= eq (reverse sets)))) + +(define (lset-adjoin eq set . elts) + (lset-union2 eq elts set)) + +(define (lset-union2 eq a b) + (if (null? b) + a + (lset-union2 eq (if (member (car b) a eq) a (cons (car b) a)) (cdr b)))) + +(define (lset-union eq . sets) + (reduce (lambda (a b) (lset-union2 eq a b)) '() sets)) + +(define (lset-intersection eq . sets) + (reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-difference eq . sets) + (reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets)) + +(define (lset-xor eq . sets) + (reduce (lambda (a b) + (append (filter (lambda (x) (member x b eq)) a) + (filter (lambda (x) (member x a eq)) b))) + '() + sets)) + +(define (lset-diff+intersection eq . sets) + (values (apply lset-difference eq sets) (apply lset-intersection eq sets))) + +(define lset-diff+intersection! lset-diff+intersection) +(define lset-xor! lset-xor) +(define lset-difference! lset-difference) +(define lset-intersection! lset-intersection) +(define lset-union! lset-union) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm new file mode 100644 index 00000000..1e7568df --- /dev/null +++ b/lib/srfi/1/misc.scm @@ -0,0 +1,54 @@ +;; misc.scm -- miscellaneous list utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (map-onto proc ls init) + (let lp ((ls ls) (res init)) + (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res))))) + +(define (append! . lists) (concatenate! lists)) + +(define (concatenate lists) + (let lp ((ls (reverse lists)) (res '())) + (if (null? ls) res (lp (cdr ls) (append (car ls) res))))) + +(define (concatenate! lists) + (if (null? lists) + '() + (let lp ((ls lists)) + (cond ((not (pair? (cdr ls))) + lists) + (else + (set-cdr! (last-pair (car ls)) (cadr ls)) + (lp (cdr ls))))))) + +(define (append-reverse rev tail) + (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail)))) + +(define (append-reverse! rev tail) + (if (null? rev) + tail + (let ((head (reverse! rev))) + (set-cdr! rev tail) + head))) + +(define (zip . lists) (apply map list lists)) + +(define (unzip1 ls) (map car ls)) +(define (unzip2 ls) (values (map car ls) (map cadr ls))) +(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls))) +(define (unzip4 ls) + (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) +(define (unzip5 ls) + (values (map car ls) (map cadr ls) (map caddr ls) + (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls))) + +(define (count pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (res 0)) + (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res)) + (let lp ((lists (cons ls lists)) (res 0)) + (if (every pair? lists) + (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res)) + res)))) + diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm new file mode 100644 index 00000000..be84e085 --- /dev/null +++ b/lib/srfi/1/predicates.scm @@ -0,0 +1,42 @@ +;; predicates.scm -- list prediates +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (proper-list? x) + (cond ((null? x) #t) + ((pair? x) (proper-list? (cdr x))) + (else #f))) + +(define (circular-list? x) + (and (pair? x) (pair? (cdr x)) + (let race ((hare (cdr x)) (tortoise x)) + (or (eq? hare tortoise) + (and (pair? hare) (pair? (cdr hare)) + (race (cddr hare) (cdr tortoise))))))) + +(define (dotted-list? x) + (not (proper-list? x))) + +(define (not-pair? x) (not (pair? x))) + +(define (null-list? x) (null? x)) ; no error + +(define (list= eq . lists) + (let lp1 ((lists lists)) + (or (null? lists) + (null? (cdr lists)) + (let lp2 ((ls1 (car lists)) (ls2 (cadr lists))) + (if (null? ls1) + (and (null? ls2) + (lp1 (cdr lists))) + (and (eq (car ls1) (car ls2)) + (lp2 (cdr ls1) (cdr ls2)))))))) + +(define (length+ x) + (if (not (pair? x)) + 0 + (let lp ((hare (cdr x)) (tortoise x) (res 0)) + (and (not (eq? hare tortoise)) + (if (pair? hare) + (lp (cddr hare) (cdr tortoise) (+ res 1)) + res))))) diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm new file mode 100644 index 00000000..ea31d931 --- /dev/null +++ b/lib/srfi/1/search.scm @@ -0,0 +1,54 @@ +;; search.scm -- list searching and splitting +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (find pred ls) + (cond ((find-tail pred ls) => car) (else #f))) + +(define (find-tail pred ls) + (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls))))) + +(define (take-while pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (reverse! res)))) + +(define take-while! take-while) + +(define (drop-while pred ls) + (or (find-tail (lambda (x) (not (pred x))) ls) '())) + +(define (span pred ls) + (let lp ((ls ls) (res '())) + (if (and (pair? ls) (pred (car ls))) + (lp (cdr ls) (cons (car ls) res)) + (values (reverse! res) ls)))) + +(define span! span) + +(define (break pred ls) (span (lambda (x) (not (pred x))) ls)) + +(define break! break) + +(define (any pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls))))) + (let lp ((lists (cons ls lists))) + (and (every pair? lists) + (let ((args (map car lists))) + (if (apply pred args) args (lp (map cdr lists)))))))) + +(define (every pred ls . lists) + (if (null? lists) + (let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t)) + (not (apply any (lambda (x) (not (pred x))) ls lists)))) + +(define (list-index pred ls . lists) + (if (null? lists) + (let lp ((ls ls) (n 0)) + (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1))))) + (let lp ((lists (cons ls lists)) (n 0)) + (and (every pair? lists) + (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1))) + )))) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm new file mode 100644 index 00000000..74ef7119 --- /dev/null +++ b/lib/srfi/1/selectors.scm @@ -0,0 +1,59 @@ +;; selectors.scm -- extended list selectors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth ls) (car (cdr (cdr (cdr (cdr ls)))))) +(define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls))))))) +(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (eighth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) +(define (ninth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))) +(define (tenth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))) + +(define (car+cdr x) (values (car x) (cdr x))) + +(define (take ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (reverse! res) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (take! ls i) + (if (<= i 0) + '() + (let ((tail (list-tail ls (- i 1)))) + (set-cdr! tail '()) + ls))) + +(define (drop ls i) + (if (<= i 0) ls (drop (cdr ls) (- i 1)))) + +(define (take-right ls i) + (drop ls (- (length+ ls) i))) + +(define (drop-right ls i) + (take ls (- (length+ ls) i))) + +(define (drop-right! ls i) + (take! ls (- (length+ ls) i))) + +(define (split-at ls i) + (let lp ((i i) (ls ls) (res '())) + (if (<= i 0) + (values (reverse! res) ls) + (lp (- i 1) (cdr ls) (cons (car ls) res))))) + +(define (split-at! ls i) + (if (<= i 0) + (values '() ls) + (let* ((tail (list-tail ls (- i 1))) + (right (cdr tail))) + (set-cdr! tail '()) + (values ls right)))) + +(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls)))) +(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls)))) + diff --git a/lib/srfi/11.module b/lib/srfi/11.module new file mode 100644 index 00000000..f3c91df8 --- /dev/null +++ b/lib/srfi/11.module @@ -0,0 +1,28 @@ + +(define-module (srfi 11) + (export let-values let*-values) + (import-immutable (scheme)) + (body + (define-syntax let*-values + (syntax-rules () + ((let*-values () . body) + (begin . body)) + ((let*-values (((a) expr) . rest) . body) + (let ((a expr)) (let*-values rest . body))) + ((let*-values ((params expr) . rest) . body) + (call-with-values (lambda () expr) + (lambda params (let*-values rest . body)))))) + (define-syntax let-values + (syntax-rules () + ((let-values ("step") (binds ...) bind expr maps () () . body) + (let*-values (binds ... (bind expr)) (let maps . body))) + ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body) + (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body) + (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body) + (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body)) + ((let-values ((params expr) . rest) . body) + (let-values ("step") () () expr () params rest . body)) + )))) + diff --git a/lib/srfi/16.module b/lib/srfi/16.module new file mode 100644 index 00000000..f931a376 --- /dev/null +++ b/lib/srfi/16.module @@ -0,0 +1,24 @@ + +(define-module (srfi 16) + (export case-lambda) + (import-immutable (scheme)) + (body + (define-syntax %case + (syntax-rules () + ((%case args len n p ((params ...) . body) . rest) + (if (= len (length '(params ...))) + (apply (lambda (params ...) . body) args) + (%case args len 0 () . rest))) + ((%case args len n (p ...) ((x . y) . body) . rest) + (%case args len (+ n 1) (p ... x) (y . body) . rest)) + ((%case args len n (p ...) (y . body) . rest) + (if (>= len n) + (apply (lambda (p ... y) . body) args) + (%case args len 0 () . rest))) + ((%case args len n p) + (error "case-lambda: no cases matched")))) + (define-syntax case-lambda + (syntax-rules () + ((case-lambda . clauses) + (lambda args (let ((len (length args))) (%case args len 0 () . clauses)))))))) + diff --git a/lib/srfi/18.module b/lib/srfi/18.module new file mode 100644 index 00000000..3ed564f8 --- /dev/null +++ b/lib/srfi/18.module @@ -0,0 +1,24 @@ + +(define-module (srfi 18) + (export + current-thread thread? make-thread thread-name + thread-specific thread-specific-set! thread-start! + thread-yield! thread-sleep! thread-terminate! + thread-join! mutex? make-mutex mutex-name + mutex-specific mutex-specific-set! mutex-state + mutex-lock! mutex-unlock! condition-variable? + make-condition-variable condition-variable-name + condition-variable-specific condition-variable-specific-set! + condition-variable-signal! condition-variable-broadcast! + current-time time? time->seconds seconds->time + current-exception-handler with-exception-handler raise + join-timeout-exception? abandoned-mutex-exception? + terminated-thread-exception? uncaught-exception? + uncaught-exception-reason) + (import-immutable (scheme) + (srfi 9) + (chibi ast) + (chibi time)) + (include-shared "18/threads") + (include "18/types.scm" "18/interface.scm")) + diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm new file mode 100644 index 00000000..f814aa6a --- /dev/null +++ b/lib/srfi/18/interface.scm @@ -0,0 +1,63 @@ + +(define (thread-join! thread . o) + (let ((timeout (if (pair? o) (car o) #f))) + (cond + ((%thread-join! thread timeout)) + (else + (thread-yield!) + (if (thread-timeout?) + (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (error "timed out waiting for thread" thread)) + #t))))) + +(define (thread-terminate! thread) + (if (%thread-terminate! thread) ;; need to yield if terminating ourself + (thread-yield!))) + +(define (thread-sleep! timeout) + (%thread-sleep! timeout) + (thread-yield!)) + +(define (mutex-lock! mutex . o) + (let ((timeout (and (pair? o) (car o))) + (thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t))) + (cond ((%mutex-lock! mutex timeout thread)) + (else + (thread-yield!) + (not (thread-timeout?)))))) + +(define (mutex-unlock! mutex . o) + (let ((condvar (and (pair? o) (car o))) + (timeout (if (and (pair? o) (pair? (cdr o))) (cadr o) #f))) + (cond ((%mutex-unlock! mutex condvar timeout)) + (else + (thread-yield!) + (not (thread-timeout?)))))) + +(define current-time get-time-of-day) +(define time? timeval?) + +(define (join-timeout-exception? x) + (and (exception? x) + (equal? (exception-message x) "timed out waiting for thread"))) + +;; XXXX flush out exception types +(define (abandoned-mutex-exception? x) #f) +(define (terminated-thread-exception? x) #f) +(define (uncaught-exception? x) #f) +(define (uncaught-exception-reason x) #f) + +;; signal runner + +(define (signal-runner) + (let lp () + (let ((n (pop-signal!))) + (cond + ((integer? n) + (let ((handler (get-signal-handler n))) + (if (procedure? handler) + (handler n)))) + (else + (thread-sleep! #t)))) + (lp))) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c new file mode 100644 index 00000000..b84d59f4 --- /dev/null +++ b/lib/srfi/18/threads.c @@ -0,0 +1,421 @@ +/* threads.c -- SRFI-18 thread primitives */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include +#include +#include + +#define sexp_mutex_name(x) sexp_slot_ref(x, 0) +#define sexp_mutex_specific(x) sexp_slot_ref(x, 1) +#define sexp_mutex_thread(x) sexp_slot_ref(x, 2) +#define sexp_mutex_lockp(x) sexp_slot_ref(x, 3) + +#define sexp_condvar_name(x) sexp_slot_ref(x, 0) +#define sexp_condvar_specific(x) sexp_slot_ref(x, 1) +#define sexp_condvar_threads(x) sexp_slot_ref(x, 2) + +#define timeval_le(a, b) (((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec < (b).tv_usec))) +#define sexp_context_before(c, t) (((sexp_context_timeval(c).tv_sec != 0) || (sexp_context_timeval(c).tv_usec != 0)) && timeval_le(sexp_context_timeval(c), t)) + +/* static int mutex_id, condvar_id; */ + +/**************************** threads *************************************/ + +static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { + sexp_gc_var2(name, op); + sexp_gc_preserve2(ctx, name, op); + name = sexp_c_string(ctx, cname, -1); + op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); + sexp_gc_release2(ctx); +} + +sexp sexp_thread_timeoutp (sexp ctx sexp_api_params(self, n)) { + return sexp_make_boolean(sexp_context_timeoutp(ctx)); +} + +sexp sexp_thread_name (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + return sexp_context_name(thread); +} + +sexp sexp_thread_specific (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + return sexp_context_specific(thread); +} + +sexp sexp_thread_specific_set (sexp ctx sexp_api_params(self, n), sexp thread, sexp val) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + sexp_context_specific(thread) = val; + return SEXP_VOID; +} + +sexp sexp_current_thread (sexp ctx sexp_api_params(self, n)) { + return ctx; +} + +sexp sexp_make_thread (sexp ctx sexp_api_params(self, n), sexp thunk, sexp name) { + sexp res, *stack; + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk); + res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0); + sexp_context_proc(res) = thunk; + sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk)); + stack = sexp_stack_data(sexp_context_stack(res)); + stack[0] = stack[1] = stack[3] = SEXP_ZERO; + stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + sexp_context_top(res) = 4; + sexp_context_last_fp(res) = 0; + return res; +} + +sexp sexp_thread_start (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp cell; + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + cell = sexp_cons(ctx, thread, SEXP_NULL); + if (sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = cell; + sexp_global(ctx, SEXP_G_THREADS_BACK) = cell; + } else { /* init queue */ + sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) = cell; + } + return SEXP_VOID; +} + +sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) { + sexp res = sexp_make_boolean(ctx == thread); + for ( ; thread && sexp_contextp(thread); thread=sexp_context_child(thread)) + sexp_context_refuel(thread) = 0; + /* return true if terminating self */ + return res; +} + +static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { +#if SEXP_USE_FLONUMS + double d; +#endif + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + if (sexp_integerp(timeout) || sexp_flonump(timeout)) + gettimeofday(&sexp_context_timeval(ctx), NULL); + if (sexp_integerp(timeout)) { + sexp_context_timeval(ctx).tv_sec += sexp_unbox_fixnum(timeout); +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(timeout)) { + d = sexp_flonum_value(timeout); + sexp_context_timeval(ctx).tv_sec += trunc(d); + sexp_context_timeval(ctx).tv_usec += (d-trunc(d))*1000000; +#endif + } else { + sexp_context_timeval(ctx).tv_sec = 0; + sexp_context_timeval(ctx).tv_usec = 0; + } + if (sexp_numberp(timeout)) + while (sexp_pairp(ls2) + && sexp_context_before(sexp_car(ls2), sexp_context_timeval(ctx))) + ls1=ls2, ls2=sexp_cdr(ls2); + else + while (sexp_pairp(ls2) && sexp_context_timeval(sexp_car(ls2)).tv_sec) + ls1=ls2, ls2=sexp_cdr(ls2); + if (ls1 == SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cons(ctx, thread, ls2); + else + sexp_cdr(ls1) = sexp_cons(ctx, thread, ls2); +} + +sexp sexp_thread_join (sexp ctx sexp_api_params(self, n), sexp thread, sexp timeout) { + sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread); + if (sexp_context_refuel(thread) <= 0) /* return true if already terminated */ { + return SEXP_TRUE; + } + sexp_context_timeoutp(ctx) = 0; + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = thread; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; +} + +sexp sexp_thread_sleep (sexp ctx sexp_api_params(self, n), sexp timeout) { + sexp_context_waitp(ctx) = 1; + if (timeout != SEXP_TRUE) { + sexp_assert_type(ctx, sexp_numberp, SEXP_NUMBER, timeout); + sexp_insert_timed(ctx, ctx, timeout); + } + return SEXP_FALSE; +} + +/**************************** mutexes *************************************/ + +sexp sexp_mutex_state (sexp ctx sexp_api_params(self, n), sexp mutex) { + /* sexp_assert_type(ctx, sexp_mutexp, mutex_id, timeout); */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + if (sexp_contextp(sexp_mutex_thread(mutex))) + return sexp_mutex_thread(mutex); + else + return sexp_intern(ctx, "not-owned", -1); + } else { + return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1); + } +} + +sexp sexp_mutex_lock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp timeout, sexp thread) { + if (thread == SEXP_TRUE) + thread = ctx; + if (sexp_not(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_TRUE; + sexp_mutex_thread(mutex) = thread; + return SEXP_TRUE; + } else { + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = mutex; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; + } +} + +sexp sexp_mutex_unlock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp condvar, sexp timeout) { + sexp ls1, ls2; + if (sexp_not(condvar)) { + /* normal unlock - always succeeds, just need to unblock threads */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_FALSE; + sexp_mutex_thread(mutex) = ctx; + /* search for threads blocked on this mutex */ + for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == mutex) { + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2; + if (! sexp_pairp(sexp_cdr(ls2))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + sexp_context_waitp(sexp_car(ls2)) + = sexp_context_timeoutp(sexp_car(ls2)) = 0; + break; + } + } + return SEXP_TRUE; + } else { + /* wait on condition var */ + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = condvar; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; + } +} + +/**************************** condition variables *************************/ + +sexp sexp_condition_variable_signal (sexp ctx sexp_api_params(self, n), sexp condvar) { + sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + for ( ; sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_context_event(sexp_car(ls2)) == condvar) { + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2; + if (! sexp_pairp(sexp_cdr(ls2))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + sexp_context_waitp(sexp_car(ls2)) = sexp_context_timeoutp(sexp_car(ls2)) = 0; + return SEXP_TRUE; + } + return SEXP_FALSE; +} + +sexp sexp_condition_variable_broadcast (sexp ctx sexp_api_params(self, n), sexp condvar) { + sexp res = SEXP_FALSE; + while (sexp_truep(sexp_condition_variable_signal(ctx, self, n, condvar))) + res = SEXP_TRUE; + return res; +} + +/**************************** the scheduler *******************************/ + +void sexp_wait_on_single_thread (sexp ctx) { + struct timeval tval; + useconds_t usecs = 0; + gettimeofday(&tval, NULL); + if (tval.tv_sec < sexp_context_timeval(ctx).tv_sec) + usecs = (sexp_context_timeval(ctx).tv_sec - tval.tv_sec) * 1000000; + if (tval.tv_usec < sexp_context_timeval(ctx).tv_usec) + usecs += sexp_context_timeval(ctx).tv_usec - tval.tv_usec; + usleep(usecs); +} + +static const sexp_uint_t sexp_log2_lookup[32] = { + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 +}; + +/* only works on powers of two */ +static sexp_uint_t sexp_log2_of_pow2 (sexp_uint_t n) { + return sexp_log2_lookup[(n * 0x077CB531U) >> 27]; +} + +static sexp sexp_pop_signal (sexp ctx sexp_api_params(self, n)) { + int allsigs, restsigs, signum; + if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) == SEXP_ZERO) { + return SEXP_FALSE; + } else { + allsigs = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS)); + restsigs = allsigs & (allsigs-1); + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = sexp_make_fixnum(restsigs); + signum = sexp_log2_of_pow2(allsigs-restsigs); + return sexp_make_fixnum(signum); + } +} + +static sexp sexp_get_signal_handler (sexp ctx sexp_api_params(self, n), sexp signum) { + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, signum); + return sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); +} + +sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { + struct timeval tval; + sexp res, ls1, ls2, runner, paused, front; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + + front = sexp_global(ctx, SEXP_G_THREADS_FRONT); + paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); + + /* check for signals */ + if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) { + runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER); + if (! sexp_contextp(runner)) { /* ensure the runner exists */ + if (sexp_envp(runner)) { + tmp = sexp_env_cell(runner, (tmp=sexp_intern(ctx, "signal-runner", -1))); + if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) { + runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE); + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner; + sexp_thread_start(ctx, self, 1, runner); + } + } + } else if (sexp_context_waitp(runner)) { /* wake it if it's sleeping */ + sexp_context_waitp(runner) = 0; + sexp_thread_start(ctx, self, 1, runner); + } + } + + /* if we've terminated, check threads joining us */ + if (sexp_context_refuel(ctx) <= 0) { + for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { + if (sexp_context_event(sexp_car(ls2)) == ctx) { + sexp_context_waitp(sexp_car(ls2)) = 0; + sexp_context_timeoutp(sexp_car(ls2)) = 0; + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + tmp = sexp_cdr(ls2); + sexp_cdr(ls2) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + ls2 = tmp; + } else { + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + } + } + + /* check timeouts */ + if (sexp_pairp(paused)) { + if (gettimeofday(&tval, NULL) == 0) { + ls1 = SEXP_NULL; + ls2 = paused; + while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), tval)) { + sexp_context_timeoutp(sexp_car(ls2)) = 1; + sexp_context_waitp(ctx) = 0; + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + if (sexp_pairp(ls1)) { + sexp_cdr(ls1) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = paused; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1; + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = ls2; + } + } + } + + /* dequeue next thread */ + if (sexp_pairp(front)) { + res = sexp_car(front); + if ((sexp_context_refuel(ctx) <= 0) || sexp_context_waitp(ctx)) { + /* either terminated or paused */ + sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(front); + if (! sexp_pairp(sexp_cdr(front))) + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + } else { + /* swap with front of queue */ + sexp_car(sexp_global(ctx, SEXP_G_THREADS_FRONT)) = ctx; + /* rotate front of queue to back */ + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) + = sexp_global(ctx, SEXP_G_THREADS_FRONT); + sexp_global(ctx, SEXP_G_THREADS_FRONT) + = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_FRONT)); + sexp_global(ctx, SEXP_G_THREADS_BACK) + = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)); + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = SEXP_NULL; + } + } else { + res = ctx; + } + + if (sexp_context_waitp(res)) { + /* the only thread available was waiting */ + sexp_wait_on_single_thread(res); + sexp_context_timeoutp(res) = 1; + sexp_context_waitp(res) = 0; + } + + sexp_gc_release1(ctx); + return res; +} + +/**************************************************************************/ + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + + sexp_define_type_predicate(ctx, env, "thread?", SEXP_CONTEXT); + sexp_define_foreign(ctx, env, "thread-timeout?", 0, sexp_thread_timeoutp); + sexp_define_foreign(ctx, env, "current-thread", 0, sexp_current_thread); + sexp_define_foreign_opt(ctx, env, "make-thread", 2, sexp_make_thread, SEXP_FALSE); + sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start); + sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate); + sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join); + sexp_define_foreign(ctx, env, "%thread-sleep!", 1, sexp_thread_sleep); + sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name); + sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific); + sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set); + sexp_define_foreign(ctx, env, "mutex-state", 1, sexp_mutex_state); + sexp_define_foreign(ctx, env, "%mutex-lock!", 3, sexp_mutex_lock); + sexp_define_foreign(ctx, env, "%mutex-unlock!", 3, sexp_mutex_unlock); + sexp_define_foreign(ctx, env, "condition-variable-signal!", 1, sexp_condition_variable_signal); + sexp_define_foreign(ctx, env, "condition-variable-broadcast!", 1, sexp_condition_variable_broadcast); + sexp_define_foreign(ctx, env, "pop-signal!", 0, sexp_pop_signal); + sexp_define_foreign(ctx, env, "get-signal-handler", 1, sexp_get_signal_handler); + + sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) + = sexp_make_foreign(ctx, "scheduler", 0, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); + + /* remember the env to lookup the runner later */ + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env; + + return SEXP_VOID; +} + diff --git a/lib/srfi/18/types.scm b/lib/srfi/18/types.scm new file mode 100644 index 00000000..093c97a7 --- /dev/null +++ b/lib/srfi/18/types.scm @@ -0,0 +1,24 @@ +;; types.scm -- thread types +;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type mutex + (%make-mutex name specific thread lock) + mutex? + (name mutex-name) + (specific mutex-specific mutex-specific-set!) + (thread %mutex-thread %mutex-thread-set!) + (lock %mutex-lock %mutex-lock-set!)) + +(define (make-mutex . o) + (%make-mutex (and (pair? o) (car o)) #f #f #f)) + +(define-record-type condition-variable + (%make-condition-variable name specific threads) + condition-variable? + (name condition-variable-name) + (specific condition-variable-specific condition-variable-specific-set!) + (threads %condition-variable-threads %condition-variable-threads-set!)) + +(define (make-condition-variable . o) + (%make-condition-variable (and (pair? o) (car o)) #f #f)) diff --git a/lib/srfi/2.module b/lib/srfi/2.module new file mode 100644 index 00000000..4ceb8b6b --- /dev/null +++ b/lib/srfi/2.module @@ -0,0 +1,16 @@ + +(define-module (srfi 2) + (export and-let*) + (import-immutable (scheme)) + (body + (define-syntax and-let* + (syntax-rules () + ((and-let* () . body) + (begin . body)) + ((and-let* ((var expr) . rest) . body) + (let ((var expr)) + (and var (and-let* rest . body)))) + ((and-let* ((expr) . rest) . body) + (let ((tmp expr)) + (and tmp (and-let* rest . body)))))))) + diff --git a/lib/srfi/26.module b/lib/srfi/26.module new file mode 100644 index 00000000..f97ab783 --- /dev/null +++ b/lib/srfi/26.module @@ -0,0 +1,24 @@ + +(define-module (srfi 26) + (export cut cute) + (import-immutable (scheme)) + (body + (define-syntax %cut + (syntax-rules (<> <...>) + ((%cut e? params args) + (lambda params args)) + ((%cut e? (params ...) (args ...) <> . rest) + (%cut e? (params ... tmp) (args ... tmp) . rest)) + ((%cut e? (params ...) (args ...) <...>) + (%cut e? (params ... . tmp) (apply args ... tmp))) + ((%cut e? (params ...) (args ...) <...> . rest) + (error "cut: non-terminal <...>")) + ((%cut #t (params ...) (args ...) x . rest) + (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest))) + ((%cut #f (params ...) (args ...) x . rest) + (%cut #t (params ...) (args ... x) . rest)))) + (define-syntax cut + (syntax-rules () ((cut args ...) (%cut #f () () args ...)))) + (define-syntax cute + (syntax-rules () ((cute args ...) (%cut #t () () args ...)))))) + diff --git a/lib/srfi/27.module b/lib/srfi/27.module new file mode 100644 index 00000000..5c451629 --- /dev/null +++ b/lib/srfi/27.module @@ -0,0 +1,11 @@ + +(define-module (srfi 27) + (export random-integer random-real default-random-source + make-random-source random-source? + random-source-state-ref random-source-state-set! + random-source-randomize! random-source-pseudo-randomize! + random-source-make-integers random-source-make-reals) + (import-immutable (scheme)) + (include-shared "27/rand") + (include "27/constructors.scm")) + diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm new file mode 100644 index 00000000..dbd0a8c6 --- /dev/null +++ b/lib/srfi/27/constructors.scm @@ -0,0 +1,10 @@ +;; constructors.scm -- random function constructors +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (random-source-make-integers rs) + (lambda (n) (%random-integer rs n))) + +(define (random-source-make-reals rs . o) + (lambda () (%random-real rs))) + diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c new file mode 100644 index 00000000..6e971df8 --- /dev/null +++ b/lib/srfi/27/rand.c @@ -0,0 +1,204 @@ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include +#include + +#define SEXP_RANDOM_STATE_SIZE 128 + +#define ZERO sexp_make_fixnum(0) +#define ONE sexp_make_fixnum(1) +#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE) + +#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id) + +#define sexp_random_init(x, seed) \ + initstate_r(seed, \ + sexp_string_data(sexp_random_state(x)), \ + SEXP_RANDOM_STATE_SIZE, \ + sexp_random_data(x)) + +#if SEXP_BSD || defined(__CYGWIN__) +typedef unsigned int sexp_random_t; +#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs))) +#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n) +#else +typedef struct random_data sexp_random_t; +#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst) +#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs)) +#endif + +#define sexp_random_state(x) (sexp_slot_ref((x), 0)) +#define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1))) + +#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp)) + +static sexp_uint_t rs_type_id; +static sexp default_random_source; + +static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, sexp bound) { + sexp res; + int32_t m; +#if SEXP_USE_BIGNUMS + int32_t hi, mod, len, i, *data; +#endif + if (! sexp_random_source_p(rs)) + res = sexp_type_exception(ctx, self, rs_type_id, rs); + if (sexp_fixnump(bound)) { + sexp_call_random(rs, m); + res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(bound)) { + hi = sexp_bignum_hi(bound); + len = hi * sizeof(sexp_uint_t) / sizeof(int32_t); + res = sexp_make_bignum(ctx, hi); + data = (int32_t*) sexp_bignum_data(res); + for (i=0; i +#include + +#if SEXP_USE_BIGNUMS +#include +#else +#define sexp_bignum_normalize(x) x +#endif + +static sexp sexp_bit_and (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { + sexp res; +#if SEXP_USE_BIGNUMS + sexp_sint_t len, i; +#endif + if (sexp_fixnump(x)) { + if (sexp_fixnump(y)) + res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(y)) + res = sexp_bit_and(ctx sexp_api_pass(self, n), y, x); +#endif + else + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + if (sexp_fixnump(y)) { + res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); + } else if (sexp_bignump(y)) { + if (sexp_bignum_length(x) < sexp_bignum_length(y)) + res = sexp_copy_bignum(ctx, NULL, x, 0); + else + res = sexp_copy_bignum(ctx, NULL, y, 0); + for (i=0, len=sexp_bignum_length(res); i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i> -c); + } else { + tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c; +#if SEXP_USE_BIGNUMS + if (((tmp >> c) == sexp_unbox_fixnum(i)) + && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) { +#endif + res = sexp_make_fixnum(tmp); +#if SEXP_USE_BIGNUMS + } else { + sexp_gc_preserve1(ctx, res); + res = sexp_fixnum_to_bignum(ctx, i); + res = sexp_arithmetic_shift(ctx sexp_api_pass(self, n), res, count); + sexp_gc_release1(ctx); + } +#endif + } +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(i)) { + len = sexp_bignum_hi(i); + if (c < 0) { + c = -c; + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + if (len < offset) { + res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1); + } else { + res = sexp_make_bignum(ctx, len - offset + 1); + for (j=len-offset, tmp=0; j>=0; j--) { + sexp_bignum_data(res)[j] + = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp; + tmp = sexp_bignum_data(i)[j+offset] + << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + } + } else { + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + res = sexp_make_bignum(ctx, len + offset + 1); + for (j=tmp=0; j> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + sexp_bignum_data(res)[len+offset] = tmp; + } +#endif + } else { + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + } + return sexp_bignum_normalize(res); +} + +/* bit-count and integer-length were adapted from: */ +/* http://graphics.stanford.edu/~seander/bithacks.html */ +static sexp_uint_t bit_count (sexp_uint_t i) { + i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3); + i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3) + + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3)); + i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15; + return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255)) + >> (sizeof(i) - 1) * CHAR_BIT); +} + +static sexp sexp_bit_count (sexp ctx sexp_api_params(self, n), sexp x) { + sexp res; + sexp_sint_t i; +#if SEXP_USE_BIGNUMS + sexp_uint_t count; +#endif + if (sexp_fixnump(x)) { + i = sexp_unbox_fixnum(x); + res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + for (i=count=0; i> 32)) + return integer_log2(tt) + 32; + else +#endif + if ((tt = x >> 16)) + return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt]; + else + return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; +} + +static sexp sexp_integer_length (sexp ctx sexp_api_params(self, n), sexp x) { + sexp_sint_t tmp; +#if SEXP_USE_BIGNUMS + sexp_sint_t hi; +#endif + if (sexp_fixnump(x)) { + tmp = sexp_unbox_fixnum(x); + return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp)); +#if SEXP_USE_BIGNUMS + } else if (sexp_bignump(x)) { + hi = sexp_bignum_hi(x); + return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi]) + + hi*sizeof(sexp_uint_t)); +#endif + } else { + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + } +} + +static sexp sexp_bit_set_p (sexp ctx sexp_api_params(self, n), sexp i, sexp x) { +#if SEXP_USE_BIGNUMS + sexp_uint_t pos; +#endif + if (! sexp_fixnump(i)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + if (sexp_fixnump(x)) { + return sexp_make_boolean(sexp_unbox_fixnum(x) & (1< (lambda (cell) (set-cdr! cell (+ (cdr cell) 1)))) + ((pair? x) + (set! seen (cons (cons x 1) seen)) + (find (car x)) + (find (cdr x))) + ((vector? x) + (set! seen (cons (cons x 1) seen)) + (do ((i 0 (+ i 1))) + ((= i (vector-length x))) + (find (vector-ref x i)))))) + (let extract ((ls seen) (res '())) + (cond + ((null? ls) res) + ((> (cdar ls) 1) (extract (cdr ls) (cons (cons (caar ls) #f) res))) + (else (extract (cdr ls) res)))))) + +(define (write-with-shared-structure x . o) + (let ((out (if (pair? o) (car o) (current-output-port))) + (shared (extract-shared-objects x)) + (count 0)) + (define (check-shared x prefix cont) + (let ((cell (assq x shared))) + (cond ((and cell (cdr cell)) + (display prefix out) + (display "#" out) + (write (cdr cell)) + (display "#" out)) + (else + (cond (cell + (display prefix out) + (display "#=" out) + (write count out) + (set-cdr! cell count) + (set! count (+ count 1)))) + (cont x))))) + (cond + ((null? shared) + (write x out)) + (else + (let wr ((x x)) + (check-shared + x + "" + (lambda (x) + (cond + ((pair? x) + (display "(" out) + (wr (car x)) + (let lp ((ls (cdr x))) + (check-shared + ls + " . " + (lambda (ls) + (cond ((null? ls)) + ((pair? ls) + (display " " out) + (wr (car ls)) + (lp (cdr ls))) + (else + (display " . " out) + (wr ls)))))) + (display ")" out)) + ((vector? x) + (display "#(" out) + (let ((len (vector-length x))) + (cond ((> len 0) + (wr (vector-ref x 0)) + (do ((i 1 (+ i 1))) + ((= i len)) + (display " " out) + (wr (vector-ref x i)))))) + (display ")" out)) + (else + (write x out)))))))))) + +(define write/ss write-with-shared-structure) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (skip-line in) + (let ((c (read-char in))) + (if (not (or (eof-object? c) (eqv? c #\newline))) + (skip-line in)))) + +(define (skip-whitespace in) + (case (peek-char in) + ((#\space #\tab #\newline #\return) + (read-char in) + (skip-whitespace in)) + ((#\;) + (skip-line in) + (skip-whitespace in)))) + +(define (skip-comment in depth) + (case (read-char in) + ((#\#) (skip-comment in (if (eqv? #\| (peek-char in)) (+ depth 1) depth))) + ((#\|) (if (eqv? #\# (peek-char in)) + (if (zero? depth) (read-char in) (skip-comment in (- depth 1))) + (skip-comment in depth))) + (else (if (eof-object? (peek-char in)) + (error "unterminated #| comment") + (skip-comment in depth))))) + +(define delimiters + '(#\( #\) #\[ #\] #\space #\tab #\newline #\return)) + +(define read-with-shared-structure + (let ((read read)) + (lambda o + (let ((in (if (pair? o) (car o) (current-input-port))) + (shared '())) + (define (read-label res) + (let ((c (char-downcase (peek-char in)))) + (if (if (char-numeric? c) #t (memv c '(#\a #\b #\c #\d #\e))) + (read-label (cons (read-char in) res)) + (list->string (reverse res))))) + (define (read-number base) + (let* ((str (read-label '())) + (n (string->number str base))) + (if (or (not n) (not (memv (peek-char in) delimiters))) + (error "read error: invalid number syntax" str (peek-char in)) + n))) + (define (read-float-tail in) ;; called only after a leading period + (let lp ((res 0.0) (k 0.1)) + (let ((c (peek-char in))) + (cond + ((char-numeric? c) (lp (+ res (* (read-char in) k)) (* k 0.1))) + ((memv c delimiters) res) + (else (error "invalid char in float syntax" c)))))) + (define (read-name c in) + (let lp ((ls (if (char? c) (list c) '()))) + (let ((c (peek-char in))) + (cond ((memv c delimiters) (list->string (reverse ls))) + (else (lp (cons (read-char in) ls))))))) + (define (read-named-char c in) + (let ((name (read-name c in))) + (cond ((string-ci=? name "space") #\space) + ((string-ci=? name "newline") #\newline) + (else (error "unknown char name"))))) + (define (read-one) + (skip-whitespace in) + (case (peek-char in) + ((#\#) + (read-char in) + (case (char-downcase (peek-char in)) + ((#\=) + (read-char in) + (let* ((str (read-label '())) + (n (string->number str)) + (cell (list #f)) + (thunk (lambda () (car cell)))) + (if (not n) (error "read error: invalid reference" str)) + (set! shared (cons (cons n thunk) shared)) + (let ((x (read-one))) + (set-car! cell x) + x))) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let ((n (string->number (read-label '())))) + (cond + ((not (eqv? #\# (peek-char in))) + (error "read error: expected # after #n" (read-char in))) + (else + (read-char in) + (cond ((assv n shared) => cdr) + (else (error "read error: unknown reference" n))))))) + ((#\;) + (read-char in) + (read-one) ;; discard + (read-one)) + ((#\|) + (skip-comment in 0)) + ((#\!) (skip-line in) (read-one in)) + ((#\() (list->vector (read-one))) + ((#\') (read-char in) (list 'syntax (read-one))) + ((#\`) (read-char in) (list 'quasisyntax (read-one))) + ((#\t) (read-char in) #t) + ((#\f) (read-char in) #t) ; support SRFI-4 f32/64 vectors + ((#\d) (read-char in) (read in)) + ((#\x) (read-char in) (read-number 16)) + ((#\o) (read-char in) (read-number 8)) + ((#\b) (read-char in) (read-number 2)) + ((#\i) (read-char in) (exact->inexact (read-one))) + ((#\e) (read-char in) (inexact->exact (read-one))) + ((#\\) + (read-char in) + (let ((c (read-char in))) + (if (memv (peek-char in) delimiters) + c + (read-named-char c in)))) + (else + (error "unknown # syntax: " (peek-char in))))) + ((#\() + (read-char in) + (let lp ((res '())) + (skip-whitespace in) + (case (peek-char in) + ((#\)) + (read-char in) + (reverse res)) + ((#\.) + (read-char in) + (cond + ((memv (peek-char in) delimiters) + (let ((tail (read-one))) + (skip-whitespace in) + (if (eqv? #\) (peek-char in)) + (begin (read-char in) (append (reverse res) tail)) + (error "expected end of list after dot")))) + ((char-numeric? (peek-char in)) (read-float-tail in)) + (else (string->symbol (read-name #\. in))))) + (else + (lp (cons (read-one) res)))))) + ((#\') (read-char in) (list 'quote (read-one))) + ((#\`) (read-char in) (list 'quasiquote (read-one))) + ((#\,) + (read-char in) + (list (if (eqv? #\@ (peek-char in)) + (begin (read-char in) 'unquote-splicing) + 'unquote) + (read-one))) + (else + (read in)))) + ;; body + (let ((res (read-one))) + (if (pair? shared) + (patch res)) + res))))) + +(define (hole? x) (procedure? x)) +(define (fill-hole x) (if (hole? x) (fill-hole (x)) x)) + +(define (patch x) + (cond + ((pair? x) + (if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch (car x))) + (if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch (cdr x)))) + ((vector? x) + (do ((i (- (vector-length x) 1) (- i 1))) + ((< i 0)) + (let ((elt (vector-ref x i))) + (if (hole? elt) + (vector-set! x i (fill-hole elt)) + (patch elt))))))) + +(define read/ss read-with-shared-structure) diff --git a/lib/srfi/39.module b/lib/srfi/39.module new file mode 100644 index 00000000..11b9ed9f --- /dev/null +++ b/lib/srfi/39.module @@ -0,0 +1,25 @@ + +(define-module (srfi 39) + (export make-parameter parameterize) + (import-immutable (scheme)) + (body + (define (make-parameter value . o) + (if (pair? o) + (let ((converter (car o))) + (lambda args + (if (null? args) + value + (set! value (converter (car args)))))) + (lambda args (if (null? args) value (set! value (car args)))))) + (define-syntax parameterize + (syntax-rules () + ((parameterize ("step") ((param value tmp1 tmp2) ...) () body) + (let ((tmp1 value) ...) + (let ((tmp2 (param)) ...) + (dynamic-wind (lambda () (param tmp1) ...) + (lambda () . body) + (lambda () (param tmp2) ...))))) + ((parameterize ("step") args ((param value) . rest) body) + (parameterize ("step") ((param value tmp1 tmp2) . args) rest body)) + ((parameterize ((param value) ...) . body) + (parameterize ("step") () ((param value) ...) body)))))) diff --git a/lib/srfi/6.module b/lib/srfi/6.module new file mode 100644 index 00000000..e589b6ff --- /dev/null +++ b/lib/srfi/6.module @@ -0,0 +1,5 @@ + +(define-module (srfi 6) + (export open-input-string open-output-string get-output-string) + (import-immutable (scheme))) + diff --git a/lib/srfi/69.module b/lib/srfi/69.module new file mode 100644 index 00000000..037b6393 --- /dev/null +++ b/lib/srfi/69.module @@ -0,0 +1,17 @@ + +(define-module (srfi 69) + (export + make-hash-table hash-table? alist->hash-table + hash-table-equivalence-function hash-table-hash-function + hash-table-ref hash-table-ref/default hash-table-set! + hash-table-delete! hash-table-exists? + hash-table-update! hash-table-update!/default + hash-table-size hash-table-keys hash-table-values + hash-table-walk hash-table-fold hash-table->alist + hash-table-copy hash-table-merge! + hash string-hash string-ci-hash hash-by-identity) + (import-immutable (scheme) + (srfi 9)) + (include-shared "69/hash") + (include "69/type.scm" "69/interface.scm")) + diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c new file mode 100644 index 00000000..42d1e864 --- /dev/null +++ b/lib/srfi/69/hash.c @@ -0,0 +1,242 @@ +/* hash.c -- type-general hashing */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define HASH_DEPTH 5 +#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM) + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0) +#define sexp_hash_table_size(x) sexp_slot_ref(x, 1) +#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2) +#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3) + +#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2)) + +static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc % bound; +} + +static sexp sexp_string_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); + return sexp_make_fixnum(string_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) { + sexp_uint_t acc = FNV_OFFSET_BASIS; + while (*str) {acc *= FNV_PRIME; acc ^= (tolower)(*str++);} + return acc % bound; +} + +static sexp sexp_string_ci_hash (sexp ctx sexp_api_params(self, n), sexp str, sexp bound) { + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + else if (! sexp_fixnump(bound)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); + return sexp_make_fixnum(string_ci_hash(sexp_string_data(str), + sexp_unbox_fixnum(bound))); +} + +static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) { + sexp_uint_t acc = FNV_OFFSET_BASIS, size; + sexp_sint_t i, len; + sexp t, *p; + char *p0; + loop: +#if SEXP_USE_FLONUMS + if (sexp_flonump(obj)) + acc ^= (sexp_sint_t) sexp_flonum_value(obj); + else +#endif + if (sexp_pointerp(obj)) { + if (depth) { + t = sexp_object_type(ctx, obj); + p = (sexp*) (((char*)obj) + sexp_type_field_base(t)); + p0 = ((char*)obj) + offsetof(struct sexp_struct, value); + if ((sexp)p == obj) p=(sexp*)p0; + /* hash trailing non-object data */ + size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp)); + if (((char*)obj + size) > p0) + for (i=0; i 0) { + depth--; + for (i=0; ialist table) + (hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '())) + +(define (hash-table-keys table) + (hash-table-fold table (lambda (k v a) (cons k a)) '())) + +(define (hash-table-values table) + (hash-table-fold table (lambda (k v a) (cons v a)) '())) + +(define (alist->hash-table ls . o) + (let ((res (apply make-hash-table o))) + (for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls) + res)) + +(define (hash-table-merge! a b) + (hash-table-walk b (lambda (k v) (hash-table-set! a k v))) + a) + +(define (hash-table-copy table) + (assert-hash-table "hash-table-copy" table) + (let ((res (make-hash-table (hash-table-equivalence-function table)))) + (hash-table-merge! res table) + res)) + diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm new file mode 100644 index 00000000..1fca9953 --- /dev/null +++ b/lib/srfi/69/type.scm @@ -0,0 +1,12 @@ +;; types.scm -- the hash-table record type +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type hash-table + (%make-hash-table buckets size hash-fn eq-fn) + hash-table? + (buckets hash-table-buckets hash-table-buckets-set!) + (size hash-table-size hash-table-size-set!) + (hash-fn %hash-table-hash-function) + (eq-fn %hash-table-equivalence-function)) + diff --git a/lib/srfi/8.module b/lib/srfi/8.module new file mode 100644 index 00000000..64a3e6e2 --- /dev/null +++ b/lib/srfi/8.module @@ -0,0 +1,10 @@ + +(define-module (srfi 8) + (export receive) + (import-immutable (scheme)) + (body + (define-syntax receive + (syntax-rules () + ((receive params expr . body) + (call-with-values (lambda () expr) (lambda params . body))))))) + diff --git a/lib/srfi/9.module b/lib/srfi/9.module new file mode 100644 index 00000000..58368111 --- /dev/null +++ b/lib/srfi/9.module @@ -0,0 +1,90 @@ + +(define-module (srfi 9) + (export define-record-type) + (import-immutable (scheme)) + (body + (define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((name (cadr expr)) + (name-str (symbol->string (identifier->symbol name))) + (make (caaddr expr)) + (make-fields (cdaddr expr)) + (pred (cadddr expr)) + (fields (cddddr expr)) + (num-fields (length fields)) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let)) + (_register (rename 'register-simple-type))) + (define (index-of field ls) + (let lp ((ls ls) (i 0)) + (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) + `(,(rename 'begin) + ;; type + (,_define ,name (,_register ,name-str ,num-fields)) + ;; predicate + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string (identifier->symbol pred)) + ,name)) + ;; fields + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string + (identifier->symbol (cadar ls))) + ,name + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string + (identifier->symbol (caddar ls))) + ,name + ,i)) + res) + res))))) + ;; constructor + (,_define ,make + ,(let lp ((ls make-fields) (sets '()) (set-defs '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string (identifier->symbol make)) + ,name)) + ,@set-defs) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets) + set-defs)) + (else + (let* ((setter-name + (string-append "%" name-str "-" + (symbol->string (car ls)) "-set!")) + (setter (rename (string->symbol setter-name))) + (i (index-of (car ls) fields))) + (lp (cdr ls) + (cons (list setter 'res (car ls)) sets) + (cons (list setter + (list (rename 'make-setter) + setter-name + name + (index-of (car ls) fields))) + set-defs))))))))))))))))) + diff --git a/lib/srfi/95.module b/lib/srfi/95.module new file mode 100644 index 00000000..43bab9dd --- /dev/null +++ b/lib/srfi/95.module @@ -0,0 +1,7 @@ + +(define-module (srfi 95) + (export sorted? merge merge! sort sort! object-cmp) + (import-immutable (scheme)) + (include-shared "95/qsort") + (include "95/sort.scm")) + diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c new file mode 100644 index 00000000..14329e37 --- /dev/null +++ b/lib/srfi/95/qsort.c @@ -0,0 +1,228 @@ +/* qsort.c -- quicksort implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#if SEXP_USE_HUFF_SYMS +#include "../../../opt/sexp-hufftabs.c" +#endif + +#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var) + +static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) { + sexp_sint_t i; + sexp ls, *data=sexp_vector_data(vec); + for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls)) + sexp_car(ls) = data[i]; + return seq; +} + +static sexp sexp_vector_nreverse (sexp ctx, sexp vec) { + int i, j; + sexp tmp, *data=sexp_vector_data(vec); + for (i=0, j=sexp_vector_length(vec)-1; i>3, d = ((sexp_uint_t)b)>>3; + while (c && d) { +#include "../../../opt/sexp-unhuff.c" +#define c d +#define res res2 +#include "../../../opt/sexp-unhuff.c" +#undef c +#undef res + if ((tmp=res-res2) != 0) + return tmp; + } + return c ? 1 : d ? -1 : 0; +} +#endif + +static int sexp_object_compare (sexp ctx, sexp a, sexp b) { + int res; + if (a == b) + return 0; + if (sexp_pointerp(a)) { + if (sexp_pointerp(b)) { + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) { + res = sexp_pointer_tag(a) - sexp_pointer_tag(b); + } else { + switch (sexp_pointer_tag(a)) { + case SEXP_FLONUM: + res = sexp_flonum_value(a) - sexp_flonum_value(b); + break; + case SEXP_BIGNUM: + res = sexp_bignum_compare(a, b); + break; + case SEXP_STRING: + res = strcmp(sexp_string_data(a), sexp_string_data(b)); + break; + case SEXP_SYMBOL: + res = strcmp(sexp_symbol_data(a), sexp_symbol_data(b)); + break; + default: + res = 0; + break; + } + } +#if SEXP_USE_HUFF_SYMS + } else if (sexp_lsymbolp(a) && sexp_isymbolp(b)) { + res = strcmp(sexp_symbol_data(a), + sexp_string_data(sexp_write_to_string(ctx, b))); +#endif + } else { + res = 1; + } + } else if (sexp_pointerp(b)) { +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_lsymbolp(b)) + res = strcmp(sexp_string_data(sexp_write_to_string(ctx, a)), + sexp_symbol_data(b)); + else +#endif + res = -1; + } else { +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(a) && sexp_isymbolp(b)) + return sexp_isymbol_compare(ctx, a, b); + else +#endif + res = (sexp_sint_t)a - (sexp_sint_t)b; + } + return res; +} + +static sexp sexp_object_compare_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + return sexp_make_fixnum(sexp_object_compare(ctx, a, b)); +} + +/* fast path when using general object-cmp comparator with no key */ +static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) { + sexp_sint_t mid, i, j; + sexp tmp, tmp2; + loop: + if (lo < hi) { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + for (i=j=lo; i < hi; i++) + if (sexp_object_compare(ctx, vec[i], tmp) < 0) + swap(tmp2, vec[i], vec[j]), j++; + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + sexp_qsort(ctx, vec, lo, j-1); + lo = j; + goto loop; /* tail recurse on right side */ + } + } +} + +static sexp sexp_qsort_less (sexp ctx, sexp *vec, + sexp_sint_t lo, sexp_sint_t hi, + sexp less, sexp key) { + sexp_sint_t mid, i, j; + sexp tmp, res, args1; + sexp_gc_var3(a, b, args2); + sexp_gc_preserve3(ctx, a, b, args2); + args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID); + args1 = sexp_cdr(args2); + loop: + if (lo >= hi) { + res = SEXP_VOID; + } else { + mid = lo + (hi-lo)/2; + swap(tmp, vec[mid], vec[hi]); + if (sexp_truep(key)) { + sexp_car(args1) = tmp; + b = sexp_apply(ctx, key, args1); + } else { + b = tmp; + } + for (i=j=lo; i < hi; i++) { + if (sexp_truep(key)) { + sexp_car(args1) = vec[i]; + a = sexp_apply(ctx, key, args1); + } else { + a = vec[i]; + } + sexp_car(args2) = a; + sexp_car(args1) = b; + res = sexp_apply(ctx, less, args2); + if (sexp_exceptionp(res)) + goto done; + else if (sexp_truep(res)) + swap(res, vec[i], vec[j]), j++; + } + swap(tmp, vec[j], vec[hi]); + if ((hi-lo) > 2) { + res = sexp_qsort_less(ctx, vec, lo, j-1, less, key); + if (sexp_exceptionp(res)) + goto done; + lo = j; + goto loop; /* tail recurse on right side */ + } + } + done: + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq, + sexp less, sexp key) { + sexp_sint_t len; + sexp res, *data; + sexp_gc_var1(vec); + + if (sexp_nullp(seq)) return seq; + + sexp_gc_preserve1(ctx, vec); + + vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq); + + if (! sexp_vectorp(vec)) { + res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec); + } else { + data = sexp_vector_data(vec); + len = sexp_vector_length(vec); + if (sexp_not(key) && sexp_basic_comparator(less)) { + sexp_qsort(ctx, data, 0, len-1); + if (sexp_opcodep(less) && sexp_opcode_inverse(less)) + sexp_vector_nreverse(ctx, vec); + } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) { + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less); + } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) { + res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key); + } else { + res = sexp_qsort_less(ctx, data, 0, len-1, less, key); + } + } + + if (sexp_pairp(seq)) + res = sexp_vector_copy_to_list(ctx, vec, seq); + else if (! sexp_exceptionp(res)) + res = vec; + + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "object-cmp", 2, sexp_object_compare_op); + sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE); + return SEXP_VOID; +} diff --git a/lib/srfi/95/sort.scm b/lib/srfi/95/sort.scm new file mode 100644 index 00000000..14e24517 --- /dev/null +++ b/lib/srfi/95/sort.scm @@ -0,0 +1,70 @@ +;; sort.scm -- SRFI-95 sorting utilities +;; Copyright (c) 2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (copy seq) + (if (vector? seq) + (let* ((len (vector-length seq)) + (res (make-vector len))) + (do ((i (- len 1) (- i 1))) + ((< i 0) res) + (vector-set! res i (vector-ref seq i)))) + (map (lambda (x) x) seq))) + +(define (sort seq . o) + (let ((less (and (pair? o) (car o))) + (key (and (pair? o) (pair? (cdr o)) (car (cdr o))))) + (sort! (copy seq) less key))) + +(define (sorted? seq less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (cond + ((vector? seq) + (let ((len (- (vector-length seq) 1))) + (let lp ((i 0)) + (cond + ((>= i len) #t) + ((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f) + (else (lp (+ i 1))))))) + ((null? seq) + #t) + (else + (let lp ((ls1 seq) (ls2 (cdr seq))) + (cond ((null? ls2) #t) + ((less (key (car ls2)) (key (car ls1))) #f) + (else (lp ls2 (cdr ls2))))))))) + +(define (merge! ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (define (lp prev ls1 ls2 a b less key) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))) + (else + (set-cdr! prev ls2) + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))))) + (cond + ((null? ls1) ls2) + ((null? ls2) ls1) + (else + (let ((a (key (car ls1))) + (b (key (car ls2)))) + (cond + ((less a b) + (if (null? (cdr ls1)) + (set-cdr! ls1 ls2) + (lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)) + ls1) + (else + (if (null? (cdr ls2)) + (set-cdr! ls2 ls1) + (lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)) + ls2))))))) + +(define (merge ls1 ls2 less . o) + (let ((key (if (pair? o) (car o) (lambda (x) x)))) + (merge! (copy ls1) (copy ls2) less key))) diff --git a/lib/srfi/98.module b/lib/srfi/98.module new file mode 100644 index 00000000..9d124d66 --- /dev/null +++ b/lib/srfi/98.module @@ -0,0 +1,5 @@ + +(define-module (srfi 98) + (export get-environment-variable get-environment-variables) + (include-shared "98/env")) + diff --git a/lib/srfi/98/env.c b/lib/srfi/98/env.c new file mode 100644 index 00000000..f8e519f3 --- /dev/null +++ b/lib/srfi/98/env.c @@ -0,0 +1,48 @@ +/* env.c -- SRFI-98 environment interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifdef __APPLE__ +#include +#define environ (*_NSGetEnviron()) +#else +extern char **environ; +#endif + +#include + +sexp sexp_get_environment_variable (sexp ctx sexp_api_params(self, n), sexp str) { + char *cstr; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, self, SEXP_STRING, str); + cstr = getenv(sexp_string_data(str)); + return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE; +} + +sexp sexp_get_environment_variables (sexp ctx sexp_api_params(self, n)) { + int i; + char **env, *cname, *cval; + sexp_gc_var3(res, name, val); + sexp_gc_preserve3(ctx, res, name, val); + res = SEXP_NULL; + env = environ; + for (i=0; env[i]; i++) { + cname = env[i]; + cval = strchr(cname, '='); + if (cval) { + name = sexp_c_string(ctx, cname, cval-cname); + val = sexp_c_string(ctx, cval+1, -1); + val = sexp_cons(ctx, name, val); + res = sexp_cons(ctx, val, res); + } + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable); + sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables); + return SEXP_VOID; +} + diff --git a/main.c b/main.c new file mode 100644 index 00000000..d07a9767 --- /dev/null +++ b/main.c @@ -0,0 +1,219 @@ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#define sexp_argv_symbol "*command-line-arguments*" +#define sexp_argv_proc "(define (command-line-arguments) "sexp_argv_symbol")" + +#define sexp_import_prefix "(import (" +#define sexp_import_suffix "))" + +#define sexp_version_string "chibi-scheme "sexp_version" \""sexp_release_name"\" " + +#ifdef PLAN9 +#define exit_failure() exits("ERROR") +#else +#define exit_failure() exit(70) +#endif + +static void repl (sexp ctx) { + sexp in, out, err; + sexp_gc_var4(obj, tmp, res, env); + sexp_gc_preserve4(ctx, obj, tmp, res, env); + env = sexp_make_env(ctx); + sexp_env_parent(env) = sexp_context_env(ctx); + sexp_env_define(ctx, sexp_context_env(ctx), + sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); + sexp_context_tracep(ctx) = 1; + in = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE); + out = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE); + err = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE); + 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, env); + if (sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); + } else { +#if SEXP_USE_WARN_UNDEFS + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); +#endif + if (res != SEXP_VOID) { + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + } + } + } + sexp_gc_release4(ctx); +} + +static void check_nonull_arg (int c, char *arg) { + if (! arg) { + fprintf(stderr, "chibi-scheme: option '%c' requires an argument\n", c); + exit_failure(); + } +} + +static sexp check_exception (sexp ctx, sexp res) { + sexp err; + if (res && sexp_exceptionp(res)) { + err = sexp_current_error_port(ctx); + if (! sexp_oportp(err)) + err = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_print_exception(ctx, res, err); + sexp_stack_trace(ctx, err); + exit_failure(); + } + return res; +} + +#define init_context() if (! ctx) do { \ + ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \ + env = sexp_context_env(ctx); \ + sexp_gc_preserve2(ctx, tmp, args); \ + } while (0) + +#define load_init() if (! init_loaded++) do { \ + init_context(); \ + check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \ + } while (0) + +void run_main (int argc, char **argv) { + char *arg, *impmod, *p; + sexp env, out=SEXP_FALSE, res=SEXP_VOID, ctx=NULL; + sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0; + sexp_uint_t heap_size=0; + sexp_gc_var2(tmp, args); + args = SEXP_NULL; + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + case 'p': + load_init(); + print = (argv[i][1] == 'p'); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('e', arg); + res = check_exception(ctx, sexp_read_from_string(ctx, arg, -1)); + res = check_exception(ctx, sexp_eval(ctx, res, env)); + if (print) { + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + quit = 1; + break; + case 'l': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('l', arg); + check_exception(ctx, sexp_load_module_file(ctx, arg, env)); + break; + case 'm': + load_init(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('m', arg); + len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); + impmod = (char*) malloc(len+1); + strcpy(impmod, sexp_import_prefix); + strcpy(impmod+strlen(sexp_import_prefix), arg); + strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix); + impmod[len] = '\0'; + for (p=impmod; *p; p++) + if (*p == '.') *p=' '; + check_exception(ctx, sexp_eval_string(ctx, impmod, -1, env)); + free(impmod); + break; + case 'q': + init_context(); + if (! init_loaded++) sexp_load_standard_parameters(ctx, env); + break; + case 'A': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('A', arg); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); + break; + case 'I': + init_context(); + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('I', arg); + sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); + break; + case '-': + i++; + goto done_options; + case 'h': + arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); + check_nonull_arg('h', arg); + heap_size = atol(arg); + len = strlen(arg); + if (heap_size && (isalpha)(arg[len-1])) { + switch ((tolower)(arg[len-1])) { + case 'k': heap_size *= 1024; break; + case 'm': heap_size *= (1024*1024); break; + } + } + break; + case 'V': + load_init(); + if (! sexp_oportp(out)) + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + sexp_write_string(ctx, sexp_version_string, out); + tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*", -1), SEXP_NULL); + sexp_write(ctx, tmp, out); + sexp_newline(ctx, out); + return; + default: + fprintf(stderr, "unknown option: %s\n", argv[i]); + exit_failure(); + } + } + + done_options: + if (! quit) { + load_init(); + if (i < argc) + for (j=argc-1; j>i; j--) + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); + else + args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); + sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args); + sexp_eval_string(ctx, sexp_argv_proc, -1, env); + if (i < argc) { /* script usage */ + check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); + tmp = sexp_intern(ctx, "main", -1); + tmp = sexp_env_ref(env, tmp, SEXP_FALSE); + if (sexp_procedurep(tmp)) { + args = sexp_list1(ctx, args); + check_exception(ctx, sexp_apply(ctx, tmp, args)); + } + } else { + repl(ctx); + } + } + + sexp_gc_release2(ctx); + sexp_destroy_context(ctx); +} + +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..a193e9b6 --- /dev/null +++ b/mkfile @@ -0,0 +1,28 @@ + include/chibi/install.h + echo '#define sexp_platform "plan9"' >> include/chibi/install.h + echo '#define sexp_version "'`{cat VERSION}'"' >> include/chibi/install.h + echo '#define sexp_release_name "'`{cat RELEASE}'"' >> include/chibi/install.h + +install:V: $BIN/$TARG + test -d $MODDIR || mkdir -p $MODDIR + cp -r lib/* $MODDIR/ + +test:V: + ./$O.out tests/r5rs-tests.scm + +sexp.c:N: gc.c opt/bignum.c diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..34505644 --- /dev/null +++ b/opcodes.c @@ -0,0 +1,178 @@ + +#define _I(n) sexp_make_fixnum(n) +#define _OP(c,o,n,m,rt,a1,a2,a3,i,s,d,f) {c, o, n, m, i, s, d, NULL, NULL, rt, a1, a2, a3, f} +#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, rt, a1, a2, a3, 0, s, d, (sexp_proc1)f) +#define _FN0(rt, s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, rt, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1OPT(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN1OPTP(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) +#define _FN2(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN2OPT(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN2OPTP(rt, a1, a2, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, rt, a1, a2, SEXP_FALSE, s, d, f) +#define _FN3(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, rt, a1, a2, a3, s, d, f) +#define _FN4(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, rt, a1, a2, a3, s, d, f) +#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, t, SEXP_FALSE, SEXP_FALSE, 0, n, a, 0) + +static struct sexp_opcode_struct opcodes[] = { +_OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "car", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-car!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "cdr", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-cdr!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF, 2, 0, _I(SEXP_OBJECT), _I(SEXP_VECTOR), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET, 3, 0, SEXP_VOID, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), 0,"vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_VECTOR), SEXP_FALSE, SEXP_FALSE, 0,"vector-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"byte-vector-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET, 3, 0, SEXP_VOID, _I(SEXP_BYTES), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0,"byte-vector-set!", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), SEXP_FALSE, SEXP_FALSE, 0,"byte-vector-length", 0, NULL), +#if SEXP_USE_UTF8_STRINGS +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-cursor-ref", 0, NULL), +#else +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-ref", 0, NULL), +#endif +#if SEXP_USE_MUTABLE_STRINGS +#if SEXP_USE_UTF8_STRINGS +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), 0,"string-cursor-set!", 0, NULL), +#else +_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), 0,"string-set!", 0, NULL), +#endif +#endif +_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), SEXP_FALSE, SEXP_FALSE, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, _I(SEXP_FLONUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "exact->inexact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "inexact->exact", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, _I(SEXP_CHAR), _I(SEXP_FIXNUM), SEXP_FALSE, SEXP_FALSE, 0, "integer->char", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-upcase", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-downcase", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "+", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "*", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "-", SEXP_ZERO, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "/", SEXP_ONE, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "quotient", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), SEXP_FALSE, 0, "remainder", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "<", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "<=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, ">", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, ">=", 0, NULL), +_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, _I(SEXP_BOOLEAN), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "=", 0, NULL), +_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "eq?", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, _I(SEXP_PAIR), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "cons", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), SEXP_FALSE, 0, "make-vector", SEXP_VOID, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, _I(SEXP_PROCEDURE), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_BYTECODE), 0, "make-procedure", 0, NULL), +_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, _I(SEXP_EXCEPTION), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA, 2, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, 0, "is-a?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "null?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "eof-object?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "symbol?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "char?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "fixnum?", NULL, 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "pair?", _I(SEXP_PAIR), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "string?", _I(SEXP_STRING), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "vector?", _I(SEXP_VECTOR), 0), +#if SEXP_USE_IMMEDIATE_FLONUMS +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op), +#else +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "flonum?", _I(SEXP_FLONUM), 0), +#endif +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "bignum?", _I(SEXP_BIGNUM), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "closure?", _I(SEXP_PROCEDURE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "opcode?", _I(SEXP_OPCODE), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "input-port?", _I(SEXP_IPORT), 0), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "output-port?", _I(SEXP_OPORT), 0), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%call/cc", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), SEXP_FALSE, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, SEXP_VOID, _I(SEXP_OPORT), SEXP_FALSE, SEXP_FALSE, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_FN1OPTP(_I(SEXP_OBJECT), _I(SEXP_IPORT), "read", (sexp)"*current-input-port*", sexp_read_op), +_FN2OPTP(SEXP_VOID,_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"*current-output-port*", sexp_write_op), +_FN2OPTP(SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"*current-output-port*", sexp_display_op), +_FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op), +_FN2(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op), +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "list?", 0, sexp_listp_op), +_FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "identifier?", 0, sexp_identifierp_op), +_FN1(_I(SEXP_SYMBOL), _I(SEXP_OBJECT), "identifier->symbol", 0, sexp_syntactic_closure_expr_op), +_FN4(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_ENV), _I(SEXP_OBJECT), "identifier=?", 0, sexp_identifier_eq_op), +_FN1(_I(SEXP_FIXNUM), SEXP_NULL, "length", 0, sexp_length_op), +_FN1(SEXP_NULL, SEXP_NULL, "reverse", 0, sexp_reverse_op), +_FN1(SEXP_NULL, SEXP_NULL, "reverse!", 0, sexp_nreverse_op), +_FN2(SEXP_NULL, SEXP_NULL, SEXP_NULL, "append2", 0, sexp_append2_op), +_FN1(_I(SEXP_VECTOR), SEXP_NULL, "list->vector", 0, sexp_list_to_vector_op), +_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-file", 0, sexp_open_input_file_op), +_FN1(_I(SEXP_OPORT), _I(SEXP_STRING), "open-output-file", 0, sexp_open_output_file_op), +_FN1(SEXP_VOID, _I(SEXP_IPORT), "close-input-port", 0, sexp_close_port_op), +_FN1(SEXP_VOID, _I(SEXP_OPORT), "close-output-port", 0, sexp_close_port_op), +_FN0(_I(SEXP_ENV), "make-environment", 0, sexp_make_env_op), +_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "null-environment", 0, sexp_make_null_env_op), +_FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_standard_env_op), +_FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "eval", (sexp)"*interaction-environment*", sexp_eval_op), +_FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"*interaction-environment*", sexp_load_op), +_FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%env-copy!", 0, sexp_env_copy_op), +_FN2(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op), +_FN1(_I(SEXP_OBJECT), _I(SEXP_EXCEPTION), "exception-type", 0, sexp_exception_type_op), +_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "make-string", sexp_make_character(' '), sexp_make_string_op), +_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-byte-vector", SEXP_ZERO, sexp_make_bytes_op), +_FN2OPT(_I(SEXP_NUMBER), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string->number", SEXP_TEN, sexp_string_to_number_op), +_FN3(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_BOOLEAN), "string-cmp", 0, sexp_string_cmp_op), +_FN3(_I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "substring", 0, sexp_substring_op), +_FN1(_I(SEXP_SYMBOL), _I(SEXP_STRING), "string->symbol", 0, sexp_string_to_symbol_op), +_FN2OPT(_I(SEXP_STRING), SEXP_NULL, _I(SEXP_STRING), "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op), +_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "memq", 0, sexp_memq_op), +_FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "assq", 0, sexp_assq_op), +_FN3(_I(SEXP_SYNCLO), _I(SEXP_ENV), SEXP_NULL, _I(SEXP_OBJECT), "make-syntactic-closure", 0, sexp_make_synclo_op), +_FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip_synclos), +_PARAM("current-input-port", (sexp)"*current-input-port*", _I(SEXP_IPORT)), +_PARAM("current-output-port", (sexp)"*current-output-port*", _I(SEXP_OPORT)), +_PARAM("current-error-port", (sexp)"*current-error-port*", _I(SEXP_OPORT)), +_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", _I(SEXP_PROCEDURE)), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", _I(SEXP_ENV)), +_FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_make_output_string_port_op), +_FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_make_input_string_port_op), +_FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op), +#if SEXP_USE_MATH +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "exp", 0, sexp_exp), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "log", 0, sexp_log), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sin", 0, sexp_sin), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "cos", 0, sexp_cos), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "tan", 0, sexp_tan), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "asin", 0, sexp_asin), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "acos", 0, sexp_acos), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "atan1", 0, sexp_atan), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sqrt", 0, sexp_sqrt), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "round", 0, sexp_round), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "truncate", 0, sexp_trunc), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "floor", 0, sexp_floor), +_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "ceiling", 0, sexp_ceiling), +#endif +_FN2(_I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), "expt", 0, sexp_expt_op), +#if SEXP_USE_UTF8_STRINGS +_FN2(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-index->offset", 0, sexp_string_index_to_offset), +_FN2(_I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-ref", 0, sexp_string_utf8_index_ref), +_FN3(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "string-set!", 0, sexp_string_utf8_index_set), +#endif +#if SEXP_USE_TYPE_DEFS +_FN2(_I(SEXP_TYPE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "register-simple-type", 0, sexp_register_simple_type_op), +_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0, sexp_make_type_predicate_op), +_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op), +_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op), +_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-setter", 0, sexp_make_setter_op), +#endif +#if PLAN9 +#include "opt/plan9-opcodes.c" +#endif +#if SEXP_USE_MODULES +_FN0(_I(SEXP_ENV), "current-environment", 0, sexp_current_environment), +_FN1(SEXP_NULL, _I(SEXP_ENV), "env-exports", 0, sexp_env_exports_op), +_FN1(_I(SEXP_STRING), _I(SEXP_STRING), "find-module-file", 0, sexp_find_module_file_op), +_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load-module-file", 0, sexp_load_module_file_op), +_FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_BOOLEAN), "add-module-directory", 0, sexp_add_module_directory_op), +#endif +#if SEXP_USE_GREEN_THREADS +_OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, SEXP_VOID, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, 0, "thread-yield!", 0, NULL), +#endif +}; + + diff --git a/opt/bignum.c b/opt/bignum.c new file mode 100644 index 00000000..767d8898 --- /dev/null +++ b/opt/bignum.c @@ -0,0 +1,775 @@ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_INIT_BIGNUM_SIZE 2 + +#define sexp_negate(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_fixnump(x)) \ + x = sexp_fx_neg(x); + +sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) { + sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + sexp_bignum_length(res) = len; + sexp_bignum_sign(res) = 1; + return res; +} + +sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) { + sexp res = sexp_make_bignum(ctx, 1); + sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a)); + sexp_bignum_sign(res) = sexp_fx_sign(a); + return res; +} + +sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { + sexp res; + if ((SEXP_MIN_FIXNUM <= x) && (x <= SEXP_MAX_FIXNUM)) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + if (x < 0) { + sexp_bignum_sign(res) = -1; + sexp_bignum_data(res)[0] = -x; + } else { + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + } + return res; +} + +sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { + sexp res; + if (x <= SEXP_MAX_FIXNUM) { + res = sexp_make_fixnum(x); + } else { + res = sexp_make_bignum(ctx, 1); + sexp_bignum_sign(res) = 1; + sexp_bignum_data(res)[0] = x; + } + return res; +} + +#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0) +#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f)) + +sexp sexp_double_to_bignum (sexp ctx, double f) { + int sign; + sexp_gc_var3(res, scale, tmp); + sexp_gc_preserve3(ctx, res, scale, tmp); + res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + sign = (f < 0 ? -1 : 1); + for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { + tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); + res = sexp_bignum_add(ctx, res, res, tmp); + scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); + } + sexp_bignum_sign(res) = sign; + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) { + sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size; + size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t); + if (! dst || sexp_bignum_length(dst) < len) { + dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM); + memmove(dst, a, size); + sexp_bignum_length(dst) = len; + } else { + memset(dst->value.bignum.data, 0, + sexp_bignum_length(dst)*sizeof(sexp_uint_t)); + memmove(dst->value.bignum.data, a->value.bignum.data, + sexp_bignum_length(a)*sizeof(sexp_uint_t)); + } + return dst; +} + +int sexp_bignum_zerop (sexp a) { + int i; + sexp_uint_t *data = sexp_bignum_data(a); + for (i=sexp_bignum_length(a)-1; i>=0; i--) + if (data[i]) + return 0; + return 1; +} + +sexp_uint_t sexp_bignum_hi (sexp a) { + sexp_uint_t i=sexp_bignum_length(a)-1; + while ((i>0) && ! sexp_bignum_data(a)[i]) + i--; + return i+1; +} + +sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) { + int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b); + sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b); + if (ai != bi) + return ai - bi; + for (--ai; ai >= 0; ai--) { + if (adata[ai] > bdata[ai]) + return 1; + else if (adata[ai] < bdata[ai]) + return -1; + } + return 0; +} + +sexp_sint_t sexp_bignum_compare (sexp a, sexp b) { + if (sexp_bignum_sign(a) != sexp_bignum_sign(b)) + return sexp_bignum_sign(a); + return sexp_bignum_compare_abs(a, b); +} + +sexp sexp_bignum_normalize (sexp a) { + sexp_uint_t *data; + if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1)) + return a; + data = sexp_bignum_data(a); + if ((data[0] > SEXP_MAX_FIXNUM) + && ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1))) + return a; + return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a)); +} + +double sexp_bignum_to_double (sexp a) { + double res = 0; + sexp_sint_t i; + sexp_uint_t *data=sexp_bignum_data(a); + for (i=sexp_bignum_hi(a)-1; i>=0; i--) + res = res * ((double)SEXP_UINT_T_MAX+1) + data[i]; + return res * sexp_bignum_sign(a); +} + +sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), + carry=b, i=0, n; + do { n = data[i]; + data[i] += carry; + carry = (n > (SEXP_UINT_T_MAX - carry)); + } while (++i> (sizeof(sexp_uint_t)*8); + } + if (carry) { + if (sexp_bignum_length(d)+offset <= len) + d = sexp_copy_bignum(ctx, NULL, d, len+offset+1); + sexp_bignum_data(d)[len+offset] = carry; + } + sexp_gc_release1(ctx); + return d; +} + +sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0; + int i; + sexp_luint_t n = 0; + for (i=len-1; i>=offset; i--) { + n = (n << sizeof(sexp_uint_t)*8) + data[i]; + q = n / b; + r = n - (sexp_luint_t)q * b; + data[i] = q; + n = r; + } + return r; +} + +sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, + char sign, sexp_uint_t base) { + int c, digit; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE); + sexp_bignum_sign(res) = sign; + sexp_bignum_data(res)[0] = init; + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + res = sexp_bignum_fxmul(ctx, res, res, base, 0); + res = sexp_bignum_fxadd(ctx, res, digit); + } + if (c=='.' || c=='e' || c=='E') { + if (base != 10) { + res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + } else { + if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */ + res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1)); + } + } else if ((c!=EOF) && ! is_separator(c)) { + res = sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + } else { + sexp_push_char(ctx, c, in); + } + sexp_gc_release1(ctx); + return sexp_bignum_normalize(res); +} + +static int log2i(int v) { + int i; + for (i = 0; i < sizeof(v)*8; i++) + if ((1<<(i+1)) > v) + break; + return i; +} + +sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { + int i, str_len, lg_base = log2i(base); + char *data; + sexp_gc_var2(b, str); + sexp_gc_preserve2(ctx, b, str); + b = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(b) = 1; + i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) + / lg_base + 1; + str = sexp_make_string(ctx, sexp_make_fixnum(str_len), + sexp_make_character(' ')); + data = sexp_string_data(str); + while (! sexp_bignum_zerop(b)) + data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0)); + if (i == str_len) + data[--i] = '0'; + else if (sexp_bignum_sign(a) == -1) + data[--i] = '-'; + sexp_write_string(ctx, data + i, out); + sexp_gc_release2(ctx); + return SEXP_VOID; +} + +/****************** bignum arithmetic *************************/ + +sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(c); + sexp_gc_preserve1(ctx, c); + c = sexp_copy_bignum(ctx, NULL, a, 0); + if (sexp_bignum_sign(c) == sexp_fx_sign(b)) + c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + else + c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b))); + sexp_gc_release1(ctx); + return c; +} + +sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), + borrow=0, i, *adata, *bdata, *cdata; + sexp_gc_var1(c); + if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0))) + return sexp_bignum_sub_digits(ctx, dst, b, a); + sexp_gc_preserve1(ctx, c); + c = ((dst && sexp_bignum_hi(dst) >= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i= alen) + ? dst : sexp_copy_bignum(ctx, NULL, a, 0)); + adata = sexp_bignum_data(a); + bdata = sexp_bignum_data(b); + cdata = sexp_bignum_data(c); + for (i=0; i (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0); + } + for ( ; carry && (i= 0 ? a : b); + } + return res; +} + +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { + sexp res; + if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { + res = sexp_bignum_sub_digits(ctx, dst, a, b); + sexp_bignum_sign(res) + = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a) + : -sexp_bignum_sign(a)); + } else { + res = sexp_bignum_add_digits(ctx, dst, a, b); + sexp_bignum_sign(res) = sexp_bignum_sign(a); + } + return res; +} + +sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) { + sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i, + *bdata=sexp_bignum_data(b); + sexp_gc_var2(c, d); + if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a); + sexp_gc_preserve2(ctx, c, d); + c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1)); + d = sexp_make_bignum(ctx, alen+blen+1); + for (i=0; i 0) { + *rem = a; + return sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + } + sexp_gc_preserve5(ctx, x, prod, diff, k2, i2); + k2 = sexp_bignum_double(ctx, k); + i2 = sexp_bignum_double(ctx, i); + x = quot_step(ctx, rem, a, b, k2, i2); + prod = sexp_bignum_mul(ctx, NULL, x, b); + diff = sexp_bignum_sub_digits(ctx, NULL, a, prod); + if (sexp_bignum_compare(diff, k) >= 0) { + *rem = sexp_bignum_sub_digits(ctx, NULL, diff, k); + res = sexp_bignum_add_digits(ctx, NULL, x, i); + } else { + *rem = diff; + res = x; + } + sexp_gc_release5(ctx); + return res; +} + +sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { + sexp res; + sexp_gc_var4(k, i, a1, b1); + sexp_gc_preserve4(ctx, k, i, a1, b1); + a1 = sexp_copy_bignum(ctx, NULL, a, 0); + sexp_bignum_sign(a1) = 1; + b1 = sexp_copy_bignum(ctx, NULL, b, 0); + sexp_bignum_sign(b1) = 1; + k = sexp_copy_bignum(ctx, NULL, b1, 0); + i = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + res = quot_step(ctx, rem, a1, b1, k, i); + sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b); + if (sexp_bignum_sign(a) < 0) { + sexp_negate(*rem); + } + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) { + sexp res; + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + res = sexp_bignum_quot_rem(ctx, &rem, a, b); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(rem); + sexp_gc_preserve1(ctx, rem); + sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */ + sexp_gc_release1(ctx); + return rem; +} + +sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) { + sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b)); + sexp_gc_var2(res, acc); + sexp_gc_preserve2(ctx, res, acc); + res = sexp_fixnum_to_bignum(ctx, SEXP_ONE); + acc = sexp_copy_bignum(ctx, NULL, a, 0); + for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc)) + if (e & 1) + res = sexp_bignum_mul(ctx, NULL, res, acc); + sexp_gc_release2(ctx); + return res; +} + +/****************** generic arithmetic ************************/ + +enum sexp_number_types { + SEXP_NUM_NOT = 0, + SEXP_NUM_FIX, + SEXP_NUM_FLO, + SEXP_NUM_BIG +}; + +enum sexp_number_combs { + SEXP_NUM_NOT_NOT = 0, + SEXP_NUM_NOT_FIX, + SEXP_NUM_NOT_FLO, + SEXP_NUM_NOT_BIG, + SEXP_NUM_FIX_NOT, + SEXP_NUM_FIX_FIX, + SEXP_NUM_FIX_FLO, + SEXP_NUM_FIX_BIG, + SEXP_NUM_FLO_NOT, + SEXP_NUM_FLO_FIX, + SEXP_NUM_FLO_FLO, + SEXP_NUM_FLO_BIG, + SEXP_NUM_BIG_NOT, + SEXP_NUM_BIG_FIX, + SEXP_NUM_BIG_FLO, + SEXP_NUM_BIG_BIG +}; + +static int sexp_number_types[] = + {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0}; + +static int sexp_number_type (sexp a) { + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15] +#if SEXP_USE_IMMEDIATE_FLONUMS + : sexp_flonump(a) ? 2 +#endif + : sexp_fixnump(a); +} + +sexp sexp_add (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_add(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_add(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_add(ctx, NULL, b, a)); + break; + } + return r; +} + +sexp sexp_sub (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_sub(a, b); /* VM catches this case */ + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + tmp = sexp_fixnum_to_bignum(ctx, a); + r = sexp_bignum_sub(ctx, NULL, b, tmp); + sexp_negate(r); + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)+sexp_flonum_value(a)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_sub(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + tmp = sexp_fixnum_to_bignum(ctx, b); + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, tmp)); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) - sexp_flonum_value(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_mul (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_mul(a, b); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0); + sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_mul(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_mul(ctx, NULL, a, b); + break; + } + return r; +} + +sexp sexp_div (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + double f; + sexp r=SEXP_VOID; + sexp_gc_var2(tmp, rem); + sexp_gc_preserve2(ctx, tmp, rem); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: + f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b); + r = ((f == trunc(f)) ? sexp_make_fixnum((sexp_sint_t)f) + : sexp_make_flonum(ctx, f)); + break; + case SEXP_NUM_FIX_FLO: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_flonum_value(b)); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); + break; + case SEXP_NUM_FLO_FIX: + r = sexp_make_flonum(ctx, sexp_flonum_value(a)/sexp_fixnum_to_double(b)); + break; + case SEXP_NUM_FLO_FLO: + r = sexp_fp_div(ctx, a, b); + break; + case SEXP_NUM_FLO_BIG: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_bignum_to_double(b)); + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_quot_rem(ctx, &rem, a, b); + if (sexp_bignum_normalize(rem) != SEXP_ZERO) + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) + / sexp_bignum_to_double(b)); + else + r = sexp_bignum_normalize(r); + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b)); + break; + } + sexp_gc_release2(ctx); + return r; +} + +sexp sexp_quotient (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_div(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = SEXP_ZERO; + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_remainder (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_fx_rem(a, b); + break; + case SEXP_NUM_FIX_BIG: + r = a; + break; + case SEXP_NUM_BIG_FIX: + b = tmp = sexp_fixnum_to_bignum(ctx, b); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b)); + break; + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_compare (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + double f; + if (at > bt) { + r = sexp_compare(ctx, b, a); + sexp_negate(r); + } else { + switch ((at << 2) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b)); + break; + case SEXP_NUM_FIX_FLO: + f = sexp_fixnum_to_double(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FIX_BIG: + r = sexp_make_fixnum(-1); + break; + case SEXP_NUM_FLO_FLO: + f = sexp_flonum_value(a) - sexp_flonum_value(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_FLO_BIG: + f = sexp_flonum_value(a) - sexp_bignum_to_double(b); + r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1); + break; + case SEXP_NUM_BIG_BIG: + r = sexp_make_fixnum(sexp_bignum_compare(a, b)); + break; + } + } + return r; +} + diff --git a/opt/fcall.c b/opt/fcall.c new file mode 100644 index 00000000..c38cc3fe --- /dev/null +++ b/opt/fcall.c @@ -0,0 +1,33 @@ + +typedef sexp (*sexp_proc8) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc9) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc10) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc11) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc12) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc13) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc14) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc15) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc16) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc17) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); + +#define _A(i) stack[top-i] + +sexp sexp_fcall (sexp ctx, sexp self, sexp_sint_t n, sexp f) { + sexp *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx); + switch (n) { + case 5: return ((sexp_proc6)sexp_opcode_func(f))(ctx, f, 5, _A(1), _A(2), _A(3), _A(4), _A(5)); + case 6: return ((sexp_proc7)sexp_opcode_func(f))(ctx, f, 6, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6)); + case 7: return ((sexp_proc8)sexp_opcode_func(f))(ctx, f, 7, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7)); + case 8: return ((sexp_proc9)sexp_opcode_func(f))(ctx, f, 8, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8)); + case 9: return ((sexp_proc10)sexp_opcode_func(f))(ctx, f, 9, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9)); + case 10: return ((sexp_proc11)sexp_opcode_func(f))(ctx, f, 10, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10)); + case 11: return ((sexp_proc12)sexp_opcode_func(f))(ctx, f, 11, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11)); + case 12: return ((sexp_proc13)sexp_opcode_func(f))(ctx, f, 12, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12)); + case 13: return ((sexp_proc14)sexp_opcode_func(f))(ctx, f, 13, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13)); + case 14: return ((sexp_proc15)sexp_opcode_func(f))(ctx, f, 14, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14)); + case 15: return ((sexp_proc16)sexp_opcode_func(f))(ctx, f, 15, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15)); + case 16: return ((sexp_proc17)sexp_opcode_func(f))(ctx, f, 16, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16)); + default: return sexp_user_exception(ctx, self, "too many FFI arguments", f); + } +} diff --git a/opt/opcode_names.h b/opt/opcode_names.h new file mode 100644 index 00000000..a87aeb1c --- /dev/null +++ b/opt/opcode_names.h @@ -0,0 +1,21 @@ + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALLN", + "JUMP-UNLESS", "JUMP", "PUSH", "DROP", + "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", + "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", + "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", + "BYTES-REF", "BYTES-SET", "BYTES-LENGTH", + "STRING-REF", "STRING-SET", "STRING-LENGTH", + "MAKE-PROCEDURE", "MAKE-VECTOR", + "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", + "ISA?", "SLOTN-REF", "SLOTN-SET", + "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", + "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", + "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", + "YIELD", "RET", "DONE", + }; diff --git a/opt/plan9-opcodes.c b/opt/plan9-opcodes.c new file mode 100644 index 00000000..9f7cac33 --- /dev/null +++ b/opt/plan9-opcodes.c @@ -0,0 +1,19 @@ +_FN0("random-integer", 0, sexp_rand), +_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand), +_FN0("current-directory", 0, sexp_getwd), +_FN0("current-user", 0, sexp_getuser), +_FN0("system-name", 0, sexp_sysname), +_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno), +_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen), +_FN0("fork", 0, sexp_fork), +_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec), +_FN1(SEXP_STRING, "exits", 0, sexp_exits), +_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup), +_FN0("pipe", 0, sexp_pipe), +_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep), +_FN1(SEXP_STRING, "getenv", 0, sexp_getenv), +_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir), +_FN0("wait", 0, sexp_wait), +_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote), +_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv), +_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), diff --git a/opt/plan9.c b/opt/plan9.c new file mode 100644 index 00000000..ca25afba --- /dev/null +++ b/opt/plan9.c @@ -0,0 +1,351 @@ +/* plan9.c -- extended Plan 9 system utils */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +sexp sexp_rand (sexp ctx sexp_api_params(self, n)) { + return sexp_make_fixnum(rand()); +} + +sexp sexp_srand (sexp ctx sexp_api_params(self, n), sexp seed) { + srand(sexp_unbox_fixnum(seed)); + return SEXP_VOID; +} + +sexp sexp_file_exists_p (sexp ctx sexp_api_params(self, n), sexp path) { + int res; + uchar statbuf[STATMAX]; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "file-exists?: not a string", path); + res = stat(sexp_string_data(path), statbuf, sizeof(statbuf)); + return (res < 0) ? SEXP_FALSE : SEXP_TRUE; +} + +sexp sexp_fdopen (sexp ctx sexp_api_params(self, n), sexp fd, sexp mode) { + FILE *f; + if (! sexp_integerp(fd)) + return sexp_type_exception(ctx, "fdopen: not an integer", fd); + if (! sexp_stringp(mode)) + return sexp_type_exception(ctx, "fdopen: not a mode string", mode); + f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode)); + if (! f) + return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd); + /* maybe use fd2path to get the name of the fd */ + if (sexp_string_data(mode)[0] == 'w') + return sexp_make_output_port(ctx, f, SEXP_FALSE); + else + return sexp_make_input_port(ctx, f, SEXP_FALSE); +} + +sexp sexp_fileno (sexp ctx sexp_api_params(self, n), sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "fileno: not a port", port); + return sexp_make_fixnum(fileno(sexp_port_stream(port))); +} + +sexp sexp_fork (sexp ctx sexp_api_params(self, n)) { + return sexp_make_fixnum(fork()); +} + +sexp sexp_exec (sexp ctx sexp_api_params(self, n), sexp name, sexp args) { + int i, len = sexp_unbox_fixnum(sexp_length(ctx, args)); + char **argv = malloc((len+1)*sizeof(char*)); + for (i=0; imsg, -1); + res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg); + sexp_gc_release(ctx, msg, s_msg); + return res; +} + +sexp sexp_postnote (sexp ctx sexp_api_params(self, n), sexp pid, sexp note) { + if (! sexp_integerp(pid)) + return sexp_type_exception(ctx, "postnote: not an integer", pid); + if (! sexp_stringp(note)) + return sexp_type_exception(ctx, "postnote: not a string", note); + postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note)); + return SEXP_VOID; +} + +/**********************************************************************/ +/* 9p interface */ + +typedef struct sexp_plan9_srv { + sexp context, auth, attach, walk, walk1, clone, open, create, remove, + read, write, stat, wstat, flush, destroyfid, destroyreq, end; +} *sexp_plan9_srv; + +void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) { + s->context = ctx; + s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open + = s->create = s->remove = s->read = s->write = s->stat = s->wstat + = s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE; + for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) { + if (sexp_car(ls) == sexp_intern(ctx, "auth:", -1)) { + s->auth = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "attach:", -1)) { + s->attach = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk:", -1)) { + s->walk = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "walk1:", -1)) { + s->walk1 = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "clone:", -1)) { + s->clone = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "open:", -1)) { + s->open = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "create:", -1)) { + s->create = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "remove:", -1)) { + s->remove = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "read:", -1)) { + s->read = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "write:", -1)) { + s->write = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "stat:", -1)) { + s->stat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "wstat:", -1)) { + s->wstat = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "flush:", -1)) { + s->flush = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:", -1)) { + s->destroyfid = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:", -1)) { + s->destroyreq = sexp_cadr(ls); + } else if (sexp_car(ls) == sexp_intern(ctx, "end:", -1)) { + s->end = sexp_cadr(ls); + } + } +} + +void sexp_run_9p_handler (Req *r, sexp handler) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, handler, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +#define sexp_def_9p_handler(name, field) \ + void name (Req *r) { \ + sexp_run_9p_handler(r, ((sexp_plan9_srv)r->srv->aux)->field); \ + } + +sexp_def_9p_handler(sexp_9p_auth, auth) +sexp_def_9p_handler(sexp_9p_attach, attach) +sexp_def_9p_handler(sexp_9p_walk, walk) +sexp_def_9p_handler(sexp_9p_open, open) +sexp_def_9p_handler(sexp_9p_create, create) +sexp_def_9p_handler(sexp_9p_remove, remove) +sexp_def_9p_handler(sexp_9p_read, read) +sexp_def_9p_handler(sexp_9p_write, write) +sexp_def_9p_handler(sexp_9p_stat, stat) +sexp_def_9p_handler(sexp_9p_wstat, wstat) +sexp_def_9p_handler(sexp_9p_flush, flush) + +char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_c_string(ctx, name, -1); + args = sexp_cons(ctx, ptr, args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->walk1, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +char* sexp_9p_clone (Fid *oldfid, Fid *newfid) { + sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux; + sexp res, ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, args); + res = sexp_apply(ctx, s->clone, args); + sexp_gc_release(ctx, ptr, s_ptr); + return sexp_stringp(res) ? sexp_string_data(res) : nil; +} + +void sexp_9p_destroyfid (Fid *fid) { + sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyfid, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_destroyreq (Req *r) { + sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->destroyreq, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +void sexp_9p_end (Srv *srv) { + sexp_plan9_srv s = (sexp_plan9_srv)srv->aux; + sexp ctx = s->context; + sexp_gc_var(ctx, ptr, s_ptr); + sexp_gc_var(ctx, args, s_args); + sexp_gc_preserve(ctx, ptr, s_ptr); + sexp_gc_preserve(ctx, args, s_args); + ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0); + args = sexp_cons(ctx, ptr, SEXP_NULL); + sexp_apply(ctx, s->end, args); + sexp_gc_release(ctx, ptr, s_ptr); +} + +sexp sexp_postmountsrv (sexp ctx sexp_api_params(self, n), sexp ls, sexp name, sexp mtpt, sexp flags) { + Srv s; + struct sexp_plan9_srv p9s; + if (! sexp_listp(ctx, ls)) + return sexp_type_exception(ctx, "postmountsrv: not a list", ls); + if (! sexp_stringp(name)) + return sexp_type_exception(ctx, "postmountsrv: not a string", name); + if (! sexp_stringp(mtpt)) + return sexp_type_exception(ctx, "postmountsrv: not a string", mtpt); + if (! sexp_integerp(flags)) + return sexp_type_exception(ctx, "postmountsrv: not an integer", flags); + sexp_build_srv(ctx, &p9s, ls); + s.aux = &p9s; + s.auth = &sexp_9p_auth; + s.attach = &sexp_9p_attach; + s.walk = &sexp_9p_walk; + s.walk1 = &sexp_9p_walk1; + s.clone = &sexp_9p_clone; + s.open = &sexp_9p_open; + s.create = &sexp_9p_create; + s.remove = &sexp_9p_remove; + s.read = &sexp_9p_read; + s.write = &sexp_9p_write; + s.stat = &sexp_9p_stat; + s.wstat = &sexp_9p_wstat; + s.flush = &sexp_9p_flush; + s.destroyfid = &sexp_9p_destroyfid; + s.destroyreq = &sexp_9p_destroyreq; + s.end = &sexp_9p_end; + postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt), + sexp_unbox_fixnum(flags)); + return SEXP_UNDEF; +} + +sexp sexp_9p_req_offset (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset); +} + +sexp sexp_9p_req_count (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count); +} + +#if 0 +sexp sexp_9p_req_path (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1); +} +#endif + +sexp sexp_9p_req_fid (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0); +} + +sexp sexp_9p_req_newfid (sexp ctx sexp_api_params(self, n), sexp req) { + return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0); +} + +sexp sexp_9p_respond (sexp ctx sexp_api_params(self, n), sexp req, sexp err) { + char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil; + respond(sexp_cpointer_value(req), cerr); + return SEXP_VOID; +} + +sexp sexp_9p_responderror (sexp ctx sexp_api_params(self, n), sexp req) { + responderror(sexp_cpointer_value(req)); + return SEXP_VOID; +} + 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/opt/simplify.c b/opt/simplify.c new file mode 100644 index 00000000..4217a1bb --- /dev/null +++ b/opt/simplify.c @@ -0,0 +1,143 @@ +/* simplify.c -- basic simplification pass */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda)) + +static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) { + int check; + sexp ls1, ls2, p1, p2, sv, ctx2; + sexp_gc_var4(res, substs, tmp, app); + sexp_gc_preserve4(ctx, res, substs, tmp, app); + res = ast; /* return the ast as-is by default */ + substs = init_substs; + + loop: + switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) { + + case SEXP_PAIR: + /* don't simplify the operator if it's a lambda because we + simplify that as a special case below, with the appropriate + substs list */ + app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res) + : (tmp=simplify(ctx, sexp_car(res), substs, lambda))); + for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda)); + app = sexp_nreverse(ctx, app); + /* app now holds a copy of the list, and is the default result + (res = app below) if we don't replace it with a simplification */ + if (sexp_opcodep(sexp_car(app))) { + /* opcode app - right now we just constant fold arithmetic */ + if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) { + for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { + if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) { + check = 0; + break; + } + } + if (check) { + ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0); + generate(ctx2, app); + res = finalize_bytecode(ctx2); + if (! sexp_exceptionp(res)) { + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp); + if (! sexp_exceptionp(tmp)) { + tmp = sexp_apply(ctx2, tmp, SEXP_NULL); + if (! sexp_exceptionp(tmp)) + app = sexp_make_lit(ctx2, tmp); + } + } + } + } + } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */ + p1 = NULL; + p2 = sexp_lambda_params(sexp_car(app)); + ls1 = app; + ls2 = sexp_cdr(app); + sv = sexp_lambda_sv(sexp_car(app)); + for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) { + if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv)) + && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2)) + || (sexp_refp(sexp_car(ls2)) + && sexp_lambdap(sexp_ref_loc(sexp_car(ls2))) + && sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)), + sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) { + tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2)); + tmp = sexp_cons(ctx, sexp_car(p2), tmp); + sexp_push(ctx, substs, tmp); + sexp_cdr(ls1) = sexp_cdr(ls2); + if (p1) + sexp_cdr(p1) = sexp_cdr(p2); + else + sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2); + } else { + p1 = p2; + ls1 = ls2; + } + } + sexp_lambda_body(sexp_car(app)) + = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app)); + if (sexp_nullp(sexp_cdr(app)) + && sexp_nullp(sexp_lambda_params(sexp_car(app))) + && sexp_nullp(sexp_lambda_defs(sexp_car(app)))) + app = sexp_lambda_body(sexp_car(app)); + } + res = app; + break; + + case SEXP_LAMBDA: + sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res); + break; + + case SEXP_CND: + tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda); + if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) { + res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp)) + ? sexp_cnd_fail(res) : sexp_cnd_pass(res); + goto loop; + } else { + sexp_cnd_test(res) = tmp; + simplify_it(sexp_cnd_pass(res)); + simplify_it(sexp_cnd_fail(res)); + } + break; + + case SEXP_REF: + tmp = sexp_ref_name(res); + for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) + if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) { + res = sexp_cddar(ls1); + break; + } + break; + + case SEXP_SET: + simplify_it(sexp_set_value(res)); + break; + + case SEXP_SEQ: + app = SEXP_NULL; + for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) { + tmp = simplify(ctx, sexp_car(ls2), substs, lambda); + if (! (sexp_pairp(sexp_cdr(ls2)) + && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp) + || sexp_lambdap(tmp)))) + sexp_push(ctx, app, tmp); + } + if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app))) + res = sexp_car(app); + else + sexp_seq_ls(res) = sexp_nreverse(ctx, app); + break; + + } + + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_simplify (sexp ctx sexp_api_params(self, n), sexp ast) { + return simplify(ctx, ast, SEXP_NULL, NULL); +} + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..db4c91fe --- /dev/null +++ b/sexp.c @@ -0,0 +1,1842 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +/* optional huffman-compressed immediate symbols */ +struct sexp_huff_entry { + unsigned char len; + unsigned short bits; +}; + +#if SEXP_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; + +sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp); + +static const 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 (int c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int hex_digit (int n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + +static int is_separator(int c) { + return 0= SEXP_MAXIMUM_TYPES) { + res = sexp_user_exception(ctx, self, "register-type: exceeded maximum type limit", name); + } else if (! sexp_stringp(name)) { + res = sexp_type_exception(ctx, self, SEXP_STRING, name); + } else { + if (num_types >= type_array_size) { + len = type_array_size*2; + if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES; +#if SEXP_USE_GLOBAL_TYPES + new = malloc(len * sizeof(_sexp_type_specs[0])); + for (i=0; i num_types) free(tmp); + sexp_type_array_size = len; +#else + res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID); + v1 = sexp_vector_data(res); + v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)); + for (i=0; ivalue), &(_sexp_type_specs[i]), sizeof(_sexp_type_specs[0])); + vec[i] = type; + } +#endif +} + +#if ! SEXP_USE_GLOBAL_HEAP +sexp sexp_bootstrap_context (sexp_uint_t size) { + sexp dummy_ctx, ctx; + sexp_heap heap; + if (size < SEXP_MINIMUM_HEAP_SIZE) size = SEXP_INITIAL_HEAP_SIZE; + heap = sexp_make_heap(sexp_heap_align(size)); + dummy_ctx = (sexp) malloc(sexp_sizeof(context)); + sexp_pointer_tag(dummy_ctx) = SEXP_CONTEXT; + sexp_context_saves(dummy_ctx) = NULL; + sexp_context_heap(dummy_ctx) = heap; + ctx = sexp_alloc_type(dummy_ctx, context, SEXP_CONTEXT); + sexp_context_heap(dummy_ctx) = NULL; + sexp_context_heap(ctx) = heap; + free(dummy_ctx); + return ctx; +} +#endif + +sexp sexp_make_context (sexp ctx, size_t size) { + sexp_gc_var1(res); + if (ctx) sexp_gc_preserve1(ctx, res); +#if ! SEXP_USE_GLOBAL_HEAP + if (! ctx) res = sexp_bootstrap_context(size); + else +#endif + { + res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); +#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC + sexp_context_heap(res) = sexp_context_heap(ctx); +#endif + } + sexp_context_parent(res) = ctx; + sexp_context_lambda(res) = SEXP_FALSE; + sexp_context_name(res) = sexp_context_specific(res) = SEXP_FALSE; + sexp_context_fv(res) = SEXP_NULL; + sexp_context_saves(res) = NULL; + sexp_context_depth(res)=sexp_context_tracep(res)=sexp_context_pos(res)=0; + sexp_context_tailp(res) = 1; +#if SEXP_USE_GREEN_THREADS + sexp_context_refuel(res) = SEXP_DEFAULT_QUANTUM; +#endif + if (ctx) { + sexp_context_globals(res) = sexp_context_globals(ctx); + sexp_gc_release1(ctx); + } else { + sexp_init_context_globals(res); + } + return res; +} + +#if ! SEXP_USE_GLOBAL_HEAP +void sexp_destroy_context (sexp ctx) { + sexp_heap heap, tmp; + size_t sum_freed; + if (sexp_context_heap(ctx)) { + heap = sexp_context_heap(ctx); + sexp_sweep(ctx, &sum_freed); /* sweep w/o mark to run finalizers */ + sexp_context_heap(ctx) = NULL; + for ( ; heap; heap=tmp) { + tmp = heap->next; +#if SEXP_USE_MMAP_GC + munmap(heap, sexp_heap_pad_size(heap->size)); +#else + free(heap); +#endif + } + } +} +#endif + +/***************************** exceptions *****************************/ + +sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, + 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_source(exn) = source; + return exn; +} + +sexp sexp_string_cat3 (sexp ctx, char *pre, char *mid, char* suf) { + int plen=strlen(pre), mlen=strlen(mid), slen=strlen(suf); + char *s; + sexp str; + str = sexp_make_string(ctx, sexp_make_fixnum(plen+mlen+slen), SEXP_VOID); + memcpy(s=sexp_string_data(str), pre, plen); + memcpy(s+plen, mid, mlen); + memcpy(s+plen+mlen, suf, slen); + return str; +} + +sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { + sexp res; + sexp_gc_var3(sym, str, irr); + sexp_gc_preserve3(ctx, sym, str, irr); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user", -1), + str = sexp_c_string(ctx, ms, -1), + ((sexp_pairp(ir) || sexp_nullp(ir)) + ? ir : (irr = sexp_list1(ctx, ir))), + self, SEXP_FALSE); + sexp_gc_release3(ctx); + return res; +} + +static sexp type_exception (sexp ctx, sexp self, sexp str, sexp obj, sexp src) { + sexp_gc_var2(res, sym); + sexp_gc_preserve2(ctx, res, sym); + sym = sexp_intern(ctx, "type", -1); + res = sexp_make_exception(ctx, sym, str, obj, self, src); + sexp_exception_irritants(res)=sexp_list1(ctx, sexp_exception_irritants(res)); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_c_string(ctx, msg, -1); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp obj) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_string_cat3(ctx, "invalid type, expected ", + sexp_type_name_by_index(ctx, type_id), ""); + res = type_exception(ctx, self, res, obj, SEXP_FALSE); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { + sexp_gc_var2(res, msg); + sexp_gc_preserve2(ctx, res, 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", -1), msg, res, + SEXP_FALSE, SEXP_FALSE); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out) { + sexp ls; + if (! sexp_oportp(out)) + out = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_write_string(ctx, "ERROR", out); + if (sexp_exceptionp(exn)) { + if (sexp_exception_procedure(exn)) { + if (sexp_procedurep(sexp_exception_procedure(exn))) { + ls = sexp_bytecode_name( + sexp_procedure_code(sexp_exception_procedure(exn))); + if (ls && sexp_symbolp(ls)) { + sexp_write_string(ctx, " in ", out); + sexp_write(ctx, ls, out); + } + } else if (sexp_opcodep(sexp_exception_procedure(exn))) { + sexp_write_string(ctx, " in ", out); + sexp_write_string(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out); + } + } + ls = sexp_exception_source(exn); + if ((! (ls && sexp_pairp(ls))) + && sexp_exception_procedure(exn) + && sexp_procedurep(sexp_exception_procedure(exn))) + ls = sexp_bytecode_source(sexp_procedure_code(sexp_exception_procedure(exn))); + if (ls && sexp_pairp(ls)) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(sexp_exception_message(exn))) + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); + else + sexp_write(ctx, 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, const char *msg, sexp ir, sexp port) { + sexp res; + sexp_gc_var4(sym, name, str, irr); + sexp_gc_preserve4(ctx, sym, name, str, irr); + name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); + name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port))); + str = sexp_c_string(ctx, msg, -1); + irr = ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir)); + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read", -1), + str, irr, SEXP_FALSE, name); + sexp_gc_release4(ctx); + return res; +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons_op (sexp ctx sexp_api_params(self, n), sexp head, sexp tail) { + sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); + if (sexp_exceptionp(pair)) return 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_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_listp_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(ctx, sexp_car(ls), res); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp a, b, tmp; + if (ls == SEXP_NULL) return ls; + sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, ls); + 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_copy_list_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp tmp; + sexp_gc_var1(res); + if (! sexp_pairp(ls)) return ls; + sexp_gc_preserve1(ctx, res); + tmp = res = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + for (ls=sexp_cdr(ls); sexp_pairp(ls); ls=sexp_cdr(ls), tmp=sexp_cdr(tmp)) + sexp_cdr(tmp) = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_append2_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + sexp_gc_var2(a1, b1); + sexp_gc_preserve2(ctx, a1, 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_release2(ctx); + return b1; +} + +sexp sexp_length_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp_uint_t res=0; + for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) + ; + return sexp_make_fixnum(res); +} + +sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { + sexp_uint_t size; + sexp_sint_t i, len; + sexp t, *p, *q; + char *p0, *q0; + + loop: + if (a == b) + return SEXP_TRUE; + else if ((! sexp_pointerp(a)) || (! sexp_pointerp(b)) + || (sexp_pointer_tag(a) != sexp_pointer_tag(b))) + return SEXP_FALSE; + + /* a and b are both pointers of the same type */ +#if SEXP_USE_BIGNUMS + if (sexp_pointer_tag(a) == SEXP_BIGNUM) + return sexp_make_boolean(!sexp_bignum_compare(a, b)); +#endif +#if SEXP_USE_FLONUMS && ! SEXP_USE_IMMEDIATE_FLONUMS + if (sexp_pointer_tag(a) == SEXP_FLONUM) + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); +#endif + t = sexp_object_type(ctx, a); + p0 = ((char*)a) + offsetof(struct sexp_struct, value); + p = (sexp*) (((char*)a) + sexp_type_field_base(t)); + q0 = ((char*)b) + offsetof(struct sexp_struct, value); + q = (sexp*) (((char*)b) + sexp_type_field_base(t)); + if ((sexp)p == a) {p=(sexp*)p0; q=(sexp*)q0;} + /* check preliminary non-object data */ + if ((p0 < (char*)p) && memcmp(p0, q0, ((char*)p - p0))) + return SEXP_FALSE; + /* check trailing non-object data */ + size = sexp_type_size_of_object(t, a) - offsetof(struct sexp_struct, value); + p0 = ((char*)p + sexp_type_num_slots_of_object(t,a)*sizeof(sexp)); + if (((char*)a + size) > p0) { + q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp)); + if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value)) + return SEXP_FALSE; + if (memcmp(p0, q0, size)) + return SEXP_FALSE; + } + /* check eq-object slots */ + len = sexp_type_num_eq_slots_of_object(t, a); + if (len > 0) { + for (i=0; i> 32; + return r.flonum; +} +sexp sexp_make_flonum (sexp ctx, float f) { + union sexp_flonum_conv x; + x.flonum = f; + return (sexp)(((sexp_uint_t)(x.bits) << 32) + SEXP_IFLONUM_TAG); +} +#endif +#endif + +sexp sexp_make_bytes_op (sexp ctx sexp_api_params(self, n), sexp len, sexp i) { + sexp_sint_t clen = sexp_unbox_fixnum(len); + sexp s; + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len); + if (clen < 0) return sexp_xtype_exception(ctx, self, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(bytes)+clen+1); + if (sexp_exceptionp(s)) return s; + sexp_pointer_tag(s) = SEXP_BYTES; +#if SEXP_USE_HEADER_MAGIC + sexp_pointer_magic(s) = SEXP_POINTER_MAGIC; +#endif + sexp_bytes_length(s) = clen; + if (sexp_fixnump(i)) + memset(sexp_bytes_data(s), sexp_unbox_fixnum(i), clen); + sexp_bytes_data(s)[clen] = '\0'; + return s; +} + +sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) +{ + sexp i = (sexp_charp(ch) ? sexp_make_fixnum(sexp_unbox_character(ch)) : ch); + sexp_gc_var2(b, s); + b = sexp_make_bytes_op(ctx sexp_api_pass(self, n), len, i); + if (sexp_exceptionp(b)) return b; +#if SEXP_USE_PACKED_STRINGS + sexp_pointer_tag(b) = SEXP_STRING; + return b; +#else + sexp_gc_preserve2(ctx, b, s); + s = sexp_alloc_type(ctx, string, SEXP_STRING); + sexp_string_bytes(s) = b; + sexp_string_offset(s) = 0; + sexp_string_length(s) = sexp_unbox_fixnum(len); + sexp_gc_release2(ctx); + return s; +#endif +} + +sexp sexp_c_string (sexp ctx, const char *str, sexp_sint_t slen) { + sexp_sint_t len = ((slen >= 0) ? slen : strlen(str)); + sexp s = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID); + memcpy(sexp_string_data(s), str, len); + sexp_string_data(s)[len] = '\0'; + return s; +} + +sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start); + if (sexp_not(end)) + end = sexp_make_fixnum(sexp_string_length(str)); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end); + if ((sexp_unbox_fixnum(start) < 0) + || (sexp_unbox_fixnum(start) > sexp_string_length(str)) + || (sexp_unbox_fixnum(end) < 0) + || (sexp_unbox_fixnum(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_fixnum(start), + sexp_string_length(res)); + sexp_string_data(res)[sexp_string_length(res)] = '\0'; + return res; +} + +sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep) { + sexp res, ls; + sexp_uint_t len=0, i=0, sep_len=0; + char *p, *csep; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception(ctx, self, SEXP_STRING, sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + if (sexp_stringp(sep) && ((sep_len=sexp_string_length(sep)) > 0)) { + csep = sexp_string_data(sep); + len += sep_len*(i-1); + } + res = sexp_make_string(ctx, sexp_make_fixnum(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; + if (sep_len && sexp_pairp(sexp_cdr(ls))) { + memcpy(p, csep, sep_len); + p += sep_len; + } + } + *p = '\0'; + return res; +} + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#if SEXP_USE_HASH_SYMS + +static sexp_uint_t sexp_string_hash(const char *str, sexp_sint_t len, + sexp_uint_t acc) { + for ( ; len; len--) {acc *= FNV_PRIME; acc ^= *str++;} + return acc; +} + +#endif + +sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { +#if SEXP_USE_HUFF_SYMS + struct sexp_huff_entry he; + sexp_uint_t space=3, newbits; + char c; +#endif + sexp_uint_t res=FNV_OFFSET_BASIS, bucket, i=0; + const char *p=str; + sexp ls, tmp; + sexp_gc_var1(sym); + + if (len < 0) len = strlen(str); + +#if SEXP_USE_HUFF_SYMS + res = 0; + for ( ; i 127) + goto normal_intern; + 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); + + normal_intern: +#endif +#if SEXP_USE_HASH_SYMS + bucket = (sexp_string_hash(p, len-i, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if ((sexp_symbol_length(tmp=sexp_car(ls)) == len) + && ! strncmp(str, sexp_symbol_data(tmp), len)) + return sexp_car(ls); + + /* not found, make a new symbol */ + sexp_gc_preserve1(ctx, sym); + sym = sexp_c_string(ctx, str, len); + if (sexp_exceptionp(sym)) return sym; +#if ! SEXP_USE_PACKED_STRINGS + sym = sexp_string_bytes(sym); +#endif + sexp_pointer_tag(sym) = SEXP_SYMBOL; + sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); + sexp_gc_release1(ctx); + return sym; +} + +sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); +} + +sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt) { + sexp vec, *x; + int i, clen = sexp_unbox_fixnum(len); + if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR); + vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); + if (sexp_exceptionp(vec)) return vec; + x = sexp_vector_data(vec); + 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_fixnum(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_fixnum(sexp_stream_size(vec)); + pos = sexp_unbox_fixnum(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_stream_ctx(vec), + sexp_make_fixnum(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_fixnum(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_fixnum(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_fixnum(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_fixnum(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_fixnum(pos); + return pos; +} + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + FILE *in; + sexp res; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = str; + sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str)); + sexp_stream_pos(cookie) = SEXP_ZERO; + 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_release1(ctx); + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + FILE *out; + sexp res, size; + sexp_gc_var1(cookie); + sexp_gc_preserve1(ctx, cookie); + size = sexp_make_fixnum(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_make_vector(ctx, sexp_make_fixnum(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_ZERO; + 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_release1(ctx); + return res; +} + +sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(ctx, + sexp_stream_buf(cookie), + SEXP_ZERO, + sexp_stream_pos(cookie)); +} + +#else + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + FILE *in; + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + if (sexp_string_length(str) == 0) + in = fopen("/dev/null", "r"); + else + in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + if (in) { + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + if (sexp_string_length(str) == 0) + sexp_port_name(res) = sexp_c_string(ctx, "/dev/null", -1); + sexp_port_cookie(res) = str; /* for gc preservation */ + } else { + res = sexp_user_exception(ctx, SEXP_FALSE, "couldn't open string", str); + } + return res; +} + +sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) { + 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_op (sexp ctx sexp_api_params(self, n), 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, const 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, const 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_var1(tmp); + if (! sexp_oportp(p)) + return sexp_type_exception(ctx, NULL, SEXP_OPORT, p); + 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_preserve1(ctx, tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_gc_release1(ctx); + } + sexp_port_offset(p) = 0; + return SEXP_VOID; + } +} + +sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) { + sexp res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + 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_op (sexp ctx sexp_api_params(self, n)) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + if (sexp_exceptionp(res)) return res; + 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_op (sexp ctx sexp_api_params(self, n), sexp out) { + sexp res; + sexp_gc_var2(ls, tmp); + sexp_gc_preserve2(ctx, ls, 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_FALSE); + sexp_gc_release2(ctx); + return res; +} + +#endif + +sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { + sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); + if (sexp_exceptionp(p)) return p; + 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_no_closep(p) = 0; + sexp_port_sourcep(p) = 0; + 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); + if (sexp_exceptionp(p)) return p; + sexp_pointer_tag(p) = SEXP_OPORT; + return p; +} + +#define NUMBUF_LEN 32 + +sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { +#if SEXP_USE_HUFF_SYMS + unsigned long res, c; +#endif + unsigned long len; + long i=0; + double f; + sexp x, *elts; + char *str=NULL, numbuf[NUMBUF_LEN]; + + 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_one(ctx, sexp_car(obj), out); + for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { + sexp_write_char(ctx, ' ', out); + sexp_write_one(ctx, sexp_car(x), out); + } + if (! sexp_nullp(x)) { + sexp_write_string(ctx, " . ", out); + sexp_write_one(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_one(ctx, elts[0], out); + for (i=1; i", out); + break; + case SEXP_SYNCLO: + sexp_write_string(ctx, "#", out); + break; + case SEXP_TYPE: + sexp_write_string(ctx, "#", 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_symbol_length(obj); + str = sexp_symbol_data(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; +#if SEXP_USE_BIGNUMS + case SEXP_BIGNUM: + sexp_write_bignum(ctx, obj, out, 10); + break; +#endif + case SEXP_OPCODE: + sexp_write_string(ctx, "#', out); + break; + default: + i = sexp_pointer_tag(obj); + sexp_write_string(ctx, "#<", out); + sexp_write_string(ctx, + (i < sexp_context_num_types(ctx)) + ? sexp_type_name_by_index(ctx, i) : "invalid", + out); + sexp_write_char(ctx, '>', out); + break; + } + } else if (sexp_fixnump(obj)) { + snprintf(numbuf, NUMBUF_LEN, "%ld", (long)sexp_unbox_fixnum(obj)); + sexp_write_string(ctx, numbuf, out); +#if SEXP_USE_IMMEDIATE_FLONUMS + } else if (sexp_flonump(obj)) { + f = sexp_flonum_value(obj); +#if SEXP_USE_INFINITIES + if (isinf(f) || isnan(f)) { + numbuf[0] = (isinf(f) && f < 0 ? '-' : '+'); + strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0"); + } else +#endif + { + i = snprintf(numbuf, NUMBUF_LEN, "%.8g", f); + if (f == trunc(f) && ! strchr(numbuf, '.')) { + 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); + c = sexp_unbox_character(obj); + if (c >= 0x100) { + if (c >= 0x10000) { + sexp_write_char(ctx, hex_digit((c>>20)&0x0F), out); + sexp_write_char(ctx, hex_digit((c>>16)&0x0F), out); + } + sexp_write_char(ctx, hex_digit((c>>12)&0x0F), out); + sexp_write_char(ctx, hex_digit((c>>8)&0x0F), out); + } + sexp_write_char(ctx, hex_digit((c>>4)&0x0F), out); + sexp_write_char(ctx, hex_digit(c&0x0F), out); + } + } else if (sexp_symbolp(obj)) { + +#if SEXP_USE_HUFF_SYMS + if (sexp_isymbolp(obj)) { + 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); + } + } + return SEXP_VOID; +} + +sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + return sexp_write_one(ctx, obj, out); +} + +sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) { + sexp res=SEXP_VOID; + sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out); + if (sexp_stringp(obj)) + sexp_write_string(ctx, sexp_string_data(obj), out); + else if (sexp_charp(obj)) + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else + res = sexp_write_one(ctx, obj, out); + return res; +} + +sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), sexp out) { + sexp_flush(ctx, out); + return SEXP_VOID; +} + +#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 'r': c = '\r'; break; + case 't': c = '\t'; break; + case 'x': + c = sexp_read_char(ctx, in); + if (isxdigit(c)) { + c = digit_value(c)*16 + digit_value(sexp_read_char(ctx, in)); + } else { + sexp_push_char(ctx, c, in); c = 'x'; + } + } + } + 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, i) : 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, double whole, int negp) { + sexp exponent=SEXP_VOID; + 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; + if (c=='e' || c=='E') { + exponent = sexp_read_number(ctx, in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(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); + } else { + sexp_push_char(ctx, c, in); + } + res = (whole + res) * pow(10, e); + if (negp) res *= -1; + return sexp_make_flonum(ctx, res); +} + +sexp sexp_read_number (sexp ctx, sexp in, int base) { + sexp den; + sexp_uint_t res = 0, tmp; + int c, digit, negativep = 0; + + c = sexp_read_char(ctx, in); + if (c == '-') { + negativep = 1; + c = sexp_read_char(ctx, in); + } + + for ( ; isxdigit(c); c=sexp_read_char(ctx, in)) { + digit = digit_value(c); + if ((digit < 0) || (digit >= base)) + break; + tmp = res * base + digit; +#if SEXP_USE_BIGNUMS + if ((tmp < res) || (tmp > SEXP_MAX_FIXNUM)) { + sexp_push_char(ctx, c, in); + return sexp_read_bignum(ctx, in, res, (negativep ? -1 : 1), base); + } +#endif + res = tmp; + } + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in); + if (c!='.') sexp_push_char(ctx, c, in); + return sexp_read_float_tail(ctx, in, res, negativep); + } else if (c=='/') { + den = sexp_read_number(ctx, in, base); + if (! sexp_fixnump(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_fixnum(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_fixnum(negativep ? -res : res); +} + +sexp sexp_read_raw (sexp ctx, sexp in) { + char *str; + int c1, c2, line; + sexp tmp2; + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + + scan_loop: + switch (c1 = sexp_read_char(ctx, in)) { + case EOF: + if (sexp_at_eofp(in)) + res = SEXP_EOF; + else + goto scan_loop; + 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); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res); + break; + case '`': + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res); + break; + case ',': + if ((c1 = sexp_read_char(ctx, in)) == '@') { + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_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)) { + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } + res = sexp_cons(ctx, tmp, res); + if (sexp_port_sourcep(in) && (line >= 0)) + sexp_pair_source(res) + = sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line)); + tmp = sexp_read_raw(ctx, in); + } + 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_fixnum(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_fixnum((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(ctx, in); + if (sexp_fixnump(res)) + res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res)); + break; + case 'f': case 'F': + case 't': case 'T': + c2 = sexp_read_char(ctx, in); + if (c2 == EOF || is_separator(c2)) { + res = (tolower(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; + break; + case '!': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + sexp_port_line(in)++; + 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); + sexp_push_char(ctx, c1, in); + if (c1 == EOF || is_separator(c1)) { + res = SEXP_RAWDOT; + } else if (isdigit(c1)) { + res = sexp_read_float_tail(ctx, in, 0, 0); + } else { + 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 SEXP_USE_FLONUMS + if (sexp_flonump(res)) +#if SEXP_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 +#if SEXP_USE_BIGNUMS + if (sexp_bignump(res)) { + if ((sexp_bignum_hi(res) == 1) + && (sexp_bignum_data(res)[0] == (SEXP_MAX_FIXNUM+1))) + res = sexp_make_fixnum(-sexp_bignum_data(res)[0]); + else + sexp_bignum_sign(res) = -sexp_bignum_sign(res); + } else +#endif + res = sexp_fx_mul(res, SEXP_NEG_ONE); + } + } else { + sexp_push_char(ctx, c2, in); + res = sexp_read_symbol(ctx, in, c1, 1); +#if SEXP_USE_INFINITIES + if (res == sexp_intern(ctx, "+inf.0", -1)) + res = sexp_make_flonum(ctx, sexp_pos_infinity); + else if (res == sexp_intern(ctx, "-inf.0", -1)) + res = sexp_make_flonum(ctx, sexp_neg_infinity); + else if (res == sexp_intern(ctx, "+nan.0", -1)) + res = sexp_make_flonum(ctx, sexp_nan); +#endif + } + 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_release2(ctx); + return res; +} + +sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in) { + sexp res; + sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in); + res = sexp_read_raw(ctx, in); + if (res == SEXP_CLOSE) + res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); + if (res == SEXP_RAWDOT) + res = sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); + return res; +} + +sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) { + sexp res; + sexp_gc_var2(s, in); + sexp_gc_preserve2(ctx, s, in); + s = sexp_c_string(ctx, str, len); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b) { + int base; + sexp_gc_var1(in); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b); + if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36)) + return sexp_user_exception(ctx, self, "invalid numeric base", b); + sexp_gc_preserve1(ctx, in); + in = sexp_make_input_string_port(ctx, str); + in = ((sexp_string_data(str)[0] == '#') ? + sexp_read(ctx, in) : sexp_read_number(ctx, in, base)); + sexp_gc_release1(ctx); + return sexp_numberp(in) ? in : SEXP_FALSE; +} + +sexp sexp_write_to_string (sexp ctx, sexp obj) { + sexp str; + sexp_gc_var1(out); + sexp_gc_preserve1(ctx, out); + out = sexp_make_output_string_port(ctx); + str = sexp_write(ctx, obj, out); + if (! sexp_exceptionp(str)) + str = sexp_get_output_string(ctx, out); + sexp_gc_release1(ctx); + return str; +} + +void sexp_init (void) { +#if SEXP_USE_GLOBAL_SYMBOLS + int i; +#endif + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if SEXP_USE_BOEHM + GC_init(); +#if SEXP_USE_GLOBAL_SYMBOLS + GC_add_roots((char*)&sexp_symbol_table, + ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); +#endif +#elif ! SEXP_USE_MALLOC + sexp_gc_init(); +#endif +#if SEXP_USE_GLOBAL_SYMBOLS + 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..820020c1 --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,48 @@ + +(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)))) 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/build/build-opts.txt b/tests/build/build-opts.txt new file mode 100644 index 00000000..e6bcd056 --- /dev/null +++ b/tests/build/build-opts.txt @@ -0,0 +1,21 @@ +CPPFLAGS=-DSEXP_USE_MODULES=0 +CPPFLAGS=-DSEXP_USE_DL=0 +CPPFLAGS=-DSEXP_USE_SIMPLIFY=0 +CPPFLAGS=-DSEXP_USE_TYPE_DEFS=0 +SEXP_USE_BOEHM=1 +CPPFLAGS=-DSEXP_USE_DEBUG_GC=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_HEAP=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_TYPES=1 +CPPFLAGS=-DSEXP_USE_GLOBAL_SYMBOLS=1 +CPPFLAGS=-DSEXP_USE_FLONUMS=0 +CPPFLAGS=-DSEXP_USE_IMMEDIATE_FLONUMS=1 +CPPFLAGS=-DSEXP_USE_BIGNUMS=0 +CPPFLAGS=-DSEXP_USE_MATH=0 +CPPFLAGS=-DSEXP_WARN_UNDEFS=0 +CPPFLAGS=-DSEXP_USE_HUFF_SYMS=0 +CPPFLAGS=-DSEXP_USE_HASH_SYMS=0 +CPPFLAGS=-DSEXP_USE_STRING_STREAMS=0 +CPPFLAGS=-DSEXP_USE_AUTOCLOSE_PORTS=0 +CPPFLAGS=-DSEXP_USE_2010_EPOCH=0 +CPPFLAGS=-DSEXP_USE_CHECK_STACK=0 +CPPFLAGS=-DSEXP_USE_NO_FEATURES=1 diff --git a/tests/build/build-tests.sh b/tests/build/build-tests.sh new file mode 100755 index 00000000..1d239629 --- /dev/null +++ b/tests/build/build-tests.sh @@ -0,0 +1,37 @@ +#! /bin/bash + +# test basic build options + +# for bootstrapping reasons this is a shell script, instead of a +# scheme script using (chibi process) + +# we just check each build against r5rs-tests.scm - +# some of the libraries will fail to build (notably +# if modules or user-defined types are disabled). + +BUILDDIR=tests/build +FAILURES=0 +i=0 + +for opts in `cat ${BUILDDIR}/build-opts.txt`; do + make cleaner 2>&1 >/dev/null + if make $opts chibi-scheme 2>&1 >${BUILDDIR}/build${i}-make.out; then + if make test 2>&1 | tee ${BUILDDIR}/build${i}-test.out | grep -q -E 'FAIL|ERROR'; then + echo "[FAIL] ${i}: tests failed with $opts" + FAILURES=$((FAILURES + 1)) + else + echo "[PASS] ${i}: tests passed with $opts" + fi + else + echo "[FAIL] ${i}: couldn't build with $opts" + FAILURES=$((FAILURES + 1)) + fi + i=$((i+1)) +done + +if (( FAILURES == 0 )); then + echo "build-tests: all tests passed" +else + echo "build-tests: ${FAILURES} tests failed" +fi + diff --git a/tests/flonum-tests.scm b/tests/flonum-tests.scm new file mode 100644 index 00000000..5abe4772 --- /dev/null +++ b/tests/flonum-tests.scm @@ -0,0 +1,21 @@ +;;;; these will fail when compiled either without flonums or trig funcs + +(import (chibi test)) + +(test-begin "floating point") + +(test-assert (= -5 (floor -4.3))) +(test-assert (= -4 (ceiling -4.3))) +(test-assert (= -4 (truncate -4.3))) +(test-assert (= -4 (round -4.3))) +(test-assert (= 3 (floor 3.5))) +(test-assert (= 4 (ceiling 3.5))) +(test-assert (= 3 (truncate 3.5))) +(test-assert (= 4 (round 3.5))) + +(test 1124378190243790143.0 (exact->inexact 1124378190243790143)) + +;; (test "1124378190243790143.0" +;; (number->string (exact->inexact 1124378190243790143))) + +(test-end) diff --git a/tests/hash-tests.scm b/tests/hash-tests.scm new file mode 100644 index 00000000..09792c5e --- /dev/null +++ b/tests/hash-tests.scm @@ -0,0 +1,37 @@ + +(import (srfi 69) (chibi test)) + +(test-begin "hash") + +(test + 'white + (let ((ht (make-hash-table eq?))) + (hash-table-set! ht 'cat 'black) + (hash-table-set! ht 'dog 'white) + (hash-table-set! ht 'elephant 'pink) + (hash-table-ref/default ht 'dog #f))) + +(test + 'white + (let ((ht (make-hash-table equal?))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "dog" #f))) + +(test + 'white + (let ((ht (make-hash-table string-ci=? string-ci-hash))) + (hash-table-set! ht "cat" 'black) + (hash-table-set! ht "dog" 'white) + (hash-table-set! ht "elephant" 'pink) + (hash-table-ref/default ht "DOG" #f))) + +(test 625 + (let ((ht (make-hash-table))) + (do ((i 0 (+ i 1))) ((= i 1000)) + (hash-table-set! ht i (* i i))) + (hash-table-ref/default ht 25 #f))) + +(test-end) + diff --git a/tests/install/install-tests.pl b/tests/install/install-tests.pl new file mode 100755 index 00000000..63681324 --- /dev/null +++ b/tests/install/install-tests.pl @@ -0,0 +1,57 @@ +#! /usr/bin/env perl + +use strict; +use warnings; + +my $ROOT="tests/install/root"; +my $USER=$ENV{USER}; + +my $ignore = qr!/lib\d*/modules|/X11|alsa-lib|aspell|dosemu|emacs|erlang|/perl|python|ruby|lisp|sbcl|/ghc-|ocaml|evolution|office|gimp|gtk|mysql|postgres|wordnet|xulrunner!; + +sub linkdir ($$$) { + my ($FROM, $TO, $DEPTH) = @_; + mkdir $TO; + for my $f (`ls $FROM`) { + chomp $f; + if (-d "$FROM/$f") { + if (($DEPTH > 0) && ($FROM !~ $ignore)) { + linkdir("$FROM/$f", "$TO/$f", $DEPTH-1); + } + } else { + link "$FROM/$f", "$TO/$f"; + } + } +} + +mkdir "$ROOT"; +mkdir "$ROOT/bin"; +mkdir "$ROOT/sbin"; +mkdir "$ROOT/dev"; +mkdir "$ROOT/etc"; +mkdir "$ROOT/etc/alternatives"; +mkdir "$ROOT/lib"; +mkdir "$ROOT/lib64"; +mkdir "$ROOT/usr"; +mkdir "$ROOT/usr/bin"; +mkdir "$ROOT/usr/include"; +mkdir "$ROOT/usr/lib"; +mkdir "$ROOT/usr/lib/gcc"; + +linkdir "/bin", "$ROOT/bin", 1; +linkdir "/sbin", "$ROOT/sbin", 1; +link "/etc/passwd", "$ROOT/etc/passwd"; +linkdir "/etc/alternatives", "$ROOT/etc/alternatives", 1; +linkdir "/lib", "$ROOT/lib", 3; +linkdir "/lib64", "$ROOT/lib64", 3; +linkdir "/usr/bin", "$ROOT/usr/bin", 3; +linkdir "/usr/include", "$ROOT/usr/include", 2; +linkdir "/usr/lib", "$ROOT/usr/lib", 3; +linkdir "/usr/lib/gcc", "$ROOT/usr/lib/gcc", 3; + +`make dist`; +my $VERSION=`cat VERSION`; +chomp $VERSION; +`cp chibi-scheme-$VERSION.tgz $ROOT/`; +`sed -e 's/\@VERSION\@/$VERSION/g' $ROOT/bin/run-install-test.sh`; +`chmod 755 $ROOT/bin/run-install-test.sh`; +exec "sudo chroot $ROOT run-install-test.sh"; diff --git a/tests/install/run-install-test.sh b/tests/install/run-install-test.sh new file mode 100755 index 00000000..c558e7cd --- /dev/null +++ b/tests/install/run-install-test.sh @@ -0,0 +1,12 @@ +#! /bin/bash + +export PATH=/usr/local/bin:$PATH +export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH + +tar xzvf chibi-scheme-@VERSION@.tgz +cd chibi-scheme-@VERSION@ +make +make install +cp tests/r5rs-tests.scm .. +cd .. +chibi-scheme r5rs-tests.scm | tee r5rs-tests.out diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm new file mode 100644 index 00000000..fbd8ae0a --- /dev/null +++ b/tests/lib-tests.scm @@ -0,0 +1,13 @@ + +(import (chibi test)) + +(test-begin "libraries") + +(load "tests/flonum-tests.scm") +(load "tests/numeric-tests.scm") +(load "tests/hash-tests.scm") +(load "tests/sort-tests.scm") +(load "tests/loop-tests.scm") +(load "tests/match-tests.scm") + +(test-end) diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm new file mode 100644 index 00000000..f259245c --- /dev/null +++ b/tests/loop-tests.scm @@ -0,0 +1,168 @@ + +(import (chibi loop) (chibi test)) + +(test-begin "loops") + +(test + "stepping" + '(0 1 2) + (loop lp ((with i 0 (+ i 1)) + (with res '() (cons i res))) + (if (= i 3) + (reverse res) + (lp)))) + +(test + "basic in-list" + '(c b a) + (let ((res '())) + (loop ((for x (in-list '(a b c)))) + (set! res (cons x res))) + res)) + +(test + "in-list with result" + '(c b a) + (loop ((for x (in-list '(a b c))) + (with res '() (cons x res))) + => res)) + +(test + "in-list with listing" + '(a b c) + (loop ((for x (in-list '(a b c))) (for res (listing x))) => res)) + +(test + "in-list with listing-reverse" + '(c b a) + (loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res)) + +(test + "uneven length in-list's" + '((a . 1) (b . 2) (c . 3)) + (loop ((for x (in-list '(a b c))) + (for y (in-list '(1 2 3 4))) + (for res (listing (cons x y)))) + => res)) + +(test + "in-lists" + '((a 1) (b 2) (c 3)) + (loop ((for ls (in-lists '((a b c) (1 2 3)))) + (for res (listing ls))) + => res)) + +(define (flatten ls) + (reverse + (loop lp ((for x ls (in-list ls)) (with res '())) + => res + (if (pair? x) + (lp (=> res (lp (=> ls x)))) + (lp (=> res (cons x res))))))) + +(test + "flatten (recursion test)" + '(1 2 3 4 5 6 7) + (flatten '(1 (2) (3 (4 (5)) 6) 7))) + +(test + "in-string" + '(#\h #\e #\l #\l #\o) + (loop ((for c (in-string "hello")) (for res (listing c))) => res)) + +(test + "in-string with start" + '(#\l #\o) + (loop ((for c (in-string "hello" 3)) (for res (listing c))) => res)) + +(test + "in-string with start and end" + '(#\h #\e #\l #\l) + (loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res)) + +(test + "in-string with start, end and step" + '(#\e #\l) + (loop ((for c (in-string "hello" 1 4 2)) (for res (listing c))) => res)) + +(test + "in-string-reverse" + '(#\o #\l #\l #\e #\h) + (loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res)) + +(test + "in-vector" + '(1 2 3) + (loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res)) + +(test "up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 8))) + (for res (listing i))) + => res)) + +(test "up-from by" '(5 10 15) + (loop ((for i (up-from 5 (to 20) (by 5))) + (for res (listing i))) + => res)) + +(test "up-from listing if" '(10 12 14 16 18) + (loop ((for i (up-from 10 (to 20))) + (for res (listing i (if (even? i))))) + => res)) + +(test "down-from" '(7 6 5) + (loop ((for i (down-from 8 (to 5))) + (for res (listing i))) + => res)) + +(test "down-from by" '(15 10 5) + (loop ((for i (down-from 20 (to 5) (by 5))) + (for res (listing i))) + => res)) + +(test "down-from listing if" '(18 16 14 12 10) + (loop ((for i (down-from 20 (to 10))) + (for res (listing i (if (even? i))))) + => res)) + +(test "appending" '(1 2 3 4 5 6 7 8 9) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending ls))) + => res)) + +(test "appending-reverse" '(9 8 7 6 5 4 3 2 1) + (loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9)))) + (for res (appending-reverse ls))) + => res)) + +(test "while + up-from" '(5 6 7) + (loop ((for i (up-from 5 (to 10))) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "up-from by, open-ended" '(5 7 9) + (loop ((for i (up-from 5 (by 2))) + (while (< i 10)) + (for res (listing i))) + => res)) + +(test "up-from open-ended" '(5 6 7) + (loop ((for i (up-from 5)) + (while (< i 8)) + (for res (listing i))) + => res)) + +(test "down-from by, open-ended" '(5 3 1) + (loop ((for i (down-from 7 (by 2))) + (until (< i 1)) + (for res (listing i))) + => res)) + +(test "down-from open-ended" '(4 3 2) + (loop ((for i (down-from 5)) + (until (< i 2)) + (for res (listing i))) + => res)) + +(test-end) diff --git a/tests/match-tests.scm b/tests/match-tests.scm new file mode 100644 index 00000000..911dd831 --- /dev/null +++ b/tests/match-tests.scm @@ -0,0 +1,135 @@ + +(import (chibi match) (chibi test)) + +(test-begin "match") + +(test "any" 'ok (match 'any (_ 'ok))) +(test "symbol" 'ok (match 'ok (x x))) +(test "number" 'ok (match 28 (28 'ok))) +(test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok))) +(test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok))) +(test "null" 'ok (match '() (() 'ok))) +(test "pair" 'ok (match '(ok) ((x) x))) +(test "vector" 'ok (match '#(ok) (#(x) x))) +(test "any doubled" 'ok (match '(1 2) ((_ _) 'ok))) +(test "and empty" 'ok (match '(o k) ((and) 'ok))) +(test "and single" 'ok (match 'ok ((and x) x))) +(test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok))) +(test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok))) +(test "or single" 'ok (match 'ok ((or x) 'ok))) +(test "or double" 'ok (match 'ok ((or (? symbol? y) y) y))) +(test "not" 'ok (match 28 ((not (a . b)) 'ok))) +(test "pred" 'ok (match 28 ((? number?) 'ok))) +(test "named pred" 29 (match 28 ((? number? x) (+ x 1)))) + +(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x))) +(test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok))) +(test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x))) + +(test "ellipses" '((a b c) (1 2 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ___) (list x y)))) + +(test "real ellipses" '((a b c) (1 2 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ...) (list x y)))) + +(test "vector ellipses" '(1 2 3 (a b c) (1 2 3)) + (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) + (#(a b c (hd . tl) ...) (list a b c hd tl)))) + +(test "pred ellipses" '(1 2 3) + (match '(1 2 3) + (((? odd? n) ___) n) + (((? number? n) ___) n))) + +(test "failure continuation" 'ok + (match '(1 2) + ((a . b) (=> next) (if (even? a) 'fail (next))) + ((a . b) 'ok))) + +(test "let" '(o k) + (match-let ((x 'ok) (y '(o k))) y)) + +(test "let*" '(f o o f) + (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w))) + +(test "getter car" '(1 2) + (match '(1 . 2) (((get! a) . b) (list (a) b)))) + +(test "getter cdr" '(1 2) + (match '(1 . 2) ((a . (get! b)) (list a (b))))) + +(test "getter vector" '(1 2 3) + (match '#(1 2 3) (#((get! a) b c) (list (a) b c)))) + +(test "setter car" '(3 . 2) + (let ((x (cons 1 2))) + (match x (((set! a) . b) (a 3))) + x)) + +(test "setter cdr" '(1 . 3) + (let ((x (cons 1 2))) + (match x ((a . (set! b)) (b 3))) + x)) + +(test "setter vector" '#(1 0 3) + (let ((x (vector 1 2 3))) + (match x (#(a (set! b) c) (b 0))) + x)) + +(test "single tail" '((a b) (1 2) (c . 3)) + (match '((a . 1) (b . 2) (c . 3)) + (((x . y) ... last) (list x y last)))) + +(test "single tail 2" '((a b) (1 2) 3) + (match '((a . 1) (b . 2) 3) + (((x . y) ... last) (list x y last)))) + +(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5)) + (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) + (((x . y) ... u v w) (list x y u v w)))) + +(test "Riastradh quasiquote" '(2 3) + (match '(1 2 3) (`(1 ,b ,c) (list b c)))) + +(test "trivial tree search" '(1 2 3) + (match '(1 2 3) ((_ *** (a b c)) (list a b c)))) + +(test "simple tree search" '(1 2 3) + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c)))) + +(test "deep tree search" '(1 2 3) + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c)))) + +(test "non-tail tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c)))) + +(test "restricted tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c)))) + +(test "fail restricted tree search" #f + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f))) + +(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "failed sxml tree search" #f + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "collect tree search" + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f))) + +(test-end) diff --git a/tests/numeric-tests.scm b/tests/numeric-tests.scm new file mode 100644 index 00000000..43b16cb4 --- /dev/null +++ b/tests/numeric-tests.scm @@ -0,0 +1,120 @@ + +;; these tests are only valid if chibi-scheme is compiled with full +;; numeric support (USE_BIGNUMS, USE_FLONUMS and USE_MATH) + +(import (chibi test)) + +(test-begin "numbers") + +(define (integer-neighborhoods x) + (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x))) + +(test '(536870912 536870913 536870911 -536870912 -536870911 -536870913) + (integer-neighborhoods (expt 2 29))) + +(test '(1073741824 1073741825 1073741823 -1073741824 -1073741823 -1073741825) + (integer-neighborhoods (expt 2 30))) + +(test '(2147483648 2147483649 2147483647 -2147483648 -2147483647 -2147483649) + (integer-neighborhoods (expt 2 31))) + +(test '(4294967296 4294967297 4294967295 -4294967296 -4294967295 -4294967297) + (integer-neighborhoods (expt 2 32))) + +(test '(4611686018427387904 4611686018427387905 4611686018427387903 + -4611686018427387904 -4611686018427387903 -4611686018427387905) + (integer-neighborhoods (expt 2 62))) + +(test '(9223372036854775808 9223372036854775809 9223372036854775807 + -9223372036854775808 -9223372036854775807 -9223372036854775809) + (integer-neighborhoods (expt 2 63))) + +(test '(18446744073709551616 18446744073709551617 18446744073709551615 + -18446744073709551616 -18446744073709551615 -18446744073709551617) + (integer-neighborhoods (expt 2 64))) + +(test '(85070591730234615865843651857942052864 + 85070591730234615865843651857942052865 + 85070591730234615865843651857942052863 + -85070591730234615865843651857942052864 + -85070591730234615865843651857942052863 + -85070591730234615865843651857942052865) + (integer-neighborhoods (expt 2 126))) + +(test '(170141183460469231731687303715884105728 + 170141183460469231731687303715884105729 + 170141183460469231731687303715884105727 + -170141183460469231731687303715884105728 + -170141183460469231731687303715884105727 + -170141183460469231731687303715884105729) + (integer-neighborhoods (expt 2 127))) + +(test '(340282366920938463463374607431768211456 + 340282366920938463463374607431768211457 + 340282366920938463463374607431768211455 + -340282366920938463463374607431768211456 + -340282366920938463463374607431768211455 + -340282366920938463463374607431768211457) + (integer-neighborhoods (expt 2 128))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (integer-arithmetic-combinations a b) + (list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b))) + +(define (sign-combinations a b) + (list (integer-arithmetic-combinations a b) + (integer-arithmetic-combinations (- a) b) + (integer-arithmetic-combinations a (- b)) + (integer-arithmetic-combinations (- a) (- b)))) + +;; fix x fix +(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0)) + (sign-combinations 0 1)) +(test '((2 0 1 1 0) (0 -2 -1 -1 0) (0 2 -1 -1 0) (-2 0 1 1 0)) + (sign-combinations 1 1)) +(test '((59 25 714 2 8) (-25 -59 -714 -2 -8) + (25 59 -714 -2 8) (-59 -25 714 2 -8)) + (sign-combinations 42 17)) + +;; fix x big +(test '((4294967338 -4294967254 180388626432 0 42) + (4294967254 -4294967338 -180388626432 0 -42) + (-4294967254 4294967338 -180388626432 0 42) + (-4294967338 4294967254 180388626432 0 -42)) + (sign-combinations 42 (expt 2 32))) + +;; big x fix +(test '((4294967338 4294967254 180388626432 102261126 4) + (-4294967254 -4294967338 -180388626432 -102261126 -4) + (4294967254 4294967338 -180388626432 -102261126 4) + (-4294967338 -4294967254 180388626432 102261126 -4)) + (sign-combinations (expt 2 32) 42)) + +;; big x bigger +(test '((12884901889 -4294967297 36893488151714070528 0 4294967296) + (4294967297 -12884901889 -36893488151714070528 0 -4294967296) + (-4294967297 12884901889 -36893488151714070528 0 4294967296) + (-12884901889 4294967297 36893488151714070528 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 33)))) + +(test '((18446744078004518913 -18446744069414584321 79228162514264337597838917632 0 4294967296) + (18446744069414584321 -18446744078004518913 -79228162514264337597838917632 0 -4294967296) + (-18446744069414584321 18446744078004518913 -79228162514264337597838917632 0 4294967296) + (-18446744078004518913 18446744069414584321 79228162514264337597838917632 0 -4294967296)) + (sign-combinations (expt 2 32) (+ 1 (expt 2 64)))) + +;; bigger x big +(test '((12884901889 4294967297 36893488151714070528 2 1) + (-4294967297 -12884901889 -36893488151714070528 -2 -1) + (4294967297 12884901889 -36893488151714070528 -2 1) + (-12884901889 -4294967297 36893488151714070528 2 -1)) + (sign-combinations (+ 1 (expt 2 33)) (expt 2 32))) + +(test '((18446744078004518913 18446744069414584321 79228162514264337597838917632 4294967296 1) + (-18446744069414584321 -18446744078004518913 -79228162514264337597838917632 -4294967296 -1) + (18446744069414584321 18446744078004518913 -79228162514264337597838917632 -4294967296 1) + (-18446744078004518913 -18446744069414584321 79228162514264337597838917632 4294967296 -1)) + (sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) + +(test-end) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..a9197fb1 --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,465 @@ + +(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) + (write *tests-run*) + (display ". ") + (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 -2 (let () + (define x 2) + (define f (lambda () (- x))) + (f))) + +(define let*-def 1) +(let* () (define let*-def 2) #f) +(test 1 let*-def) + +(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 4 16 9 8) + `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 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 #f (eqv? 2 2.0)) + +;;(test #f (equal? 2.0 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 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 127 (string->number "177" 8)) + +(test 5 (string->number "101" 2)) + +(test 100.0 (string->number "1e2")) + +(test "100" (number->string 100)) + +(test "100" (number->string 256 16)) + +(test "FF" (number->string 255 16)) + +(test "177" (number->string 127 8)) + +(test "101" (number->string 5 2)) + +(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 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + +(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 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad)))) + +(test 'ok (let ((=> 1)) (cond (#t => 'ok)))) + +(test '(,foo) (let ((unquote 1)) `(,foo))) + +(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) + +(test 'ok + (let ((... 2)) + (let-syntax ((s (syntax-rules () + ((_ x ...) 'bad) + ((_ . r) 'ok)))) + (s a b c)))) + +(test 'ok (let () + (let-syntax () + (define internal-def 'ok)) + internal-def)) + +(test 'ok (let () + (letrec-syntax () + (define internal-def 'ok)) + internal-def)) + +(test '(2 1) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y)))))) + +(test '(2 2) + ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y)))))) + +(test '(1 2) + ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y)))))) + +(test '(2 3) + ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) + +(test '(a b c) + (let* ((path '()) + (add (lambda (s) (set! path (cons s path))))) + (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) + (reverse path))) + +(test '(connect talk1 disconnect connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + +(test 2 (let-syntax + ((foo (syntax-rules ::: () + ((foo ... args :::) + (args ::: ...))))) + (foo 3 - 5))) + +(test '(5 4 1 2 3) + (let-syntax + ((foo (syntax-rules () + ((foo args ... penultimate ultimate) + (list ultimate penultimate args ...))))) + (foo 1 2 3 4 5))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm new file mode 100644 index 00000000..f506baca --- /dev/null +++ b/tests/sort-tests.scm @@ -0,0 +1,40 @@ + +(import (srfi 95) (chibi test)) + +(test-begin "sorting") + +(test "sort null" '() (sort '())) +(test "sort null <" '() (sort '() <)) +(test "sort null < car" '() (sort '() < car)) +(test "sort ordered list" '(1 2 3 4 5 6 7 8 9) (sort '(1 2 3 4 5 6 7 8 9))) +(test "sort reversed list" '(1 2 3 4 5 6 7 8 9) (sort '(9 8 7 6 5 4 3 2 1))) +(test "sort random list 1" '(1 2 3 4 5 6 7 8 9) (sort '(7 5 2 8 1 6 4 9 3))) +(test "sort random list 2" '(1 2 3 4 5 6 7 8) (sort '(5 3 4 1 7 6 8 2))) +(test "sort random list 3" '(1 2 3 4 5 6 7 8 9) (sort '(5 3 4 1 7 9 6 8 2))) +(test "sort numeric list <" '(1 2 3 4 5 6 7 8 9) + (sort '(7 5 2 8 1 6 4 9 3) <)) +(test "sort numeric list < car" '((1) (2) (3) (4) (5) (6) (7) (8) (9)) + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) < car)) +(test "sort list (lambda (a b) (< (car a) (car b)))" + '((1) (2) (3) (4) (5) (6) (7) (8) (9)) + (sort '((7) (5) (2) (8) (1) (6) (4) (9) (3)) + (lambda (a b) (< (car a) (car b))))) +(test "sort 1-char symbols" '(a b c d e f g h i j k) + (sort '(h b k d a c j i e g f))) +(test "sort short symbols" '(a aa b c d e ee f g h i j k) + (sort '(h b aa k d a ee c j i e g f))) +(test "sort long symbol" + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz c d e ee f g h i j k) + (sort '(h b aa k d a ee c j i bzzzzzzzzzzzzzzzzzzzzzzz e g f))) +(test "sort long symbols" + '(a aa b bzzzzzzzzzzzzzzzzzzzzzzz czzzzzzzzzzzzz dzzzzzzzz e ee f g h i j k) + (sort '(h b aa k dzzzzzzzz a ee czzzzzzzzzzzzz j i bzzzzzzzzzzzzzzzzzzzzzzz e g f))) +(test "sort strings" + '("ape" "bear" "cat" "dog" "elephant" "fox" "goat" "hawk") + (sort '("elephant" "cat" "dog" "ape" "goat" "fox" "hawk" "bear"))) +(test "sort strings string-cistring x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate (reverse (collect)))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (path-relative path dir) + (let ((p-len (string-length path)) + (d-len (string-length dir))) + (and (> p-len d-len) + (string=? dir (substring path 0 d-len)) + (cond + ((eqv? #\/ (string-ref path d-len)) + (substring path (+ d-len 1) p-len)) + ((eqv? #\/ (string-ref path (- d-len 1))) + (substring path d-len p-len)) + (else #f))))) + +(define (path-split file) + (let ((len (string-length file))) + (let lp ((i 0) (res '())) + (let ((j (string-scan #\/ file i))) + (cond + (j (lp (+ j 1) (cons (substring file i j) res))) + (else (reverse (if (= i len) + res + (cons (substring file i len) res))))))))) + +(define (init-name mod) + (string-append "sexp_init_lib_" + (string-concatenate (map mangle mod) "_"))) + +(define (find-c-libs basedir) + (define (process-dir dir) + (directory-fold + dir + (lambda (f x) + (if (and (not (equal? "" f)) (not (eqv? #\. (string-ref f 0)))) + (process (string-append dir "/" f)))) + #f)) + (define (process file) + (cond + ((file-directory? file) + (process-dir file)) + ((equal? "module" (path-extension file)) + (let* ((mod-path (path-strip-extension (path-relative file basedir))) + (mod-name (map (lambda (x) (or (string->number x) (string->symbol x))) + (path-split mod-path)))) + (cond + ((eval `(find-module ',mod-name) *config-env*) + => (lambda (mod) + (cond + ((assq 'include-shared (vector-ref mod 2)) + => (lambda (x) + (set! c-libs + (cons (cons (string-append + (path-directory file) + "/" + (cadr x) + ".c") + (init-name mod-name)) + c-libs)))))))))))) + (process-dir basedir)) + +(define (include-c-lib lib) + (display "#define sexp_init_library ") + (display (cdr lib)) + (newline) + (display "#include \"") + (display (car lib)) + (display "\"") + (newline) + (display "#undef sexp_init_library") + (newline) + (newline)) + +(define (init-c-lib lib) + (display " ") + (display (cdr lib)) + (display "(ctx, env);\n")) + +(define (main args) + (find-c-libs (if (pair? (cdr args)) (cadr args) "lib")) + (newline) + (for-each include-c-lib c-libs) + (newline) + (display "static sexp sexp_init_all_libraries (sexp ctx, sexp env) {\n") + (for-each init-c-lib c-libs) + (display " return SEXP_VOID;\n") + (display "}\n\n")) + diff --git a/tools/genstubs.scm b/tools/genstubs.scm new file mode 100755 index 00000000..e75d9a92 --- /dev/null +++ b/tools/genstubs.scm @@ -0,0 +1,1280 @@ +#! /usr/bin/env chibi-scheme + +;; Note: this evolved as a throw-away script to provide certain core +;; modules, and so is a mess. Tread carefully. + +;; Simple C FFI. "genstubs.scm file.stub" will read in the C function +;; FFI definitions from file.stub and output the appropriate C +;; wrappers into file.c. You can then compile that file with: +;; +;; cc -fPIC -shared file.c -lchibi-scheme +;; +;; (or using whatever flags are appropriate to generate shared libs on +;; your platform) and then the generated .so file can be loaded +;; directly with load, or portably using (include-shared "file") in a +;; module definition (note that include-shared uses no suffix). + +;; The goal of this interface is to make access to C types and +;; functions easy, without requiring the user to write any C code. +;; That means the stubber needs to be intelligent about various C +;; calling conventions and idioms, such as return values passed in +;; actual parameters. Writing C by hand is still possible, and +;; several of the core modules provide C interfaces directly without +;; using the stubber. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Struct Interface +;; +;; (define-c-struct struct-name +;; [predicate: predicate-name] +;; [constructor: constructor-name] +;; [finalizer: c_finalizer_name] +;; (type c_field_name getter-name setter-name) ...) +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Function Interface +;; +;; (define-c return-type name-spec (arg-type ...)) +;; +;; where name-space is either a symbol name, or a list of +;; (scheme-name c_name). If just a symbol, the C name is taken +;; to be the same with -'s replaced by _'s. +;; +;; arg-type is a type suitable for input validation and conversion. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Types +;; +;; Types +;; +;; Basic Types +;; void +;; boolean +;; char +;; sexp (no conversions) +;; +;; Integer Types: +;; signed-char short int long +;; unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t +;; time_t (in seconds, but using the chibi epoch of 2010/01/01) +;; errno (as a return type returns #f on error) +;; +;; Float Types: +;; float double long-double +;; +;; String Types: +;; string - a null-terminated char* +;; env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme +;; in addition you can use (array char) as a string +;; +;; Port Types: +;; input-port output-port +;; port-or-fd - an fd-backed port or a fixnum +;; +;; Struct Types: +;; +;; Struct types are by default just referred to by the bare +;; struct-name from define-c-struct, and it is assumed you want a +;; pointer to that type. To refer to the full struct, use the struct +;; modifier, as in (struct struct-name). + +;; Type modifiers +;; +;; Any type may also be written as a list of modifiers followed by the +;; type itself. The supported modifiers are: +;; +;; const: prepends the "const" C type modifier +;; * as a return or result parameter, makes non-immediates immutable +;; +;; free: it's Scheme's responsibility to "free" this resource +;; * as a return or result parameter, registers the freep flag +;; this causes the type finalizer to be run when GCed +;; +;; maybe-null: this pointer type may be NULL +;; * as a result parameter, NULL is translated to #f +;; normally this would just return a wrapped NULL pointer +;; * as an input parameter, #f is translated to NULL +;; normally this would be a type error +;; +;; pointer: create a pointer to this type +;; * as a return parameter, wraps the result in a vanilla cpointer +;; * as a result parameter, boxes then unboxes the value +;; +;; struct: treat this struct type as a struct, not a pointer +;; * as an input parameter, dereferences the pointer +;; * as a type field, indicates a nested struct +;; +;; link: add a gc link +;; * as a field getter, link to the parent object, so the +;; parent won't be GCed so long as we have a reference +;; to the child. this behavior is automatic for nested +;; structs. +;; +;; result: return a result in this parameter +;; * if there are multiple results (including the return type), +;; they are all returned in a list +;; * if there are any result parameters, a return type +;; of errno returns #f on failure, and as eliminated +;; from the list of results otherwise +;; +;; (value ): specify a fixed value +;; * as an input parameter, this parameter is not provided +;; in the Scheme API but always passed as +;; +;; (default ): specify a default value +;; * as the final input parameter, makes the Scheme parameter +;; optional, defaulting to +;; +;; (array []) an array type +;; * length must be specified for return and result parameters +;; * if specified, length can be any of +;; ** an integer, for a fixed size +;; ** the symbol null, indicating a NULL-terminated array + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; globals + +(define *types* '()) +(define *funcs* '()) +(define *consts* '()) +(define *inits* '()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type objects + +(define (parse-type type . o) + (cond + ((vector? type) + type) + (else + (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) + (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f) + (value #f) (default? #f)) + (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) + (case (and (pair? type) (car type)) + ((free) + (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) + ((const) + (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) + ((maybe-null) + (lp (next) free? const? #t ptr? struct? link? result? array value default?)) + ((pointer) + (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) + ((struct) + (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) + ((link) + (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) + ((result) + (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) + ((array) + (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) + ((value) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) + ((default) + (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) + (else + (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) + +(define (type-base type) (vector-ref type 0)) +(define (type-free? type) (vector-ref type 1)) +(define (type-const? type) (vector-ref type 2)) +(define (type-null? type) (vector-ref type 3)) +(define (type-pointer? type) (vector-ref type 4)) +(define (type-struct? type) (vector-ref type 5)) +(define (type-link? type) (vector-ref type 6)) +(define (type-result? type) (vector-ref type 7)) +(define (type-array type) (vector-ref type 8)) +(define (type-value type) (vector-ref type 9)) +(define (type-default? type) (vector-ref type 10)) +(define (type-index type) (vector-ref type 11)) + +(define (type-auto-expand? type) + (and (pair? (type-array type)) + (memq 'auto-expand (type-array type)))) + +(define (type-index-string type) + (if (integer? (type-index type)) + (number->string (type-index type)) + "")) + +(define (struct-fields ls) + (let lp ((ls ls) (res '())) + (cond ((null? ls) (reverse res)) + ((symbol? (car ls)) (lp (cddr ls) res)) + (else (lp (cdr ls) (cons (car ls) res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; type predicates + +(define (signed-int-type? type) + (memq type '(signed-char short int long boolean))) + +(define (unsigned-int-type? type) + (memq type '(unsigned-char unsigned-short unsigned unsigned-int unsigned-long + size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t + uid_t gid_t pid_t blksize_t blkcnt_t sigval_t))) + +(define (int-type? type) + (or (signed-int-type? type) (unsigned-int-type? type))) + +(define (float-type? type) + (memq type '(float double long-double long-long-double))) + +(define (string-type? type) + (or (memq type '(char* string env-string non-null-string)) + (and (vector? type) + (type-array type) + (not (type-pointer? type)) + (eq? 'char (type-base type))))) + +(define (port-type? type) + (memq type '(port input-port output-port))) + +(define (error-type? type) + (memq type '(errno non-null-string non-null-pointer))) + +(define (array-type? type) + (and (type-array type) (not (eq? 'char (type-base type))))) + +(define (basic-type? type) + (let ((type (parse-type type))) + (and (not (type-array type)) + (not (void-pointer-type? type)) + (not (assq (type-base type) *types*))))) + +(define (void-pointer-type? type) + (or (and (eq? 'void (type-base type)) (type-pointer? type)) + (eq? 'void* (type-base type)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; function objects + +(define (parse-func func) + (if (not (and (= 3 (length func)) + (or (identifier? (cadr func)) (list (cadr func))) + (list (caddr func)))) + (error "bad function definition" func)) + (let* ((ret-type (parse-type (car func))) + (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) + (c-name (if (pair? (cadr func)) + (cadadr func) + (mangle scheme-name))) + (stub-name (if (and (pair? (cadr func)) (pair? (cddadr func))) + (car (cddadr func)) + (generate-stub-name scheme-name)))) + (let lp ((ls (caddr func)) + (i 0) + (results '()) + (c-args '()) + (s-args '())) + (cond + ((null? ls) + (vector scheme-name c-name stub-name ret-type + (reverse results) (reverse c-args) (reverse s-args))) + (else + (let ((type (parse-type (car ls) i))) + (cond + ((type-result? type) + (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) + ((and (type-value type) (not (type-default? type))) + (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) + (else + (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) + ))))))) + +(define (func-scheme-name func) (vector-ref func 0)) +(define (func-c-name func) (vector-ref func 1)) +(define (func-stub-name func) (vector-ref func 2)) +(define (func-ret-type func) (vector-ref func 3)) +(define (func-results func) (vector-ref func 4)) +(define (func-c-args func) (vector-ref func 5)) +(define (func-scheme-args func) (vector-ref func 6)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utilities + +(define (cat . args) + (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "non-stringable object" x)))) + +(define (filter pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (cons (car ls) (filter pred (cdr ls)))) + (else (filter pred (cdr ls))))) + +(define (remove pred ls) + (cond ((null? ls) '()) + ((pred (car ls)) (filter pred (cdr ls))) + (else (cons (car ls) (filter pred (cdr ls)))))) + +(define (strip-extension path) + (let lp ((i (- (string-length path) 1))) + (cond ((<= i 0) path) + ((eq? #\. (string-ref path i)) (substring path 0 i)) + (else (lp (- i 1)))))) + +(define (string-concatenate-reverse ls) + (cond ((null? ls) "") + ((null? (cdr ls)) (car ls)) + (else (string-concatenate (reverse ls))))) + +(define (string-replace str c r) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) + (else (lp from (+ i 1) res)))))) + +(define (string-scan c str . o) + (let ((limit (string-length str))) + (let lp ((i (if (pair? o) (car o) 0))) + (cond ((>= i limit) #f) + ((eqv? c (string-ref str i)) i) + (else (lp (+ i 1))))))) + +(define (string-downcase str) + (list->string (map char-downcase (string->list str)))) + +(define (with-output-to-string thunk) + (call-with-output-string + (lambda (out) + (let ((old-out (current-output-port))) + (current-output-port out) + (thunk) + (current-output-port old-out))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; naming + +(define (c-char? c) + (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) + +(define (c-escape str) + (let ((len (string-length str))) + (let lp ((from 0) (i 0) (res '())) + (define (collect) (if (= i from) res (cons (substring str from i) res))) + (cond + ((>= i len) (string-concatenate-reverse (collect))) + ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) + (else (lp from (+ i 1) res)))))) + +(define (mangle x) + (string-replace + (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") + #\! "_x")) + +(define (generate-stub-name sym) + (string-append "sexp_" (mangle sym) "_stub")) + +(define (type-id-name sym) + (string-append "sexp_" (mangle sym) "_type_id")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; .stub file interface + +(define (c-declare . args) + (apply cat args) + (newline)) + +(define (c-include header) + (cat "\n#include \"" header "\"\n")) + +(define (c-system-include header) + (cat "\n#include <" header ">\n")) + +(define (c-init x) + (set! *inits* (cons x *inits*))) + +(define (parse-struct-like ls) + (let lp ((ls ls) (res '())) + (cond + ((null? ls) + (reverse res)) + ((symbol? (car ls)) + (lp (cddr ls) (cons (cadr ls) (cons (car ls) res)))) + ((pair? (car ls)) + (lp (cdr ls) (cons (cons (parse-type (caar ls)) (cdar ls)) res))) + (else + (lp (cdr ls) (cons (car ls) res)))))) + +(define-syntax define-struct-like + (er-macro-transformer + (lambda (expr rename compare) + (set! *types* + `((,(cadr expr) + ,@(parse-struct-like (cddr expr))) + ,@*types*)) + `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n")))) + +(define-syntax define-c-struct + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr))))) + +(define-syntax define-c-class + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) + +(define-syntax define-c-union + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) type: union ,@(cddr expr))))) + +(define-syntax define-c-type + (er-macro-transformer + (lambda (expr rename compare) + `(define-struct-like ,(cadr expr) ,@(cddr expr))))) + +(define-syntax define-c + (er-macro-transformer + (lambda (expr rename compare) + (set! *funcs* (cons (parse-func (cdr expr)) *funcs*)) + #f))) + +(define-syntax define-c-const + (er-macro-transformer + (lambda (expr rename compare) + (let ((type (parse-type (cadr expr)))) + (for-each (lambda (x) (set! *consts* (cons (list type x) *consts*))) + (cddr expr)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; C code generation + +(define (c->scheme-converter type val . o) + (let ((base (type-base type))) + (cond + ((and (eq? base 'void) (not (type-pointer? type))) + (cat "((" val "), SEXP_VOID)")) + ((or (eq? base 'sexp) (error-type? base)) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_make_boolean(" val ")")) + ((eq? base 'time_t) + (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) + ((unsigned-int-type? base) + (cat "sexp_make_unsigned_integer(ctx, " val ")")) + ((signed-int-type? base) + (cat "sexp_make_integer(ctx, " val ")")) + ((eq? base 'char) + (if (type-array type) + (cat "sexp_c_string(ctx, " val ", -1)") + (cat "sexp_make_character(ctx, " val ")"))) + ((eq? 'env-string base) + (cat "(p=strchr(" val ", '=') ? " + "sexp_cons(ctx, str=sexp_c_string(ctx, " val ", p - " val "), str=sexp_c_string(ctx, p, -1))" + " : sexp_cons(ctx, str=" val ", SEXP_FALSE)")) + ((string-type? base) + (cat "sexp_c_string(ctx, " val ", -1)")) + ((eq? 'input-port base) + (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)")) + ((eq? 'output-port base) + (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) + (else + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) + (cond + ((or ctype void*?) + (cat "sexp_make_cpointer(ctx, " + (if void*? "SEXP_CPOINTER" (type-id-name base)) ", " + val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " + (if (or (type-free? type) + (and (type-result? type) (not (basic-type? type)))) + 1 + 0) + ")")) + (else + (error "unknown type" base)))))))) + +(define (scheme->c-converter type val) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'sexp) + (cat val)) + ((eq? base 'boolean) + (cat "sexp_truep(" val ")")) + ((eq? base 'time_t) + (cat "sexp_unshift_epoch(sexp_uint_value(" val "))")) + ((signed-int-type? base) + (cat "sexp_sint_value(" val ")")) + ((unsigned-int-type? base) + (cat "sexp_uint_value(" val ")")) + ((eq? base 'char) + (cat "sexp_unbox_character(" val ")")) + ((eq? base 'env-string) + (cat "sexp_concat_env_string(" val ")")) + ((string-type? base) + (cat "sexp_string_data(" val ")")) + ((eq? base 'port-or-fd) + (cat "(sexp_portp(" val ") ? fileno(sexp_port_stream(" val "))" + " : sexp_unbox_fixnum(" val "))")) + ((port-type? base) + (cat "sexp_port_stream(" val ")")) + (else + (let ((ctype (assq base *types*)) + (void*? (void-pointer-type? type))) + (cond + ((or ctype void*?) + (cat "(" (type-c-name type) ")" + (if (type-null? type) + "sexp_cpointer_maybe_null_value" + "sexp_cpointer_value") + "(" val ")")) + (else + (error "unknown type" base)))))))) + +(define (type-predicate type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "sexp_exact_integerp") + ((float-type? base) "sexp_flonump") + ((string-type? base) "sexp_stringp") + ((eq? base 'char) "sexp_charp") + ((eq? base 'boolean) "sexp_booleanp") + ((eq? base 'port) "sexp_portp") + ((eq? base 'input-port) "sexp_iportp") + ((eq? base 'output-port) "sexp_oportp") + (else #f)))) + +(define (type-name type) + (let ((base (type-base (parse-type type)))) + (cond + ((int-type? base) "integer") + ((float-type? base) "flonum") + ((eq? 'boolean base) "int") + (else base)))) + +(define (base-type-c-name base) + (case base + ((string env-string non-null-string) "char*") + (else (symbol->string base)))) + +(define (type-struct-type type) + (let ((type-spec (assq (if (vector? type) (type-base type) type) *types*))) + (cond ((and type-spec (memq 'type: type-spec)) => cadr) + (else #f)))) + +(define (type-c-name type) + (let* ((type (parse-type type)) + (base (type-base type)) + (type-spec (assq base *types*)) + (struct-type (type-struct-type type))) + (string-append + (if (type-const? type) "const " "") + (if struct-type (string-append (symbol->string struct-type) " ") "") + (string-replace (base-type-c-name base) #\- " ") + (if struct-type "*" "") + (if (type-pointer? type) "*" "")))) + +(define (check-type arg type) + (let* ((type (parse-type type)) + (base (type-base type))) + (cond + ((eq? base 'env-string) + (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg + ")) && sexp_stringp(sexp_cdr(" arg ")))")) + ((or (int-type? base) (float-type? base) + (string-type? base) (port-type? base)) + (cat (type-predicate type) "(" arg ")")) + ((or (assq base *types*) (void-pointer-type? type)) + (cat + (if (type-null? type) "(" "") + "(sexp_pointerp(" arg ")" + " && (sexp_pointer_tag(" arg ") == " + (if (void-pointer-type? type) "SEXP_CPOINTER" (type-id-name base)) "))" + (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) + (else + (display "WARNING: don't know how to check: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)) + (cat "1"))))) + +(define (type-id-number type) + (let ((base (type-base type))) + (cond + ((int-type? base) "SEXP_FIXNUM") + ((float-type? base) "SEXP_FLONUM") + ((string-type? base) "SEXP_STRING") + ((eq? base 'char) "SEXP_CHAR") + ((eq? base 'boolean) "SEXP_BOOLEAN") + ((eq? base 'port) "SEXP_IPORT") + ((eq? base 'input-port) "SEXP_IPORT") + ((eq? base 'output-port) "SEXP_OPORT") + ((void-pointer-type? type) "SEXP_CPOINTER") + (else (type-id-name base))))) + +(define (write-validator arg type) + (let* ((type (parse-type type)) + (array (type-array type)) + (base-type (type-base type))) + (cond + ((and array (not (string-type? type))) + (cond + ((number? array) + (cat " if (!sexp_listp(ctx, " arg ")" + " || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n" + " return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n"))) + (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" + " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" + " return sexp_xtype_exception(ctx, self, \"not a list of " + (type-name type) "s\", " arg ");\n") + (if (not (number? array)) + (cat " if (! sexp_nullp(res))\n" + " return sexp_xtype_exception(ctx, self, \"not a list of " + (type-name type) "s\", " arg ");\n"))) + ((eq? base-type 'port-or-fd) + (cat " if (! (sexp_portp(" arg ") || sexp_fixnump(" arg ")))\n" + " return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n")) + ((or (int-type? base-type) + (float-type? base-type) + (string-type? base-type) + (port-type? base-type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) + ((or (assq base-type *types*) (void-pointer-type? type)) + (cat + " if (! " (lambda () (check-type arg type)) ")\n" + " return sexp_type_exception(ctx, self, " + (type-id-number type) ", " arg ");\n")) + ((eq? 'sexp base-type)) + ((string-type? type) + (write-validator arg 'string)) + (else + (display "WARNING: don't know how to validate: " (current-error-port)) + (write type (current-error-port)) + (newline (current-error-port)))))) + +(define (write-parameters args) + (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) + +(define (get-array-length func x) + (let ((len (if (pair? (type-array x)) + (car (reverse (type-array x))) + (type-array x)))) + (if (number? len) + len + (and (symbol? len) + (let* ((str (symbol->string len)) + (len2 (string-length str))) + (and (> len2 3) + (string=? "arg" (substring str 0 3)) + (let ((i (string->number (substring str 3 len2)))) + (if i + (let ((y (list-ref (func-c-args func) i))) + (or (type-value y) len)))))))))) + +(define (write-locals func) + (define (arg-res x) + (string-append "res" (type-index-string x))) + (let* ((ret-type (func-ret-type func)) + (results (func-results func)) + (scheme-args (func-scheme-args func)) + (return-res? (not (error-type? (type-base ret-type)))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons ret-type results))) + (gc-vars (map arg-res results)) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (sexps (if preserve-res? '() '("res"))) + (num-gc-vars (length gc-vars)) + (ints (if (or return-res? + (memq (type-base ret-type) + '(non-null-string non-null-pointer))) + '() + '("err"))) + (ints (if (or (array-type? ret-type) + (any array-type? results) + (any array-type? scheme-args)) + (cons "i" ints) + ints))) + (case (type-base ret-type) + ((non-null-string) (cat " char *err;\n")) + ((non-null-pointer) (cat " void *err;\n"))) + (cond + ((pair? ints) + (cat " int " (car ints)) + (for-each (lambda (x) (display ", ") (display x)) (cdr ints)) + (cat ";\n"))) + (if (any (lambda (a) (eq? 'env-string (type-base a))) + (cons ret-type results)) + (cat " char *p;\n")) + (for-each + (lambda (x) + (let ((len (get-array-length func x))) + (cat " " (type-c-name (type-base x)) " ") + (if (or (and (type-array x) (not (number? len))) (type-pointer? x)) + (cat "*")) + (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) + (if (number? len) + (cat "[" len "]")) + (cat ";\n") + (if (or (vector? len) (type-auto-expand? x)) + (cat " int len" (type-index x) ";\n")) + (if (type-auto-expand? x) + (cat " " (type-c-name (type-base x)) + " *tmp" (type-index-string x) ";\n")))) + (append (if (or (type-array ret-type) (type-pointer? ret-type)) + (list ret-type) + '()) + results + (remove type-result? (filter type-array scheme-args)))) + (for-each + (lambda (arg) + (cond + ((and (type-pointer? arg) (basic-type? arg)) + (cat " " (type-c-name (type-base arg)) + " tmp" (type-index arg) ";\n")))) + scheme-args) + (cond + ((pair? sexps) + (cat " sexp " (car sexps)) + (for-each (lambda (x) (display ", ") (display x)) (cdr sexps)) + (cat ";\n"))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_var" num-gc-vars "(") + (display (car gc-vars)) + (for-each (lambda (x) (display ", ") (display x)) (cdr gc-vars)) + (cat ");\n") + (cat " sexp_gc_preserve" num-gc-vars "(ctx") + (for-each (lambda (x) (display ", ") (display x)) gc-vars) + (cat ");\n"))))) + +(define (write-validators args) + (for-each + (lambda (a) + (write-validator (string-append "arg" (type-index-string a)) a)) + args)) + +(define (write-temporaries func) + (for-each + (lambda (a) + (let ((len (and (type-array a) (get-array-length func a)))) + (cond + ((and (type-array a) (or (vector? len) (type-auto-expand? a))) + (cat " len" (type-index a) " = " + (lambda () + (if (number? len) (cat len) (scheme->c-converter 'int len))) + ";\n" + " tmp" (type-index a) " = buf" (type-index a) ";\n"))) + (cond + ((and (not (type-result? a)) (type-array a) (not (string-type? a))) + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) + " = (" (type-c-name (type-base a)) "*) malloc(" + "(sexp_unbox_fixnum(sexp_length(ctx, arg" (type-index a) + "))+1) * sizeof(tmp" (type-index a) "[0]));\n")) + (cat " for (i=0, res=arg" (type-index a) + "; sexp_pairp(res); res=sexp_cdr(res), i++) {\n" + " tmp" (type-index a) "[i] = " + (lambda () (scheme->c-converter (type-base a) "sexp_car(res)")) + ";\n" + " }\n") + (if (not (number? (type-array a))) + (cat " tmp" (type-index a) "[i] = NULL;\n"))) + ((and (type-result? a) (not (basic-type? a)) + (not (type-free? a)) ;;(not (type-pointer? a)) + (not (type-auto-expand? a)) + (or (not (type-array a)) + (not (integer? len)))) + (cat " tmp" (type-index a) " = malloc(" + (if (and (symbol? len) (not (eq? len 'null))) + (lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len)) + "*sizeof(tmp" (type-index a) "[0])")) + (lambda () (cat "sizeof(tmp" (type-index a) "[0])"))) + ");\n")) + ((and (type-pointer? a) (basic-type? a)) + (cat " tmp" (type-index a) " = " + (lambda () + (scheme->c-converter + a + (string-append "arg" (type-index-string a)))) + ";\n"))))) + (func-c-args func))) + +(define (write-actual-parameter func arg) + (cond + ((and (not (type-default? arg)) (type-value arg)) + => (lambda (x) + (cond + ((any (lambda (y) + (and (type-array y) + (type-auto-expand? y) + (eq? x (get-array-length func y)))) + (func-c-args func)) + => (lambda (y) (cat "len" (type-index y)))) + (else (write x))))) + ((or (type-result? arg) (type-array arg)) + (cat (if (or (type-free? arg) (basic-type? arg)) ;; (type-pointer? arg) + "&" + "") + "tmp" (type-index arg))) + ((and (type-pointer? arg) (basic-type? arg)) + (cat "&tmp" (type-index arg))) + (else + (scheme->c-converter + arg + (string-append "arg" (type-index-string arg)))))) + +(define (write-call func) + (let ((ret-type (func-ret-type func)) + (c-name (func-c-name func)) + (c-args (func-c-args func))) + (if (any type-auto-expand? (func-c-args func)) + (cat " loop:\n")) + (cat (cond ((error-type? (type-base ret-type)) " err = ") + ((type-array ret-type) " tmp = ") + (else " res = "))) + ((if (type-array ret-type) + (lambda (t f x) (f)) + c->scheme-converter) + ret-type + (lambda () + (cat c-name "(") + (for-each + (lambda (arg) + (if (> (type-index arg) 0) (cat ", ")) + (write-actual-parameter func arg)) + c-args) + (cat ")")) + (cond + ((any type-link? (func-c-args func)) + => (lambda (a) (string-append "arg" (type-index-string a)))) + (else #f))) + (cat ";\n") + (if (type-array ret-type) + (write-result ret-type)))) + +(define (write-result result) + (let ((res (string-append "res" (type-index-string result))) + (tmp (string-append "tmp" (type-index-string result)))) + (cond + ((and (type-array result) (eq? 'char (type-base result))) + (cat " " res " = " (lambda () (c->scheme-converter result tmp)) ";\n")) + ((type-array result) + (cat " " res " = SEXP_NULL;\n") + (let ((auto-expand? + (and (pair? (type-array result)) + (memq 'auto-expand (type-array result)))) + (len (if (pair? (type-array result)) + (car (reverse (type-array result))) + (type-array result)))) + (cond + ((eq? 'null len) + (cat " for (i=0; " tmp "[i]; i++) {\n" + " sexp_push(ctx, " res ", " + (if (eq? 'string (type-base result)) + "str=" + (lambda () (cat "SEXP_VOID);\n sexp_car(" res ") = "))) + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ");\n" + " }\n" + " " res " = sexp_nreverse(ctx, " res ");\n")) + (else + (cat " for (i=" len "-1; i>=0; i--) {\n" + " sexp_push(ctx, " res ", SEXP_VOID);\n" + " sexp_car(" res ") = " + (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) + ";\n" + " }\n"))))) + (else + (cat " " res " = ") + (c->scheme-converter + result + (string-append "tmp" (type-index-string result))) + (cat ";\n"))))) + +(define (write-results func) + (let ((error-res? (error-type? (type-base (func-ret-type func)))) + (results (func-results func))) + (if error-res? + (cat " if (" + (if (memq (type-base (func-ret-type func)) + '(non-null-string non-null-pointer)) + "!" + "") + "err) {\n" + (cond + ((any type-auto-expand? (func-c-args func)) + => (lambda (a) + (lambda () + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")) + (cat " len" i " *= 2;\n" + " tmp" i + " = malloc(len" i "*sizeof(tmp" i "[0]));\n" + " goto loop;\n"))))) + (else + " res = SEXP_FALSE;\n")) + " } else {\n")) + (if (null? results) + (if error-res? + (cat " res = SEXP_TRUE;\n")) + (for-each write-result results)) + (cond + ((> (length results) (if error-res? 1 0)) + (if error-res? + (cat " res = SEXP_NULL;\n") + (cat " res = sexp_cons(ctx, res, SEXP_NULL);\n")) + (for-each + (lambda (x) + (if error-res? + (cat " sexp_push(ctx, res, res" (type-index x) ");\n") + (cat " sexp_push(ctx, res, sexp_car(res));\n" + " sexp_cadr(res) = res" (type-index x) ";\n"))) + (reverse results))) + ((pair? results) + (cat " res = res" (type-index (car results)) ";\n"))) + (if error-res? + (cat " }\n")))) + +(define (write-free type) + (if (type-array type) + (cat " free(tmp" (type-index-string type) ");\n"))) + +(define (write-cleanup func) + (for-each write-free (func-scheme-args func)) + (for-each + (lambda (a) + (cond + ((type-auto-expand? a) + (let ((len (get-array-length func a)) + (i (type-index a))) + (if (number? len) + (cat " if (len" i " != " len ")\n" + " free(tmp" i ");\n")))) + ((and (type-result? a) (not (basic-type? a)) + (not (assq (type-base a) *types*)) + (not (type-free? a)) (not (type-pointer? a)) + (or (not (type-array a)) + (not (integer? (get-array-length func a))))) + ;; the above is hairy - basically this frees temporary strings + (cat " free(tmp" (type-index a) ");\n")))) + (func-c-args func)) + (let* ((results (func-results func)) + (return-res? (not (error-type? (type-base (func-ret-type func))))) + (preserve-res? (> (+ (length results)) (if return-res? 0 1))) + (single-res? (and (= 1 (length results)) (not return-res?))) + (tmp-string? (any (lambda (a) + (and (type-array a) + (string-type? (type-base a)))) + (cons (func-ret-type func) + (func-results func)))) + (gc-vars results) + (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) + (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) + (num-gc-vars (length gc-vars))) + (cond + ((pair? gc-vars) + (cat " sexp_gc_release" num-gc-vars "(ctx);\n"))))) + +(define (write-func func) + (cat "static sexp " (func-stub-name func) + " (sexp ctx sexp_api_params(self, n)" + (write-parameters (func-scheme-args func)) ") {\n") + (write-locals func) + (write-validators (func-scheme-args func)) + (write-temporaries func) + (write-call func) + (write-results func) + (write-cleanup func) + (cat " return res;\n" + "}\n\n")) + +(define (parameter-default? x) + (and (pair? x) + (member x '((current-input-port) + (current-output-port) + (current-error-port))))) + +(define (write-default x) ;; this is a hack but very convenient + (lambda () + (let ((value (type-value x))) + (cond + ((equal? value '(current-input-port)) + (cat "\"*current-input-port*\"")) + ((equal? value '(current-output-port)) + (cat "\"*current-output-port*\"")) + ((equal? value '(current-error-port)) + (cat "\"*current-error-port*\"")) + (else + (c->scheme-converter x value)))))) + +(define (write-func-binding func) + (let ((default (and (pair? (func-scheme-args func)) + (type-default? (car (reverse (func-scheme-args func)))) + (car (reverse (func-scheme-args func)))))) + (cat (if default + (if (parameter-default? (type-value default)) + " sexp_define_foreign_param(ctx, env, " + " sexp_define_foreign_opt(ctx, env, ") + " sexp_define_foreign(ctx, env, ") + (lambda () (write (symbol->string (func-scheme-name func)))) + ", " (length (func-scheme-args func)) ", " + (if default "(sexp_proc1)" "") + (func-stub-name func) + (if default ", " "") + (if default (write-default default) "") + ");\n"))) + +(define (write-type type) + (let ((name (car type)) + (type (cdr type))) + (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" + " " (type-id-name name) + " = sexp_unbox_fixnum(sexp_type_tag(sexp_register_c_type(ctx, name, " + (cond ((memq 'finalizer: type) + => (lambda (x) (generate-stub-name (cadr x)))) + (else "sexp_finalize_c_type")) + ")));\n") + (cond + ((memq 'predicate: type) + => (lambda (x) + (let ((pred (cadr x))) + (cat " tmp = sexp_make_type_predicate(ctx, name, " + "sexp_make_fixnum(" (type-id-name name) "));\n" + " name = sexp_intern(ctx, \"" pred "\", " + (string-length (x->string pred)) ");\n" + " sexp_env_define(ctx, env, name, tmp);\n"))))))) + +(define (type-getter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_get_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-getter type name field) + (cat "static sexp " (type-getter-name type name field) + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" + (lambda () (write-validator "x" name)) + " return " + (lambda () + (c->scheme-converter + (car field) + (string-append (if (type-struct? (car field)) "&" "") + "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" + "sexp_cpointer_value(x))" "->" + (x->string (cadr field))) + (and (or (type-struct? (car field)) (type-link? (car field))) "x"))) + ";\n" + "}\n\n")) + +(define (type-setter-name type name field) + (string-append "sexp_" (x->string (type-name (parse-type name))) + "_set_" (x->string (type-base (parse-type (cadr field)))))) + +(define (write-type-setter-assignment type name field dst val) + (cond + ((type-struct? (car field)) + ;; assign to a nested struct - copy field-by-field + (let ((field-type + (cond ((assq (type-name (car field)) *types*) => cdddr) + (else (cdr field))))) + (lambda () + (for-each + (lambda (subfield) + (let ((subname (x->string (cadr subfield)))) + (cat + " " + (string-append dst "." (x->string (cadr subfield))) + " = " + (string-append + "((" (x->string (or (type-struct-type (type-name (car field))) "")) + " " (mangle (type-name (car field))) "*)" "sexp_cpointer_value(" val "))" + "->" (x->string (cadr subfield))) + ";\n"))) + (struct-fields field-type))))) + (else + (lambda () + (cat " " dst " = " (lambda () (scheme->c-converter (car field) val)) ";\n"))))) + +(define (write-type-setter type name field) + (cat "static sexp " (type-setter-name type name field) + " (sexp ctx sexp_api_params(self, n), sexp x, sexp v) {\n" + (lambda () (write-validator "x" name)) + (lambda () (write-validator "v" (car field))) + (write-type-setter-assignment + type name field + (string-append "((" (x->string (or (type-struct-type name) "")) + " " (mangle name) "*)" "sexp_cpointer_value(x))" + "->" (x->string (cadr field))) + "v") + " return SEXP_VOID;\n" + "}\n\n")) + +(define (write-type-funcs orig-type) + (let ((name (car orig-type)) + (type (cdr orig-type))) + ;; maybe write finalizer + (cond + ((memq 'finalizer: type) + => (lambda (x) + (cat "static sexp " (generate-stub-name (cadr x)) + " (sexp ctx sexp_api_params(self, n), sexp x) {\n" + " if (sexp_cpointer_freep(x))\n" + " " (cadr x) "(sexp_cpointer_value(x));\n" + " return SEXP_VOID;\n" + "}\n\n")))) + ;; maybe write constructor + (cond + ((memq 'constructor: type) + => (lambda (x) + (let ((make (caadr x)) + (args (cdadr x))) + (cat "static sexp " (generate-stub-name make) + " (sexp ctx sexp_api_params(self, n)" + (lambda () + (let lp ((ls args) (i 0)) + (cond ((pair? ls) + (cat ", sexp arg" i) + (lp (cdr ls) (+ i 1)))))) + ") {\n" + " " (or (type-struct-type name) "") " " (type-name name) " *r;\n" + " sexp_gc_var1(res);\n" + " sexp_gc_preserve1(ctx, res);\n" + ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " + ;; (type-id-name name) + ;; ");\n" + ;; " r = sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" + " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), " + (type-id-name name) + ");\n" + " r = sexp_cpointer_value(res) = malloc(sizeof(" + (or (type-struct-type name) "") " " (type-name name) "));\n" + " sexp_freep(res) = 1;\n" + (lambda () + (let lp ((ls args) (i 0)) + (cond + ((pair? ls) + (let* ((a (car ls)) + (field + (any (lambda (f) (and (pair? f) (eq? a (cadr f)))) + (cddr x)))) + (if field + (cat " r->" (cadr field) " = " + (lambda () + (scheme->c-converter + (car field) + (string-append "arg" + (number->string i)))) + ";\n")) + (lp (cdr ls) (+ i 1))))))) + " sexp_gc_release1(ctx);\n" + " return res;\n" + "}\n\n") + (set! *funcs* + (cons (parse-func `(void ,make ,args)) *funcs*)))))) + ;; write field accessors + (for-each + (lambda (field) + (cond + ((and (pair? field) (pair? (cdr field))) + (cond + ((and (pair? (cddr field)) (caddr field)) + (write-type-getter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(caddr field) + #f + ,(type-getter-name type name field)) + (,name))) + *funcs*)))) + (cond + ((and (pair? (cddr field)) + (pair? (cdddr field)) + (car (cdddr field))) + (write-type-setter type name field) + (set! *funcs* + (cons (parse-func + `(,(car field) + (,(car (cdddr field)) + #f + ,(type-setter-name type name field)) + (,name ,(car field)))) + *funcs*))))))) + (struct-fields type)))) + +(define (write-const const) + (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) + (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) + (cat " name = sexp_intern(ctx, \"" scheme-name "\", " + (string-length (x->string scheme-name)) ");\n" + " sexp_env_define(ctx, env, name, tmp=" + (lambda () (c->scheme-converter (car const) c-name)) ");\n"))) + +(define (write-utilities) + (define (input-env-string? x) + (and (eq? 'env-string (type-base x)) (not (type-result? x)))) + (cond + ((any (lambda (f) + (or (any input-env-string? (func-results f)) + (any input-env-string? (func-scheme-args f)))) + *funcs*) + (cat "static char* sexp_concat_env_string (sexp x) {\n" + " int klen=sexp_string_length(sexp_car(x)), vlen=sexp_string_length(sexp_cdr(x));\n" + " char *res = (char*) malloc(klen+vlen+2);\n" + " strncpy(res, sexp_string_data(sexp_car(x)), klen);\n" + " res[sexp_string_length(sexp_car(x))] = '=';\n" + " strncpy(res+sexp_string_length(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n" + " res[len-1] = '\\0';\n" + " return res;\n" + "}\n\n")))) + +(define (write-init) + (newline) + (write-utilities) + (for-each write-func *funcs*) + (for-each write-type-funcs *types*) + (cat "sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {\n" + " sexp_gc_var2(name, tmp);\n" + " sexp_gc_preserve2(ctx, name, tmp);\n") + (for-each write-const *consts*) + (for-each write-type *types*) + (for-each write-func-binding *funcs*) + (for-each (lambda (x) (cat " " x "\n")) (reverse *inits*)) + (cat " sexp_gc_release2(ctx);\n" + " return SEXP_VOID;\n" + "}\n\n")) + +(define (generate file) + (display "/* automatically generated by chibi genstubs */\n") + (c-system-include "chibi/eval.h") + (load file) + (write-init)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main + +(define (main args) + (case (length args) + ((1) + (with-output-to-file (string-append (strip-extension (car args)) ".c") + (lambda () (generate (car args))))) + ((2) + (if (equal? "-" (cadr args)) + (generate (car args)) + (with-output-to-file (cadr args) (lambda () (generate (car args)))))) + (else + (error "usage: genstubs []")))) diff --git a/vm.c b/vm.c new file mode 100644 index 00000000..c89f5271 --- /dev/null +++ b/vm.c @@ -0,0 +1,1394 @@ +/* vm.c -- stack-based virtual machine backend */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#if SEXP_USE_DEBUG_VM > 1 +static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { + int i; + if (! sexp_oportp(out)) out = sexp_current_error_port(ctx); + for (i=0; i4; i=sexp_unbox_fixnum(stack[i+3])) { + self = stack[i+2]; + if (sexp_procedurep(self)) { + sexp_write_string(ctx, " called from ", out); + bc = sexp_procedure_code(self); + if (sexp_truep(sexp_bytecode_name(bc))) + sexp_write(ctx, sexp_bytecode_name(bc), out); + else + sexp_write_string(ctx, "", out); + if ((ls=sexp_bytecode_source(bc)) && sexp_pairp(ls)) { + if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(ls), out); + } + if (sexp_stringp(sexp_car(ls))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out); + } + } + sexp_write_char(ctx, '\n', out); + } + } +} + +/************************* code generation ****************************/ + +static void emit_word (sexp ctx, sexp_uint_t val) { + unsigned char *data; + expand_bcode(ctx, sizeof(sexp)); + data = sexp_bytecode_data(sexp_context_bc(ctx)); + sexp_context_align_pos(ctx); + *((sexp_uint_t*)(&(data[sexp_context_pos(ctx)]))) = val; + sexp_context_pos(ctx) += sizeof(sexp); +} + +static void emit_push (sexp ctx, sexp obj) { + emit(ctx, SEXP_OP_PUSH); + emit_word(ctx, (sexp_uint_t)obj); + if (sexp_pointerp(obj) && ! sexp_symbolp(obj)) + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); +} + +static void emit_enter (sexp ctx) {return;} +static void bless_bytecode (sexp ctx, sexp bc) {return;} + +static void emit_return (sexp ctx) { + emit(ctx, SEXP_OP_RET); +} + +static sexp_sint_t sexp_context_make_label (sexp ctx) { + sexp_sint_t label; + sexp_context_align_pos(ctx); + 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 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, SEXP_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, SEXP_OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, SEXP_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, SEXP_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, SEXP_OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, SEXP_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) + ? SEXP_OP_GLOBAL_REF : SEXP_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, SEXP_OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, SEXP_OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, SEXP_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, inv_default=0; + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); + + num_args = sexp_unbox_fixnum(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_data(op) + && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { + if (sexp_opcode_inverse(op)) { + inv_default = 1; + } else { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + } + + /* push the arguments onto the stack in reverse order */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC)) + ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the default for inverse opcodes */ + if (inv_default) { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case SEXP_OPC_ARITHMETIC: + /* fold variadic arithmetic operators */ + for (i=num_args-1; i>0; i--) + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + emit(ctx, SEXP_OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_FOREIGN: + emit(ctx, sexp_opcode_code(op)); + emit_word(ctx, (sexp_uint_t)op); + break; + case SEXP_OPC_TYPE_PREDICATE: + case SEXP_OPC_GETTER: + case SEXP_OPC_SETTER: + case SEXP_OPC_CONSTRUCTOR: + emit(ctx, sexp_opcode_code(op)); + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE) { + if (sexp_opcode_data(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); + if (sexp_opcode_data2(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + } + break; + case SEXP_OPC_PARAMETER: + emit_push(ctx, sexp_opcode_data(op)); + emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + sexp_context_depth(ctx) -= (num_args-1); + sexp_gc_release1(ctx); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, 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 ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); + + sexp_context_tailp(ctx) = tailp; + sexp_context_depth(ctx) -= len; + sexp_gc_release1(ctx); +} + +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_var2(tmp, bc); + sexp_gc_preserve2(ctx, tmp, 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_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); + 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, SEXP_OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, SEXP_OP_CONS); + emit(ctx2, SEXP_OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, SEXP_OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_fixnum((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); + sexp_bytecode_source(bc) = sexp_lambda_source(lambda); + if (sexp_nullp(fv)) { + /* shortcut, no free vars */ + tmp = sexp_make_vector(ctx2, SEXP_ZERO, 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, SEXP_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_fixnum(k)); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_VECTOR_SET); + emit(ctx, SEXP_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, SEXP_OP_MAKE_PROCEDURE); + } + sexp_gc_release2(ctx); +} + +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 make_param_list (sexp ctx, sexp_uint_t i) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_fixnum(i), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ls, bc, res, env; + sexp_gc_var5(params, ref, refs, lambda, ctx2); + if (i == sexp_opcode_num_args(op)) { /* return before preserving */ + if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); + } else if (i < sexp_opcode_num_args(op)) { + return sexp_compile_error(ctx, "not enough args for opcode", op); + } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ + return sexp_compile_error(ctx, "too many args for opcode", op); + } + sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = sexp_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), sexp_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_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + sexp_gc_release5(ctx); + 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_fixnum(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= SEXP_INIT_STACK_SIZE) { + _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); + goto end_loop; + } +#endif + _ALIGN_IP(); + i = sexp_unbox_fixnum(_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_fixnum(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_fixnum(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_fixnum(i); + stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + stack[top+1] = self; + stack[top+2] = sexp_make_fixnum(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 SEXP_OP_FCALL0: + tmp1 = _WORD0; + _ALIGN_IP(); + sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = fp; + _PUSH(((sexp_proc1)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 0))); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL1: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 1), _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL2: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 2), _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL3: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG3 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 3), _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case SEXP_OP_FCALL4: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + _ARG4 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx sexp_api_pass(_WORD0, 4), _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; +#if SEXP_USE_EXTENDED_FCALL + case SEXP_OP_FCALLN: + _ALIGN_IP(); + sexp_context_top(ctx) = top; + i = sexp_opcode_num_args(_WORD0); + tmp1 = sexp_fcall(ctx, self, i, _WORD0); + top -= (i-1); + _ARG1 = tmp1; + ip += sizeof(sexp); + sexp_check_exception(); + break; +#endif + case SEXP_OP_JUMP_UNLESS: + _ALIGN_IP(); + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case SEXP_OP_JUMP: + _ALIGN_IP(); + ip += _SWORD0; + break; + case SEXP_OP_PUSH: + _ALIGN_IP(); + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case SEXP_OP_DROP: + top--; + break; + case SEXP_OP_GLOBAL_REF: + _ALIGN_IP(); + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case SEXP_OP_GLOBAL_KNOWN_REF: + _ALIGN_IP(); + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_STACK_REF: /* `pick' in forth */ + _ALIGN_IP(); + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_REF: + _ALIGN_IP(); + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case SEXP_OP_LOCAL_SET: + _ALIGN_IP(); + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case SEXP_OP_CLOSURE_REF: + _ALIGN_IP(); + _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_WORD0))); + ip += sizeof(sexp); + break; + case SEXP_OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_VECTOR_LENGTH: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1)); + break; + case SEXP_OP_BYTES_REF: + case SEXP_OP_STRING_REF: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-ref: not a string", sexp_list1(ctx, _ARG1)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + if (ip[-1] == SEXP_OP_BYTES_REF) + _ARG2 = sexp_bytes_ref(_ARG1, _ARG2); + else +#if SEXP_USE_UTF8_STRINGS + _ARG2 = sexp_string_utf8_ref(ctx, _ARG1, _ARG2); +#else + _ARG2 = sexp_string_ref(_ARG1, _ARG2); +#endif + top--; + break; + case SEXP_OP_BYTES_SET: + case SEXP_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)); + else if (! sexp_fixnump(_ARG2)) + sexp_raise("string-set!: not an integer", sexp_list1(ctx, _ARG2)); + else if (! sexp_charp(_ARG3)) + sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); + i = sexp_unbox_fixnum(_ARG2); + if ((i < 0) || (i >= sexp_string_length(_ARG1))) + sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); + if (ip[-1] == SEXP_OP_BYTES_SET) + sexp_bytes_set(_ARG1, _ARG2, _ARG3); + else +#if SEXP_USE_UTF8_STRINGS + sexp_string_utf8_set(ctx, _ARG1, _ARG2, _ARG3); +#else + sexp_string_set(_ARG1, _ARG2, _ARG3); +#endif + _ARG3 = SEXP_VOID; + top-=2; + break; + case SEXP_OP_BYTES_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("bytes-length: not a byte-vector", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_bytes_length(_ARG1)); + break; + case SEXP_OP_STRING_LENGTH: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_UTF8_STRINGS + _ARG1 = sexp_make_fixnum(sexp_string_utf8_length((unsigned char*)sexp_string_data(_ARG1), sexp_string_length(_ARG1))); +#else + _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1)); +#endif + break; + case SEXP_OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; + _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case SEXP_OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; + if (! sexp_fixnump(_ARG1)) + sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1)); + _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_MAKE_EXCEPTION: + _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + break; + case SEXP_OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case SEXP_OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case SEXP_OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case SEXP_OP_FIXNUMP: + _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break; + case SEXP_OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case SEXP_OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case SEXP_OP_TYPEP: + _ALIGN_IP(); + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); + ip += sizeof(sexp); + break; + case SEXP_OP_MAKE: + _ALIGN_IP(); + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_REF: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); + ip += sizeof(sexp)*2; + break; + case SEXP_OP_SLOT_SET: + _ALIGN_IP(); + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); + sexp_slot_set(_ARG1, _UWORD1, _ARG2); + _ARG2 = SEXP_VOID; + ip += sizeof(sexp)*2; + top--; + break; + case SEXP_OP_ISA: + _ARG2 = sexp_make_boolean(sexp_isa(_ARG1, _ARG2)); + top--; + break; + case SEXP_OP_SLOTN_REF: + if (! sexp_typep(_ARG1)) + sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + else if (! sexp_isa(_ARG2, _ARG1)) + sexp_raise("slot-ref: bad type", sexp_list1(ctx, _ARG2)); + else if (! sexp_fixnump(_ARG3)) + sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + _ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3)); + top-=2; + break; + case SEXP_OP_SLOTN_SET: + if (! sexp_typep(_ARG1)) + sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + else if (! sexp_isa(_ARG2, _ARG1)) + sexp_raise("slot-set!: bad type", sexp_list1(ctx, _ARG2)); + else if (sexp_immutablep(_ARG2)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG2)); + else if (! sexp_fixnump(_ARG3)) + sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4); + _ARG4 = SEXP_VOID; + top-=3; + break; + case SEXP_OP_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case SEXP_OP_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case SEXP_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 SEXP_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 SEXP_OP_CONS: + sexp_context_top(ctx) = top; + _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); + top--; + break; + case SEXP_OP_ADD: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(j); + } + else { + _ARG1 = sexp_add(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_add(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_add(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) + (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) + sexp_flonum_value(tmp2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_SUB: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2); + if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(j); + } + else { + _ARG1 = sexp_sub(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_sub(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_sub(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) - (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) - sexp_flonum_value(tmp2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_MUL: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + prod = (sexp_lsint_t)sexp_unbox_fixnum(tmp1) * sexp_unbox_fixnum(tmp2); + if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) + _ARG1 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2); + else + _ARG1 = sexp_make_fixnum(prod); + } + else { + _ARG1 = sexp_mul(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_fx_mul(tmp1, tmp2); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_mul(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) * (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) * sexp_flonum_value(tmp2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_DIV: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (tmp2 == SEXP_ZERO) { +#if SEXP_USE_FLONUMS + if (sexp_flonump(tmp1) && sexp_flonum_value(tmp1) == 0.0) + _ARG1 = sexp_make_flonum(ctx, 0.0); + else +#endif + sexp_raise("divide by zero", SEXP_NULL); + } else if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { +#if SEXP_USE_FLONUMS + tmp1 = sexp_fixnum_to_flonum(ctx, tmp1); + tmp2 = sexp_fixnum_to_flonum(ctx, tmp2); + _ARG1 = sexp_fp_div(ctx, tmp1, tmp2); + if (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1))) + _ARG1 = sexp_make_fixnum(sexp_flonum_value(_ARG1)); +#else + _ARG1 = sexp_fx_div(tmp1, tmp2); +#endif + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_div(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else +#if SEXP_USE_FLONUMS + else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_fp_div(ctx, tmp1, tmp2); + else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) / (double)sexp_unbox_fixnum(tmp2)); + else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) + _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) / sexp_flonum_value(tmp2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, tmp1, tmp2)); +#endif + break; + case SEXP_OP_QUOTIENT: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + if (tmp2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG1 = sexp_fx_div(tmp1, tmp2); + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_quotient(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, tmp2)); +#endif + break; + case SEXP_OP_REMAINDER: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + if (tmp2 == SEXP_ZERO) + sexp_raise("divide by zero", SEXP_NULL); + _ARG1 = sexp_fx_rem(tmp1, tmp2); + } +#if SEXP_USE_BIGNUMS + else { + _ARG1 = sexp_remainder(ctx, tmp1, tmp2); + sexp_check_exception(); + } +#else + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, tmp2)); +#endif + break; + case SEXP_OP_LT: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = (sexp_sint_t)tmp1 < (sexp_sint_t)tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) < 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) < sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) < sexp_flonum_value(tmp2); +#endif + } else sexp_raise("<: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_LE: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = (sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) <= 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) <= sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) <= (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) <= sexp_flonum_value(tmp2); +#endif + } else sexp_raise("<=: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_EQN: + tmp1 = _ARG1, tmp2 = _ARG2; + sexp_context_top(ctx) = --top; + if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) { + i = tmp1 == tmp2; +#if SEXP_USE_BIGNUMS + _ARG1 = sexp_make_boolean(i); + } else { + _ARG1 = sexp_compare(ctx, tmp1, tmp2); + sexp_check_exception(); + _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) == 0); + } +#else +#if SEXP_USE_FLONUMS + } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { + i = sexp_flonum_value(tmp1) == sexp_flonum_value(tmp2); + } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { + i = sexp_flonum_value(tmp1) == (double)sexp_unbox_fixnum(tmp2); + } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { + i = (double)sexp_unbox_fixnum(tmp1) == sexp_flonum_value(tmp2); +#endif + } else sexp_raise("=: not a number", sexp_list2(ctx, tmp1, tmp2)); + _ARG1 = sexp_make_boolean(i); +#endif + break; + case SEXP_OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case SEXP_OP_FIX2FLO: + if (sexp_fixnump(_ARG1)) + _ARG1 = sexp_fixnum_to_flonum(ctx, _ARG1); +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, sexp_bignum_to_double(_ARG1)); +#endif + else if (! sexp_flonump(_ARG1)) + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case SEXP_OP_FLO2FIX: + if (sexp_flonump(_ARG1)) { + if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { + sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); +#if SEXP_USE_BIGNUMS + } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { + _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); +#endif + } else { + _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); + } + } else if (! sexp_fixnump(_ARG1) && ! sexp_bignump(_ARG1)) { + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + } + break; + case SEXP_OP_CHAR2INT: + if (! sexp_charp(_ARG1)) + sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1)); + break; + case SEXP_OP_INT2CHAR: + if (! sexp_fixnump(_ARG1)) + sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1)); + break; + case SEXP_OP_CHAR_UPCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_CHAR_DOWNCASE: + if (! sexp_charp(_ARG1)) + sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case SEXP_OP_WRITE_CHAR: + if (! sexp_charp(_ARG1)) + sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); + if (! sexp_oportp(_ARG2)) + sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2)); +#if SEXP_USE_UTF8_STRINGS + if (sexp_unbox_character(_ARG1) >= 0x80) + sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + else +#endif + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case SEXP_OP_NEWLINE: + if (! sexp_oportp(_ARG1)) + sexp_raise("newline: not an output-port", sexp_list1(ctx, _ARG1)); + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case SEXP_OP_READ_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); +#if SEXP_USE_UTF8_STRINGS + if (i >= 0x80) + _ARG1 = sexp_read_utf8_char(ctx, _ARG1, i); + else +#endif + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_PEEK_CHAR: + if (! sexp_iportp(_ARG1)) + sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1)); + i = sexp_read_char(ctx, _ARG1); + sexp_push_char(ctx, i, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case SEXP_OP_YIELD: + fuel = 0; + _PUSH(SEXP_VOID); + break; + case SEXP_OP_RET: + i = sexp_unbox_fixnum(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_fixnum(stack[fp+1]); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_fixnum(stack[fp+3]); + break; + case SEXP_OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1)))); + } + goto loop; + + end_loop: +#if SEXP_USE_GREEN_THREADS + if (ctx != root_thread) { + if (sexp_context_refuel(root_thread) <= 0) { + /* the root already terminated */ + _ARG1 = SEXP_VOID; + } else { + /* don't return from child threads */ + sexp_context_refuel(ctx) = fuel = 0; + goto loop; + } + } +#endif + sexp_gc_release3(ctx); + sexp_context_top(ctx) = top; + return _ARG1; +} + +/******************************* apply ********************************/ + +sexp sexp_apply1 (sexp ctx, sexp f, sexp x) { + sexp res; + sexp_gc_var1(args); + if (sexp_opcodep(f)) { + res = ((sexp_proc2)sexp_opcode_func(f))(ctx sexp_api_pass(f, 1), x); + } else { + sexp_gc_preserve1(ctx, args); + res = sexp_apply(ctx, f, args=sexp_list1(ctx, x)); + sexp_gc_release1(ctx); + } + return res; +} + +sexp sexp_apply (sexp ctx, sexp proc, sexp args) { + sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); + sexp_sint_t top = sexp_context_top(ctx), len, offset; + len = sexp_unbox_fixnum(sexp_length(ctx, args)); + if (sexp_opcodep(proc)) + proc = make_opcode_procedure(ctx, proc, len); + if (! sexp_procedurep(proc)) { + res = sexp_exceptionp(proc) ? proc : + sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); + } else { + offset = top + len; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) + stack[--offset] = sexp_car(ls); + stack[top++] = sexp_make_fixnum(len); + stack[top++] = SEXP_ZERO; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + stack[top++] = SEXP_ZERO; + sexp_context_top(ctx) = top; + res = sexp_vm(ctx, proc); + if (! res) res = SEXP_VOID; /* shouldn't happen */ + } + return res; +} From 3acae168fc0bcd93da8af209ade0b0c3413a84fd Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 17 Aug 2010 21:06:45 +0900 Subject: [PATCH 515/535] committing incomplete changes for merge (stupid hg) --- include/chibi/sexp.h | 3 +++ lib/srfi/18/threads.c | 14 ++++++++++++-- vm.c | 26 ++++++++++++++++++++++++-- 3 files changed, 39 insertions(+), 4 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 7484d9c6..5213446f 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -22,6 +22,7 @@ extern "C" { #endif #if SEXP_USE_GREEN_THREADS #include +#include #endif #endif @@ -887,6 +888,8 @@ enum sexp_context_globals { SEXP_G_THREADS_LOCAL, SEXP_G_THREADS_SIGNALS, SEXP_G_THREADS_SIGNAL_RUNNER, + SEXP_G_THREADS_POLL_FDS, + SEXP_G_THREADS_BLOCKER, #endif SEXP_G_NUM_GLOBALS }; diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index b84d59f4..88da3307 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -275,6 +275,10 @@ static sexp sexp_get_signal_handler (sexp ctx sexp_api_params(self, n), sexp sig return sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); } +static sexp sexp_blocker (sexp ctx sexp_api_params(self, n), sexp port) { + return SEXP_VOID; +} + sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { struct timeval tval; sexp res, ls1, ls2, runner, paused, front; @@ -284,7 +288,7 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { front = sexp_global(ctx, SEXP_G_THREADS_FRONT); paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); - /* check for signals */ + /* check signals */ if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) { runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER); if (! sexp_contextp(runner)) { /* ensure the runner exists */ @@ -302,6 +306,10 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { } } + /* check blocked fds */ + /* if () { */ + /* } */ + /* if we've terminated, check threads joining us */ if (sexp_context_refuel(ctx) <= 0) { for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { @@ -411,7 +419,9 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "get-signal-handler", 1, sexp_get_signal_handler); sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) - = sexp_make_foreign(ctx, "scheduler", 0, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); + = sexp_make_foreign(ctx, "scheduler", 1, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); + sexp_global(ctx, SEXP_G_THREADS_BLOCKER) + = sexp_make_foreign(ctx, "blocker", 1, 0, (sexp_proc1)sexp_blocker, SEXP_FALSE); /* remember the env to lookup the runner later */ sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env; diff --git a/vm.c b/vm.c index acbea8b2..f14a9650 100644 --- a/vm.c +++ b/vm.c @@ -1303,14 +1303,36 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG1 = sexp_read_utf8_char(ctx, _ARG1, i); else #endif - _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + if (i == EOF) { +#if SEXP_USE_GREEN_THREADS + if ((errno == EAGAIN) + && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { + sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1); + fuel = 0; + ip--; /* try again */ + } else +#endif + _ARG1 = SEXP_EOF; + } else + _ARG1 = sexp_make_character(i); break; case SEXP_OP_PEEK_CHAR: if (! sexp_iportp(_ARG1)) sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1)); i = sexp_read_char(ctx, _ARG1); sexp_push_char(ctx, i, _ARG1); - _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + if (i == EOF) { +#if SEXP_USE_GREEN_THREADS + if ((errno == EAGAIN) + && sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER))) { + sexp_apply1(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1); + fuel = 0; + ip--; /* try again */ + } else +#endif + _ARG1 = SEXP_EOF; + } else + _ARG1 = sexp_make_character(i); break; case SEXP_OP_YIELD: fuel = 0; From 0bfb97851b95cd6a15ad798959f1b7b07dc95c24 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 26 Aug 2010 01:37:53 +0900 Subject: [PATCH 516/535] returning thread on thread-start! --- lib/srfi/18/threads.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index 88da3307..eb6e98d3 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -80,7 +80,7 @@ sexp sexp_thread_start (sexp ctx sexp_api_params(self, n), sexp thread) { } else { /* init queue */ sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT) = cell; } - return SEXP_VOID; + return thread; } sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) { From 148528ecab25ccceb54da7cd395ba19d352a0ce8 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 26 Aug 2010 20:47:53 +0900 Subject: [PATCH 517/535] was updating sexp_context_timeout for wrong context in sexp_insert_timed --- lib/srfi/18/threads.c | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index eb6e98d3..ba8ca316 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -97,22 +97,22 @@ static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { #endif sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); if (sexp_integerp(timeout) || sexp_flonump(timeout)) - gettimeofday(&sexp_context_timeval(ctx), NULL); + gettimeofday(&sexp_context_timeval(thread), NULL); if (sexp_integerp(timeout)) { - sexp_context_timeval(ctx).tv_sec += sexp_unbox_fixnum(timeout); + sexp_context_timeval(thread).tv_sec += sexp_unbox_fixnum(timeout); #if SEXP_USE_FLONUMS } else if (sexp_flonump(timeout)) { d = sexp_flonum_value(timeout); - sexp_context_timeval(ctx).tv_sec += trunc(d); - sexp_context_timeval(ctx).tv_usec += (d-trunc(d))*1000000; + sexp_context_timeval(thread).tv_sec += trunc(d); + sexp_context_timeval(thread).tv_usec += (d-trunc(d))*1000000; #endif } else { - sexp_context_timeval(ctx).tv_sec = 0; - sexp_context_timeval(ctx).tv_usec = 0; + sexp_context_timeval(thread).tv_sec = 0; + sexp_context_timeval(thread).tv_usec = 0; } if (sexp_numberp(timeout)) while (sexp_pairp(ls2) - && sexp_context_before(sexp_car(ls2), sexp_context_timeval(ctx))) + && sexp_context_before(sexp_car(ls2), sexp_context_timeval(thread))) ls1=ls2, ls2=sexp_cdr(ls2); else while (sexp_pairp(ls2) && sexp_context_timeval(sexp_car(ls2)).tv_sec) From 280d0dc7b38713455648bb082c9d5ebc7fb7b2be Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 26 Aug 2010 21:18:00 +0900 Subject: [PATCH 518/535] removing threads from paused list before re-queueing them --- lib/srfi/18/threads.c | 30 ++++++++++++++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index ba8ca316..ed0b6131 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -91,11 +91,26 @@ sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) { return res; } +static int sexp_delete_list (sexp ctx, int global, sexp x) { + sexp ls1=NULL, ls2=sexp_global(ctx, global); + for ( ; sexp_pairp(ls2) && sexp_car(ls2) != x; ls1=ls2, ls2=sexp_cdr(ls2)) + ; + if (sexp_pairp(ls2)) { + if (ls1) sexp_cdr(ls1) = sexp_cdr(ls2); + else sexp_global(ctx, global) = sexp_cdr(ls2); + return 1; + } else { + return 0; + } +} + static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { #if SEXP_USE_FLONUMS double d; #endif - sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED); + sexp ls1=SEXP_NULL, ls2; + sexp_delete_list(ctx, SEXP_G_THREADS_PAUSED, thread); + ls2 = sexp_global(ctx, SEXP_G_THREADS_PAUSED); if (sexp_integerp(timeout) || sexp_flonump(timeout)) gettimeofday(&sexp_context_timeval(thread), NULL); if (sexp_integerp(timeout)) { @@ -106,11 +121,14 @@ static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { sexp_context_timeval(thread).tv_sec += trunc(d); sexp_context_timeval(thread).tv_usec += (d-trunc(d))*1000000; #endif + } else if (sexp_contextp(timeout)) { + sexp_context_timeval(thread).tv_sec = sexp_context_timeval(timeout).tv_sec; + sexp_context_timeval(thread).tv_usec = sexp_context_timeval(timeout).tv_usec; } else { sexp_context_timeval(thread).tv_sec = 0; sexp_context_timeval(thread).tv_usec = 0; } - if (sexp_numberp(timeout)) + if (sexp_numberp(timeout) || sexp_contextp(timeout)) while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), sexp_context_timeval(thread))) ls1=ls2, ls2=sexp_cdr(ls2); @@ -386,6 +404,14 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { if (sexp_context_waitp(res)) { /* the only thread available was waiting */ + if (sexp_pairp(paused) + && sexp_context_before(sexp_car(paused), sexp_context_timeval(res))) { + tmp = res; + res = sexp_car(paused); + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(paused); + if (sexp_not(sexp_memq(ctx, tmp, paused))) + sexp_insert_timed(ctx, tmp, tmp); + } sexp_wait_on_single_thread(res); sexp_context_timeoutp(res) = 1; sexp_context_waitp(res) = 0; From c712c0823f011294dd9f044550ff8fffcb43590b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 27 Aug 2010 08:54:49 +0900 Subject: [PATCH 519/535] fixing usec calculation in sexp_wait_on_single_thread --- lib/srfi/18/threads.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index ed0b6131..99390353 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -262,6 +262,8 @@ void sexp_wait_on_single_thread (sexp ctx) { usecs = (sexp_context_timeval(ctx).tv_sec - tval.tv_sec) * 1000000; if (tval.tv_usec < sexp_context_timeval(ctx).tv_usec) usecs += sexp_context_timeval(ctx).tv_usec - tval.tv_usec; + else if (usecs > 0) + usecs -= tval.tv_usec - sexp_context_timeval(ctx).tv_usec; usleep(usecs); } From 9894e491f6872b19b0ee4bd48f0d3b8b849f7105 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 31 Aug 2010 23:59:21 +0900 Subject: [PATCH 520/535] updating srfi-27 to expect a type (not a tag) returned from register-type --- lib/srfi/27/rand.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index 6e971df8..2d47a87f 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -34,7 +34,7 @@ typedef struct random_data sexp_random_t; #define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp)) -static sexp_uint_t rs_type_id; +static sexp_uint_t rs_type_id = 0; static sexp default_random_source; static sexp sexp_rs_random_integer (sexp ctx sexp_api_params(self, n), sexp rs, sexp bound) { @@ -124,6 +124,7 @@ static sexp sexp_make_random_source (sexp ctx sexp_api_params(self, n)) { sexp_gc_preserve1(ctx, state); state = sexp_make_string(ctx, STATE_SIZE, SEXP_UNDEF); res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id); + if (sexp_exceptionp(res)) return res; sexp_random_state(res) = state; sexp_random_init(res, 1); sexp_gc_release1(ctx); @@ -171,12 +172,13 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_gc_preserve2(ctx, name, op); name = sexp_c_string(ctx, "random-source", -1); - rs_type_id - = sexp_unbox_fixnum(sexp_register_type(ctx, name, - sexp_make_fixnum(sexp_offsetof_slot0), - ONE, ONE, ZERO, ZERO, - sexp_make_fixnum(sexp_sizeof_random), - ZERO, ZERO, NULL)); + op = sexp_register_type(ctx, name, sexp_make_fixnum(sexp_offsetof_slot0), + ONE, ONE, ZERO, ZERO, + sexp_make_fixnum(sexp_sizeof_random), + ZERO, ZERO, NULL); + if (sexp_exceptionp(op)) + return op; + rs_type_id = sexp_type_tag(op); name = sexp_c_string(ctx, "random-source?", -1); op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(rs_type_id)); From 6c38c5d858800cce11ae08ea839a265686691732 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 4 Sep 2010 12:26:15 +0900 Subject: [PATCH 521/535] adding initial support for weak references --- Makefile | 2 +- gc.c | 47 +++++++++++++++++++++++ include/chibi/features.h | 7 ++++ include/chibi/sexp.h | 23 ++++++++++-- lib/chibi/weak.c | 49 ++++++++++++++++++++++++ lib/chibi/weak.module | 7 ++++ lib/srfi/27/rand.c | 2 +- sexp.c | 81 +++++++++++++++++++++------------------- 8 files changed, 174 insertions(+), 44 deletions(-) create mode 100644 lib/chibi/weak.c create mode 100644 lib/chibi/weak.module diff --git a/Makefile b/Makefile index 131a73d2..3840909e 100644 --- a/Makefile +++ b/Makefile @@ -108,7 +108,7 @@ COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \ lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/net$(SO) \ lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \ lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \ - lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) + lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) libs: $(COMPILED_LIBS) diff --git a/gc.c b/gc.c index af7b3986..62365a13 100644 --- a/gc.c +++ b/gc.c @@ -96,6 +96,50 @@ int stack_references_pointer_p (sexp ctx, sexp x) { #define stack_references_pointer_p(ctx, x) 0 #endif +#if SEXP_USE_WEAK_REFERENCES +void sexp_reset_weak_references(sexp ctx) { + int i, len, all_reset_p; + sexp_heap h = sexp_context_heap(ctx); + sexp p, t, end, *v; + sexp_free_list q, r; + for ( ; h; h=h->next) { /* just scan the whole heap */ + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); + q = h->free_list; + end = (sexp) ((char*)h->data + h->size - sexp_heap_align(sexp_sizeof(pair))); + while (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) { /* this is a free block, skip it */ + p = (sexp) (((char*)p) + r->size); + continue; + } + if (sexp_gc_mark(p)) { + t = sexp_object_type(ctx, p); + if (sexp_type_weak_base(t) > 0) { + all_reset_p = 1; + v = (sexp*) ((char*)p + sexp_type_weak_base(t)); + len = sexp_type_num_weak_slots_of_object(t, p); + for (i=0; iflags) #define sexp_immutablep(x) ((x)->immutablep) #define sexp_freep(x) ((x)->freep) +#define sexp_brokenp(x) ((x)->brokenp) #define sexp_pointer_magic(x) ((x)->magic) #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) @@ -817,6 +820,10 @@ SEXP_API struct sexp_struct *sexp_type_specs; (((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \ * sexp_type_field_len_scale(t) \ + sexp_type_field_eq_len_base(t)) +#define sexp_type_num_weak_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_weak_len_off(t)))[0] \ + * sexp_type_weak_len_scale(t) \ + + sexp_type_weak_len_base(t)) #define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) @@ -829,6 +836,11 @@ SEXP_API struct sexp_struct *sexp_type_specs; #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_weak_base(x) ((x)->value.type.weak_base) +#define sexp_type_weak_len_base(x) ((x)->value.type.weak_len_base) +#define sexp_type_weak_len_off(x) ((x)->value.type.weak_len_off) +#define sexp_type_weak_len_scale(x) ((x)->value.type.weak_len_scale) +#define sexp_type_weak_len_extra(x) ((x)->value.type.weak_len_extra) #define sexp_type_name(x) ((x)->value.type.name) #define sexp_type_finalize(x) ((x)->value.type.finalize) @@ -880,6 +892,9 @@ enum sexp_context_globals { SEXP_G_ERR_HANDLER, SEXP_G_RESUMECC_BYTECODE, SEXP_G_FINAL_RESUMER, +#if SEXP_USE_WEAK_REFERENCES + SEXP_G_WEAK_REFERENCE_CACHE, +#endif #if SEXP_USE_GREEN_THREADS SEXP_G_THREADS_SCHEDULER, SEXP_G_THREADS_FRONT, @@ -1010,14 +1025,14 @@ SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags); #endif #if SEXP_USE_TYPE_DEFS -SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots); -SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name); SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj); #define sexp_register_c_type(ctx, name, finalizer) \ sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ - SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer) + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer) #endif #define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) @@ -1054,7 +1069,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) #define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx sexp_api_pass(NULL, 1), out) #define sexp_expt(ctx, a, b) sexp_expt_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_register_simple_type(ctx, a, b) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 2), a, b) -#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j) sexp_register_type_op(ctx sexp_api_pass(NULL, 10), a, b, c, d, e, f, g, h, i, j) +#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p) sexp_register_type_op(ctx sexp_api_pass(NULL, 15), a, b, c, d, e, f, g, h, i, j, k, l, m, o, p) #define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) diff --git a/lib/chibi/weak.c b/lib/chibi/weak.c new file mode 100644 index 00000000..f2d75687 --- /dev/null +++ b/lib/chibi/weak.c @@ -0,0 +1,49 @@ +/* weak.c -- weak pointers and ephemerons */ +/* Copyright (c) 2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +static int sexp_ephemeron_id; + +#define sexp_ephemeron_key(x) sexp_slot_ref(x, 0) +#define sexp_ephemeron_value(x) sexp_slot_ref(x, 1) + +sexp sexp_make_ephemeron (sexp ctx sexp_api_params(self, n), sexp key, sexp value) { + sexp res = sexp_alloc_type(ctx, pair, sexp_ephemeron_id); + if (! sexp_exceptionp(res)) { + sexp_ephemeron_key(res) = key; + sexp_ephemeron_value(res) = value; + } + return res; +} + +sexp sexp_ephemeron_brokenp_op (sexp ctx sexp_api_params(self, n), sexp eph) { + return sexp_make_boolean(sexp_brokenp(eph)); +} + +sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp_gc_var3(name, t, op); + sexp_gc_preserve3(ctx, name, t, op); + + name = sexp_c_string(ctx, "Ephemeron", -1); + t = sexp_register_simple_type(ctx, name, SEXP_TWO); + sexp_ephemeron_id = sexp_type_tag(t); + sexp_type_field_len_base(t) = 0; + sexp_type_weak_base(t) = sexp_type_field_base(t); + sexp_type_weak_len_base(t) = 1; + sexp_type_weak_len_extra(t) = 1; + + op = sexp_make_type_predicate(ctx, name=sexp_c_string(ctx,"ephemeron?",-1), t); + sexp_env_define(ctx, env, name=sexp_intern(ctx, "ephemeron?", -1), op); + op = sexp_make_getter(ctx, name=sexp_c_string(ctx, "ephemeron-key", -1), t, SEXP_ZERO); + sexp_env_define(ctx, env, name=sexp_intern(ctx, "ephemeron-key", -1), op); + op = sexp_make_getter(ctx, name=sexp_c_string(ctx, "ephemeron-value", -1), t, SEXP_ONE); + sexp_env_define(ctx, env, name=sexp_intern(ctx, "ephemeron-value", -1), op); + sexp_define_foreign(ctx, env, "make-ephemeron", 2, sexp_make_ephemeron); + sexp_define_foreign(ctx, env, "ephemeron-broken?", 1, sexp_ephemeron_brokenp_op); + + sexp_gc_release3(ctx); + return SEXP_VOID; +} + diff --git a/lib/chibi/weak.module b/lib/chibi/weak.module new file mode 100644 index 00000000..e739bf89 --- /dev/null +++ b/lib/chibi/weak.module @@ -0,0 +1,7 @@ + +(define-module (chibi weak) + (export make-ephemeron ephemeron? ephemeron-broken? + ephemeron-key ephemeron-value + make-weak-vector weak-vector? weak-vector-length + weak-vector-ref weak-vector-set!) + (include-shared "weak")) diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index 2d47a87f..6190b811 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -175,7 +175,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { op = sexp_register_type(ctx, name, sexp_make_fixnum(sexp_offsetof_slot0), ONE, ONE, ZERO, ZERO, sexp_make_fixnum(sexp_sizeof_random), - ZERO, ZERO, NULL); + ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, NULL); if (sexp_exceptionp(op)) return op; rs_type_id = sexp_type_tag(op); diff --git a/sexp.c b/sexp.c index db4c91fe..c16a2778 100644 --- a/sexp.c +++ b/sexp.c @@ -76,47 +76,44 @@ sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port) { #define SEXP_FINALIZE_PORT NULL #endif -#define _DEF_TYPE(t,fb,felb,flb,flo,fls,sb,so,sc,n,f) {t,fb,felb,flb,flo,fls,sb,so,sc,n,f} - static struct sexp_type_struct _sexp_type_specs[] = { - _DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, "object", NULL), - _DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type", NULL), - _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, "integer", NULL), - _DEF_TYPE(SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, "number", NULL), - _DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, "char", NULL), - _DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", NULL), - _DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, "pair", NULL), - _DEF_TYPE(SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, "symbol", NULL), - _DEF_TYPE(SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, "byte-vector", NULL), + {SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "object", NULL}, + {SEXP_TYPE, 0, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, "type", NULL}, + {SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "integer", NULL}, + {SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "number", NULL}, + {SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "char", NULL}, + {SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", NULL}, + {SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, 0, 0, 0, 0, 0, "pair", NULL}, + {SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, 0, 0, 0, 0, 0, "symbol", NULL}, + {SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, 0, 0, 0, 0, 0, "byte-vector", NULL}, #if SEXP_USE_PACKED_STRINGS - _DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string", NULL), + {SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, 0, 0, 0, 0, 0, "string", NULL}, #else - _DEF_TYPE(SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, "string", NULL), + {SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, 0, 0, 0, 0, 0, "string", NULL}, #endif - _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector", NULL), - _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "real", NULL), - _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), "bignum", NULL), - _DEF_TYPE(SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL), - _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", SEXP_FINALIZE_PORT), - _DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port", SEXP_FINALIZE_PORT), - _DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception", NULL), - _DEF_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure", NULL), - _DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro", NULL), - _DEF_TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure", NULL), - _DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, "environment", NULL), - _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode", NULL), - _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form", NULL), - _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 7, 7, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode", NULL), - _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda", NULL), - _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional", NULL), - _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, "reference", NULL), - _DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, "set!", NULL), - _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, "sequence", NULL), - _DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, "literal", NULL), - _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack", NULL), - _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 12, 12, 0, 0, sexp_sizeof(context), 0, 0, "context", NULL), + {SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), 0, 0, 0, 0, 0, "vector", NULL}, + {SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, 0, 0, 0, 0, 0, "real", NULL}, + {SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), 0, 0, 0, 0, 0, "bignum", NULL}, + {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, "cpointer", NULL}, + {SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, "input-port", SEXP_FINALIZE_PORT}, + {SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, "output-port", SEXP_FINALIZE_PORT}, + {SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, "exception", NULL}, + {SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, "procedure", NULL}, + {SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, "macro", NULL}, + {SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, "syntactic-closure", NULL}, + {SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, "environment", NULL}, + {SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, "bytecode", NULL}, + {SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, "core-form", NULL}, + {SEXP_OPCODE, sexp_offsetof(opcode, data), 7, 7, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, "opcode", NULL}, + {SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, "lambda", NULL}, + {SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, "conditional", NULL}, + {SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, "reference", NULL}, + {SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, 0, 0, 0, 0, 0, "set!", NULL}, + {SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, "sequence", NULL}, + {SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, "literal", NULL}, + {SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, "stack", NULL}, + {SEXP_CONTEXT, sexp_offsetof(context, bc), 12, 12, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, "context", NULL}, }; -#undef _DEF_TYPE #if SEXP_USE_GLOBAL_TYPES struct sexp_struct *sexp_type_specs = _sexp_type_specs; @@ -133,7 +130,8 @@ static sexp_uint_t sexp_type_array_size = SEXP_NUM_CORE_TYPES; sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp fb, sexp felb, sexp flb, sexp flo, sexp fls, - sexp sb, sexp so, sexp sc, sexp_proc2 f) { + sexp sb, sexp so, sexp sc, sexp w, sexp wb, sexp wo, + sexp ws, sexp we, sexp_proc2 f) { #if SEXP_USE_GLOBAL_TYPES struct sexp_struct *new, *tmp; #else @@ -181,6 +179,11 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp_type_size_base(type) = sexp_unbox_fixnum(sb); sexp_type_size_off(type) = sexp_unbox_fixnum(so); sexp_type_size_scale(type) = sexp_unbox_fixnum(sc); + sexp_type_weak_base(type) = sexp_unbox_fixnum(w); + sexp_type_weak_len_base(type) = sexp_unbox_fixnum(wb); + sexp_type_weak_len_off(type) = sexp_unbox_fixnum(wo); + sexp_type_weak_len_scale(type) = sexp_unbox_fixnum(ws); + sexp_type_weak_len_extra(type) = sexp_unbox_fixnum(we); sexp_type_name(type) = strdup(sexp_string_data(name)); sexp_type_finalize(type) = f; res = type; @@ -198,7 +201,9 @@ sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, return sexp_register_type(ctx, name, sexp_make_fixnum(sexp_offsetof_slot0), slots, slots, SEXP_ZERO, SEXP_ZERO, - sexp_make_fixnum(type_size), SEXP_ZERO, SEXP_ZERO, NULL); + sexp_make_fixnum(type_size), SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, + NULL); } sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) { From d38c6bc3e19e231d60a665cedeae0cbb54257d15 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 5 Sep 2010 20:24:37 +0900 Subject: [PATCH 522/535] fixing SEXP_USE_CONSERVATIVE_GC, should be appropriate for general use --- gc.c | 29 +++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/gc.c b/gc.c index 62365a13..305654cb 100644 --- a/gc.c +++ b/gc.c @@ -85,6 +85,7 @@ void sexp_mark (sexp ctx, sexp x) { } #if SEXP_USE_CONSERVATIVE_GC + int stack_references_pointer_p (sexp ctx, sexp x) { sexp *p; for (p=(&x)+1; pnext) { /* just scan the whole heap */ + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); + q = h->free_list; + end = (sexp) ((char*)h->data + h->size - sexp_heap_align(sexp_sizeof(pair))); + while (p < end) { + 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; + } + if (! sexp_gc_mark(p) && stack_references_pointer_p(ctx, p)) + sexp_mark(ctx, p); + p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p))); + } + } +} + #else -#define stack_references_pointer_p(ctx, x) 0 +#define sexp_conservative_mark(ctx) #endif #if SEXP_USE_WEAK_REFERENCES @@ -160,7 +184,7 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { continue; } size = sexp_heap_align(sexp_allocated_bytes(ctx, p)); - if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + if (! sexp_gc_mark(p)) { /* free p */ finalizer = sexp_type_finalize(sexp_object_type(ctx, p)); if (finalizer) finalizer(ctx sexp_api_pass(NULL, 1), p); @@ -213,6 +237,7 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) { sexp_mark(ctx, sexp_symbol_table[i]); #endif sexp_mark(ctx, ctx); + sexp_conservative_mark(ctx); #if SEXP_USE_DEBUG_GC sexp_sweep_stats(ctx, 2, NULL, "* \x1B[31mFREE:\x1B[0m "); #endif From e474561f70211becf4f207058ff1c38462f62815 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 7 Sep 2010 11:13:17 +0000 Subject: [PATCH 523/535] fixinf identifier extraction in some `...' and `***' patterns --- lib/chibi/match/match.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm index f4eb173d..ff5b7bd6 100644 --- a/lib/chibi/match/match.scm +++ b/lib/chibi/match/match.scm @@ -28,6 +28,7 @@ ;; performance can be found at ;; http://synthcode.com/scheme/match-cond-expand.scm ;; +;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns ;; 2009/11/25 - adding `***' tree search patterns ;; 2008/03/20 - fixing bug where (a ...) matched non-lists ;; 2008/03/15 - removing redundant check in vector patterns @@ -240,6 +241,11 @@ (syntax-rules () ((_ expr ids ...) expr))) +(define-syntax match-tuck-ids + (syntax-rules () + ((_ (letish args (expr ...)) ids ...) + (letish args (expr ... ids ...))))) + (define-syntax match-drop-first-arg (syntax-rules () ((_ arg expr) expr))) @@ -316,7 +322,7 @@ (cond ((= n tail-len) (let ((id (reverse id-ls)) ...) - (match-one ls r (#f #f) (sk ... i) fk i))) + (match-one ls r (#f #f) (sk ...) fk i))) ((pair? ls) (let ((w (car ls))) (match-one w p ((car ls) (set-car! ls)) @@ -380,7 +386,7 @@ ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) (letrec ((try (lambda (w fail id-ls ...) (match-one w q g+s - (match-drop-ids + (match-tuck-ids (let ((id (reverse id-ls)) ...) sk)) (next w fail id-ls ...) i))) From e4a7224a2daffb17f1ce7d5de28ed6c8db51130d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 8 Sep 2010 13:54:52 +0000 Subject: [PATCH 524/535] initial support for non-blocking i/o --- include/chibi/sexp.h | 12 +-- lib/chibi/net.module | 3 +- lib/chibi/net.scm | 19 +++-- lib/chibi/net.stub | 1 + lib/chibi/process.module | 32 ++++++- lib/chibi/process.stub | 5 ++ lib/chibi/signal.c | 45 ++++++++++ lib/srfi/18.module | 3 +- lib/srfi/18/threads.c | 176 ++++++++++++++++++++++++++++++++++----- main.c | 21 ++++- 10 files changed, 278 insertions(+), 39 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index afa11fbc..da0597b0 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -844,9 +844,9 @@ SEXP_API struct sexp_struct *sexp_type_specs; #define sexp_type_name(x) ((x)->value.type.name) #define sexp_type_finalize(x) ((x)->value.type.finalize) -#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) +#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 ****************************/ @@ -904,6 +904,7 @@ enum sexp_context_globals { SEXP_G_THREADS_SIGNALS, SEXP_G_THREADS_SIGNAL_RUNNER, SEXP_G_THREADS_POLL_FDS, + SEXP_G_THREADS_FD_THREADS, SEXP_G_THREADS_BLOCKER, #endif SEXP_G_NUM_GLOBALS @@ -961,8 +962,9 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); #endif -#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) -#define sexp_at_eofp(p) (feof(sexp_port_stream(p))) +#define sexp_newline(ctx, p) sexp_write_char((ctx), '\n', (p)) +#define sexp_at_eofp(p) (feof(sexp_port_stream(p))) +#define sexp_port_fileno(p) (fileno(sexp_port_stream(p))) SEXP_API sexp sexp_make_context(sexp ctx, size_t size); SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); diff --git a/lib/chibi/net.module b/lib/chibi/net.module index 845a7aa8..39335033 100644 --- a/lib/chibi/net.module +++ b/lib/chibi/net.module @@ -1,6 +1,7 @@ (define-module (chibi net) - (export sockaddr? address-info? get-address-info socket connect + (export sockaddr? address-info? get-address-info + socket connect bind accept listen with-net-io open-net-io address-info-family address-info-socket-type address-info-protocol address-info-address address-info-address-length address-info-next) diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm index 5f912cb5..4235c2e4 100644 --- a/lib/chibi/net.scm +++ b/lib/chibi/net.scm @@ -15,13 +15,18 @@ (address-info-protocol addr)))) (if (negative? sock) (lp (address-info-next addr)) - (if (negative? - (connect sock - (address-info-address addr) - (address-info-address-length addr))) - (lp (address-info-next addr)) - (list (open-input-file-descriptor sock) - (open-output-file-descriptor sock)))))))) + (cond + ((negative? + (connect sock + (address-info-address addr) + (address-info-address-length addr))) + (lp (address-info-next addr))) + (else + (cond-expand + (threads (set-file-descriptor-flags! sock open/non-block)) + (else #f)) + (list (open-input-file-descriptor sock) + (open-output-file-descriptor sock))))))))) (define (with-net-io host service proc) (let ((io (open-net-io host service))) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub index 0d72bc90..5b923b28 100644 --- a/lib/chibi/net.stub +++ b/lib/chibi/net.stub @@ -23,3 +23,4 @@ (define-c int listen (int int)) (define-c int socket (int int int)) (define-c int connect (int sockaddr int)) +(define-c int accept (int sockaddr int)) diff --git a/lib/chibi/process.module b/lib/chibi/process.module index 372b56e4..b487ccef 100644 --- a/lib/chibi/process.module +++ b/lib/chibi/process.module @@ -1,6 +1,7 @@ (define-module (chibi process) (export exit sleep alarm fork kill execute waitpid + process-command-line process-running? set-signal-action! make-signal-set signal-set-contains? signal-set-fill! signal-set-add! signal-set-delete! current-signal-mask @@ -14,5 +15,34 @@ signal/tty-output) (import-immutable (scheme)) (cond-expand (threads (import (srfi 18))) (else #f)) - (include-shared "process")) + (include-shared "process") + (cond-expand + (unix + (body + (define (process-command-line pid) + (call-with-current-continuation + (lambda (return) + (with-exception-handler + (lambda (exn) (return #f)) + (lambda () + (let ((file (string-append "/proc/" (number->string pid) "/cmdline"))) + (call-with-input-file file + (lambda (in) + (let lp ((arg '()) (res '())) + (let ((ch (read-char in))) + (if (or (eof-object? ch) (eqv? (char->integer ch) 0)) + (let ((res (cons (list->string (reverse arg)) res)) + (ch2 (peek-char in))) + (if (or (eof-object? ch2) (eqv? (char->integer ch2) 0)) + (reverse res) + (lp '() res))) + (lp (cons ch arg) res)))))))))))))) + (else #f)) + (body + (define (process-running? pid . o) + (let ((cmdline (process-command-line pid))) + (and (pair? cmdline) + (or (null? o) + (not (car o)) + (equal? (car o) (car cmdline)))))))) diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub index 93b08d95..ed0db2eb 100644 --- a/lib/chibi/process.stub +++ b/lib/chibi/process.stub @@ -70,4 +70,9 @@ (define-c void exit (int)) (define-c int (execute execvp) (string (array string))) +(cond-expand + (unix) + (else + (define-c sexp (process-command-line sexp_pid_cmdline) ((value ctx sexp) int)))) + (c-init "sexp_init_signals(ctx, env);") diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c index 7202d96e..baa4ff84 100644 --- a/lib/chibi/signal.c +++ b/lib/chibi/signal.c @@ -62,6 +62,51 @@ static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newac return oldaction; } +#if SEXP_BSD + +#include +#include + +static sexp sexp_pid_cmdline (sexp ctx, int pid) { + unsigned long reslen = sizeof(struct kinfo_proc); + struct kinfo_proc res; + int name[4] = {CTL_KERN, KERN_PROC, KERN_PROC_PID, pid}; + if (sysctl(name, 4, &res, &reslen, NULL, 0) >= 0) { + return sexp_c_string(ctx, res.kp_proc.p_comm, -1); + } else { + return SEXP_FALSE; + } +} + +#else + +/* #include */ +/* #include */ + +/* #define CMDLINE_LENGTH 512 */ + +/* static sexp sexp_pid_cmdline (sexp ctx, int pid) { */ +/* struct __sysctl_args args; */ +/* char cmdline[CMDLINE_LENGTH]; */ +/* size_t cmdline_length; */ +/* int name[] = { CTL_KERN, KERN_OSTYPE }; */ + +/* memset(&args, 0, sizeof(struct __sysctl_args)); */ +/* args.name = name; */ +/* args.nlen = sizeof(name)/sizeof(name[0]); */ +/* args.oldval = cmdline; */ +/* args.oldlenp = &cmdline_length; */ +/* cmdline_length = sizeof(cmdline); */ + +/* if (syscall(SYS__sysctl, &args) == -1) { */ +/* return SEXP_FALSE; */ +/* } else { */ +/* return sexp_c_string(ctx, cmdline, -1); */ +/* } */ +/* } */ + +#endif + static void sexp_init_signals (sexp ctx, sexp env) { call_sigaction.sa_sigaction = sexp_call_sigaction; #if SEXP_USE_GREEN_THREADS diff --git a/lib/srfi/18.module b/lib/srfi/18.module index 3ed564f8..dd0fa8a3 100644 --- a/lib/srfi/18.module +++ b/lib/srfi/18.module @@ -19,6 +19,7 @@ (srfi 9) (chibi ast) (chibi time)) + (include "18/types.scm") (include-shared "18/threads") - (include "18/types.scm" "18/interface.scm")) + (include "18/interface.scm")) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index 99390353..dd5c22dd 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -6,20 +6,37 @@ #include #include #include +#include +#define sexp_mutexp(x) (sexp_check_tag(x, sexp_mutex_id)) #define sexp_mutex_name(x) sexp_slot_ref(x, 0) #define sexp_mutex_specific(x) sexp_slot_ref(x, 1) #define sexp_mutex_thread(x) sexp_slot_ref(x, 2) -#define sexp_mutex_lockp(x) sexp_slot_ref(x, 3) +#define sexp_mutex_lockp(x) sexp_slot_ref(x, 3) +#define sexp_condvarp(x) (sexp_check_tag(x, sexp_condvar_id)) #define sexp_condvar_name(x) sexp_slot_ref(x, 0) #define sexp_condvar_specific(x) sexp_slot_ref(x, 1) #define sexp_condvar_threads(x) sexp_slot_ref(x, 2) +struct sexp_pollfds_t { + struct pollfd *fds; + nfds_t nfds, mfds; +}; + +#define SEXP_INIT_POLLFDS_MAX_FDS 16 + +#define sexp_pollfdsp(x) (sexp_check_tag(x, sexp_pollfds_id)) +#define sexp_pollfds_fds(x) (((struct sexp_pollfds_t*)(&(x)->value))->fds) +#define sexp_pollfds_num_fds(x) (((struct sexp_pollfds_t*)(&(x)->value))->nfds) +#define sexp_pollfds_max_fds(x) (((struct sexp_pollfds_t*)(&(x)->value))->mfds) + +#define sexp_sizeof_pollfds (sexp_sizeof_header + sizeof(struct sexp_pollfds_t)) + #define timeval_le(a, b) (((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec < (b).tv_usec))) #define sexp_context_before(c, t) (((sexp_context_timeval(c).tv_sec != 0) || (sexp_context_timeval(c).tv_usec != 0)) && timeval_le(sexp_context_timeval(c), t)) -/* static int mutex_id, condvar_id; */ +static int sexp_mutex_id, sexp_condvar_id, sexp_pollfds_id; /**************************** threads *************************************/ @@ -165,7 +182,7 @@ sexp sexp_thread_sleep (sexp ctx sexp_api_params(self, n), sexp timeout) { /**************************** mutexes *************************************/ sexp sexp_mutex_state (sexp ctx sexp_api_params(self, n), sexp mutex) { - /* sexp_assert_type(ctx, sexp_mutexp, mutex_id, timeout); */ + sexp_assert_type(ctx, sexp_mutexp, sexp_mutex_id, mutex); if (sexp_truep(sexp_mutex_lockp(mutex))) { if (sexp_contextp(sexp_mutex_thread(mutex))) return sexp_mutex_thread(mutex); @@ -254,19 +271,6 @@ sexp sexp_condition_variable_broadcast (sexp ctx sexp_api_params(self, n), sexp /**************************** the scheduler *******************************/ -void sexp_wait_on_single_thread (sexp ctx) { - struct timeval tval; - useconds_t usecs = 0; - gettimeofday(&tval, NULL); - if (tval.tv_sec < sexp_context_timeval(ctx).tv_sec) - usecs = (sexp_context_timeval(ctx).tv_sec - tval.tv_sec) * 1000000; - if (tval.tv_usec < sexp_context_timeval(ctx).tv_usec) - usecs += sexp_context_timeval(ctx).tv_usec - tval.tv_usec; - else if (usecs > 0) - usecs -= tval.tv_usec - sexp_context_timeval(ctx).tv_usec; - usleep(usecs); -} - static const sexp_uint_t sexp_log2_lookup[32] = { 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 @@ -295,13 +299,73 @@ static sexp sexp_get_signal_handler (sexp ctx sexp_api_params(self, n), sexp sig return sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); } +static sexp sexp_make_pollfds (sexp ctx) { + sexp res = sexp_alloc_tagged(ctx, sexp_sizeof_pollfds, sexp_pollfds_id); + sexp_pollfds_fds(res) = malloc(SEXP_INIT_POLLFDS_MAX_FDS * sizeof(struct pollfd)); + sexp_pollfds_num_fds(res) = 0; + sexp_pollfds_max_fds(res) = SEXP_INIT_POLLFDS_MAX_FDS; + return res; +} + +static sexp sexp_free_pollfds (sexp ctx sexp_api_params(self, n), sexp pollfds) { + if (sexp_pollfds_fds(pollfds)) { + free(sexp_pollfds_fds(pollfds)); + sexp_pollfds_fds(pollfds) = NULL; + sexp_pollfds_num_fds(pollfds) = 0; + sexp_pollfds_max_fds(pollfds) = 0; + } + return SEXP_VOID; +} + +/* return true if this fd was already being polled */ +static sexp sexp_insert_pollfd (sexp ctx, int fd, int events) { + int i; + struct pollfd *pfd; + sexp pollfds = sexp_global(ctx, SEXP_G_THREADS_POLL_FDS); + if (! (pollfds && sexp_pollfdsp(pollfds))) { + sexp_global(ctx, SEXP_G_THREADS_POLL_FDS) = pollfds = sexp_make_pollfds(ctx); + } + for (i=0; ifd = fd; + pfd->events = events; + return SEXP_FALSE; +} + +/* block the current thread on the specified port */ static sexp sexp_blocker (sexp ctx sexp_api_params(self, n), sexp port) { + int fd; + sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port); + /* register the fd */ + fd = sexp_port_fileno(port); + if (fd >= 0) + sexp_insert_pollfd(ctx, fd, sexp_iportp(port) ? POLLIN : POLLOUT); + /* pause the current thread */ + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = port; + sexp_insert_timed(ctx, ctx, SEXP_FALSE); return SEXP_VOID; } sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { + int i, k; struct timeval tval; - sexp res, ls1, ls2, runner, paused, front; + struct pollfd *pfds; + useconds_t usecs = 0; + sexp res, ls1, ls2, runner, paused, front, pollfds; sexp_gc_var1(tmp); sexp_gc_preserve1(ctx, tmp); @@ -327,8 +391,42 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { } /* check blocked fds */ - /* if () { */ - /* } */ + pollfds = sexp_global(ctx, SEXP_G_THREADS_POLL_FDS); + if (sexp_pollfdsp(pollfds) && sexp_pollfds_num_fds(pollfds) > 0) { + pfds = sexp_pollfds_fds(pollfds); + k = poll(sexp_pollfds_fds(pollfds), sexp_pollfds_num_fds(pollfds), 0); + unblock_io_threads: + for (i=sexp_pollfds_num_fds(pollfds)-1; i>=0 && k>0; --i) { + if (pfds[i].revents > 0) { /* free all threads blocked on this fd */ + k--; + pfds[i].events = 0; /* FIXME: delete from queue completely */ + for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { + /* FIXME distinguish input and output on the same fd */ + if (sexp_portp(sexp_context_event(sexp_car(ls2))) + && sexp_port_fileno(sexp_context_event(sexp_car(ls2))) == pfds[i].fd) { + sexp_context_waitp(sexp_car(ls2)) = 0; + sexp_context_timeoutp(sexp_car(ls2)) = 0; + if (ls1==SEXP_NULL) + sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); + else + sexp_cdr(ls1) = sexp_cdr(ls2); + tmp = sexp_cdr(ls2); + sexp_cdr(ls2) = SEXP_NULL; + if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { + sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; + } else { + sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; + } + sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; + ls2 = tmp; + } else { + ls1 = ls2; + ls2 = sexp_cdr(ls2); + } + } + } + } + } /* if we've terminated, check threads joining us */ if (sexp_context_refuel(ctx) <= 0) { @@ -414,9 +512,24 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { if (sexp_not(sexp_memq(ctx, tmp, paused))) sexp_insert_timed(ctx, tmp, tmp); } - sexp_wait_on_single_thread(res); - sexp_context_timeoutp(res) = 1; - sexp_context_waitp(res) = 0; + usecs = 0; + gettimeofday(&tval, NULL); + if (tval.tv_sec < sexp_context_timeval(res).tv_sec) + usecs = (sexp_context_timeval(res).tv_sec - tval.tv_sec) * 1000000; + if (tval.tv_usec < sexp_context_timeval(res).tv_usec) + usecs += sexp_context_timeval(res).tv_usec - tval.tv_usec; + else if (usecs > 0) + usecs -= tval.tv_usec - sexp_context_timeval(res).tv_usec; + /* either wait on an fd, or just sleep */ + pollfds = sexp_global(res, SEXP_G_THREADS_POLL_FDS); + if (sexp_portp(sexp_context_event(res)) && sexp_pollfdsp(pollfds)) { + if ((k = poll(sexp_pollfds_fds(pollfds), sexp_pollfds_num_fds(pollfds), usecs/1000)) > 0) + goto unblock_io_threads; + } else { + usleep(usecs); + sexp_context_timeoutp(res) = 1; + sexp_context_waitp(res) = 0; + } } sexp_gc_release1(ctx); @@ -425,7 +538,25 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { /**************************************************************************/ +int sexp_lookup_type (sexp ctx, sexp env, const char *name) { + sexp t = sexp_env_ref(env, sexp_intern(ctx, name, -1), SEXP_FALSE); + return (sexp_typep(t)) ? sexp_type_tag(t) : -1; +} + sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { + sexp t; + sexp_gc_var1(name); + sexp_gc_preserve1(ctx, name); + + sexp_mutex_id = sexp_lookup_type(ctx, env, "mutex"); + sexp_condvar_id = sexp_lookup_type(ctx, env, "condition-variable"); + name = sexp_c_string(ctx, "pollfds", -1); + t = sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, sexp_make_fixnum(sexp_sizeof_pollfds), + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, + SEXP_ZERO, SEXP_ZERO, (sexp_proc2)sexp_free_pollfds); + if (sexp_typep(t)) + sexp_pollfds_id = sexp_type_tag(t); sexp_define_type_predicate(ctx, env, "thread?", SEXP_CONTEXT); sexp_define_foreign(ctx, env, "thread-timeout?", 0, sexp_thread_timeoutp); @@ -454,6 +585,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { /* remember the env to lookup the runner later */ sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env; + sexp_gc_release1(ctx); return SEXP_VOID; } diff --git a/main.c b/main.c index d07a9767..cbdd2bff 100644 --- a/main.c +++ b/main.c @@ -12,6 +12,10 @@ #define sexp_version_string "chibi-scheme "sexp_version" \""sexp_release_name"\" " +#if SEXP_USE_GREEN_THREADS +#include +#endif + #ifdef PLAN9 #define exit_failure() exits("ERROR") #else @@ -27,7 +31,7 @@ static void repl (sexp ctx) { sexp_env_define(ctx, sexp_context_env(ctx), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); sexp_context_tracep(ctx) = 1; - in = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE); + in = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE); out = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE); err = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE); sexp_port_sourcep(in) = 1; @@ -80,6 +84,19 @@ static sexp check_exception (sexp ctx, sexp res) { return res; } +static sexp sexp_load_standard_repl_env (sexp ctx, sexp env, sexp k) { + sexp p, res = sexp_load_standard_env(ctx, env, k); +#if SEXP_USE_GREEN_THREADS + p = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE); + if (sexp_portp(p)) fcntl(sexp_port_fileno(p), F_SETFL, O_NONBLOCK); + p = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE); + if (sexp_portp(p)) fcntl(sexp_port_fileno(p), F_SETFL, O_NONBLOCK); + p = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE); + if (sexp_portp(p)) fcntl(sexp_port_fileno(p), F_SETFL, O_NONBLOCK); +#endif + return res; +} + #define init_context() if (! ctx) do { \ ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \ env = sexp_context_env(ctx); \ @@ -88,7 +105,7 @@ static sexp check_exception (sexp ctx, sexp res) { #define load_init() if (! init_loaded++) do { \ init_context(); \ - check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \ + check_exception(ctx, sexp_load_standard_repl_env(ctx, env, SEXP_FIVE)); \ } while (0) void run_main (int argc, char **argv) { From dfa90962eb00e0beeba22261869ef730707048e0 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 12 Sep 2010 06:52:29 +0000 Subject: [PATCH 525/535] fixing timeout issue --- lib/srfi/18/threads.c | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index dd5c22dd..3a3e2b15 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -527,7 +527,6 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { goto unblock_io_threads; } else { usleep(usecs); - sexp_context_timeoutp(res) = 1; sexp_context_waitp(res) = 0; } } From 37f8c6c8b93e136565c96ca46773ba6a4fb4bcbf Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 12 Sep 2010 06:52:55 +0000 Subject: [PATCH 526/535] exporting history utils --- lib/chibi/term/edit-line.module | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/chibi/term/edit-line.module b/lib/chibi/term/edit-line.module index d8116473..279f8c75 100644 --- a/lib/chibi/term/edit-line.module +++ b/lib/chibi/term/edit-line.module @@ -1,5 +1,5 @@ (define-module (chibi term edit-line) - (export edit-line edit-line-repl) + (export edit-line edit-line-repl make-history history-insert! history-commit!) (import-immutable (scheme) (chibi stty) (srfi 9)) (include "edit-line.scm")) From bfb698fd1bcf1d99e348379f2d220b7cbc874c24 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 12 Sep 2010 06:53:41 +0000 Subject: [PATCH 527/535] keeping track of history in repl --- lib/chibi/repl.module | 3 ++- lib/chibi/repl.scm | 41 +++++++++++++++++++++++------------------ 2 files changed, 25 insertions(+), 19 deletions(-) diff --git a/lib/chibi/repl.module b/lib/chibi/repl.module index 742b9581..2bb224e5 100644 --- a/lib/chibi/repl.module +++ b/lib/chibi/repl.module @@ -5,5 +5,6 @@ (import (chibi ast) (chibi process) (chibi term edit-line) - (srfi 18)) + (srfi 18) + (srfi 38)) (include "repl.scm")) diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm index b7ff79bc..d4ae19c9 100644 --- a/lib/chibi/repl.scm +++ b/lib/chibi/repl.scm @@ -18,24 +18,29 @@ thunk (lambda () (set-signal-action! sig old-handler))))) -(define (run-repl module env) - (let ((line (edit-line (if module (string-append (symbol->string module) "> ") "> ")))) - (cond - ((or (not line) (eof-object? line))) - ((equal? line "") (run-repl module env)) - (else - (handle-exceptions exn (print-exception exn (current-error-port)) - (let* ((expr (call-with-input-string line read)) - (thread (make-thread (lambda () - (let ((res (eval expr env))) - (if (not (eq? res (if #f #f))) - (write res))))))) - (with-signal-handler - signal/interrupt - (lambda (n) (thread-terminate! thread)) - (lambda () (thread-start! thread) (thread-join! thread))))) - (newline) - (run-repl module env))))) +(define (run-repl module env . o) + (let ((history (make-history))) + (let lp ((module module) (env env)) + (let ((line (edit-line (if module (string-append (symbol->string module) "> ") "> ") + 'history: history))) + (cond + ((or (not line) (eof-object? line))) + ((equal? line "") (lp module env)) + (else + (history-commit! history line) + (handle-exceptions + exn (print-exception exn (current-error-port)) + (let* ((expr (call-with-input-string line read/ss)) + (thread (make-thread (lambda () + (let ((res (eval expr env))) + (if (not (eq? res (if #f #f))) + (write/ss res)) + (newline)))))) + (with-signal-handler + signal/interrupt + (lambda (n) (thread-terminate! thread)) + (lambda () (thread-start! thread) (thread-join! thread))))) + (lp module env))))))) (define (repl) (run-repl #f (interaction-environment))) From bb8f14941d4d539e041f166fac0547c1739cfcb5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 12 Sep 2010 06:55:11 +0000 Subject: [PATCH 528/535] ECHOPRT not defined on linux --- lib/chibi/stty.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/chibi/stty.scm b/lib/chibi/stty.scm index b4aee004..d9c07b82 100644 --- a/lib/chibi/stty.scm +++ b/lib/chibi/stty.scm @@ -111,12 +111,12 @@ ;;(echok local ,ECHOK) ; echo a newline after a kill character (echoke local ,ECHOKE) ; same as [-]crtkill (echonl local ,ECHONL) ; echo newline even if not echoing other characters - (echoprt local ,ECHOPRT) ; echo erased characters backward, between `\' and '/' + ;;(echoprt local ,ECHOPRT) ; echo erased characters backward, between `\' and '/' (icanon local ,ICANON) ; enable erase, kill, werase, and rprnt special characters ;;(iexten local ,IEXTEN) ; enable non-POSIX special characters (isig local ,ISIG) ; enable interrupt, quit, and suspend special characters (noflsh local ,NOFLSH) ; disable flushing after interrupt and quit special characters - (prterase local ,ECHOPRT) ; same as [-]echoprt + ;;(prterase local ,ECHOPRT) ; same as [-]echoprt (tostop local ,TOSTOP) ; stop background jobs that try to write to the terminal ;;(xcase local ,XCASE) ; with icanon, escape with `\' for uppercase characters From 3703e705214e27b71b816c8ca368db06415ed775 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 12 Sep 2010 20:05:13 +0900 Subject: [PATCH 529/535] fixing third arg to accept(2) --- lib/chibi/net.stub | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub index 5b923b28..f52209df 100644 --- a/lib/chibi/net.stub +++ b/lib/chibi/net.stub @@ -23,4 +23,4 @@ (define-c int listen (int int)) (define-c int socket (int int int)) (define-c int connect (int sockaddr int)) -(define-c int accept (int sockaddr int)) +(define-c int accept (int sockaddr (pointer unsigned))) From 08d065f8a22746455802aad298b4254971696079 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 12 Sep 2010 20:06:03 +0900 Subject: [PATCH 530/535] adding support for ffi calls with up to 18 parameters --- opt/fcall.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/opt/fcall.c b/opt/fcall.c index c38cc3fe..ca20f0c0 100644 --- a/opt/fcall.c +++ b/opt/fcall.c @@ -9,6 +9,8 @@ typedef sexp (*sexp_proc14) (sexp sexp_api_params(self, n), sexp, sexp, sexp, se typedef sexp (*sexp_proc15) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); typedef sexp (*sexp_proc16) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); typedef sexp (*sexp_proc17) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc18) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc19) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); #define _A(i) stack[top-i] @@ -28,6 +30,8 @@ sexp sexp_fcall (sexp ctx, sexp self, sexp_sint_t n, sexp f) { case 14: return ((sexp_proc15)sexp_opcode_func(f))(ctx, f, 14, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14)); case 15: return ((sexp_proc16)sexp_opcode_func(f))(ctx, f, 15, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15)); case 16: return ((sexp_proc17)sexp_opcode_func(f))(ctx, f, 16, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16)); + case 17: return ((sexp_proc18)sexp_opcode_func(f))(ctx, f, 17, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16), _A(17)); + case 18: return ((sexp_proc19)sexp_opcode_func(f))(ctx, f, 18, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16), _A(17), _A(18)); default: return sexp_user_exception(ctx, self, "too many FFI arguments", f); } } From 755aa0effd85babaf25e62f10e3c861625bdd073 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 12 Sep 2010 23:53:07 +0900 Subject: [PATCH 531/535] adding single inheritence for record types --- include/chibi/sexp.h | 20 +++++---- lib/chibi/weak.c | 2 +- lib/srfi/18/threads.c | 3 +- lib/srfi/27/rand.c | 3 +- lib/srfi/9.module | 86 +------------------------------------- lib/srfi/9.scm | 87 +++++++++++++++++++++++++++++++++++++++ opcodes.c | 2 +- sexp.c | 96 ++++++++++++++++++++++++++----------------- vm.c | 36 ++++++++++++---- 9 files changed, 192 insertions(+), 143 deletions(-) create mode 100644 lib/srfi/9.scm diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index da0597b0..50a484e1 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -206,7 +206,9 @@ struct sexp_type_struct { short size_base, size_off; unsigned short size_scale; short weak_base, weak_len_base, weak_len_off, weak_len_scale, weak_len_extra; + short depth; char *name; + sexp cpl, slots; sexp_proc2 finalize; }; @@ -841,7 +843,10 @@ SEXP_API struct sexp_struct *sexp_type_specs; #define sexp_type_weak_len_off(x) ((x)->value.type.weak_len_off) #define sexp_type_weak_len_scale(x) ((x)->value.type.weak_len_scale) #define sexp_type_weak_len_extra(x) ((x)->value.type.weak_len_extra) +#define sexp_type_depth(x) ((x)->value.type.depth) #define sexp_type_name(x) ((x)->value.type.name) +#define sexp_type_cpl(x) ((x)->value.type.cpl) +#define sexp_type_slots(x) ((x)->value.type.slots) #define sexp_type_finalize(x) ((x)->value.type.finalize) #define sexp_bignum_sign(x) ((x)->value.bignum.sign) @@ -1027,13 +1032,14 @@ SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags); #endif #if SEXP_USE_TYPE_DEFS -SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); -SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots); +SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp parent, sexp slots); SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj); #define sexp_register_c_type(ctx, name, finalizer) \ - sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ - SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \ - SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + sexp_make_fixnum(sexp_sizeof(cpointer)), \ + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer) #endif @@ -1070,8 +1076,8 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) #define sexp_make_input_string_port(ctx, s) sexp_make_input_string_port_op(ctx sexp_api_pass(NULL, 1), s) #define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx sexp_api_pass(NULL, 1), out) #define sexp_expt(ctx, a, b) sexp_expt_op(ctx sexp_api_pass(NULL, 2), a, b) -#define sexp_register_simple_type(ctx, a, b) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 2), a, b) -#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p) sexp_register_type_op(ctx sexp_api_pass(NULL, 15), a, b, c, d, e, f, g, h, i, j, k, l, m, o, p) +#define sexp_register_simple_type(ctx, a, b, c) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 3), a, b, c) +#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r) sexp_register_type_op(ctx sexp_api_pass(NULL, 17), a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r) #define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c) diff --git a/lib/chibi/weak.c b/lib/chibi/weak.c index f2d75687..16e74e8a 100644 --- a/lib/chibi/weak.c +++ b/lib/chibi/weak.c @@ -27,7 +27,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_gc_preserve3(ctx, name, t, op); name = sexp_c_string(ctx, "Ephemeron", -1); - t = sexp_register_simple_type(ctx, name, SEXP_TWO); + t = sexp_register_simple_type(ctx, name, SEXP_FALSE, SEXP_TWO); sexp_ephemeron_id = sexp_type_tag(t); sexp_type_field_len_base(t) = 0; sexp_type_weak_base(t) = sexp_type_field_base(t); diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index 3a3e2b15..d8f0f865 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -550,7 +550,8 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_mutex_id = sexp_lookup_type(ctx, env, "mutex"); sexp_condvar_id = sexp_lookup_type(ctx, env, "condition-variable"); name = sexp_c_string(ctx, "pollfds", -1); - t = sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, + t = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, sexp_make_fixnum(sexp_sizeof_pollfds), SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, (sexp_proc2)sexp_free_pollfds); diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index 6190b811..7efd03f9 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -172,7 +172,8 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_gc_preserve2(ctx, name, op); name = sexp_c_string(ctx, "random-source", -1); - op = sexp_register_type(ctx, name, sexp_make_fixnum(sexp_offsetof_slot0), + op = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, + sexp_make_fixnum(sexp_offsetof_slot0), ONE, ONE, ZERO, ZERO, sexp_make_fixnum(sexp_sizeof_random), ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, NULL); diff --git a/lib/srfi/9.module b/lib/srfi/9.module index 58368111..7513b7f3 100644 --- a/lib/srfi/9.module +++ b/lib/srfi/9.module @@ -2,89 +2,5 @@ (define-module (srfi 9) (export define-record-type) (import-immutable (scheme)) - (body - (define-syntax define-record-type - (er-macro-transformer - (lambda (expr rename compare) - (let* ((name (cadr expr)) - (name-str (symbol->string (identifier->symbol name))) - (make (caaddr expr)) - (make-fields (cdaddr expr)) - (pred (cadddr expr)) - (fields (cddddr expr)) - (num-fields (length fields)) - (_define (rename 'define)) - (_lambda (rename 'lambda)) - (_let (rename 'let)) - (_register (rename 'register-simple-type))) - (define (index-of field ls) - (let lp ((ls ls) (i 0)) - (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) - `(,(rename 'begin) - ;; type - (,_define ,name (,_register ,name-str ,num-fields)) - ;; predicate - (,_define ,pred (,(rename 'make-type-predicate) - ,(symbol->string (identifier->symbol pred)) - ,name)) - ;; fields - ,@(let lp ((ls fields) (i 0) (res '())) - (if (null? ls) - res - (let ((res - (cons `(,_define ,(cadar ls) - (,(rename 'make-getter) - ,(symbol->string - (identifier->symbol (cadar ls))) - ,name - ,i)) - res))) - (lp (cdr ls) - (+ i 1) - (if (pair? (cddar ls)) - (cons - `(,_define ,(caddar ls) - (,(rename 'make-setter) - ,(symbol->string - (identifier->symbol (caddar ls))) - ,name - ,i)) - res) - res))))) - ;; constructor - (,_define ,make - ,(let lp ((ls make-fields) (sets '()) (set-defs '())) - (cond - ((null? ls) - `(,_let ((%make (,(rename 'make-constructor) - ,(symbol->string (identifier->symbol make)) - ,name)) - ,@set-defs) - (,_lambda ,make-fields - (,_let ((res (%make))) - ,@sets - res)))) - (else - (let ((field (assq (car ls) fields))) - (cond - ((not field) - (error "unknown record field in constructor" (car ls))) - ((pair? (cddr field)) - (lp (cdr ls) - (cons (list (caddr field) 'res (car ls)) sets) - set-defs)) - (else - (let* ((setter-name - (string-append "%" name-str "-" - (symbol->string (car ls)) "-set!")) - (setter (rename (string->symbol setter-name))) - (i (index-of (car ls) fields))) - (lp (cdr ls) - (cons (list setter 'res (car ls)) sets) - (cons (list setter - (list (rename 'make-setter) - setter-name - name - (index-of (car ls) fields))) - set-defs))))))))))))))))) + (include "9.scm")) diff --git a/lib/srfi/9.scm b/lib/srfi/9.scm new file mode 100644 index 00000000..5100b341 --- /dev/null +++ b/lib/srfi/9.scm @@ -0,0 +1,87 @@ + +(define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((name (if (pair? (cadr expr)) (caadr expr) (cadr expr))) + (parent (and (pair? (cadr expr)) (cadadr expr))) + (name-str (symbol->string (identifier->symbol name))) + (make (caaddr expr)) + (make-fields (cdaddr expr)) + (pred (cadddr expr)) + (fields (cddddr expr)) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let)) + (_register (rename 'register-simple-type))) + (define (index-of field ls) + (let lp ((ls ls) (i 0)) + (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) + (write `(name: ,name parent: ,parent)) (newline) + `(,(rename 'begin) + ;; type + (,_define ,name (,_register ,name-str ,parent ',fields)) + ;; predicate + (,_define ,pred (,(rename 'make-type-predicate) + ,(symbol->string (identifier->symbol pred)) + ,name)) + ;; fields + ,@(let lp ((ls fields) (i 0) (res '())) + (if (null? ls) + res + (let ((res + (cons `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string + (identifier->symbol (cadar ls))) + ,name + ,i)) + res))) + (lp (cdr ls) + (+ i 1) + (if (pair? (cddar ls)) + (cons + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string + (identifier->symbol (caddar ls))) + ,name + ,i)) + res) + res))))) + ;; constructor + (,_define ,make + ,(let lp ((ls make-fields) (sets '()) (set-defs '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string (identifier->symbol make)) + ,name)) + ,@set-defs) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets) + set-defs)) + (else + (let* ((setter-name + (string-append "%" name-str "-" + (symbol->string (car ls)) "-set!")) + (setter (rename (string->symbol setter-name))) + (i (index-of (car ls) fields))) + (lp (cdr ls) + (cons (list setter 'res (car ls)) sets) + (cons (list setter + (list (rename 'make-setter) + setter-name + name + (index-of (car ls) fields))) + set-defs)))))))))) + (display "done\n")))))) diff --git a/opcodes.c b/opcodes.c index 34505644..3d3aff5d 100644 --- a/opcodes.c +++ b/opcodes.c @@ -154,7 +154,7 @@ _FN2(_I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-ref", 0, sexp_stri _FN3(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "string-set!", 0, sexp_string_utf8_index_set), #endif #if SEXP_USE_TYPE_DEFS -_FN2(_I(SEXP_TYPE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "register-simple-type", 0, sexp_register_simple_type_op), +_FN3(_I(SEXP_TYPE), _I(SEXP_STRING), _I(SEXP_TYPE), SEXP_NULL, "register-simple-type", 0, sexp_register_simple_type_op), _FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0, sexp_make_type_predicate_op), _FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op), _FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op), diff --git a/sexp.c b/sexp.c index c16a2778..d043b9ae 100644 --- a/sexp.c +++ b/sexp.c @@ -77,42 +77,42 @@ sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port) { #endif static struct sexp_type_struct _sexp_type_specs[] = { - {SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "object", NULL}, - {SEXP_TYPE, 0, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, "type", NULL}, - {SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "integer", NULL}, - {SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "number", NULL}, - {SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "char", NULL}, - {SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", NULL}, - {SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, 0, 0, 0, 0, 0, "pair", NULL}, - {SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, 0, 0, 0, 0, 0, "symbol", NULL}, - {SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, 0, 0, 0, 0, 0, "byte-vector", NULL}, + {SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "object", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_TYPE, sexp_offsetof(type, cpl), 2, 2, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, 0, "type", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "integer", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "number", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "char", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, 0, 0, 0, 0, 0, 0, "pair", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, 0, 0, 0, 0, 0, 0, "symbol", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, 0, 0, 0, 0, 0, 0, "byte-vector", SEXP_FALSE, SEXP_FALSE, NULL}, #if SEXP_USE_PACKED_STRINGS - {SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, 0, 0, 0, 0, 0, "string", NULL}, + {SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, 0, 0, 0, 0, 0, 0, "string", SEXP_FALSE, SEXP_FALSE, NULL}, #else - {SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, 0, 0, 0, 0, 0, "string", NULL}, + {SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, 0, 0, 0, 0, 0, 0, "string", SEXP_FALSE, SEXP_FALSE, NULL}, #endif - {SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), 0, 0, 0, 0, 0, "vector", NULL}, - {SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, 0, 0, 0, 0, 0, "real", NULL}, - {SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), 0, 0, 0, 0, 0, "bignum", NULL}, - {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, "cpointer", NULL}, - {SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, "input-port", SEXP_FINALIZE_PORT}, - {SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, "output-port", SEXP_FINALIZE_PORT}, - {SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, "exception", NULL}, - {SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, "procedure", NULL}, - {SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, "macro", NULL}, - {SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, "syntactic-closure", NULL}, - {SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, "environment", NULL}, - {SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, "bytecode", NULL}, - {SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, "core-form", NULL}, - {SEXP_OPCODE, sexp_offsetof(opcode, data), 7, 7, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, "opcode", NULL}, - {SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, "lambda", NULL}, - {SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, "conditional", NULL}, - {SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, "reference", NULL}, - {SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, 0, 0, 0, 0, 0, "set!", NULL}, - {SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, "sequence", NULL}, - {SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, "literal", NULL}, - {SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, "stack", NULL}, - {SEXP_CONTEXT, sexp_offsetof(context, bc), 12, 12, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, "context", NULL}, + {SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), 0, 0, 0, 0, 0, 0, "vector", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, 0, 0, 0, 0, 0, 0, "real", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), 0, 0, 0, 0, 0, 0, "bignum", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, "cpointer", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, "input-port", SEXP_FALSE, SEXP_FALSE, SEXP_FINALIZE_PORT}, + {SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, "output-port", SEXP_FALSE, SEXP_FALSE, SEXP_FINALIZE_PORT}, + {SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, "exception", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, "procedure", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, "macro", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, "syntactic-closure", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, "environment", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, 0, "bytecode", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, 0, "core-form", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_OPCODE, sexp_offsetof(opcode, data), 7, 7, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, "opcode", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, 0, "lambda", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, 0, "conditional", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, 0, "reference", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, 0, 0, 0, 0, 0, 0, "set!", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, "sequence", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, "literal", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, "stack", SEXP_FALSE, SEXP_FALSE, NULL}, + {SEXP_CONTEXT, sexp_offsetof(context, bc), 12, 12, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, "context", SEXP_FALSE, SEXP_FALSE, NULL}, }; #if SEXP_USE_GLOBAL_TYPES @@ -129,6 +129,7 @@ static sexp_uint_t sexp_type_array_size = SEXP_NUM_CORE_TYPES; #endif sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, + sexp parent, sexp slots, sexp fb, sexp felb, sexp flb, sexp flo, sexp fls, sexp sb, sexp so, sexp sc, sexp w, sexp wb, sexp wo, sexp ws, sexp we, sexp_proc2 f) { @@ -137,9 +138,10 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, #else sexp *v1, *v2; #endif - sexp res, type; + sexp_gc_var2(res, type); sexp_uint_t i, len, num_types=sexp_context_num_types(ctx), type_array_size=sexp_context_type_array_size(ctx); + sexp_gc_preserve2(ctx, res, type); if (num_types >= SEXP_MAXIMUM_TYPES) { res = sexp_user_exception(ctx, self, "register-type: exceeded maximum type limit", name); } else if (! sexp_stringp(name)) { @@ -186,6 +188,21 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp_type_weak_len_extra(type) = sexp_unbox_fixnum(we); sexp_type_name(type) = strdup(sexp_string_data(name)); sexp_type_finalize(type) = f; + if (sexp_typep(parent)) { + len = sexp_vectorp(sexp_type_cpl(parent)) ? sexp_vector_length(sexp_type_cpl(parent)) : 1; + sexp_type_cpl(type) = sexp_make_vector(ctx, sexp_make_fixnum(len+1), SEXP_VOID); + if (sexp_vectorp(sexp_type_cpl(parent))) + memcpy(sexp_vector_data(sexp_type_cpl(type)), + sexp_vector_data(sexp_type_cpl(parent)), + len * sizeof(sexp)); + else + sexp_vector_data(sexp_type_cpl(type))[len-1] = parent; + } else { + len = 0; + sexp_type_cpl(type) = sexp_make_vector(ctx, SEXP_ONE, SEXP_VOID); + } + sexp_vector_data(sexp_type_cpl(type))[len] = type; + sexp_type_depth(type) = len; res = type; #if SEXP_USE_GLOBAL_TYPES sexp_num_types = num_types + 1; @@ -193,14 +210,17 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp_global(ctx, SEXP_G_NUM_TYPES) = sexp_make_fixnum(num_types + 1); #endif } + sexp_gc_release2(ctx); return res; } -sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots) { - short type_size = sexp_sizeof_header + sizeof(sexp)*sexp_unbox_fixnum(slots); +sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp parent, sexp slots) { + sexp num_slots = sexp_length(ctx, slots); + short type_size = sexp_sizeof_header + sizeof(sexp)*sexp_unbox_fixnum(num_slots); return - sexp_register_type(ctx, name, sexp_make_fixnum(sexp_offsetof_slot0), - slots, slots, SEXP_ZERO, SEXP_ZERO, + sexp_register_type(ctx, name, parent, slots, + sexp_make_fixnum(sexp_offsetof_slot0), + num_slots, num_slots, SEXP_ZERO, SEXP_ZERO, sexp_make_fixnum(type_size), SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, NULL); diff --git a/vm.c b/vm.c index 814926fe..eef3e5b3 100644 --- a/vm.c +++ b/vm.c @@ -492,6 +492,21 @@ static sexp_uint_t sexp_restore_stack (sexp saved, sexp *current) { goto call_error_handler;}} \ while (0) +static int sexp_check_type(sexp ctx, sexp a, sexp b) { + int d; + sexp t, v; + if (! sexp_pointerp(a)) + return 0; + if (sexp_isa(a, b)) + return 1; + t = sexp_object_type(ctx, a); + v = sexp_type_cpl(t); + d = sexp_type_depth(b); + return sexp_vectorp(v) + && (d < sexp_vector_length(v)) + && sexp_vector_ref(v, sexp_make_fixnum(d)) == b; +} + #if SEXP_USE_DEBUG_VM #include "opt/opcode_names.h" #endif @@ -907,10 +922,17 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; case SEXP_OP_CHARP: _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case SEXP_OP_ISA: + tmp1 = _ARG1, tmp2 = _ARG2; + if (! sexp_typep(tmp2)) sexp_raise("is-a?: not a type", tmp2); + top--; + goto do_check_type; case SEXP_OP_TYPEP: _ALIGN_IP(); - _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); + tmp1 = _ARG1, tmp2 = sexp_type_by_index(ctx, _UWORD0); ip += sizeof(sexp); + do_check_type: + _ARG1 = sexp_make_boolean(sexp_check_type(ctx, tmp1, tmp2)); break; case SEXP_OP_MAKE: _ALIGN_IP(); @@ -919,14 +941,14 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case SEXP_OP_SLOT_REF: _ALIGN_IP(); - if (! sexp_check_tag(_ARG1, _UWORD0)) + if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0))) sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); ip += sizeof(sexp)*2; break; case SEXP_OP_SLOT_SET: _ALIGN_IP(); - if (! sexp_check_tag(_ARG1, _UWORD0)) + if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0))) sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); else if (sexp_immutablep(_ARG1)) sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); @@ -935,14 +957,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { ip += sizeof(sexp)*2; top--; break; - case SEXP_OP_ISA: - _ARG2 = sexp_make_boolean(sexp_isa(_ARG1, _ARG2)); - top--; - break; case SEXP_OP_SLOTN_REF: if (! sexp_typep(_ARG1)) sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); - else if (! sexp_isa(_ARG2, _ARG1)) + else if (! sexp_check_type(ctx, _ARG2, _ARG1)) sexp_raise("slot-ref: bad type", sexp_list1(ctx, _ARG2)); else if (! sexp_fixnump(_ARG3)) sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); @@ -952,7 +970,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_SLOTN_SET: if (! sexp_typep(_ARG1)) sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); - else if (! sexp_isa(_ARG2, _ARG1)) + else if (! sexp_check_type(ctx, _ARG2, _ARG1)) sexp_raise("slot-set!: bad type", sexp_list1(ctx, _ARG2)); else if (sexp_immutablep(_ARG2)) sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG2)); From d9bdc5fb1a77d9b90bb30cc77fbd704c2bab133e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 15 Sep 2010 14:48:21 +0000 Subject: [PATCH 532/535] adding srfi-99 --- Makefile | 3 + eval.c | 114 +++++++++++-------- lib/chibi/ast.c | 27 +++++ lib/chibi/ast.module | 4 +- lib/chibi/ast.scm | 5 + lib/srfi/9.scm | 105 +++++++----------- lib/srfi/99.module | 7 ++ lib/srfi/99/records.module | 9 ++ lib/srfi/99/records/inspection.module | 7 ++ lib/srfi/99/records/inspection.scm | 34 ++++++ lib/srfi/99/records/procedural.module | 6 + lib/srfi/99/records/procedural.scm | 51 +++++++++ lib/srfi/99/records/syntactic.module | 6 + lib/srfi/99/records/syntactic.scm | 109 +++++++++++++++++++ opcodes.c | 5 +- sexp.c | 1 + tests/match-tests.scm | 99 +++++++++++++++++ tests/record-tests.scm | 151 ++++++++++++++++++++++++++ vm.c | 4 +- 19 files changed, 632 insertions(+), 115 deletions(-) create mode 100644 lib/srfi/99.module create mode 100644 lib/srfi/99/records.module create mode 100644 lib/srfi/99/records/inspection.module create mode 100644 lib/srfi/99/records/inspection.scm create mode 100644 lib/srfi/99/records/procedural.module create mode 100644 lib/srfi/99/records/procedural.scm create mode 100644 lib/srfi/99/records/syntactic.module create mode 100644 lib/srfi/99/records/syntactic.scm create mode 100644 tests/record-tests.scm diff --git a/Makefile b/Makefile index 3840909e..b4e8f221 100644 --- a/Makefile +++ b/Makefile @@ -200,6 +200,9 @@ test-loop: chibi-scheme$(EXE) test-sort: chibi-scheme$(EXE) LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm +test-records: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/record-tests.scm + test-libs: chibi-scheme$(EXE) LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/lib-tests.scm diff --git a/eval.c b/eval.c index c0c7e166..55aba87f 100644 --- a/eval.c +++ b/eval.c @@ -1288,6 +1288,73 @@ sexp sexp_string_utf8_index_set (sexp ctx sexp_api_params(self, n), sexp str, se /***************************** opcodes ********************************/ +#if SEXP_USE_TYPE_DEFS + +sexp sexp_type_slot_offset_op (sexp ctx sexp_api_params(self, n), sexp type, sexp slot) { + sexp cpl, slots, *v; + int i, offset=0, len; + sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, type); + cpl = sexp_type_cpl(type); + if (sexp_vectorp(cpl)) { + v = sexp_vector_data(cpl); + len = sexp_vector_length(cpl); + } else { + v = &sexp_type_slots(type); + len = 1; + } + len = sexp_vectorp(cpl) ? sexp_vector_length(cpl) : 1; + for (i=0; i= sexp_context_num_types(ctx))) + return SEXP_ZERO; + t = sexp_object_type(ctx, x); + return sexp_make_fixnum(sexp_type_size_of_object(t, x)); +} + static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { sexp ctx2 = ctx; if (sexp_envp(e)) { @@ -243,6 +266,10 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type); sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize); sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of); + sexp_define_foreign(ctx, env, "type-name", 1, sexp_type_name_op); + sexp_define_foreign(ctx, env, "type-cpl", 1, sexp_type_cpl_op); + sexp_define_foreign(ctx, env, "type-slots", 1, sexp_type_slots_op); + sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size); return SEXP_VOID; } diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index a439bd57..5a590489 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -26,7 +26,9 @@ exception-irritants exception-irritants-set! opcode-name opcode-num-params opcode-return-type opcode-param-type opcode-variadic? - procedure-code procedure-vars procedure-name bytecode-name) + procedure-code procedure-vars procedure-name bytecode-name + type? type-name type-cpl type-parent type-slots + object-size) (import-immutable (scheme)) (include-shared "ast") (include "ast.scm")) diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm index 020f257a..f4506ff5 100644 --- a/lib/chibi/ast.scm +++ b/lib/chibi/ast.scm @@ -89,3 +89,8 @@ ((opcode? x) (or (opcode-name x) x)) (else x))))) +(define (type-parent x) + (let ((v (type-cpl x))) + (and (vector? v) + (> (vector-length v) 1) + (vector-ref v (- (vector-length v) 2))))) diff --git a/lib/srfi/9.scm b/lib/srfi/9.scm index 5100b341..c1818042 100644 --- a/lib/srfi/9.scm +++ b/lib/srfi/9.scm @@ -12,11 +12,9 @@ (_define (rename 'define)) (_lambda (rename 'lambda)) (_let (rename 'let)) - (_register (rename 'register-simple-type))) - (define (index-of field ls) - (let lp ((ls ls) (i 0)) - (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) - (write `(name: ,name parent: ,parent)) (newline) + (_register (rename 'register-simple-type)) + (_slot-set! (rename 'slot-set!)) + (_type_slot_offset (rename 'type-slot-offset))) `(,(rename 'begin) ;; type (,_define ,name (,_register ,name-str ,parent ',fields)) @@ -25,63 +23,44 @@ ,(symbol->string (identifier->symbol pred)) ,name)) ;; fields - ,@(let lp ((ls fields) (i 0) (res '())) - (if (null? ls) - res - (let ((res - (cons `(,_define ,(cadar ls) - (,(rename 'make-getter) - ,(symbol->string - (identifier->symbol (cadar ls))) - ,name - ,i)) - res))) - (lp (cdr ls) - (+ i 1) - (if (pair? (cddar ls)) - (cons - `(,_define ,(caddar ls) - (,(rename 'make-setter) - ,(symbol->string - (identifier->symbol (caddar ls))) - ,name - ,i)) - res) - res))))) + ,@(map (lambda (f) + (and (pair? f) (pair? (cdr f)) + `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string + (identifier->symbol (cadr f))) + ,name + (,_type_slot_offset ,name ,(car f)))))) + fields) + ,@(map (lambda (f) + (and (pair? f) (pair? (cdr f)) (pair? (cddr f)) + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string + (identifier->symbol (caddr f))) + ,name + (,_type_slot_offset ,name ,(car f)))))) + fields) ;; constructor (,_define ,make - ,(let lp ((ls make-fields) (sets '()) (set-defs '())) - (cond - ((null? ls) - `(,_let ((%make (,(rename 'make-constructor) - ,(symbol->string (identifier->symbol make)) - ,name)) - ,@set-defs) - (,_lambda ,make-fields - (,_let ((res (%make))) - ,@sets - res)))) - (else - (let ((field (assq (car ls) fields))) - (cond - ((not field) - (error "unknown record field in constructor" (car ls))) - ((pair? (cddr field)) - (lp (cdr ls) - (cons (list (caddr field) 'res (car ls)) sets) - set-defs)) - (else - (let* ((setter-name - (string-append "%" name-str "-" - (symbol->string (car ls)) "-set!")) - (setter (rename (string->symbol setter-name))) - (i (index-of (car ls) fields))) - (lp (cdr ls) - (cons (list setter 'res (car ls)) sets) - (cons (list setter - (list (rename 'make-setter) - setter-name - name - (index-of (car ls) fields))) - set-defs)))))))))) - (display "done\n")))))) + ,(let lp ((ls make-fields) (sets '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string (identifier->symbol make)) + ,name))) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets))) + (else + (lp (cdr ls) + (cons (list _slot-set! 'res (list 'quote (car ls)) (car ls)) sets)))))))))))))) diff --git a/lib/srfi/99.module b/lib/srfi/99.module new file mode 100644 index 00000000..66bec55d --- /dev/null +++ b/lib/srfi/99.module @@ -0,0 +1,7 @@ + +(define-module (srfi 99) + (import (srfi 99 records)) + (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator + record? record-rtd rtd-name rtd-parent + rtd-field-names rtd-all-field-names rtd-field-mutable? + define-record-type)) \ No newline at end of file diff --git a/lib/srfi/99/records.module b/lib/srfi/99/records.module new file mode 100644 index 00000000..e26a9a77 --- /dev/null +++ b/lib/srfi/99/records.module @@ -0,0 +1,9 @@ + +(define-module (srfi 99 records) + (import (srfi 99 records procedural) + (srfi 99 records inspection) + (srfi 99 records syntactic)) + (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator + record? record-rtd rtd-name rtd-parent + rtd-field-names rtd-all-field-names rtd-field-mutable? + define-record-type)) diff --git a/lib/srfi/99/records/inspection.module b/lib/srfi/99/records/inspection.module new file mode 100644 index 00000000..527ada49 --- /dev/null +++ b/lib/srfi/99/records/inspection.module @@ -0,0 +1,7 @@ + +(define-module (srfi 99 records inspection) + (export record? record-rtd rtd-name rtd-parent + rtd-field-names rtd-all-field-names rtd-field-mutable?) + (import-immutable (scheme)) + (import (chibi ast)) + (include "inspection.scm")) diff --git a/lib/srfi/99/records/inspection.scm b/lib/srfi/99/records/inspection.scm new file mode 100644 index 00000000..bc66a3d2 --- /dev/null +++ b/lib/srfi/99/records/inspection.scm @@ -0,0 +1,34 @@ + +(define (record? x) + (is-a? x )) + +(define (record-rtd x) + (type-of x)) + +(define (rtd-name x) (type-name x)) + +(define (rtd-parent x) (type-parent x)) + +(define (rtd-field-names x) + (list->vector + (map (lambda (x) (if (pair? x) (cadr x) x)) (type-slots x)))) + +(define (rtd-all-field-names x) + (let lp ((x x) (res '())) + (let ((res (append (vector->list (rtd-field-names x)) res))) + (let ((p (type-parent x))) + (if (type? p) + (lp p res) + (list->vector res)))))) + +(define (rtd-field-mutable? rtd x) + (let lp ((ls (type-slots rtd))) + (cond ((null? ls) + (let ((p (type-parent rtd))) + (if (type? p) + (rtd-field-mutable? p x) + (error "unknown field" rtd x)))) + ((eq? x (car ls))) + ((and (pair? (car ls)) (eq? x (cadar ls))) + (not (eq? 'immutable (caar ls)))) + (else (lp (cdr ls)))))) diff --git a/lib/srfi/99/records/procedural.module b/lib/srfi/99/records/procedural.module new file mode 100644 index 00000000..2289ecf1 --- /dev/null +++ b/lib/srfi/99/records/procedural.module @@ -0,0 +1,6 @@ + +(define-module (srfi 99 records procedural) + (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator) + (import-immutable (scheme)) + (import (chibi ast) (srfi 99 records inspection)) + (include "procedural.scm")) diff --git a/lib/srfi/99/records/procedural.scm b/lib/srfi/99/records/procedural.scm new file mode 100644 index 00000000..5994f934 --- /dev/null +++ b/lib/srfi/99/records/procedural.scm @@ -0,0 +1,51 @@ + +(define (make-rtd name fields . o) + (let ((parent (and (pair? o) (car o)))) + (register-simple-type name (vector->list fields) parent))) + +(define (rtd? x) + (type? x)) + +(define (rtd-constructor rtd . o) + (let ((fields (vector->list (if (pair? o) (car o) (rtd-all-field-names)))) + (make (make-constructor (type-name rtd) rtd))) + (lambda args + (let ((res (make))) + (let lp ((a args) (p fields)) + (cond + ((null? a) (if (null? p) res (error "not enough args" p))) + ((null? p) (error "too many args" a)) + (else + (slot-set! res rtd (car p) (car a)) + (lp (cdr a) (cdr p))))))))) + +(define (rtd-predicate rtd) + (make-type-predicate (type-name rtd) rtd)) + +(define (field-index-of ls field) + (let lp ((i 0) (ls ls)) + (cond ((null? ls ) #f) + ((if (pair? (car ls)) + (eq? field (cadar ls)) + (eq? field (car ls))) + i) + (else (lp (+ i 1) (cdr ls)))))) + +(define (rtd-field-offset rtd field) + (let ((p (type-parent rtd))) + (or (and (type? p) + (rtd-field-offset p field)) + (let ((i (field-index-of (type-slots rtd) field))) + (and i + (if (type? p) + (+ i (vector-length (rtd-all-field-names p))) + i)))))) + +(define (rtd-accessor rtd field) + (make-getter rtd (type-name rtd) (rtd-field-offset rtd field))) + +(define (rtd-mutator rtd field) + (if (rtd-field-mutable? rtd field) + (make-setter rtd (type-name rtd) (rtd-field-offset rtd field)) + (error "can't make mutator for immutable field" rtd field))) + diff --git a/lib/srfi/99/records/syntactic.module b/lib/srfi/99/records/syntactic.module new file mode 100644 index 00000000..3d6f7a10 --- /dev/null +++ b/lib/srfi/99/records/syntactic.module @@ -0,0 +1,6 @@ + +(define-module (srfi 99 records syntactic) + (export define-record-type) + (import-immutable (scheme)) + (import (srfi 99 records inspection)) + (include "syntactic.scm")) diff --git a/lib/srfi/99/records/syntactic.scm b/lib/srfi/99/records/syntactic.scm new file mode 100644 index 00000000..356ec34f --- /dev/null +++ b/lib/srfi/99/records/syntactic.scm @@ -0,0 +1,109 @@ + +(define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((id->string (lambda (x) (symbol->string (identifier->symbol x)))) + (name (if (pair? (cadr expr)) (caadr expr) (cadr expr))) + (parent (and (pair? (cadr expr)) (cadadr expr))) + (name-str (id->string name)) + (make (caddr expr)) + (make-name (if (eq? make #t) + (string->symbol (string-append "make-" name-str)) + (if (pair? make) (car make) make))) + (pred (cadddr expr)) + (pred-name (if (eq? pred #t) + (string->symbol (string-append name-str "?")) + pred)) + (fields (cddddr expr)) + (field-names (map (lambda (x) (if (pair? x) (car x) x)) fields)) + (make-fields (if (pair? make) (cdr make) (and (not parent) field-names))) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let)) + (_register (rename 'register-simple-type)) + (_slot-set! (rename 'slot-set!)) + (_vector->list (rename 'vector->list)) + (_type_slot_offset (rename 'type-slot-offset)) + (_rtd-all-field-names (rename 'rtd-all-field-names))) + `(,(rename 'begin) + ;; type + (,_define ,name (,_register ,name-str ,parent ',field-names)) + ;; predicate + ,@(if pred-name + `((,_define ,pred-name + (,(rename 'make-type-predicate) + ,(id->string pred-name) + ,name))) + #f) + ;; accessors + ,@(map (lambda (f) + (let ((g (if (and (pair? f) (pair? (cdr f))) + (cadr f) + (and (identifier? f) + (string->symbol + (string-append name-str "-" (id->string f))))))) + (and g + `(,_define ,g + (,(rename 'make-getter) + ,(id->string g) + ,name + (,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) + fields) + ,@(map (lambda (f) + (let ((s (if (and (pair? f) (pair? (cdr f)) (pair? (cddr f))) + (caddr f) + (and (identifier? f) + (string->symbol + (string-append name-str "-" (id->string f) "-set!")))))) + (and s + `(,_define ,s + (,(rename 'make-setter) + ,(id->string s) + ,name + (,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) + fields) + ;; constructor + ,(if make-fields + `(,_define ,make-name + ,(let lp ((ls make-fields) (sets '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(id->string make-name) + ,name))) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ;;((not field) + ;; (error "unknown record field in constructor" (car ls))) + ((and (pair? field) (pair? (cdr field)) (pair? (cddr field))) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets))) + (else + (lp (cdr ls) + (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets))))))))) + `(,_define ,make-name + (,_let ((%make (,(rename 'make-constructor) + ,(id->string make-name) + ,name))) + (,_lambda args + (,_let ((res (%make))) + (let lp ((a args) + (p (,_vector->list (,_rtd-all-field-names ,name)))) + (cond + ((null? a) + (if (null? p) + res + (error ,(string-append "not enough arguments to " (id->string make-name) ": missing") + p))) + ((null? p) + (error ,(string-append "too many arguments to " (id->string make-name)) + a)) + (else + (,_slot-set! ,name res (,_type_slot_offset ,name (car p)) (car a)) + (lp (cdr a) (cdr p))))))))) + )))))) diff --git a/opcodes.c b/opcodes.c index 3d3aff5d..f4e66948 100644 --- a/opcodes.c +++ b/opcodes.c @@ -37,8 +37,6 @@ _OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SE #endif #endif _OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), SEXP_FALSE, SEXP_FALSE, 0,"string-length", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL), -_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, _I(SEXP_FLONUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "exact->inexact", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "inexact->exact", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char->integer", 0, NULL), @@ -159,6 +157,9 @@ _FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0 _FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op), _FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op), _FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-setter", 0, sexp_make_setter_op), +_FN2(_I(SEXP_OPCODE), _I(SEXP_TYPE), _I(SEXP_SYMBOL), "type-slot-offset", 0, sexp_type_slot_offset_op), +_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL), #endif #if PLAN9 #include "opt/plan9-opcodes.c" diff --git a/sexp.c b/sexp.c index d043b9ae..01a20a5f 100644 --- a/sexp.c +++ b/sexp.c @@ -173,6 +173,7 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, type = sexp_type_by_index(ctx, num_types); sexp_pointer_tag(type) = SEXP_TYPE; sexp_type_tag(type) = num_types; + sexp_type_slots(type) = slots; sexp_type_field_base(type) = sexp_unbox_fixnum(fb); sexp_type_field_eq_len_base(type) = sexp_unbox_fixnum(felb); sexp_type_field_len_base(type) = sexp_unbox_fixnum(flb); diff --git a/tests/match-tests.scm b/tests/match-tests.scm index 911dd831..2a8cf3ae 100644 --- a/tests/match-tests.scm +++ b/tests/match-tests.scm @@ -132,4 +132,103 @@ (list tag attrs text)) (else #f))) +(test "joined tail" '(1 2) + (match '(1 2 3) ((and (a ... b) x) a))) + (((x . y) ... u v w) (list x y u v w)))) + +(test "Riastradh quasiquote" '(2 3) + (match '(1 2 3) (`(1 ,b ,c) (list b c)))) + +(test "trivial tree search" '(1 2 3) + (match '(1 2 3) ((_ *** (a b c)) (list a b c)))) + +(test "simple tree search" '(1 2 3) + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c)))) + +(test "deep tree search" '(1 2 3) + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c)))) + +(test "non-tail tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c)))) + +(test "restricted tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c)))) + +(test "fail restricted tree search" #f + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f))) + +(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "failed sxml tree search" #f + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "collect tree search" + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f))) + +(test "joined tail" '(1 2) + (match '(1 2 3) ((and (a ... b) x) a))) + + (((x . y) ... u v w) (list x y u v w)))) + +(test "Riastradh quasiquote" '(2 3) + (match '(1 2 3) (`(1 ,b ,c) (list b c)))) + +(test "trivial tree search" '(1 2 3) + (match '(1 2 3) ((_ *** (a b c)) (list a b c)))) + +(test "simple tree search" '(1 2 3) + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c)))) + +(test "deep tree search" '(1 2 3) + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c)))) + +(test "non-tail tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c)))) + +(test "restricted tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c)))) + +(test "fail restricted tree search" #f + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f))) + +(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "failed sxml tree search" #f + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "collect tree search" + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f))) + +(test "anded tail pattern" '(1 2) + (match '(1 2 3) ((and (a ... b) x) a))) + +(test "anded search pattern" '(a b c) + (match '(a (b (c d))) ((and (p *** 'd) x) p))) + (test-end) diff --git a/tests/record-tests.scm b/tests/record-tests.scm new file mode 100644 index 00000000..32237fb9 --- /dev/null +++ b/tests/record-tests.scm @@ -0,0 +1,151 @@ + +(import (srfi 99 records syntactic) (chibi test)) + +(test-begin "records") + +(define-record-type organism + (make-organism name) + organism? + (name name-of set-name-of!)) + +;; kingdom +(define-record-type (animal organism) + (make-animal name food) + animal? + ;; all animals eat + (food food-of set-food-of!)) + +;; phylum +(define-record-type (chordate animal) + (make-chordate name food) + chordate?) + +;; class +(define-record-type (mammal chordate) + (make-mammal name food num-nipples) + mammal? + ;; all mammals have nipples + (num-nipples num-nipples-of set-num-nipples-of!)) + +;; order +(define-record-type (carnivore mammal) + (make-carnivore name food num-nipples) + carnivore?) + +(define-record-type (rodent mammal) + (make-rodent name food num-nipples) + rodent?) + +;; family +(define-record-type (felidae carnivore) + (make-felidae name food num-nipples) + felidae?) + +(define-record-type (muridae rodent) + (make-muridae name food num-nipples) + muridae?) + +;; genus +(define-record-type (felis felidae) + (make-felis name food num-nipples) + felis?) + +(define-record-type (mus muridae) + (make-mus name food num-nipples) + mus?) + +;; species +(define-record-type (cat felis) + (make-cat name food num-nipples breed color) + cat? + (breed breed-of set-breed-of!) + (color color-of set-color-of!)) + +(define-record-type (mouse mus) + (make-mouse name food num-nipples) + mouse?) + +(define mickey (make-mouse "Mickey" "cheese" 10)) +(define felix (make-cat "Felix" mickey 8 'mixed '(and black white))) + +(test-assert (organism? mickey)) +(test-assert (animal? mickey)) +(test-assert (chordate? mickey)) +(test-assert (mammal? mickey)) +(test-assert (rodent? mickey)) +(test-assert (muridae? mickey)) +(test-assert (mus? mickey)) +(test-assert (mouse? mickey)) + +(test-assert (not (carnivore? mickey))) +(test-assert (not (felidae? mickey))) +(test-assert (not (felis? mickey))) +(test-assert (not (cat? mickey))) + +(test-assert (organism? felix)) +(test-assert (animal? felix)) +(test-assert (chordate? felix)) +(test-assert (mammal? felix)) +(test-assert (carnivore? felix)) +(test-assert (felidae? felix)) +(test-assert (felis? felix)) +(test-assert (cat? felix)) + +(test-assert (not (rodent? felix))) +(test-assert (not (muridae? felix))) +(test-assert (not (mus? felix))) +(test-assert (not (mouse? felix))) + +(test "Mickey" (name-of mickey)) +(test "cheese" (food-of mickey)) +(test 10 (num-nipples-of mickey)) + +(test "Felix" (name-of felix)) +(test mickey (food-of felix)) +(test 8 (num-nipples-of felix)) +(test 'mixed (breed-of felix)) +(test '(and black white) (color-of felix)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-record-type person #t #t name sex age) +(define-record-type (employee person) #t #t department salary) + +(define bob (make-employee "Bob" 'male 28 'hr 50000.0)) +(define alice (make-employee "Alice" 'female 32 'research 100000.0)) + +(test-assert (person? bob)) +(test-assert (employee? bob)) +(test "Bob" (person-name bob)) +(test 'male (person-sex bob)) +(test 28 (person-age bob)) +(test 'hr (employee-department bob)) +(test 50000.0 (employee-salary bob)) + +(test-assert (person? alice)) +(test-assert (employee? alice)) +(test "Alice" (person-name alice)) +(test 'female (person-sex alice)) +(test 32 (person-age alice)) +(test 'research (employee-department alice)) +(test 100000.0 (employee-salary alice)) + +;; After a trip to Thailand... +(person-sex-set! bob 'female) +(person-name-set! bob "Roberta") + +;; Then Roberta quits! +(employee-department-set! bob #f) +(employee-salary-set! bob 0.0) + +(test "Roberta" (person-name bob)) +(test 'female (person-sex bob)) +(test 28 (person-age bob)) +(test #f (employee-department bob)) +(test 0.0 (employee-salary bob)) + +;;;; SRFI-99 forbids this, but we currently do it anyway. +;;(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0) +;; (make-employee "Chuck" 'male 20 'janitorial 50000.0))) + +(test-end) diff --git a/vm.c b/vm.c index eef3e5b3..0a60c6d0 100644 --- a/vm.c +++ b/vm.c @@ -969,13 +969,13 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case SEXP_OP_SLOTN_SET: if (! sexp_typep(_ARG1)) - sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + sexp_raise("slot-set!: not a record type", sexp_list1(ctx, _ARG1)); else if (! sexp_check_type(ctx, _ARG2, _ARG1)) sexp_raise("slot-set!: bad type", sexp_list1(ctx, _ARG2)); else if (sexp_immutablep(_ARG2)) sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG2)); else if (! sexp_fixnump(_ARG3)) - sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + sexp_raise("slot-set!: not an integer", sexp_list1(ctx, _ARG3)); sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4); _ARG4 = SEXP_VOID; top-=3; From 11e552576e0abc414ced9a3619bb1e6e3a7f4628 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 16 Sep 2010 00:04:35 +0900 Subject: [PATCH 533/535] oops, fixing srfi-9 --- lib/srfi/9.scm | 69 +++++++++++++++++++++++++------------------------- 1 file changed, 35 insertions(+), 34 deletions(-) diff --git a/lib/srfi/9.scm b/lib/srfi/9.scm index c1818042..9fb1aeca 100644 --- a/lib/srfi/9.scm +++ b/lib/srfi/9.scm @@ -17,7 +17,7 @@ (_type_slot_offset (rename 'type-slot-offset))) `(,(rename 'begin) ;; type - (,_define ,name (,_register ,name-str ,parent ',fields)) + (,_define ,name (,_register ,name-str ,parent ',(map car fields))) ;; predicate (,_define ,pred (,(rename 'make-type-predicate) ,(symbol->string (identifier->symbol pred)) @@ -25,42 +25,43 @@ ;; fields ,@(map (lambda (f) (and (pair? f) (pair? (cdr f)) - `(,_define ,(cadar ls) - (,(rename 'make-getter) - ,(symbol->string - (identifier->symbol (cadr f))) - ,name - (,_type_slot_offset ,name ,(car f)))))) + `(,_define ,(cadr f) + (,(rename 'make-getter) + ,(symbol->string + (identifier->symbol (cadr f))) + ,name + (,_type_slot_offset ,name ',(car f)))))) fields) ,@(map (lambda (f) (and (pair? f) (pair? (cdr f)) (pair? (cddr f)) - `(,_define ,(caddar ls) - (,(rename 'make-setter) - ,(symbol->string - (identifier->symbol (caddr f))) - ,name - (,_type_slot_offset ,name ,(car f)))))) + `(,_define ,(caddr f) + (,(rename 'make-setter) + ,(symbol->string + (identifier->symbol (caddr f))) + ,name + (,_type_slot_offset ,name ',(car f)))))) fields) ;; constructor (,_define ,make - ,(let lp ((ls make-fields) (sets '())) - (cond - ((null? ls) - `(,_let ((%make (,(rename 'make-constructor) - ,(symbol->string (identifier->symbol make)) - ,name))) - (,_lambda ,make-fields - (,_let ((res (%make))) - ,@sets - res)))) - (else - (let ((field (assq (car ls) fields))) - (cond - ((not field) - (error "unknown record field in constructor" (car ls))) - ((pair? (cddr field)) - (lp (cdr ls) - (cons (list (caddr field) 'res (car ls)) sets))) - (else - (lp (cdr ls) - (cons (list _slot-set! 'res (list 'quote (car ls)) (car ls)) sets)))))))))))))) + ,(let lp ((ls make-fields) (sets '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string (identifier->symbol make)) + ,name))) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons `(,(caddr field) res ,(car ls)) sets))) + (else + (lp (cdr ls) + (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) + sets)))))))))))))) From 6c074d686ada34956b0fbe2adbc3a752e89383f3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 16 Sep 2010 00:09:54 +0900 Subject: [PATCH 534/535] nicer indentation --- lib/srfi/99/records/syntactic.scm | 107 +++++++++++++++--------------- 1 file changed, 53 insertions(+), 54 deletions(-) diff --git a/lib/srfi/99/records/syntactic.scm b/lib/srfi/99/records/syntactic.scm index 356ec34f..c5cf90f7 100644 --- a/lib/srfi/99/records/syntactic.scm +++ b/lib/srfi/99/records/syntactic.scm @@ -31,9 +31,9 @@ ;; predicate ,@(if pred-name `((,_define ,pred-name - (,(rename 'make-type-predicate) - ,(id->string pred-name) - ,name))) + (,(rename 'make-type-predicate) + ,(id->string pred-name) + ,name))) #f) ;; accessors ,@(map (lambda (f) @@ -44,10 +44,10 @@ (string-append name-str "-" (id->string f))))))) (and g `(,_define ,g - (,(rename 'make-getter) - ,(id->string g) - ,name - (,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) + (,(rename 'make-getter) + ,(id->string g) + ,name + (,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) fields) ,@(map (lambda (f) (let ((s (if (and (pair? f) (pair? (cdr f)) (pair? (cddr f))) @@ -57,53 +57,52 @@ (string-append name-str "-" (id->string f) "-set!")))))) (and s `(,_define ,s - (,(rename 'make-setter) - ,(id->string s) - ,name - (,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) + (,(rename 'make-setter) + ,(id->string s) + ,name + (,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) fields) ;; constructor ,(if make-fields - `(,_define ,make-name - ,(let lp ((ls make-fields) (sets '())) - (cond - ((null? ls) - `(,_let ((%make (,(rename 'make-constructor) - ,(id->string make-name) - ,name))) - (,_lambda ,make-fields - (,_let ((res (%make))) - ,@sets - res)))) - (else - (let ((field (assq (car ls) fields))) - (cond - ;;((not field) - ;; (error "unknown record field in constructor" (car ls))) - ((and (pair? field) (pair? (cdr field)) (pair? (cddr field))) - (lp (cdr ls) - (cons (list (caddr field) 'res (car ls)) sets))) - (else - (lp (cdr ls) - (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets))))))))) - `(,_define ,make-name - (,_let ((%make (,(rename 'make-constructor) - ,(id->string make-name) - ,name))) - (,_lambda args - (,_let ((res (%make))) - (let lp ((a args) - (p (,_vector->list (,_rtd-all-field-names ,name)))) - (cond - ((null? a) - (if (null? p) - res - (error ,(string-append "not enough arguments to " (id->string make-name) ": missing") - p))) - ((null? p) - (error ,(string-append "too many arguments to " (id->string make-name)) - a)) - (else - (,_slot-set! ,name res (,_type_slot_offset ,name (car p)) (car a)) - (lp (cdr a) (cdr p))))))))) - )))))) + `(,_define ,make-name + ,(let lp ((ls make-fields) (sets '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(id->string make-name) + ,name))) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ;;((not field) + ;; (error "unknown record field in constructor" (car ls))) + ((and (pair? field) (pair? (cdr field)) (pair? (cddr field))) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets))) + (else + (lp (cdr ls) + (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets))))))))) + `(,_define ,make-name + (,_let ((%make (,(rename 'make-constructor) + ,(id->string make-name) + ,name))) + (,_lambda args + (,_let ((res (%make))) + (let lp ((a args) + (p (,_vector->list (,_rtd-all-field-names ,name)))) + (cond + ((null? a) + (if (null? p) + res + (error ,(string-append "not enough arguments to " (id->string make-name) ": missing") + p))) + ((null? p) + (error ,(string-append "too many arguments to " (id->string make-name)) + a)) + (else + (,_slot-set! ,name res (,_type_slot_offset ,name (car p)) (car a)) + (lp (cdr a) (cdr p))))))))))))))) From 69f3dcc3fd19fe6de23a53cfc70b7c032e2717f1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 17 Sep 2010 08:11:25 +0900 Subject: [PATCH 535/535] adding port? predicate --- lib/init.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/init.scm b/lib/init.scm index 62d044ec..c8a807e7 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -525,6 +525,8 @@ ;; I/O utils +(define (port? x) (or (input-port? x) (output-port? x))) + (define (char-ready? . o) (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port))))))