/* scheme.c -- SCHEME INTERPRETER EXAMPLE FOR THE MEMORY POOL SYSTEM * * Copyright (c) 2001-2020 Ravenbrook Limited. See end of file for license. * * This is a toy interpreter for a subset of the Scheme programming * language . * It is by no means the best or even the right way to implement Scheme, * but it serves the purpose of showing how the Memory Pool System can be * used as part of a programming language run-time system. * * To try it out, "make scheme-advanced" then * * $ ./scheme * (define (triangle n) (if (eqv? n 0) 0 (+ n (triangle (- n 1))))) * (define (church n f a) (if (eqv? n 0) a (church (- n 1) f (f a)))) * (church 1000 triangle 0) * * This won't produce interesting results but it will cause garbage * collection cycles. Note that there's never any waiting for the MPS. * THAT'S THE POINT. * * To find the code that's particularly related to the MPS, search for %%MPS. * * * MPS TO DO LIST * - make an mps_perror * * * SCHEME TO DO LIST * - unbounded integers, other number types. * - named let. * - quasiquote: vectors; nested; dotted. * - Lots of library. * - \#foo unsatisfactory in read and print */ #include #include #include #include #include #include #include #include #include #include #include "mps.h" #include "mpsavm.h" #include "mpscamc.h" #include "mpscawl.h" /* LANGUAGE EXTENSION */ #define unless(c) if(!(c)) #define LENGTH(array) (sizeof(array) / sizeof(array[0])) #define UNUSED(var) ((void)var) /* CONFIGURATION PARAMETERS */ #define SYMMAX ((size_t)255) /* max length of a symbol */ #define MSGMAX ((size_t)255) /* max length of error message */ #define STRMAX ((size_t)255) /* max length of a string */ /* DATA TYPES */ /* obj_t -- scheme object type * * obj_t is a pointer to a union, obj_u, which has members for * each scheme representation. * * The obj_u also has a "type" member. Each representation * structure also has a "type" field first. ANSI C guarantees * that these type fields correspond [section?]. * * Objects are allocated by allocating one of the representation * structures and casting the pointer to it to type obj_t. This * allows objects of different sizes to be represented by the * same type. * * To access an object, check its type by reading TYPE(obj), then * access the fields of the representation, e.g. * if(TYPE(obj) == TYPE_PAIR) fiddle_with(CAR(obj)); */ typedef union obj_u *obj_t; typedef obj_t (*entry_t)(obj_t env, obj_t op_env, obj_t operator, obj_t rands); typedef int type_t; enum { TYPE_PAIR, TYPE_INTEGER, TYPE_SYMBOL, TYPE_SPECIAL, TYPE_OPERATOR, TYPE_STRING, TYPE_PORT, TYPE_PROMISE, TYPE_CHARACTER, TYPE_VECTOR, TYPE_TABLE, TYPE_FWD2, /* two-word forwarding object */ TYPE_FWD, /* three words and up forwarding object */ TYPE_PAD1, /* one-word padding object */ TYPE_PAD /* two words and up padding object */ }; typedef struct type_s { type_t type; } type_s; typedef struct pair_s { type_t type; /* TYPE_PAIR */ obj_t car, cdr; /* first and second projections */ } pair_s; typedef struct symbol_s { type_t type; /* TYPE_SYMBOL */ obj_t name; /* its name (a string) */ } symbol_s; typedef struct integer_s { type_t type; /* TYPE_INTEGER */ long integer; /* the integer */ } integer_s; typedef struct special_s { type_t type; /* TYPE_SPECIAL */ const char *name; /* printed representation, NUL terminated */ } special_s; typedef struct operator_s { type_t type; /* TYPE_OPERATOR */ const char *name; /* printed name, NUL terminated */ entry_t entry; /* entry point -- see eval() */ obj_t arguments, body; /* function arguments and code */ obj_t env, op_env; /* closure environments */ } operator_s; typedef struct string_s { type_t type; /* TYPE_STRING */ size_t length; /* number of chars in string */ char string[1]; /* string, NUL terminated */ } string_s; typedef struct port_s { type_t type; /* TYPE_PORT */ obj_t name; /* name of stream */ FILE *stream; } port_s; typedef struct character_s { type_t type; /* TYPE_CHARACTER */ char c; /* the character */ } character_s; typedef struct vector_s { type_t type; /* TYPE_VECTOR */ size_t length; /* number of elements */ obj_t vector[1]; /* vector elements */ } vector_s; /* %%MPS: Objects in AWL pools must be formatted so that aligned * pointers (with bottom bit(s) zero) can be distinguished from other * data types (with bottom bit(s) non-zero). Here we use a bottom * bit of 1 for integers. See pool/awl. */ #define TAG_COUNT(i) (((i) << 1) + 1) #define UNTAG_COUNT(i) ((i) >> 1) typedef struct buckets_s { struct buckets_s *dependent; /* the dependent object */ size_t length; /* number of buckets (tagged) */ size_t used; /* number of buckets in use (tagged) */ size_t deleted; /* number of deleted buckets (tagged) */ obj_t bucket[1]; /* hash buckets */ } buckets_s, *buckets_t; typedef unsigned long (*hash_t)(obj_t obj, mps_ld_t ld); typedef int (*cmp_t)(obj_t obj1, obj_t obj2); /* %%MPS: The hash table is address-based, and so depends on the * location of its keys: when the garbage collector moves the keys, * the table needs to be re-hashed. The 'ld' structure is used to * detect this. See topic/location. */ typedef struct table_s { type_t type; /* TYPE_TABLE */ hash_t hash; /* hash function */ cmp_t cmp; /* comparison function */ mps_ld_s ld; /* location dependency */ mps_ap_t key_ap, value_ap; /* allocation points for keys and values */ buckets_t keys, values; /* hash buckets for keys and values */ } table_s; /* fwd2, fwd, pad1, pad -- MPS forwarding and padding objects %%MPS * * These object types are here to satisfy the MPS Format Protocol. * See topic/format. * * The MPS needs to be able to replace any object with a forwarding * object or broken heart and since the smallest normal object defined * above is two words long, we have two kinds of forwarding objects: * FWD2 is exactly two words long, and FWD stores a size for larger * objects. There are cleverer ways to do this with bit twiddling, of * course. * * The MPS needs to be able to pad out any area of memory that's a * multiple of the pool alignment. We've chosen an single word alignment * for this interpreter, so we have to have a special padding object, PAD1, * for single words. For padding multiple words we use PAD objects with a * size field. * * See obj_pad, obj_fwd etc. to see how these are used. */ typedef struct fwd2_s { type_t type; /* TYPE_FWD2 */ obj_t fwd; /* forwarded object */ } fwd2_s; typedef struct fwd_s { type_t type; /* TYPE_FWD */ obj_t fwd; /* forwarded object */ size_t size; /* total size of this object */ } fwd_s; typedef struct pad1_s { type_t type; /* TYPE_PAD1 */ } pad1_s; typedef struct pad_s { type_t type; /* TYPE_PAD */ size_t size; /* total size of this object */ } pad_s; typedef union obj_u { type_s type; /* one of TYPE_* */ pair_s pair; symbol_s symbol; integer_s integer; special_s special; operator_s operator; string_s string; port_s port; character_s character; vector_s vector; table_s table; fwd2_s fwd2; fwd_s fwd; pad_s pad; } obj_s; /* structure macros */ #define TYPE(obj) ((obj)->type.type) #define CAR(obj) ((obj)->pair.car) #define CDR(obj) ((obj)->pair.cdr) #define CAAR(obj) CAR(CAR(obj)) #define CADR(obj) CAR(CDR(obj)) #define CDAR(obj) CDR(CAR(obj)) #define CDDR(obj) CDR(CDR(obj)) #define CADDR(obj) CAR(CDDR(obj)) #define CDDDR(obj) CDR(CDDR(obj)) #define CDDAR(obj) CDR(CDAR(obj)) #define CADAR(obj) CAR(CDAR(obj)) /* GLOBAL DATA */ /* total -- total allocated bytes */ static size_t total; /* symtab -- symbol table %%MPS * * The symbol table is a weak-value hashtable mapping objects of * TYPE_STRING to objects of TYPE_SYMBOL. When a string is "interned" * it is looked up in the table, and added only if it is not there. * This guarantees that all symbols which are equal are actually the * same object. */ static obj_t symtab; static mps_root_t symtab_root; /* special objects %%MPS * * These global variables are initialized to point to objects of * TYPE_SPECIAL by main. They are used as markers for various * special purposes. * * These static global variable refer to object allocated in the `obj_pool` * and so they must also be declared to the MPS as roots. * See `globals_scan`. */ static obj_t obj_empty; /* (), the empty list */ static obj_t obj_eof; /* end of file */ static obj_t obj_error; /* error indicator */ static obj_t obj_true; /* #t, boolean true */ static obj_t obj_false; /* #f, boolean false */ static obj_t obj_undefined; /* undefined result indicator */ static obj_t obj_tail; /* tail recursion indicator */ static obj_t obj_deleted; /* deleted key in hashtable */ static obj_t obj_unused; /* unused entry in hashtable */ /* predefined symbols * * These global variables are initialized to point to interned * objects of TYPE_SYMBOL. They have special meaning in the * Scheme language, and are used by the evaluator to parse code. */ static obj_t obj_quote; /* "quote" symbol */ static obj_t obj_quasiquote; /* "quasiquote" symbol */ static obj_t obj_lambda; /* "lambda" symbol */ static obj_t obj_begin; /* "begin" symbol */ static obj_t obj_else; /* "else" symbol */ static obj_t obj_unquote; /* "unquote" symbol */ static obj_t obj_unquote_splic; /* "unquote-splicing" symbol */ /* error handler * * The error_handler variable is initialized to point at a * jmp_buf to which the "error" function longjmps if there is * any kind of error during evaluation. It can be set up by * any enclosing function that wants to catch errors. There * is a default error handler in `start`, in the read-eval-print * loop. The error function also writes an error message * into "error_message" before longjmping, and this can be * displayed to the user when catching the error. * * [An error code should also be passed so that the error can * be decoded by enclosing code.] */ static jmp_buf *error_handler = NULL; static char error_message[MSGMAX+1]; /* MPS globals %%MPS * * These are global variables holding MPS values for use by the * interpreter. In a more sophisticated integration some of these might * be thread local. See `main` for where these are set up. * * `arena` is the global state of the MPS, and there's usually only one * per process. See topic/arena. * * `obj_pool` is the memory pool in which the Scheme objects are allocated. * It is an instance of the Automatic Mostly Copying (AMC) pool class, which * is a general-purpose garbage collector for use when there are formatted * objects in the pool, but ambiguous references in thread stacks and * registers. See pool/amc. * * `obj_ap` is an Allocation Point that allows fast in-line non-locking * allocation in a memory pool. This would usually be thread-local, but * this interpreter is single-threaded. See `make_pair` etc. for how this * is used with the reserve/commit protocol. * * `buckets_pool` is the memory pool for hash table buckets. There are * two allocation points, one for buckets containing exact (strong) * references, the other for buckets containing weak references. */ static mps_arena_t arena; /* the arena */ static mps_pool_t obj_pool; /* pool for ordinary Scheme objects */ static mps_ap_t obj_ap; /* allocation point used to allocate objects */ static mps_pool_t leaf_pool; /* pool for leaf objects */ static mps_ap_t leaf_ap; /* allocation point for leaf objects */ static mps_pool_t buckets_pool; /* pool for hash table buckets */ static mps_ap_t strong_buckets_ap; /* allocation point for strong buckets */ static mps_ap_t weak_buckets_ap; /* allocation point for weak buckets */ /* SUPPORT FUNCTIONS */ /* error -- throw an error condition * * The "error" function takes a printf-style format string * and arguments, writes the message into error_message and * longjmps to *error_handler. There must be a setjmp at * the other end to catch the condition and display the * message. */ static void error(const char *format, ...) { va_list args; va_start(args, format); vsnprintf(error_message, sizeof error_message, format, args); va_end(args); if (error_handler) { longjmp(*error_handler, 1); } else { fflush(stdout); fprintf(stderr, "Fatal error during initialization: %s\n", error_message); abort(); } } /* make_* -- object constructors %%MPS * * Each object type has a function here that allocates an instance of * that type. * * These functions illustrate the two-phase MPS Allocation Point * Protocol with `reserve` and `commit`. This protocol allows very fast * in-line allocation without locking, but there is a very tiny chance that * the object must be re-initialized. In nearly all cases, however, it's * just a pointer bump. See topic/allocation. * * NOTE: We could reduce duplicated code here using macros, but we want to * write these out because this is code to illustrate how to use the * protocol. */ #define ALIGNMENT sizeof(mps_word_t) /* Align size upwards to the next multiple of the word size. */ #define ALIGN_WORD(size) \ (((size) + ALIGNMENT - 1) & ~(ALIGNMENT - 1)) /* Align size upwards to the next multiple of the word size, and * additionally ensure that it's big enough to store a forwarding * pointer. Evaluates its argument twice. */ #define ALIGN_OBJ(size) \ (ALIGN_WORD(size) >= ALIGN_WORD(sizeof(fwd_s)) \ ? ALIGN_WORD(size) \ : ALIGN_WORD(sizeof(fwd_s))) static obj_t make_bool(int condition) { return condition ? obj_true : obj_false; } static obj_t make_pair(obj_t car, obj_t cdr) { obj_t obj; mps_addr_t addr; /* When using the allocation point protocol it is up to the client code to ensure that all requests are for aligned sizes, because in nearly all cases `mps_reserve` is just an increment to a pointer. */ size_t size = ALIGN_OBJ(sizeof(pair_s)); do { mps_res_t res = mps_reserve(&addr, obj_ap, size); if (res != MPS_RES_OK) error("out of memory in make_pair"); obj = addr; obj->pair.type = TYPE_PAIR; CAR(obj) = car; CDR(obj) = cdr; /* `mps_commit` returns false on very rare occasions (when an MPS epoch change has happened since reserve) but in those cases the object must be re-initialized. It's therefore important not to do anything you don't want to repeat between reserve and commit. Also, the shorter the time between reserve and commit, the less likely commit is to return false. */ } while(!mps_commit(obj_ap, addr, size)); total += sizeof(pair_s); return obj; } static obj_t make_integer(long integer) { obj_t obj; mps_addr_t addr; size_t size = ALIGN_OBJ(sizeof(integer_s)); do { mps_res_t res = mps_reserve(&addr, leaf_ap, size); if (res != MPS_RES_OK) error("out of memory in make_integer"); obj = addr; obj->integer.type = TYPE_INTEGER; obj->integer.integer = integer; } while(!mps_commit(leaf_ap, addr, size)); total += sizeof(integer_s); return obj; } static obj_t make_symbol(obj_t name) { obj_t obj; mps_addr_t addr; size_t size = ALIGN_OBJ(sizeof(symbol_s)); assert(TYPE(name) == TYPE_STRING); do { mps_res_t res = mps_reserve(&addr, obj_ap, size); if (res != MPS_RES_OK) error("out of memory in make_symbol"); obj = addr; obj->symbol.type = TYPE_SYMBOL; obj->symbol.name = name; } while(!mps_commit(obj_ap, addr, size)); total += size; return obj; } static obj_t make_string(size_t length, const char *string) { obj_t obj; mps_addr_t addr; size_t size = ALIGN_OBJ(offsetof(string_s, string) + length+1); do { mps_res_t res = mps_reserve(&addr, leaf_ap, size); if (res != MPS_RES_OK) error("out of memory in make_string"); obj = addr; obj->string.type = TYPE_STRING; obj->string.length = length; if (string) memcpy(obj->string.string, string, length+1); else memset(obj->string.string, 0, length+1); } while(!mps_commit(leaf_ap, addr, size)); total += size; return obj; } static obj_t make_special(const char *string) { obj_t obj; mps_addr_t addr; size_t size = ALIGN_OBJ(sizeof(special_s)); do { mps_res_t res = mps_reserve(&addr, leaf_ap, size); if (res != MPS_RES_OK) error("out of memory in make_special"); obj = addr; obj->special.type = TYPE_SPECIAL; obj->special.name = string; } while(!mps_commit(leaf_ap, addr, size)); total += sizeof(special_s); return obj; } static obj_t make_operator(const char *name, entry_t entry, obj_t arguments, obj_t body, obj_t env, obj_t op_env) { obj_t obj; mps_addr_t addr; size_t size = ALIGN_OBJ(sizeof(operator_s)); do { mps_res_t res = mps_reserve(&addr, obj_ap, size); if (res != MPS_RES_OK) error("out of memory in make_operator"); obj = addr; obj->operator.type = TYPE_OPERATOR; obj->operator.name = name; obj->operator.entry = entry; obj->operator.arguments = arguments; obj->operator.body = body; obj->operator.env = env; obj->operator.op_env = op_env; } while(!mps_commit(obj_ap, addr, size)); total += sizeof(operator_s); return obj; } static obj_t make_port(obj_t name, FILE *stream) { mps_addr_t port_ref; obj_t obj; mps_addr_t addr; size_t size = ALIGN_OBJ(sizeof(port_s)); do { mps_res_t res = mps_reserve(&addr, obj_ap, size); if (res != MPS_RES_OK) error("out of memory in make_port"); obj = addr; obj->port.type = TYPE_PORT; obj->port.name = name; obj->port.stream = stream; } while(!mps_commit(obj_ap, addr, size)); total += sizeof(port_s); /* %%MPS: Register the port object for finalization. When the object is no longer referenced elsewhere, a message will be received in `mps_chat` so that the file can be closed. See topic/finalization. */ port_ref = obj; mps_finalize(arena, &port_ref); return obj; } static obj_t make_character(char c) { obj_t obj; mps_addr_t addr; size_t size = ALIGN_OBJ(sizeof(character_s)); do { mps_res_t res = mps_reserve(&addr, leaf_ap, size); if (res != MPS_RES_OK) error("out of memory in make_character"); obj = addr; obj->character.type = TYPE_CHARACTER; obj->character.c = c; } while(!mps_commit(leaf_ap, addr, size)); total += sizeof(character_s); return obj; } static obj_t make_vector(size_t length, obj_t fill) { obj_t obj; mps_addr_t addr; size_t size = ALIGN_OBJ(offsetof(vector_s, vector) + length * sizeof(obj_t)); do { mps_res_t res = mps_reserve(&addr, obj_ap, size); size_t i; if (res != MPS_RES_OK) error("out of memory in make_vector"); obj = addr; obj->vector.type = TYPE_VECTOR; obj->vector.length = length; for(i = 0; i < length; ++i) obj->vector.vector[i] = fill; } while(!mps_commit(obj_ap, addr, size)); total += size; return obj; } static buckets_t make_buckets(size_t length, mps_ap_t ap) { buckets_t buckets; mps_addr_t addr; size_t size; size = ALIGN_OBJ(offsetof(buckets_s, bucket) + length * sizeof(buckets->bucket[0])); do { mps_res_t res = mps_reserve(&addr, ap, size); size_t i; if (res != MPS_RES_OK) error("out of memory in make_buckets"); buckets = addr; buckets->dependent = NULL; buckets->length = TAG_COUNT(length); buckets->used = TAG_COUNT(0); buckets->deleted = TAG_COUNT(0); for(i = 0; i < length; ++i) { buckets->bucket[i] = obj_unused; } } while(!mps_commit(ap, addr, size)); total += size; return buckets; } static obj_t make_table(size_t length, hash_t hashf, cmp_t cmpf, int weak_key, int weak_value) { obj_t obj; mps_addr_t addr; size_t l, size = ALIGN_OBJ(sizeof(table_s)); do { mps_res_t res = mps_reserve(&addr, obj_ap, size); if (res != MPS_RES_OK) error("out of memory in make_table"); obj = addr; obj->table.type = TYPE_TABLE; obj->table.keys = obj->table.values = NULL; } while(!mps_commit(obj_ap, addr, size)); total += size; obj->table.hash = hashf; obj->table.cmp = cmpf; /* round up to next power of 2 */ for(l = 1; l < length; l *= 2); obj->table.key_ap = weak_key ? weak_buckets_ap : strong_buckets_ap; obj->table.value_ap = weak_value ? weak_buckets_ap : strong_buckets_ap; obj->table.keys = make_buckets(l, obj->table.key_ap); obj->table.values = make_buckets(l, obj->table.value_ap); obj->table.keys->dependent = obj->table.values; obj->table.values->dependent = obj->table.keys; mps_ld_reset(&obj->table.ld, arena); return obj; } /* getnbc -- get next non-blank char from stream */ static int getnbc(FILE *stream) { int c; do { c = getc(stream); if(c == ';') { do c = getc(stream); while(c != EOF && c != '\n'); } } while(isspace(c)); return c; } /* isealpha -- test for "extended alphabetic" char * * Scheme symbols may contain any "extended alphabetic" * character (see section 2.1 of R4RS). This function * returns non-zero if a character is in the set of * extended characters. */ static int isealpha(int c) { return strchr("+-.*/<=>!?:$%_&~^", c) != NULL; } /* hash -- hash a string to an unsigned long * * This hash function was derived (with permission) from * Paul Haahr's hash in the most excellent rc 1.4. */ static unsigned long hash(const char *s, size_t length) { unsigned long c, h=0; size_t i = 0; switch(length % 4) { do { c=(unsigned long)s[i++]; h+=(c<<17)^(c<<11)^(c<<5)^(c>>1); case 3: c=(unsigned long)s[i++]; h^=(c<<14)+(c<<7)+(c<<4)+c; case 2: c=(unsigned long)s[i++]; h^=(~c<<11)|((c<<3)^(c>>1)); case 1: c=(unsigned long)s[i++]; h-=(c<<16)|(c<<9)|(c<<2)|(c&3); case 0: ; } while(i < length); } return h; } /* Hash table implementation */ /* %%MPS: When taking the hash of an address, we record the dependency * on its location by calling mps_ld_add. See topic/location. */ static unsigned long eq_hash(obj_t obj, mps_ld_t ld) { union {char s[sizeof(obj_t)]; obj_t addr;} u; if (ld) mps_ld_add(ld, arena, obj); u.addr = obj; return hash(u.s, sizeof(obj_t)); } static int eqp(obj_t obj1, obj_t obj2) { return obj1 == obj2; } static unsigned long eqv_hash(obj_t obj, mps_ld_t ld) { switch(TYPE(obj)) { case TYPE_INTEGER: return (unsigned long)obj->integer.integer; case TYPE_CHARACTER: return (unsigned long)obj->character.c; default: return eq_hash(obj, ld); } } static int eqvp(obj_t obj1, obj_t obj2) { if (obj1 == obj2) return 1; if (TYPE(obj1) != TYPE(obj2)) return 0; switch(TYPE(obj1)) { case TYPE_INTEGER: return obj1->integer.integer == obj2->integer.integer; case TYPE_CHARACTER: return obj1->character.c == obj2->character.c; default: return 0; } } static unsigned long string_hash(obj_t obj, mps_ld_t ld) { UNUSED(ld); unless(TYPE(obj) == TYPE_STRING) error("string-hash: argument must be a string"); return hash(obj->string.string, obj->string.length); } static int string_equalp(obj_t obj1, obj_t obj2) { return obj1 == obj2 || (TYPE(obj1) == TYPE_STRING && TYPE(obj2) == TYPE_STRING && obj1->string.length == obj2->string.length && 0 == strcmp(obj1->string.string, obj2->string.string)); } static int buckets_find(obj_t tbl, buckets_t buckets, obj_t key, int add, size_t *b) { unsigned long i, h, probe; unsigned long l = UNTAG_COUNT(buckets->length) - 1; int result = 0; assert(TYPE(tbl) == TYPE_TABLE); h = tbl->table.hash(key, add ? &tbl->table.ld : NULL); probe = (h >> 8) | 1; h &= l; i = h; do { obj_t k = buckets->bucket[i]; if(k == obj_unused || tbl->table.cmp(k, key)) { *b = i; return 1; } if(result == 0 && k == obj_deleted) { *b = i; result = 1; } i = (i+probe) & l; } while(i != h); return result; } static size_t table_size(obj_t tbl) { size_t used, deleted; assert(TYPE(tbl) == TYPE_TABLE); used = UNTAG_COUNT(tbl->table.keys->used); deleted = UNTAG_COUNT(tbl->table.keys->deleted); assert(used >= deleted); return used - deleted; } /* Rehash 'tbl' so that it has 'new_length' buckets. If 'key' is found * during this process, update 'key_bucket' to be the index of the * bucket containing 'key' and return true, otherwise return false. * * %%MPS: When re-hashing the table we reset the associated location * dependency and re-add a dependency on each object in the table. * This is because the table gets re-hashed when the locations of * objects have changed. See topic/location. */ static int table_rehash(obj_t tbl, size_t new_length, obj_t key, size_t *key_bucket) { size_t i, length; buckets_t new_keys, new_values; int result = 0; assert(TYPE(tbl) == TYPE_TABLE); length = UNTAG_COUNT(tbl->table.keys->length); new_keys = make_buckets(new_length, tbl->table.key_ap); new_values = make_buckets(new_length, tbl->table.value_ap); new_keys->dependent = new_values; new_values->dependent = new_keys; mps_ld_reset(&tbl->table.ld, arena); for (i = 0; i < length; ++i) { obj_t old_key = tbl->table.keys->bucket[i]; if (old_key != obj_unused && old_key != obj_deleted) { int found; size_t b; found = buckets_find(tbl, new_keys, old_key, 1, &b); assert(found); /* new table shouldn't be full */ assert(new_keys->bucket[b] == obj_unused); /* shouldn't be in new table */ new_keys->bucket[b] = old_key; new_values->bucket[b] = tbl->table.values->bucket[i]; if (key != NULL && tbl->table.cmp(old_key, key)) { *key_bucket = b; result = 1; } new_keys->used = TAG_COUNT(UNTAG_COUNT(new_keys->used) + 1); } } assert(UNTAG_COUNT(new_keys->used) == table_size(tbl)); tbl->table.keys = new_keys; tbl->table.values = new_values; return result; } /* %%MPS: If we fail to find 'key' in the table, and if mps_ld_isstale * returns true, then some of the keys in the table might have been * moved by the garbage collector: in this case we need to re-hash the * table. See topic/location. */ static int table_find(obj_t tbl, obj_t key, int add, size_t *b) { if (!buckets_find(tbl, tbl->table.keys, key, add, b)) { return 0; } else if ((tbl->table.keys->bucket[*b] == obj_unused || tbl->table.keys->bucket[*b] == obj_deleted) && mps_ld_isstale(&tbl->table.ld, arena, key)) { return table_rehash(tbl, UNTAG_COUNT(tbl->table.keys->length), key, b); } else { return 1; } } static obj_t table_ref(obj_t tbl, obj_t key) { size_t b; assert(TYPE(tbl) == TYPE_TABLE); if (table_find(tbl, key, 0, &b)) { obj_t k = tbl->table.keys->bucket[b]; if (k != obj_unused && k != obj_deleted) return tbl->table.values->bucket[b]; } return NULL; } static int table_try_set(obj_t tbl, obj_t key, obj_t value) { size_t b; assert(TYPE(tbl) == TYPE_TABLE); if (!table_find(tbl, key, 1, &b)) return 0; if (tbl->table.keys->bucket[b] == obj_unused) { tbl->table.keys->bucket[b] = key; tbl->table.keys->used = TAG_COUNT(UNTAG_COUNT(tbl->table.keys->used) + 1); } else if (tbl->table.keys->bucket[b] == obj_deleted) { tbl->table.keys->bucket[b] = key; assert(tbl->table.keys->deleted > TAG_COUNT(0)); tbl->table.keys->deleted = TAG_COUNT(UNTAG_COUNT(tbl->table.keys->deleted) - 1); } tbl->table.values->bucket[b] = value; return 1; } static int table_full(obj_t tbl) { assert(TYPE(tbl) == TYPE_TABLE); return tbl->table.keys->used >= tbl->table.keys->length / 2; } static void table_set(obj_t tbl, obj_t key, obj_t value) { assert(TYPE(tbl) == TYPE_TABLE); if (table_full(tbl) || !table_try_set(tbl, key, value)) { int res; table_rehash(tbl, UNTAG_COUNT(tbl->table.keys->length) * 2, NULL, NULL); res = table_try_set(tbl, key, value); assert(res); /* rehash should have made room */ } } static void table_delete(obj_t tbl, obj_t key) { size_t b; assert(TYPE(tbl) == TYPE_TABLE); if(table_find(tbl, key, 0, &b) && tbl->table.keys->bucket[b] != obj_unused && tbl->table.keys->bucket[b] != obj_deleted) { tbl->table.keys->bucket[b] = obj_deleted; tbl->table.keys->deleted = TAG_COUNT(UNTAG_COUNT(tbl->table.keys->deleted) + 1); tbl->table.values->bucket[b] = NULL; } } static obj_t intern_string(obj_t name) { obj_t symbol; assert(TYPE(name) == TYPE_STRING); symbol = table_ref(symtab, name); if(symbol == NULL) { symbol = make_symbol(name); table_set(symtab, name, symbol); } return symbol; } static obj_t intern(const char *string) { return intern_string(make_string(strlen(string), string)); } static char *symbol_name(obj_t symbol) { assert(TYPE(symbol) == TYPE_SYMBOL); assert(TYPE(symbol->symbol.name) == TYPE_STRING); return symbol->symbol.name->string.string; } static void port_close(obj_t port) { assert(TYPE(port) == TYPE_PORT); if(port->port.stream != NULL) { fclose(port->port.stream); port->port.stream = NULL; } } static void print(obj_t obj, long depth, FILE *stream) { if (depth < 0) { depth = -1; } switch(TYPE(obj)) { case TYPE_INTEGER: { fprintf(stream, "%ld", obj->integer.integer); } break; case TYPE_SYMBOL: { fputs(symbol_name(obj), stream); } break; case TYPE_SPECIAL: { fputs(obj->special.name, stream); } break; case TYPE_PORT: { assert(TYPE(obj->port.name) == TYPE_STRING); fprintf(stream, "#[port \"%s\"]", obj->port.name->string.string); } break; case TYPE_STRING: { size_t i; putc('"', stream); for(i = 0; i < obj->string.length; ++i) { char c = obj->string.string[i]; switch(c) { case '\\': fputs("\\\\", stream); break; case '"': fputs("\\\"", stream); break; default: putc(c, stream); break; } } putc('"', stream); } break; case TYPE_PROMISE: { assert(CAR(obj) == obj_true || CAR(obj) == obj_false); fprintf(stream, "#[%sevaluated promise ", CAR(obj) == obj_false ? "un" : ""); print(CDR(obj), depth - 1, stream); putc(']', stream); } break; case TYPE_PAIR: { if(TYPE(CAR(obj)) == TYPE_SYMBOL && TYPE(CDR(obj)) == TYPE_PAIR && CDDR(obj) == obj_empty) { if(CAR(obj) == obj_quote) { putc('\'', stream); if(depth == 0) fputs("...", stream); else print(CADR(obj), depth - 1, stream); break; } if(CAR(obj) == obj_quasiquote) { putc('`', stream); if(depth == 0) fputs("...", stream); else print(CADR(obj), depth - 1, stream); break; } if(CAR(obj) == obj_unquote) { putc(',', stream); if(depth == 0) fputs("...", stream); else print(CADR(obj), depth - 1, stream); break; } if(CAR(obj) == obj_unquote_splic) { fputs(",@", stream); if(depth == 0) fputs("...", stream); else print(CADR(obj), depth - 1, stream); break; } } putc('(', stream); if(depth == 0) fputs("...", stream); else { for(;;) { print(CAR(obj), depth - 1, stream); obj = CDR(obj); if(TYPE(obj) != TYPE_PAIR) break; putc(' ', stream); } if(obj != obj_empty) { fputs(" . ", stream); print(obj, depth - 1, stream); } } putc(')', stream); } break; case TYPE_VECTOR: { fputs("#(", stream); if(depth == 0) fputs("...", stream); else { size_t i; for(i = 0; i < obj->vector.length; ++i) { if(i > 0) putc(' ', stream); print(obj->vector.vector[i], depth - 1, stream); } } putc(')', stream); } break; case TYPE_TABLE: { size_t i, length = UNTAG_COUNT(obj->table.keys->length); fputs("#[hashtable", stream); for(i = 0; i < length; ++i) { obj_t k = obj->table.keys->bucket[i]; if(k != obj_unused && k != obj_deleted) { fputs(" (", stream); print(k, depth - 1, stream); putc(' ', stream); print(obj->table.values->bucket[i], depth - 1, stream); putc(')', stream); } } putc(']', stream); } break; case TYPE_OPERATOR: { fprintf(stream, "#[operator \"%s\" %p ", obj->operator.name, (void *)obj); if(depth == 0) fputs("...", stream); else { print(obj->operator.arguments, depth - 1, stream); putc(' ', stream); print(obj->operator.body, depth - 1, stream); putc(' ', stream); print(obj->operator.env, depth - 1, stream); putc(' ', stream); print(obj->operator.op_env, depth - 1, stream); } putc(']', stream); } break; case TYPE_CHARACTER: { fprintf(stream, "#\\%c", obj->character.c); } break; default: assert(0); abort(); } } static obj_t read_integer(FILE *stream, int c) { long integer = 0; do { integer = integer*10 + c-'0'; c = getc(stream); } while(isdigit(c)); ungetc(c, stream); return make_integer(integer); } static obj_t read_symbol(FILE *stream, int c) { size_t length = 0; char string[SYMMAX+1]; do { string[length++] = (char)tolower(c); c = getc(stream); } while(length < SYMMAX && (isalnum(c) || isealpha(c))); if(isalnum(c) || isealpha(c)) error("read: symbol too long"); string[length] = '\0'; ungetc(c, stream); return intern(string); } static obj_t read_string(FILE *stream, int c) { size_t length = 0; char string[STRMAX+1]; for(;;) { c = getc(stream); if(c == EOF) error("read: end of file during string"); if(c == '"') break; if(length >= STRMAX) error("read: string too long"); if(c == '\\') { c = getc(stream); switch(c) { case '\\': break; case '"': break; case 'n': c = '\n'; break; case 't': c = '\t'; break; case EOF: error("read: end of file in escape sequence in string"); default: error("read: unknown escape '%c'", c); } } string[length++] = (char)c; } string[length] = '\0'; return make_string(length, string); } static obj_t read_(FILE *stream); static obj_t read_quote(FILE *stream, int c) { UNUSED(c); return make_pair(obj_quote, make_pair(read_(stream), obj_empty)); } static obj_t read_quasiquote(FILE *stream, int c) { UNUSED(c); return make_pair(obj_quasiquote, make_pair(read_(stream), obj_empty)); } static obj_t read_unquote(FILE *stream, int c) { c = getc(stream); if(c == '@') return make_pair(obj_unquote_splic, make_pair(read_(stream), obj_empty)); ungetc(c, stream); return make_pair(obj_unquote, make_pair(read_(stream), obj_empty)); } static obj_t read_list(FILE *stream, int c) { obj_t list, new, end; list = obj_empty; end = NULL; /* suppress "uninitialized" warning in GCC */ for(;;) { c = getnbc(stream); if(c == ')' || c == '.' || c == EOF) break; ungetc(c, stream); new = make_pair(read_(stream), obj_empty); if(list == obj_empty) { list = new; end = new; } else { CDR(end) = new; end = new; } } if(c == '.') { if(list == obj_empty) error("read: unexpected dot"); CDR(end) = read_(stream); c = getnbc(stream); } if(c != ')') error("read: expected close parenthesis"); return list; } static obj_t list_to_vector(obj_t list) { size_t i; obj_t l, vector; i = 0; l = list; while(TYPE(l) == TYPE_PAIR) { ++i; l = CDR(l); } if(l != obj_empty) return obj_error; vector = make_vector(i, obj_undefined); i = 0; l = list; while(TYPE(l) == TYPE_PAIR) { vector->vector.vector[i] = CAR(l); ++i; l = CDR(l); } return vector; } static obj_t read_special(FILE *stream, int c) { c = getnbc(stream); switch(tolower(c)) { case 't': return obj_true; case 'f': return obj_false; case '\\': { /* character (R4RS 6.6) */ c = getc(stream); if(c == EOF) error("read: end of file reading character literal"); return make_character((char)c); } case '(': { /* vector (R4RS 6.8) */ obj_t list = read_list(stream, c); obj_t vector = list_to_vector(list); if(vector == obj_error) error("read: illegal vector syntax"); return vector; } } error("read: unknown special '%c'", c); return obj_error; } static obj_t read_(FILE *stream) { int c; c = getnbc(stream); if(c == EOF) return obj_eof; if(isdigit(c)) return read_integer(stream, c); switch(c) { case '\'': return read_quote(stream, c); case '`': return read_quasiquote(stream, c); case ',': return read_unquote(stream, c); case '(': return read_list(stream, c); case '#': return read_special(stream, c); case '"': return read_string(stream, c); case '-': case '+': { int next = getc(stream); if(isdigit(next)) { obj_t integer = read_integer(stream, next); if(c == '-') integer->integer.integer = -integer->integer.integer; return integer; } ungetc(next, stream); } break; /* fall through to read as symbol */ } if(isalpha(c) || isealpha(c)) return read_symbol(stream, c); error("read: illegal char '%c'", c); return obj_error; } /* lookup_in_frame -- look up a symbol in single frame * * Search a single frame of the environment for a symbol binding. */ static obj_t lookup_in_frame(obj_t frame, obj_t symbol) { while(frame != obj_empty) { assert(TYPE(frame) == TYPE_PAIR); assert(TYPE(CAR(frame)) == TYPE_PAIR); assert(TYPE(CAAR(frame)) == TYPE_SYMBOL); if(CAAR(frame) == symbol) return CAR(frame); frame = CDR(frame); } return obj_undefined; } /* lookup -- look up symbol in environment * * Search an entire environment for a binding of a symbol. */ static obj_t lookup(obj_t env, obj_t symbol) { obj_t binding; while(env != obj_empty) { assert(TYPE(env) == TYPE_PAIR); binding = lookup_in_frame(CAR(env), symbol); if(binding != obj_undefined) return binding; env = CDR(env); } return obj_undefined; } /* define -- define symbol in environment * * In Scheme, define will actually rebind (i.e. set) a symbol in the * same frame of the environment, or add a binding if it wasn't already * set. This has the effect of making bindings local to functions * (see how entry_interpret adds an empty frame to the environments), * allowing recursion, and allowing redefinition at the top level. * See R4R2 section 5.2 for details. */ static void define(obj_t env, obj_t symbol, obj_t value) { obj_t binding; assert(TYPE(env) == TYPE_PAIR); /* always at least one frame */ binding = lookup_in_frame(CAR(env), symbol); if(binding != obj_undefined) CDR(binding) = value; else CAR(env) = make_pair(make_pair(symbol, value), CAR(env)); } static obj_t eval(obj_t env, obj_t op_env, obj_t exp) { for(;;) { obj_t operator; obj_t result; /* self-evaluating */ if(TYPE(exp) == TYPE_INTEGER || (TYPE(exp) == TYPE_SPECIAL && exp != obj_empty) || TYPE(exp) == TYPE_STRING || TYPE(exp) == TYPE_CHARACTER || TYPE(exp) == TYPE_OPERATOR) return exp; /* symbol lookup */ if(TYPE(exp) == TYPE_SYMBOL) { obj_t binding = lookup(env, exp); if(binding == obj_undefined) error("eval: unbound symbol \"%s\"", symbol_name(exp)); return CDR(binding); } if(TYPE(exp) != TYPE_PAIR) { error("eval: unknown syntax"); return obj_error; } /* apply operator or function */ if(TYPE(CAR(exp)) == TYPE_SYMBOL) { obj_t binding = lookup(op_env, CAR(exp)); if(binding != obj_undefined) { operator = CDR(binding); assert(TYPE(operator) == TYPE_OPERATOR); result = (*operator->operator.entry)(env, op_env, operator, CDR(exp)); goto found; } } operator = eval(env, op_env, CAR(exp)); unless(TYPE(operator) == TYPE_OPERATOR) error("eval: application of non-function"); result = (*operator->operator.entry)(env, op_env, operator, CDR(exp)); found: if (!(TYPE(result) == TYPE_PAIR && CAR(result) == obj_tail)) return result; env = CADR(result); op_env = CADDR(result); exp = CAR(CDDDR(result)); } } static void mps_chat(void); static obj_t load(obj_t env, obj_t op_env, obj_t filename) { obj_t port, result = obj_undefined; FILE *stream; assert(TYPE(filename) == TYPE_STRING); stream = fopen(filename->string.string, "r"); if(stream == NULL) error("load: cannot open %s: %s", filename->string.string, strerror(errno)); port = make_port(filename, stream); for(;;) { obj_t obj; mps_chat(); obj = read_(stream); if(obj == obj_eof) break; result = eval(env, op_env, obj); } port_close(port); return result; } /* OPERATOR UTILITIES */ /* eval_list -- evaluate list of expressions giving list of results * * eval_list evaluates a list of expressions and yields a list of their * results, in order. If the list is badly formed, an error is thrown * using the message given. */ static obj_t eval_list(obj_t env, obj_t op_env, obj_t list, const char *message) { obj_t result, end, pair; result = obj_empty; end = NULL; /* suppress "uninitialized" warning in GCC */ while(list != obj_empty) { if(TYPE(list) != TYPE_PAIR) error(message); pair = make_pair(eval(env, op_env, CAR(list)), obj_empty); if(result == obj_empty) result = pair; else CDR(end) = pair; end = pair; list = CDR(list); } return result; } /* eval_args1 -- evaluate some operator arguments * * See eval_args and eval_args_rest for usage. */ static obj_t eval_args1(const char *name, obj_t env, obj_t op_env, obj_t operands, unsigned n, va_list args) { unsigned i; for(i = 0; i < n; ++i) { unless(TYPE(operands) == TYPE_PAIR) error("eval: too few arguments to %s", name); *va_arg(args, obj_t *) = eval(env, op_env, CAR(operands)); operands = CDR(operands); } return operands; } /* eval_args -- evaluate operator arguments without rest list * * eval_args evaluates the first "n" expressions from the list of * expressions in "operands", returning the rest of the operands * unevaluated. It puts the results of evaluation in the addresses * passed in the vararg list. If the operands list is badly formed * an error is thrown using the operator name passed. For example: * * eval_args("foo", env, op_env, operands, 2, &arg1, &arg2); */ static void eval_args(const char *name, obj_t env, obj_t op_env, obj_t operands, unsigned n, ...) { va_list args; va_start(args, n); operands = eval_args1(name, env, op_env, operands, n, args); unless(operands == obj_empty) error("eval: too many arguments to %s", name); va_end(args); } /* eval_args_rest -- evaluate operator arguments with rest list * * eval_args_rest evaluates the first "n" expressions from the list of * expressions in "operands", then evaluates the rest of the operands * using eval_list and puts the result at *restp. It puts the results * of evaluating the first "n" operands in the addresses * passed in the vararg list. If the operands list is badly formed * an error is thrown using the operator name passed. For example: * * eval_args_rest("foo", env, op_env, operands, &rest, 2, &arg1, &arg2); */ static void eval_args_rest(const char *name, obj_t env, obj_t op_env, obj_t operands, obj_t *restp, unsigned n, ...) { va_list args; va_start(args, n); operands = eval_args1(name, env, op_env, operands, n, args); va_end(args); *restp = eval_list(env, op_env, operands, "eval: badly formed argument list"); } /* eval_tail -- return an object that will cause eval to loop * * Rather than calling `eval` an operator can return a special object that * causes a calling `eval` to loop, avoiding using up a C stack frame. * This implements tail recursion (in a simple way). */ static obj_t eval_tail(obj_t env, obj_t op_env, obj_t exp) { return make_pair(obj_tail, make_pair(env, make_pair(op_env, make_pair(exp, obj_empty)))); } /* eval_body -- evaluate a list of expressions, returning last result * * This is used for the bodies of forms such as let, begin, etc. where * a list of expressions is allowed. */ static obj_t eval_body(obj_t env, obj_t op_env, obj_t operator, obj_t body) { for (;;) { if (TYPE(body) != TYPE_PAIR) error("%s: illegal expression list", operator->operator.name); if (CDR(body) == obj_empty) return eval_tail(env, op_env, CAR(body)); (void)eval(env, op_env, CAR(body)); body = CDR(body); } } /* BUILT-IN OPERATORS */ /* entry_interpret -- interpreted function entry point * * When a function is made using lambda (see entry_lambda) an operator * is created with entry_interpret as its entry point, and the arguments * and body of the function. The entry_interpret function evaluates * the operands of the function and binds them to the argument names * in a new frame added to the lambda's closure environment. It then * evaluates the body in that environment, executing the function. */ static obj_t entry_interpret(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { obj_t arguments, fun_env, fun_op_env; assert(TYPE(operator) == TYPE_OPERATOR); /* Make a new frame so that bindings are local to the function. */ /* Arguments will be bound in this new frame. */ fun_env = make_pair(obj_empty, operator->operator.env); fun_op_env = make_pair(obj_empty, operator->operator.op_env); arguments = operator->operator.arguments; while(operands != obj_empty) { if(arguments == obj_empty) error("eval: function applied to too many arguments"); if(TYPE(arguments) == TYPE_SYMBOL) { define(fun_env, arguments, eval_list(env, op_env, operands, "eval: badly formed argument list")); operands = obj_empty; arguments = obj_empty; } else { assert(TYPE(arguments) == TYPE_PAIR && TYPE(CAR(arguments)) == TYPE_SYMBOL); define(fun_env, CAR(arguments), eval(env, op_env, CAR(operands))); operands = CDR(operands); arguments = CDR(arguments); } } if(arguments != obj_empty) error("eval: function applied to too few arguments"); return eval_tail(fun_env, fun_op_env, operator->operator.body); } /* entry_quote -- return operands unevaluated * * In Scheme, (quote foo) evaluates to foo (i.e. foo is not evaluated). * See R4RS 4.1.2. The reader expands "'x" to "(quote x)". */ static obj_t entry_quote(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { UNUSED(env); UNUSED(op_env); unless(TYPE(operands) == TYPE_PAIR && CDR(operands) == obj_empty) error("%s: illegal syntax", operator->operator.name); return CAR(operands); } /* entry_define -- bind a symbol in the top frame of the environment * * In Scheme, "(define )" evaluates expressions * and binds it to symbol in the top frame of the environment (see * R4RS 5.2). This code also allows the non-essential syntax for * define, "(define ( ) )" as a short-hand for * "(define (lambda () ))". */ static obj_t entry_define(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { obj_t symbol = NULL, value = NULL; unless(TYPE(operands) == TYPE_PAIR && TYPE(CDR(operands)) == TYPE_PAIR) error("%s: illegal syntax", operator->operator.name); if(TYPE(CAR(operands)) == TYPE_SYMBOL) { unless(CDDR(operands) == obj_empty) error("%s: too many arguments", operator->operator.name); symbol = CAR(operands); value = eval(env, op_env, CADR(operands)); } else if(TYPE(CAR(operands)) == TYPE_PAIR && TYPE(CAAR(operands)) == TYPE_SYMBOL) { symbol = CAAR(operands); value = eval(env, op_env, make_pair(obj_lambda, make_pair(CDAR(operands), CDR(operands)))); } else error("%s: applied to binder", operator->operator.name); define(env, symbol, value); return symbol; } /* entry_if -- one- or two-armed conditional * * "(if )" and "(if )". * See R4RS 4.1.5. */ static obj_t entry_if(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { obj_t test; unless(TYPE(operands) == TYPE_PAIR && TYPE(CDR(operands)) == TYPE_PAIR && (CDDR(operands) == obj_empty || (TYPE(CDDR(operands)) == TYPE_PAIR && CDDDR(operands) == obj_empty))) error("%s: illegal syntax", operator->operator.name); test = eval(env, op_env, CAR(operands)); /* Anything which is not #f counts as true [R4RS 6.1]. */ if(test != obj_false) return eval_tail(env, op_env, CADR(operands)); if(TYPE(CDDR(operands)) == TYPE_PAIR) return eval_tail(env, op_env, CADDR(operands)); return obj_undefined; } /* entry_cond -- general conditional * * "(cond ( ...) ( ...) ... [(else ...)])" */ static obj_t entry_cond(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { unless(TYPE(operands) == TYPE_PAIR) error("%s: illegal syntax", operator->operator.name); while(TYPE(operands) == TYPE_PAIR) { obj_t clause = CAR(operands); obj_t result; unless(TYPE(clause) == TYPE_PAIR && TYPE(CDR(clause)) == TYPE_PAIR) error("%s: illegal clause syntax", operator->operator.name); if(CAR(clause) == obj_else) { unless(CDR(operands) == obj_empty) error("%s: else clause must come last", operator->operator.name); result = obj_true; } else result = eval(env, op_env, CAR(clause)); if(result != obj_false) { if (CDR(clause) == obj_empty) return result; return eval_body(env, op_env, operator, CDR(clause)); } operands = CDR(operands); } return obj_undefined; } /* entry_and -- (and ...) */ static obj_t entry_and(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { obj_t test; if (operands == obj_empty) return obj_true; do { if (TYPE(operands) != TYPE_PAIR) error("%s: illegal syntax", operator->operator.name); if (CDR(operands) == obj_empty) return eval_tail(env, op_env, CAR(operands)); test = eval(env, op_env, CAR(operands)); operands = CDR(operands); } while (test != obj_false); return test; } /* entry_or -- (or ...) */ static obj_t entry_or(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { obj_t test; if (operands == obj_empty) return obj_false; do { if (TYPE(operands) != TYPE_PAIR) error("%s: illegal syntax", operator->operator.name); if (CDR(operands) == obj_empty) return eval_tail(env, op_env, CAR(operands)); test = eval(env, op_env, CAR(operands)); operands = CDR(operands); } while (test == obj_false); return test; } /* entry_let -- (let ) */ /* TODO: Too much common code with let* */ static obj_t entry_let(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { obj_t inner_env, bindings; unless(TYPE(operands) == TYPE_PAIR && TYPE(CDR(operands)) == TYPE_PAIR) error("%s: illegal syntax", operator->operator.name); inner_env = make_pair(obj_empty, env); /* TODO: common with interpret */ bindings = CAR(operands); while(TYPE(bindings) == TYPE_PAIR) { obj_t binding = CAR(bindings); unless(TYPE(binding) == TYPE_PAIR && TYPE(CAR(binding)) == TYPE_SYMBOL && TYPE(CDR(binding)) == TYPE_PAIR && CDDR(binding) == obj_empty) error("%s: illegal binding", operator->operator.name); define(inner_env, CAR(binding), eval(env, op_env, CADR(binding))); bindings = CDR(bindings); } if(bindings != obj_empty) error("%s: illegal bindings list", operator->operator.name); return eval_body(inner_env, op_env, operator, CDR(operands)); } /* entry_let_star -- (let* ) */ /* TODO: Too much common code with let */ static obj_t entry_let_star(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { obj_t inner_env, bindings; unless(TYPE(operands) == TYPE_PAIR && TYPE(CDR(operands)) == TYPE_PAIR) error("%s: illegal syntax", operator->operator.name); inner_env = make_pair(obj_empty, env); /* TODO: common with interpret */ bindings = CAR(operands); while(TYPE(bindings) == TYPE_PAIR) { obj_t binding = CAR(bindings); unless(TYPE(binding) == TYPE_PAIR && TYPE(CAR(binding)) == TYPE_SYMBOL && TYPE(CDR(binding)) == TYPE_PAIR && CDDR(binding) == obj_empty) error("%s: illegal binding", operator->operator.name); define(inner_env, CAR(binding), eval(inner_env, op_env, CADR(binding))); bindings = CDR(bindings); } if(bindings != obj_empty) error("%s: illegal bindings list", operator->operator.name); return eval_body(inner_env, op_env, operator, CDR(operands)); } /* entry_letrec -- (letrec ) */ /* TODO: Too much common code with let and let* */ static obj_t entry_letrec(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { obj_t inner_env, bindings; unless(TYPE(operands) == TYPE_PAIR && TYPE(CDR(operands)) == TYPE_PAIR) error("%s: illegal syntax", operator->operator.name); inner_env = make_pair(obj_empty, env); /* TODO: common with interpret */ bindings = CAR(operands); while(TYPE(bindings) == TYPE_PAIR) { obj_t binding = CAR(bindings); unless(TYPE(binding) == TYPE_PAIR && TYPE(CAR(binding)) == TYPE_SYMBOL && TYPE(CDR(binding)) == TYPE_PAIR && CDDR(binding) == obj_empty) error("%s: illegal binding", operator->operator.name); define(inner_env, CAR(binding), obj_undefined); bindings = CDR(bindings); } if(bindings != obj_empty) error("%s: illegal bindings list", operator->operator.name); bindings = CAR(operands); while(TYPE(bindings) == TYPE_PAIR) { obj_t binding = CAR(bindings); define(inner_env, CAR(binding), eval(inner_env, op_env, CADR(binding))); bindings = CDR(bindings); } return eval_body(inner_env, op_env, operator, CDR(operands)); } /* entry_do -- (do (( ) ...) ( ...) ...) * Do is an iteration construct. It specifies a set of variables to be * bound, how they are to be initialized at the start, and how they * are to be updated on each iteration. When a termination condition * is met, the loop exits with a specified result value. * See R4RS 4.2.4. */ static obj_t entry_do(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { obj_t inner_env, next_env, bindings; unless(TYPE(operands) == TYPE_PAIR && TYPE(CDR(operands)) == TYPE_PAIR && TYPE(CADR(operands)) == TYPE_PAIR) error("%s: illegal syntax", operator->operator.name); inner_env = make_pair(obj_empty, env); /* Do expressions are evaluated as follows: The expressions are evaluated (in some unspecified order), the s are bound to fresh locations, the results of the expressions are stored in the bindings of the s, and then the iteration phase begins. */ bindings = CAR(operands); while(TYPE(bindings) == TYPE_PAIR) { obj_t binding = CAR(bindings); unless(TYPE(binding) == TYPE_PAIR && TYPE(CAR(binding)) == TYPE_SYMBOL && TYPE(CDR(binding)) == TYPE_PAIR && (CDDR(binding) == obj_empty || (TYPE(CDDR(binding)) == TYPE_PAIR && CDDDR(binding) == obj_empty))) error("%s: illegal binding", operator->operator.name); define(inner_env, CAR(binding), eval(env, op_env, CADR(binding))); bindings = CDR(bindings); } for(;;) { /* Each iteration begins by evaluating ; */ obj_t test = CADR(operands); if(eval(inner_env, op_env, CAR(test)) == obj_false) { /* if the result is false (see section see section 6.1 Booleans), then the expressions are evaluated in order for effect, */ obj_t commands = CDDR(operands); while(TYPE(commands) == TYPE_PAIR) { eval(inner_env, op_env, CAR(commands)); commands = CDR(commands); } unless(commands == obj_empty) error("%s: illegal syntax", operator->operator.name); /* the expressions are evaluated in some unspecified order, the s are bound to fresh locations, the results of the s are stored in the bindings of the s, and the next iteration begins. */ bindings = CAR(operands); next_env = make_pair(obj_empty, inner_env); while(TYPE(bindings) == TYPE_PAIR) { obj_t binding = CAR(bindings); unless(CDDR(binding) == obj_empty) define(next_env, CAR(binding), eval(inner_env, op_env, CADDR(binding))); bindings = CDR(bindings); } inner_env = next_env; } else { /* If evaluates to a true value, then the s are evaluated from left to right and the value of the last is returned as the value of the do expression. If no s are present, then the value of the do expression is unspecified. */ obj_t result = obj_undefined; test = CDR(test); while(TYPE(test) == TYPE_PAIR) { result = eval(inner_env, op_env, CAR(test)); test = CDR(test); } unless(test == obj_empty) error("%s: illegal syntax", operator->operator.name); return result; } } } /* entry_delay -- (delay ) */ static obj_t entry_delay(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { obj_t promise; unless(TYPE(operands) == TYPE_PAIR && CDR(operands) == obj_empty) error("%s: illegal syntax", operator->operator.name); promise = make_pair(obj_false, make_operator("anonymous promise", entry_interpret, obj_empty, CAR(operands), env, op_env)); TYPE(promise) = TYPE_PROMISE; return promise; } static obj_t quasiquote(obj_t env, obj_t op_env, obj_t operator, obj_t arg) { obj_t result = obj_empty, end = NULL, insert; unless(TYPE(arg) == TYPE_PAIR) return arg; while(TYPE(arg) == TYPE_PAIR) { if(TYPE(CAR(arg)) == TYPE_PAIR && TYPE(CAAR(arg)) == TYPE_SYMBOL && (CAAR(arg) == obj_unquote || CAAR(arg) == obj_unquote_splic)) { unless(TYPE(CDAR(arg)) == TYPE_PAIR && CDDAR(arg) == obj_empty) error("%s: illegal %s syntax", operator->operator.name, symbol_name(CAAR(arg))); insert = eval(env, op_env, CADAR(arg)); if(CAAR(arg) == obj_unquote) { obj_t pair = make_pair(insert, obj_empty); if(result == obj_empty) result = pair; if(end) CDR(end) = pair; end = pair; } else if(CAAR(arg) == obj_unquote_splic) { while(TYPE(insert) == TYPE_PAIR) { obj_t pair = make_pair(CAR(insert), obj_empty); if(result == obj_empty) result = pair; if(end) CDR(end) = pair; end = pair; insert = CDR(insert); } if(insert != obj_empty) error("%s: %s expression must return list", operator->operator.name, symbol_name(CAAR(arg))); } } else { obj_t pair = make_pair(quasiquote(env, op_env, operator, CAR(arg)), obj_empty); if(result == obj_empty) result = pair; if(end) CDR(end) = pair; end = pair; } arg = CDR(arg); } return result; } /* entry_quasiquote -- (quasiquote