/* scheme.c -- SCHEME INTERPRETER EXAMPLE FOR THE MEMORY POOL SYSTEM
*
* Copyright (c) 2001-2013 Ravenbrook Limited. See end of file for license.
*
* TO DO
* - unbounded integers, other number types.
* - named let.
* - quasiquote: vectors; nested; dotted.
* - Lots of library.
* - \#foo unsatisfactory in read and print
*/
#include <assert.h>
#include <ctype.h>
#include <errno.h>
#include <setjmp.h>
#include <stdarg.h>
#include <stddef.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <gc.h>
/* LANGUAGE EXTENSION */
#define unless(c) if(!(c))
#define LENGTH(array) (sizeof(array) / sizeof(array[0]))
/* 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_BUCKETS
};
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 */
size_t length; /* length of symbol string (excl. NUL) */
char string[1]; /* symbol string, NUL terminated */
} 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 */
char *name; /* printed representation, NUL terminated */
} special_s;
typedef struct operator_s {
type_t type; /* TYPE_OPERATOR */
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;
typedef unsigned long (*hash_t)(obj_t obj);
typedef int (*cmp_t)(obj_t obj1, obj_t obj2);
typedef struct table_s {
type_t type; /* TYPE_TABLE */
hash_t hash; /* hash function */
cmp_t cmp; /* comparison function */
obj_t buckets; /* hash buckets */
} table_s;
typedef struct buckets_s {
type_t type; /* TYPE_BUCKETS */
size_t length; /* number of buckets */
size_t used; /* number of buckets in use */
size_t deleted; /* number of deleted buckets */
struct bucket_s {
obj_t key, value;
} bucket[1]; /* hash buckets */
} buckets_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;
buckets_s buckets;
} 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
*
* The symbol table is a hash-table containing 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 size_t symtab_size;
/* special objects
*
* These global variables are initialized to point to objects of
* TYPE_SPECIAL by main. They are used as markers for various
* special purposes.
*/
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 */
/* 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 main, 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];
/* 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(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 {
fprintf(stderr, "Fatal error during initialization: %s\n",
error_message);
abort();
}
}
/* make_* -- object constructors
*
* Each object type has a function here which allocates an
* instance of that type.
*/
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 = (obj_t)GC_MALLOC(sizeof(pair_s));
if(obj == NULL) error("out of memory");
total += sizeof(pair_s);
obj->pair.type = TYPE_PAIR;
CAR(obj) = car;
CDR(obj) = cdr;
return obj;
}
static obj_t make_integer(long integer)
{
obj_t obj = (obj_t)GC_MALLOC(sizeof(integer_s));
if(obj == NULL) error("out of memory");
total += sizeof(integer_s);
obj->integer.type = TYPE_INTEGER;
obj->integer.integer = integer;
return obj;
}
static obj_t make_symbol(size_t length, char string[])
{
size_t size = offsetof(symbol_s, string) + length+1;
obj_t obj = (obj_t)GC_MALLOC(size);
if(obj == NULL) error("out of memory");
total += size;
obj->symbol.type = TYPE_SYMBOL;
obj->symbol.length = length;
memcpy(obj->symbol.string, string, length+1);
return obj;
}
static obj_t make_string(size_t length, char string[])
{
size_t size = offsetof(string_s, string) + length+1;
obj_t obj = (obj_t)GC_MALLOC(size);
if(obj == NULL) error("out of memory");
total += size;
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);
return obj;
}
static obj_t make_special(char *string)
{
obj_t obj = (obj_t)GC_MALLOC(sizeof(special_s));
if(obj == NULL) error("out of memory");
total += sizeof(special_s);
obj->special.type = TYPE_SPECIAL;
obj->special.name = string;
return obj;
}
static obj_t make_operator(char *name,
entry_t entry, obj_t arguments,
obj_t body, obj_t env, obj_t op_env)
{
obj_t obj = (obj_t)GC_MALLOC(sizeof(operator_s));
if(obj == NULL) error("out of memory");
total += sizeof(operator_s);
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;
return obj;
}
static obj_t make_port(obj_t name, FILE *stream)
{
obj_t obj = (obj_t)GC_MALLOC(sizeof(port_s));
if(obj == NULL) error("out of memory");
total += sizeof(port_s);
obj->port.type = TYPE_PORT;
obj->port.name = name;
obj->port.stream = stream;
return obj;
}
static obj_t make_character(char c)
{
obj_t obj = (obj_t)GC_MALLOC(sizeof(character_s));
if(obj == NULL) error("out of memory");
total += sizeof(character_s);
obj->character.type = TYPE_CHARACTER;
obj->character.c = c;
return obj;
}
static obj_t make_vector(size_t length, obj_t fill)
{
size_t size = offsetof(vector_s, vector) + length * sizeof(obj_t);
size_t i;
obj_t obj = (obj_t)GC_MALLOC(size);
if(obj == NULL) error("out of memory");
total += size;
obj->vector.type = TYPE_VECTOR;
obj->vector.length = length;
for(i = 0; i < length; ++i)
obj->vector.vector[i] = fill;
return obj;
}
static obj_t make_buckets(size_t length)
{
size_t i, size = offsetof(buckets_s, bucket) + length * 2 * sizeof(obj_t);
obj_t obj = (obj_t)GC_MALLOC(size);
if(obj == NULL) error("out of memory");
total += size;
obj->buckets.type = TYPE_BUCKETS;
obj->buckets.length = length;
obj->buckets.used = 0;
obj->buckets.deleted = 0;
for(i = 0; i < length; ++i) {
obj->buckets.bucket[i].key = NULL;
obj->buckets.bucket[i].value = NULL;
}
return obj;
}
static obj_t make_table(size_t length, hash_t hashf, cmp_t cmpf)
{
size_t l, size = sizeof(table_s);
obj_t obj = (obj_t)GC_MALLOC(size);
if(obj == NULL) error("out of memory");
total += size;
obj->table.type = TYPE_TABLE;
obj->table.hash = hashf;
obj->table.cmp = cmpf;
/* round up to next power of 2 */
for(l = 1; l < length; l *= 2);
obj->table.buckets = make_buckets(l);
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) {
char c;
unsigned long h=0;
size_t i = 0;
switch(length % 4) {
do {
c=s[i++]; h+=(c<<17)^(c<<11)^(c<<5)^(c>>1);
case 3:
c=s[i++]; h^=(c<<14)+(c<<7)+(c<<4)+c;
case 2:
c=s[i++]; h^=(~c<<11)|((c<<3)^(c>>1));
case 1:
c=s[i++]; h-=(c<<16)|(c<<9)|(c<<2)|(c&3);
case 0:
;
} while(i < length);
}
return h;
}
/* find -- find entry for symbol in symbol table
*
* Look for a symbol matching the string in the symbol table.
* If the symbol was found, returns the address of the symbol
* table entry which points to the symbol. Otherwise it
* either returns the address of a NULL entry into which the
* new symbol should be inserted, or NULL if the symbol table
* is full.
*/
static obj_t *find(char *string) {
unsigned long i, h, probe;
h = hash(string, strlen(string));
probe = (h >> 8) | 1;
h &= (symtab_size-1);
i = h;
do {
if(symtab[i] == NULL ||
strcmp(string, symtab[i]->symbol.string) == 0)
return &symtab[i];
i = (i+probe) & (symtab_size-1);
} while(i != h);
return NULL;
}
/* rehash -- double size of symbol table */
static void rehash(void) {
obj_t *old_symtab = symtab;
unsigned old_symtab_size = symtab_size;
unsigned i;
symtab_size *= 2;
symtab = GC_MALLOC(sizeof(obj_t) * symtab_size);
if(symtab == NULL) error("out of memory");
/* Initialize the new table to NULL so that "find" will work. */
for(i = 0; i < symtab_size; ++i)
symtab[i] = NULL;
for(i = 0; i < old_symtab_size; ++i)
if(old_symtab[i] != NULL) {
obj_t *where = find(old_symtab[i]->symbol.string);
assert(where != NULL); /* new table shouldn't be full */
assert(*where == NULL); /* shouldn't be in new table */
*where = old_symtab[i];
}
}
/* union-find string in symbol table, rehashing if necessary */
static obj_t intern(char *string) {
obj_t *where;
where = find(string);
if(where == NULL) {
rehash();
where = find(string);
assert(where != NULL); /* shouldn't be full after rehash */
}
if(*where == NULL) /* symbol not found in table */
*where = make_symbol(strlen(string), string);
return *where;
}
/* Hash table implementation */
static unsigned long eq_hash(obj_t obj)
{
union {char s[sizeof(obj_t)]; obj_t addr;} u = {""};
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)
{
switch(TYPE(obj)) {
case TYPE_INTEGER:
return obj->integer.integer;
case TYPE_CHARACTER:
return obj->character.c;
default:
return eq_hash(obj);
}
}
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)
{
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 struct bucket_s *buckets_find(obj_t tbl, obj_t buckets, obj_t key)
{
unsigned long i, h, probe;
struct bucket_s *result = NULL;
assert(TYPE(tbl) == TYPE_TABLE);
assert(TYPE(buckets) == TYPE_BUCKETS);
h = tbl->table.hash(key);
probe = (h >> 8) | 1;
h &= (buckets->buckets.length-1);
i = h;
do {
struct bucket_s *b = &buckets->buckets.bucket[i];
if(b->key == NULL || tbl->table.cmp(b->key, key))
return b;
if(result == NULL && b->key == obj_deleted)
result = b;
i = (i+probe) & (buckets->buckets.length-1);
} while(i != h);
return result;
}
static size_t table_size(obj_t tbl)
{
size_t used, deleted;
assert(TYPE(tbl) == TYPE_TABLE);
used = tbl->table.buckets->buckets.used;
deleted = tbl->table.buckets->buckets.deleted;
assert(used >= deleted);
return used - deleted;
}
static void table_rehash(obj_t tbl)
{
size_t i, old_length, new_length;
obj_t new_buckets;
assert(TYPE(tbl) == TYPE_TABLE);
old_length = tbl->table.buckets->buckets.length;
new_length = old_length * 2;
new_buckets = make_buckets(new_length);
for (i = 0; i < old_length; ++i) {
struct bucket_s *old_b = &tbl->table.buckets->buckets.bucket[i];
if (old_b->key != NULL && old_b->key != obj_deleted) {
struct bucket_s *b = buckets_find(tbl, new_buckets, old_b->key);
assert(b != NULL); /* new table shouldn't be full */
assert(b->key == NULL); /* shouldn't be in new table */
*b = *old_b;
++ new_buckets->buckets.used;
}
}
assert(new_buckets->buckets.used == table_size(tbl));
tbl->table.buckets = new_buckets;
}
static obj_t table_ref(obj_t tbl, obj_t key)
{
struct bucket_s *b;
assert(TYPE(tbl) == TYPE_TABLE);
b = buckets_find(tbl, tbl->table.buckets, key);
if (b && b->key != NULL && b->key != obj_deleted)
return b->value;
return NULL;
}
static int table_full(obj_t tbl)
{
assert(TYPE(tbl) == TYPE_TABLE);
return tbl->table.buckets->buckets.used >= tbl->table.buckets->buckets.length / 2;
}
static void table_set(obj_t tbl, obj_t key, obj_t value)
{
struct bucket_s *b;
assert(TYPE(tbl) == TYPE_TABLE);
if (table_full(tbl) || (b = buckets_find(tbl, tbl->table.buckets, key)) == NULL) {
table_rehash(tbl);
b = buckets_find(tbl, tbl->table.buckets, key);
assert(b != NULL); /* shouldn't be full after rehash */
}
if (b->key == NULL) {
b->key = key;
++ tbl->table.buckets->buckets.used;
} else if (b->key == obj_deleted) {
b->key = key;
assert(tbl->table.buckets->buckets.deleted > 0);
-- tbl->table.buckets->buckets.deleted;
}
b->value = value;
}
static void table_delete(obj_t tbl, obj_t key)
{
struct bucket_s *b;
assert(TYPE(tbl) == TYPE_TABLE);
b = buckets_find(tbl, tbl->table.buckets, key);
if (b != NULL && b->key != NULL) {
b->key = obj_deleted;
++ tbl->table.buckets->buckets.deleted;
}
}
static void print(obj_t obj, unsigned depth, FILE *stream)
{
switch(TYPE(obj)) {
case TYPE_INTEGER: {
fprintf(stream, "%ld", obj->integer.integer);
} break;
case TYPE_SYMBOL: {
fputs(obj->symbol.string, 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_BUCKETS: {
size_t i;
for(i = 0; i < obj->buckets.length; ++i) {
struct bucket_s *b = &obj->buckets.bucket[i];
if(b->key != NULL && b->key != obj_deleted) {
fputs(" (", stream);
print(b->key, depth - 1, stream);
putc(' ', stream);
print(b->value, depth - 1, stream);
putc(')', stream);
}
}
} break;
case TYPE_TABLE: {
fputs("#[hashtable", stream);
print(obj->table.buckets, depth - 1, 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)
{
int length = 0;
char string[SYMMAX+1];
do {
string[length++] = 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)
{
int 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++] = c;
}
string[length] = '\0';
return make_string(length, string);
}
static obj_t read(FILE *stream);
static obj_t read_quote(FILE *stream, int c)
{
return make_pair(obj_quote, make_pair(read(stream), obj_empty));
}
static obj_t read_quasiquote(FILE *stream, int 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(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);
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\"", exp->symbol.string);
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 obj_t load(obj_t env, obj_t op_env, const char *filename) {
obj_t result = obj_undefined;
FILE *stream = fopen(filename, "r");
if(stream == NULL)
error("load: cannot open %s: %s", filename, strerror(errno));
for(;;) {
obj_t obj = read(stream);
if(obj == obj_eof) break;
result = eval(env, op_env, obj);
}
/* TODO: if there was an error, this doesn't get closed */
fclose(stream);
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, 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(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(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(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)
{
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 <symbol> <expression>)" 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 (<symbol> <formals>) <body>)" as a short-hand for
* "(define <symbol> (lambda (<formals>) <body>))".
*/
static obj_t entry_define(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t symbol, value;
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 <test> <consequent> <alternate>)" and "(if <test> <consequent>)".
* 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 (<test1> <exp1.1> ...) (<test2> <exp2.1> ...) ... [(else <expe.1> ...)])"
*/
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 <test1> ...) */
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 <test1> ...) */
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 <bindings> <body>) */
/* 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* <bindings> <body>) */
/* 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 <bindings> <body>) */
/* 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 ((<var> <init> <step1>) ...) (<test> <exp> ...) <command> ...)
* 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 <init> expressions
are evaluated (in some unspecified order), the <variable>s are
bound to fresh locations, the results of the <init> expressions
are stored in the bindings of the <variable>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 <test>; */
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 <command> 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 <step> expressions are evaluated in some unspecified
order, the <variable>s are bound to fresh locations, the
results of the <step>s are stored in the bindings of the
<variable>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 <test> evaluates to a true value, then the <expression>s
are evaluated from left to right and the value of the last
<expression> is returned as the value of the do expression.
If no <expression>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;
}
}
error("%s: unimplemented", operator->operator.name);
return obj_error;
}
/* entry_delay -- (delay <exp>) */
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,
CAAR(arg)->symbol.string);
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, CAAR(arg)->symbol.string);
}
} 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 <template>) or `<template> */
static obj_t entry_quasiquote(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
unless(TYPE(operands) == TYPE_PAIR &&
CDR(operands) == obj_empty)
error("%s: illegal syntax", operator->operator.name);
return quasiquote(env, op_env, operator, CAR(operands));
}
/* entry_set -- assignment
*
* (set! <variable> <expression>)
* See R4RS 4.1.6.
*/
static obj_t entry_set(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t symbol, binding, value;
unless(TYPE(operands) == TYPE_PAIR &&
TYPE(CDR(operands)) == TYPE_PAIR &&
CDDR(operands) == obj_empty)
error("%s: illegal syntax", operator->operator.name);
unless(TYPE(CAR(operands)) == TYPE_SYMBOL)
error("%s: applied to non-symbol", operator->operator.name);
symbol = CAR(operands);
binding = lookup(env, symbol);
if(binding == obj_undefined)
error("%s: applied to unbound symbol \"%s\"",
operator->operator.name, symbol->symbol.string);
value = eval(env, op_env, CADR(operands));
CDR(binding) = value;
return value;
}
/* entry_lambda -- lambda expressions
*
* (lambda <formals> <body>)
* See R4RS 4.1.4.
*
* The entry_lambda function creates a new object of TYPE_OPERATOR
* which captures the current environments, and contains the lambda
* formals and body. This operator has an entry point at
* entry_interpret, which will evaluate and bind the arguments when
* the operator is applied.
*
* [Capturing the whole environment is bad for GC because it means
* that everything defined when the lambda is evaluated will survive
* for as long as the operator survives. It would be better to
* examine the lambda body and determine which variables it references,
* and either create a new environment or build a new body with just
* those variables bound.]
*/
static obj_t entry_lambda(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t list;
unless(TYPE(operands) == TYPE_PAIR &&
TYPE(CDR(operands)) == TYPE_PAIR)
error("%s: illegal syntax", operator->operator.name);
/* check syntax of argument list to save time in apply */
list = CAR(operands);
while(list != obj_empty && TYPE(list) != TYPE_SYMBOL) {
unless(TYPE(list) == TYPE_PAIR &&
TYPE(CAR(list)) == TYPE_SYMBOL)
error("%s: illegal argument list", operator->operator.name);
list = CDR(list);
}
return make_operator("anonymous function",
entry_interpret, CAR(operands),
make_pair(obj_begin, CDR(operands)),
env, op_env);
}
/* entry_begin -- sequencing
*
* (begin <expression1> <expression2> ...)
* See R4RS 4.2.3.
*/
static obj_t entry_begin(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
return eval_body(env, op_env, operator, operands);
}
/* BUILT-IN FUNCTIONS */
/* (not <obj>)
* Not returns #t if obj is false, and return #f otherwise.
* See R4RS 6.1.
*/
static obj_t entry_not(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_bool(arg == obj_false);
}
/* (boolean? <obj>)
* Boolean? return #t if obj is either #t or #f, and #f otherwise.
* See R4RS 6.1.
*/
static obj_t entry_booleanp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_bool(arg == obj_true || arg == obj_false);
}
/* (eqv? <obj1> <obj2>)
* The eqv? procedure defines a useful equivalence relation on
* objects.
* See R4RS 6.2.
*/
static obj_t entry_eqvp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg1, arg2;
eval_args(operator->operator.name, env, op_env, operands, 2, &arg1, &arg2);
return make_bool(eqvp(arg1, arg2));
}
/* (eq? <obj1> <obj2>)
* Eq? is similar to eqv? except that in some cases it is capable of
* discerning distinctions finer than those detectable by eqv?.
* See R4RS 6.2.
*/
static obj_t entry_eqp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg1, arg2;
eval_args(operator->operator.name, env, op_env, operands, 2, &arg1, &arg2);
return make_bool(arg1 == arg2);
}
static int equalp(obj_t obj1, obj_t obj2)
{
size_t i;
if(TYPE(obj1) != TYPE(obj2))
return 0;
switch(TYPE(obj1)) {
case TYPE_PAIR:
return equalp(CAR(obj1), CAR(obj2)) && equalp(CDR(obj1), CDR(obj2));
case TYPE_VECTOR:
if(obj1->vector.length != obj2->vector.length)
return 0;
for(i = 0; i < obj1->vector.length; ++i) {
if(!equalp(obj1->vector.vector[i], obj2->vector.vector[i]))
return 0;
}
return 1;
case TYPE_STRING:
return obj1->string.length == obj2->string.length
&& 0 == strcmp(obj1->string.string, obj2->string.string);
default:
return eqvp(obj1, obj2);
}
}
/* (equal? <obj1> <obj2>)
* Equal? recursively compares the contents of pairs, vectors, and
* strings, applying eqv? on other objects such as numbers and
* symbols. A rule of thumb is that objects are generally equal? if
* they print the same. Equal? may fail to terminate if its arguments
* are circular data structures.
* See R4RS 6.2.
*/
static obj_t entry_equalp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg1, arg2;
eval_args(operator->operator.name, env, op_env, operands, 2, &arg1, &arg2);
return make_bool(equalp(arg1, arg2));
}
/* (pair? <obj>)
* Pair? returns #t if obj is a pair, and otherwise returns #f.
* See R4RS 6.3.
*/
static obj_t entry_pairp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_bool(TYPE(arg) == TYPE_PAIR);
}
/* (cons obj1 obj2)
* Returns a newly allocated pair whose car is obj1 and whose cdr is
* obj2. The pair is guaranteed to be different (in the sense of eqv?)
* from every existing object.
* See R4RS 6.3.
*/
static obj_t entry_cons(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t car, cdr;
eval_args(operator->operator.name, env, op_env, operands, 2, &car, &cdr);
return make_pair(car, cdr);
}
/* (car pair)
* Returns the contents of the car field of pair. Note that it is an
* error to take the car of the empty list.
* See R4RS 6.3.
*/
static obj_t entry_car(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t pair;
eval_args(operator->operator.name, env, op_env, operands, 1, &pair);
unless(TYPE(pair) == TYPE_PAIR)
error("%s: argument must be a pair", operator->operator.name);
return CAR(pair);
}
/* (cdr pair)
* Returns the contents of the cdr field of pair. Note that it is an
* error to take the cdr of the empty list.
* See R4RS 6.3.
*/
static obj_t entry_cdr(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t pair;
eval_args(operator->operator.name, env, op_env, operands, 1, &pair);
unless(TYPE(pair) == TYPE_PAIR)
error("%s: argument must be a pair", operator->operator.name);
return CDR(pair);
}
/* (set-car! pair obj)
* Stores obj in the car field of pair. The value returned by set-car!
* is unspecified.
* See R4RS 6.3.
*/
static obj_t entry_setcar(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t pair, value;
eval_args(operator->operator.name, env, op_env, operands, 2, &pair, &value);
unless(TYPE(pair) == TYPE_PAIR)
error("%s: first argument must be a pair", operator->operator.name);
CAR(pair) = value;
return obj_undefined;
}
/* (set-cdr! pair obj)
* Stores obj in the cdr field of pair. The value returned by set-cdr!
* is unspecified.
* See R4RS 6.3.
*/
static obj_t entry_setcdr(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t pair, value;
eval_args(operator->operator.name, env, op_env, operands, 2, &pair, &value);
unless(TYPE(pair) == TYPE_PAIR)
error("%s: first argument must be a pair", operator->operator.name);
CDR(pair) = value;
return obj_undefined;
}
/* (null? obj)
* Returns #t if obj is the empty list, otherwise returns #f.
* See R4RS 6.3.
*/
static obj_t entry_nullp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_bool(arg == obj_empty);
}
/* (list? obj)
* Returns #t if obj is a list, otherwise returns #f. By definition,
* all lists have finite length and are terminated by the empty list.
* See R4RS 6.3.
*/
static obj_t entry_listp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
while(TYPE(arg) == TYPE_PAIR)
arg = CDR(arg);
return make_bool(arg == obj_empty);
}
/* (list obj ...)
* Returns a newly allocated list of its arguments.
* See R4RS 6.3.
*/
static obj_t entry_list(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t rest;
eval_args_rest(operator->operator.name, env, op_env, operands, &rest, 0);
return rest;
}
/* (length list)
* Returns the length of list.
* See R4RS 6.3.
*/
static obj_t entry_length(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
long length;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
length = 0;
while(TYPE(arg) == TYPE_PAIR) {
++length;
arg = CDR(arg);
}
if(arg != obj_empty)
error("%s: applied to non-list", operator->operator.name);
return make_integer(length);
}
/* (append list ...)
* Returns a list consisting of the elements of the first list
* followed by the elements of the other lists.
* See R4RS 6.3.
*/
static obj_t entry_append(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg1, arg2, result, pair, end;
eval_args(operator->operator.name, env, op_env, operands, 2, &arg1, &arg2);
result = obj_empty;
end = NULL; /* suppress "uninitialized" warning in GCC */
while(TYPE(arg1) == TYPE_PAIR) {
pair = make_pair(CAR(arg1), obj_empty);
if(result == obj_empty)
result = pair;
else
CDR(end) = pair;
end = pair;
arg1 = CDR(arg1);
}
if(arg1 != obj_empty)
error("%s: applied to non-list", operator->operator.name);
if(result == obj_empty)
return arg2;
CDR(end) = arg2;
return result;
}
/* (integer? obj)
* These numerical type predicates can be applied to any kind of
* argument, including non-numbers. They return #t if the object is of
* the named type, and otherwise they return #f.
* See R4RS 6.5.5.
*/
static obj_t entry_integerp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_bool(TYPE(arg) == TYPE_INTEGER);
}
/* (zero? z)
* (positive? x)
* (negative? x)
* These numerical predicates test a number for a particular property,
* returning #t or #f.
* See R4RS 6.5.5.
*/
static obj_t entry_zerop(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_INTEGER)
error("%s: argument must be an integer", operator->operator.name);
return make_bool(arg->integer.integer == 0);
}
static obj_t entry_positivep(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_INTEGER)
error("%s: argument must be an integer", operator->operator.name);
return make_bool(arg->integer.integer > 0);
}
static obj_t entry_negativep(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_INTEGER)
error("%s: argument must be an integer", operator->operator.name);
return make_bool(arg->integer.integer < 0);
}
/* (symbol? obj)
* Returns #t if obj is a symbol, otherwise returns #f.
* See R4RS 6.4.
*/
static obj_t entry_symbolp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_bool(TYPE(arg) == TYPE_SYMBOL);
}
/* (procedure? obj)
* Returns #t if obj is a procedure, otherwise returns #f.
* See R4RS 6.9.
*/
static obj_t entry_procedurep(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_bool(TYPE(arg) == TYPE_OPERATOR);
}
/* (apply proc args)
* Proc must be a procedure and args must be a list. Calls proc with
* the elements of args as the actual arguments.
* See R4RS 6.9.
*/
static obj_t entry_apply(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t proc, args, qargs = obj_empty, end = NULL, quote;
eval_args(operator->operator.name, env, op_env, operands, 2, &proc, &args);
unless(TYPE(proc) == TYPE_OPERATOR)
error("%s: first argument must be a procedure", operator->operator.name);
quote = make_operator("quote", entry_quote, obj_empty, obj_empty, obj_empty, obj_empty);
while(args != obj_empty) {
obj_t a;
assert(TYPE(args) == TYPE_PAIR);
a = make_pair(make_pair(quote, make_pair(CAR(args), obj_empty)), obj_empty);
if(end != NULL)
CDR(end) = a;
else
qargs = a;
end = a;
args = CDR(args);
}
return (*proc->operator.entry)(env, op_env, proc, qargs);
}
/* (+ z1 ...)
* This procedure returns the sum of its arguments.
* See R4RS 6.5.5.
*/
static obj_t entry_add(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t args;
long result;
eval_args_rest(operator->operator.name, env, op_env, operands, &args, 0);
result = 0;
while(TYPE(args) == TYPE_PAIR) {
unless(TYPE(CAR(args)) == TYPE_INTEGER)
error("%s: arguments must be integers", operator->operator.name);
result += CAR(args)->integer.integer;
args = CDR(args);
}
assert(args == obj_empty); /* eval_args_rest always returns a list */
return make_integer(result);
}
/* (* z1 ...)
* This procedure returns the product of its arguments.
* See R4RS 6.5.5.
*/
static obj_t entry_multiply(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t args;
long result;
eval_args_rest(operator->operator.name, env, op_env, operands, &args, 0);
result = 1;
while(TYPE(args) == TYPE_PAIR) {
unless(TYPE(CAR(args)) == TYPE_INTEGER)
error("%s: arguments must be integers", operator->operator.name);
result *= CAR(args)->integer.integer;
args = CDR(args);
}
assert(args == obj_empty); /* eval_args_rest always returns a list */
return make_integer(result);
}
/* (- z)
* (- z1 z2)
* (- z1 z2 ...)
* With two or more arguments, this procedure returns the difference
* of its arguments, associating to the left. With one argument,
* however, it returns the additive inverse of its argument.
* See R4RS 6.5.5.
*/
static obj_t entry_subtract(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, args;
long result;
eval_args_rest(operator->operator.name, env, op_env, operands, &args, 1, &arg);
unless(TYPE(arg) == TYPE_INTEGER)
error("%s: first argument must be an integer", operator->operator.name);
result = arg->integer.integer;
if(args == obj_empty)
result = -result;
else {
while(TYPE(args) == TYPE_PAIR) {
unless(TYPE(CAR(args)) == TYPE_INTEGER)
error("%s: arguments must be integers", operator->operator.name);
result -= CAR(args)->integer.integer;
args = CDR(args);
}
assert(args == obj_empty); /* eval_args_rest always returns a list */
}
return make_integer(result);
}
/* (/ z)
* (/ z1 z2)
* (/ z1 z2 ...)
* With two or more arguments, this procedure returns the quotient
* of its arguments, associating to the left. With one argument,
* however, it returns the multiplicative inverse of its argument.
* See R4RS 6.5.5.
*/
static obj_t entry_divide(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, args;
long result;
eval_args_rest(operator->operator.name, env, op_env, operands, &args, 1, &arg);
unless(TYPE(arg) == TYPE_INTEGER)
error("%s: first argument must be an integer", operator->operator.name);
result = arg->integer.integer;
if(args == obj_empty) {
if(result == 0)
error("%s: reciprocal of zero", operator->operator.name);
result = 1/result; /* TODO: pretty meaningless for integers */
} else {
while(TYPE(args) == TYPE_PAIR) {
unless(TYPE(CAR(args)) == TYPE_INTEGER)
error("%s: arguments must be integers", operator->operator.name);
if(CAR(args)->integer.integer == 0)
error("%s: divide by zero", operator->operator.name);
result /= CAR(args)->integer.integer;
args = CDR(args);
}
assert(args == obj_empty); /* eval_args_rest always returns a list */
}
return make_integer(result);
}
/* (< x1 x2 x3 ...)
* This procedure returns #t if its arguments are monotonically
* increasing.
* See R4RS 6.5.5.
*/
static obj_t entry_lessthan(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, args;
long last;
eval_args_rest(operator->operator.name, env, op_env, operands, &args, 1, &arg);
unless(TYPE(arg) == TYPE_INTEGER)
error("%s: first argument must be an integer", operator->operator.name);
last = arg->integer.integer;
while(TYPE(args) == TYPE_PAIR) {
unless(TYPE(CAR(args)) == TYPE_INTEGER)
error("%s: arguments must be integers", operator->operator.name);
if (last >= CAR(args)->integer.integer)
return obj_false;
last = CAR(args)->integer.integer;
args = CDR(args);
}
assert(args == obj_empty); /* eval_args_rest always returns a list */
return obj_true;
}
/* (> x1 x2 x3 ...)
* This procedure returns #t if its arguments are monotonically
* decreasing.
* See R4RS 6.5.5.
*/
static obj_t entry_greaterthan(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, args;
long last;
eval_args_rest(operator->operator.name, env, op_env, operands, &args, 1, &arg);
unless(TYPE(arg) == TYPE_INTEGER)
error("%s: first argument must be an integer", operator->operator.name);
last = arg->integer.integer;
while(TYPE(args) == TYPE_PAIR) {
unless(TYPE(CAR(args)) == TYPE_INTEGER)
error("%s: arguments must be integers", operator->operator.name);
if (last <= CAR(args)->integer.integer)
return obj_false;
last = CAR(args)->integer.integer;
args = CDR(args);
}
assert(args == obj_empty); /* eval_args_rest always returns a list */
return obj_true;
}
/* (reverse list)
* Returns a newly allocated list consisting of the elements of list
* in reverse order.
* See R4RS 6.3.
*/
static obj_t entry_reverse(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, result;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
result = obj_empty;
while(arg != obj_empty) {
unless(TYPE(arg) == TYPE_PAIR)
error("%s: argument must be a list", operator->operator.name);
result = make_pair(CAR(arg), result);
arg = CDR(arg);
}
return result;
}
/* (list-tail list k)
* Returns the sublist of list obtained by omitting the first k
* elements.
*/
static obj_t entry_list_tail(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, k;
int i;
eval_args(operator->operator.name, env, op_env, operands, 2, &arg, &k);
unless(TYPE(k) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
i = k->integer.integer;
unless(i >= 0)
error("%s: second argument must be non-negative", operator->operator.name);
while(i-- > 0) {
unless(TYPE(arg) == TYPE_PAIR)
error("%s: first argument must be a list", operator->operator.name);
arg = CDR(arg);
}
return arg;
}
/* (list-ref list k)
* Returns the kth element of list.
* See R4RS 6.3.
*/
static obj_t entry_list_ref(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, k, result;
int i;
eval_args(operator->operator.name, env, op_env, operands, 2, &arg, &k);
unless(TYPE(k) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
i = k->integer.integer;
unless(i >= 0)
error("%s: second argument must be non-negative", operator->operator.name);
do {
if(arg == obj_empty)
error("%s: index %ld out of bounds", operator->operator.name, k->integer.integer);
unless(TYPE(arg) == TYPE_PAIR)
error("%s: first argument must be a list", operator->operator.name);
result = CAR(arg);
arg = CDR(arg);
} while(i-- > 0);
return result;
}
static obj_t entry_environment(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
eval_args(operator->operator.name, env, op_env, operands, 0);
return env;
}
/* (open-input-file filename)
* Takes a string naming an existing file and returns an input port
* capable of delivering characters from the file. If the file cannot
* be opened, an error is signalled.
* See R4RS 6.10.1
*/
static obj_t entry_open_input_file(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t filename;
FILE *stream;
eval_args(operator->operator.name, env, op_env, operands, 1, &filename);
unless(TYPE(filename) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
stream = fopen(filename->string.string, "r");
if(stream == NULL)
error("%s: cannot open input file", operator->operator.name);
return make_port(filename, stream);
}
/* (open-output-file filename)
* Takes a string naming an output file to be created and returns an
* output port capable of writing characters to a new file by that
* name. If the file cannot be opened, an error is signalled. If a
* file with the given name already exists, the effect is unspecified.
* See R4RS 6.10.1
*/
static obj_t entry_open_output_file(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t filename;
FILE *stream;
eval_args(operator->operator.name, env, op_env, operands, 1, &filename);
unless(TYPE(filename) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
stream = fopen(filename->string.string, "w");
if(stream == NULL)
error("%s: cannot open output file", operator->operator.name);
return make_port(filename, stream);
}
/* (close-input-port port)
* (close-output-port port)
* Closes the file associated with port, rendering the port incapable
* of delivering or accepting characters. These routines have no
* effect if the file has already been closed. The value returned is
* unspecified.
* See R4RS 6.10.1.
*/
static obj_t entry_close_port(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t port;
eval_args(operator->operator.name, env, op_env, operands, 1, &port);
unless(TYPE(port) == TYPE_PORT)
error("%s: argument must be a port", operator->operator.name);
if(port->port.stream != NULL) {
fclose(port->port.stream);
port->port.stream = NULL;
}
return obj_undefined;
}
static FILE *rest_port_stream(obj_t operator, obj_t rest, const char *argnumber, FILE *default_stream) {
FILE *stream = default_stream;
unless(rest == obj_empty) {
unless(CDR(rest) == obj_empty)
error("%s: too many arguments", operator->operator.name);
unless(TYPE(CAR(rest)) == TYPE_PORT)
error("%s: %s argument must be a port", operator->operator.name, argnumber);
stream = CAR(rest)->port.stream;
unless(stream)
error("%s: port is closed", operator->operator.name);
}
return stream;
}
/* (write obj)
* (write obj port)
* Writes a written representation of obj to the given port. Strings
* that appear in the written representation are enclosed in
* doublequotes, and within those strings backslash and doublequote
* characters are escaped by backslashes. Write returns an unspecified
* value. The port argument may be omitted, in which case it defaults
* to the value returned by current-output-port.
* See R4RS 6.10.3.
*/
static obj_t entry_write(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, rest;
eval_args_rest(operator->operator.name, env, op_env, operands, &rest, 1, &arg);
/* TODO: default to current-output-port */
print(arg, -1, rest_port_stream(operator, rest, "second", stdout));
return obj_undefined;
}
static obj_t entry_write_string(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, rest;
eval_args_rest(operator->operator.name, env, op_env, operands, &rest, 1, &arg);
unless(TYPE(arg) == TYPE_STRING)
error("%s: first argument must be a string", operator->operator.name);
/* TODO: default to current-output-port */
fputs(arg->string.string, rest_port_stream(operator, rest, "second", stdout));
return obj_undefined;
}
/* (newline)
* (newline port)
* Writes an end of line to port. Exactly how this is done differs
* from one operating system to another. Returns an unspecified value.
* The port argument may be omitted, in which case it defaults to the
* value returned by current-output-port.
*/
static obj_t entry_newline(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t rest;
eval_args_rest(operator->operator.name, env, op_env, operands, &rest, 0);
/* TODO: default to current-output-port */
putc('\n', rest_port_stream(operator, rest, "first", stdout));
return obj_undefined;
}
/* (load filename)
* Filename should be a string naming an existing file containing
* Scheme source code. The load procedure reads expressions and
* definitions from the file and evaluates them sequentially. It is
* unspecified whether the results of the expressions are printed. The
* load procedure does not affect the values returned by
* current-input-port and current-output-port. Load returns an
* unspecified value.
* See R4RS 6.10.4.
*/
static obj_t entry_load(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t filename;
eval_args(operator->operator.name, env, op_env, operands, 1, &filename);
unless(TYPE(filename) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
return load(env, op_env, filename->string.string);
}
/* (force promise)
* Forces the value of promise. If no value has been computed for the
* promise, then a value is computed and returned. The value of the
* promise is cached (or "memoized") so that if it is forced a second
* time, the previously computed value is returned.
* See R4RS 6.9.
*
* TODO: This doesn't work if the promise refers to its own value.
*/
static obj_t entry_force(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t promise;
eval_args(operator->operator.name, env, op_env, operands, 1, &promise);
unless(TYPE(promise) == TYPE_PROMISE)
error("%s: argument must be a promise", operator->operator.name);
assert(CAR(promise) == obj_false || CAR(promise) == obj_true);
/* If the promise is unevaluated then apply the CDR. */
if(CAR(promise) == obj_false) {
obj_t closure = CDR(promise);
assert(TYPE(closure) == TYPE_OPERATOR);
assert(closure->operator.arguments == obj_empty);
CDR(promise) = (*closure->operator.entry)(env, op_env, closure, obj_empty);
CAR(promise) = obj_true;
}
return CDR(promise);
}
/* (char? obj)
* Returns #t if obj is a character, otherwise returns #f.
* See R4RS 6.6.
*/
static obj_t entry_charp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_bool(TYPE(arg) == TYPE_CHARACTER);
}
/* (char->integer char)
* Given a character, char->integer returns its Unicode scalar value
* as an exact integer object.
* See R4RS 6.6.
*/
static obj_t entry_char_to_integer(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_CHARACTER)
error("%s: first argument must be a character", operator->operator.name);
return make_integer(arg->character.c);
}
/* (integer->char sv)
* For a Unicode scalar value sv, integer->char returns its associated
* character.
* See R4RS 6.6.
*/
static obj_t entry_integer_to_char(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_INTEGER)
error("%s: first argument must be an integer", operator->operator.name);
unless(0 <= arg->integer.integer)
error("%s: first argument is out of range", operator->operator.name);
return make_character(arg->integer.integer);
}
/* (vector? obj)
* Returns #t if obj is a vector, otherwise returns #f.
* See R4RS 6.8.
*/
static obj_t entry_vectorp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_bool(TYPE(arg) == TYPE_VECTOR);
}
/* (make-vector k)
* (make-vector k fill)
* Returns a newly allocated vector of k elements. If a second
* argument is given, then each element is initialized to fill.
* Otherwise the initial contents of each element is unspecified.
* See R4RS 6.8.
*/
static obj_t entry_make_vector(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t length, rest, fill = obj_undefined;
eval_args_rest(operator->operator.name, env, op_env, operands, &rest, 1, &length);
unless(TYPE(length) == TYPE_INTEGER)
error("%s: first argument must be an integer", operator->operator.name);
unless(rest == obj_empty) {
unless(CDR(rest) == obj_empty)
error("%s: too many arguments", operator->operator.name);
fill = CAR(rest);
}
return make_vector(length->integer.integer, fill);
}
/* (vector obj ...)
* Returns a newly allocated vector whose elements contain the given
* arguments. Analogous to list.
* See R4RS 6.8.
*/
static obj_t entry_vector(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t rest, vector;
eval_args_rest(operator->operator.name, env, op_env, operands, &rest, 0);
vector = list_to_vector(rest);
assert(vector != obj_error);
return vector;
}
/* (vector-length vector)
* Returns the number of elements in vector.
* See R4RS 6.8.
*/
static obj_t entry_vector_length(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t vector;
eval_args(operator->operator.name, env, op_env, operands, 1, &vector);
unless(TYPE(vector) == TYPE_VECTOR)
error("%s: argument must be a vector", operator->operator.name);
return make_integer(vector->vector.length);
}
/* (vector-ref vector k)
* k must be a valid index of vector. Vector-ref returns the contents
* of element k of vector.
* See R4RS 6.8.
*/
static obj_t entry_vector_ref(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t vector, index;
eval_args(operator->operator.name, env, op_env, operands, 2, &vector, &index);
unless(TYPE(vector) == TYPE_VECTOR)
error("%s: first argument must be a vector", operator->operator.name);
unless(TYPE(index) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
unless(0 <= index->integer.integer && index->integer.integer < vector->vector.length)
error("%s: index %ld out of bounds of vector length %ld",
operator->operator.name, index->integer.integer, vector->vector.length);
return vector->vector.vector[index->integer.integer];
}
/* (vector-set! vector k obj
* k must be a valid index of vector. Vector-set! stores obj in
* element k of vector. The value returned by vector-set! is
* unspecified.
* See R4RS 6.8.
*/
static obj_t entry_vector_set(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t vector, index, obj;
eval_args(operator->operator.name, env, op_env, operands, 3, &vector, &index, &obj);
unless(TYPE(vector) == TYPE_VECTOR)
error("%s: first argument must be a vector", operator->operator.name);
unless(TYPE(index) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
unless(0 <= index->integer.integer && index->integer.integer < vector->vector.length)
error("%s: index %ld out of bounds of vector length %ld",
operator->operator.name, index->integer.integer, vector->vector.length);
vector->vector.vector[index->integer.integer] = obj;
return obj_undefined;
}
/* (vector->list vector)
* Vector->list returns a newly allocated list of the objects
* contained in the elements of vector.
* See R4RS 6.8.
*/
static obj_t entry_vector_to_list(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t vector, list;
size_t i;
eval_args(operator->operator.name, env, op_env, operands, 1, &vector);
unless(TYPE(vector) == TYPE_VECTOR)
error("%s: argument must be a vector", operator->operator.name);
list = obj_empty;
i = vector->vector.length;
while(i > 0) {
--i;
list = make_pair(vector->vector.vector[i], list);
}
return list;
}
/* (list->vector list)
* List->vector returns a newly created vector initialized to the
* elements of the list list.
* See R4RS 6.8.
*/
static obj_t entry_list_to_vector(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t list, vector;
eval_args(operator->operator.name, env, op_env, operands, 1, &list);
vector = list_to_vector(list);
if(vector == obj_error)
error("%s: argument must be a list", operator->operator.name);
return vector;
}
/* (vector-fill! vector fill)
* Stores fill in every element of vector. The value returned by
* vector-fill! is unspecified.
* See R4RS 6.8.
*/
static obj_t entry_vector_fill(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t vector, obj;
size_t i;
eval_args(operator->operator.name, env, op_env, operands, 2, &vector, &obj);
unless(TYPE(vector) == TYPE_VECTOR)
error("%s: first argument must be a vector", operator->operator.name);
for(i = 0; i < vector->vector.length; ++i)
vector->vector.vector[i] = obj;
return obj_undefined;
}
static obj_t entry_eval(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t exp;
eval_args(operator->operator.name, env, op_env, operands, 1, &exp);
return eval(env, op_env, exp);
}
static obj_t entry_error(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t msg;
eval_args(operator->operator.name, env, op_env, operands, 1, &msg);
unless(TYPE(msg) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
error(msg->string.string);
return obj_undefined;
}
/* (symbol->string symbol)
* Returns the name of symbol as a string.
* See R4RS 6.4.
*/
static obj_t entry_symbol_to_string(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t symbol;
eval_args(operator->operator.name, env, op_env, operands, 1, &symbol);
unless(TYPE(symbol) == TYPE_SYMBOL)
error("%s: argument must be a symbol", operator->operator.name);
return make_string(symbol->symbol.length, symbol->symbol.string);
}
/* (string->symbol symbol)
* Returns the symbol whose name is string.
* See R4RS 6.4.
*/
static obj_t entry_string_to_symbol(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t string;
eval_args(operator->operator.name, env, op_env, operands, 1, &string);
unless(TYPE(string) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
/* TODO: Should pass length to intern to avoid problems with NUL termination. */
return intern(string->string.string);
}
/* (string? obj)
* Returns #t if obj is a string, otherwise returns #f.
* See R4RS 6.7.
*/
static obj_t entry_stringp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_bool(TYPE(arg) == TYPE_STRING);
}
/* (make-string k)
* (make-string k char)
* Make-string returns a newly allocated string of length k. If char
* is given, then all elements of the string are initialized to char,
* otherwise the contents of the string are unspecified.
* See R4RS 6.7.
*/
static obj_t entry_make_string(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t obj, k, args;
char c = '\0';
int i;
eval_args_rest(operator->operator.name, env, op_env, operands, &args, 1, &k);
unless(TYPE(k) == TYPE_INTEGER)
error("%s: first argument must be an integer", operator->operator.name);
unless(k->integer.integer >= 0)
error("%s: first argument must be non-negative", operator->operator.name);
if (TYPE(args) == TYPE_PAIR) {
unless(TYPE(CAR(args)) == TYPE_CHARACTER)
error("%s: second argument must be a character", operator->operator.name);
unless(CDR(args) == obj_empty)
error("%s: too many arguments", operator->operator.name);
c = CAR(args)->character.c;
}
obj = make_string(k->integer.integer, NULL);
for (i = 0; i < k->integer.integer; ++i) {
obj->string.string[i] = c;
}
return obj;
}
/* (string char ...)
* Returns a newly allocated string composed of the arguments.
* See R4RS 6.7.
*/
static obj_t entry_string(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t args, obj, o;
size_t length;
eval_args_rest(operator->operator.name, env, op_env, operands, &args, 0);
o = args;
length = 0;
while(TYPE(o) == TYPE_PAIR) {
unless(TYPE(CAR(o)) == TYPE_CHARACTER)
error("%s: arguments must be strings", operator->operator.name);
++ length;
o = CDR(o);
}
obj = make_string(length, NULL);
o = args;
length = 0;
while(TYPE(o) == TYPE_PAIR) {
assert(TYPE(CAR(o)) == TYPE_CHARACTER);
obj->string.string[length] = CAR(o)->character.c;
++ length;
o = CDR(o);
}
assert(length == obj->string.length);
return obj;
}
/* (string-length string)
* Returns the number of characters in the given string.
* See R4RS 6.7.
*/
static obj_t entry_string_length(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
return make_integer(arg->string.length);
}
/* (string-ref string k)
* k must be a valid index of string. String-ref returns character k
* of string using zero-origin indexing.
* See R4RS 6.7.
*/
static obj_t entry_string_ref(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, k;
eval_args(operator->operator.name, env, op_env, operands, 2, &arg, &k);
unless(TYPE(arg) == TYPE_STRING)
error("%s: first argument must be a string", operator->operator.name);
unless(TYPE(k) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
unless(0 <= k->integer.integer && k->integer.integer < arg->string.length)
error("%s: second argument is out of range", operator->operator.name);
return make_character(arg->string.string[k->integer.integer]);
}
/* (string=? string1 string2)
* Returns #t if the two strings are the same length and contain the
* same characters in the same positions, otherwise returns #f.
* See R4RS 6.7.
*/
static obj_t entry_string_equalp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg1, arg2;
eval_args(operator->operator.name, env, op_env, operands, 2, &arg1, &arg2);
unless(TYPE(arg1) == TYPE_STRING)
error("%s: first argument must be a string", operator->operator.name);
unless(TYPE(arg2) == TYPE_STRING)
error("%s: second argument must be a string", operator->operator.name);
return make_bool(string_equalp(arg1, arg2));
}
/* (substring string start end)
* String must be a string, and start and end must be exact integers
* satisfying
* 0 <= start <= end <= (string-length string).
* Substring returns a newly allocated string formed from the
* characters of string beginning with index start (inclusive) and
* ending with index end (exclusive).
* See R4RS 6.7.
*/
static obj_t entry_substring(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t obj, arg, start, end;
size_t length;
eval_args(operator->operator.name, env, op_env, operands, 3, &arg, &start, &end);
unless(TYPE(arg) == TYPE_STRING)
error("%s: first argument must be a string", operator->operator.name);
unless(TYPE(start) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
unless(TYPE(end) == TYPE_INTEGER)
error("%s: third argument must be an integer", operator->operator.name);
unless(0 <= start->integer.integer
&& start->integer.integer <= end->integer.integer
&& end->integer.integer <= arg->string.length)
error("%s: arguments out of range", operator->operator.name);
length = end->integer.integer - start->integer.integer;
obj = make_string(length, NULL);
strncpy(obj->string.string, &arg->string.string[start->integer.integer], length);
return obj;
}
/* (string-append string ...)
* Returns a newly allocated string whose characters form the
* concatenation of the given strings.
* See R4RS 6.7.
*/
static obj_t entry_string_append(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t args, obj, o;
size_t length;
eval_args_rest(operator->operator.name, env, op_env, operands, &args, 0);
o = args;
length = 0;
while(TYPE(o) == TYPE_PAIR) {
unless(TYPE(CAR(o)) == TYPE_STRING)
error("%s: arguments must be strings", operator->operator.name);
length += CAR(o)->string.length;
o = CDR(o);
}
obj = make_string(length, NULL);
o = args;
length = 0;
while(TYPE(o) == TYPE_PAIR) {
string_s *s = &CAR(o)->string;
assert(TYPE(CAR(o)) == TYPE_STRING);
memcpy(obj->string.string + length, s->string, s->length + 1);
length += s->length;
o = CDR(o);
}
assert(length == obj->string.length);
return obj;
}
/* (string->list string)
* The string->list procedure returns a newly allocated list of the
* characters that make up the given string.
* See R4RS 6.7.
*/
static obj_t entry_string_to_list(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t string, list;
size_t i;
eval_args(operator->operator.name, env, op_env, operands, 1, &string);
unless(TYPE(string) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
list = obj_empty;
i = string->string.length;
while(i > 0) {
--i;
list = make_pair(make_character(string->string.string[i]), list);
}
return list;
}
/* (list->string list)
* List must be a list of characters. The list->string procedure
* returns a newly allocated string formed from the characters in
* list.
* See R4RS 6.7.
*/
static obj_t entry_list_to_string(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t l, list, string;
size_t i, length = 0;
eval_args(operator->operator.name, env, op_env, operands, 1, &list);
l = list;
while(l != obj_empty) {
unless(TYPE(l) == TYPE_PAIR)
error("%s: argument must be a list", operator->operator.name);
unless(TYPE(CAR(l)) == TYPE_CHARACTER)
error("%s: argument must be a list of characters", operator->operator.name);
++ length;
l = CDR(l);
}
string = make_string(length, NULL);
l = list;
for(i = 0; i < length; ++i) {
assert(TYPE(l) == TYPE_PAIR);
assert(TYPE(CAR(l)) == TYPE_CHARACTER);
string->string.string[i] = CAR(l)->character.c;
l = CDR(l);
}
return string;
}
/* (string-copy string)
* Returns a newly allocated copy of the given string.
* See R4RS 6.7.
*/
static obj_t entry_string_copy(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
return make_string(arg->string.length, arg->string.string);
}
/* (string-hash string)
* Returns an integer hash value for string, based on its current
* contents. This hash function is suitable for use with string=? as
* an equivalence function.
* See R6RS Library 13.2.
*/
static obj_t entry_string_hash(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
return make_integer(string_hash(arg));
}
static obj_t entry_eq_hash(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_integer(eq_hash(arg));
}
static obj_t entry_eqv_hash(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_integer(eqv_hash(arg));
}
static obj_t make_hashtable(obj_t operator, obj_t rest, hash_t hashf, cmp_t cmpf)
{
size_t length;
if (rest == obj_empty)
length = 8;
else unless(CDR(rest) == obj_empty)
error("%s: too many arguments", operator->operator.name);
else {
obj_t arg = CAR(rest);
unless(TYPE(arg) == TYPE_INTEGER)
error("%s: first argument must be an integer", operator->operator.name);
unless(arg->integer.integer > 0)
error("%s: first argument must be positive", operator->operator.name);
length = arg->integer.integer;
}
return make_table(length, hashf, cmpf);
}
/* (make-eq-hashtable)
* (make-eq-hashtable k)
* Returns a newly allocated mutable hashtable that accepts arbitrary
* objects as keys, and compares those keys with eq?. If an argument
* is given, the initial capacity of the hashtable is set to
* approximately k elements.
* See R6RS Library 13.1.
*/
static obj_t entry_make_eq_hashtable(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t rest;
eval_args_rest(operator->operator.name, env, op_env, operands, &rest, 0);
return make_hashtable(operator, rest, eq_hash, eqp);
}
/* (make-eqv-hashtable)
* (make-eqv-hashtable k)
* Returns a newly allocated mutable hashtable that accepts arbitrary
* objects as keys, and compares those keys with eqv?. If an argument
* is given, the initial capacity of the hashtable is set to
* approximately k elements.
* See R6RS Library 13.1.
*/
static obj_t entry_make_eqv_hashtable(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t rest;
eval_args_rest(operator->operator.name, env, op_env, operands, &rest, 0);
return make_hashtable(operator, rest, eqv_hash, eqvp);
}
/* (make-hashtable hash-function equiv)
* (make-hashtable hash-function equiv k)
* Hash-function and equiv must be procedures. Hash-function should
* accept a key as an argument and should return a non-negative exact
* integer object. Equiv should accept two keys as arguments and
* return a single value. Neither procedure should mutate the
* hashtable returned by make-hashtable. The make-hashtable procedure
* returns a newly allocated mutable hashtable using hash-function as
* the hash function and equiv as the equivalence function used to
* compare keys. If a third argument is given, the initial capacity of
* the hashtable is set to approximately k elements.
* See R6RS Library 13.1.
*/
static obj_t entry_make_hashtable(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t hashf, cmpf, rest;
eval_args_rest(operator->operator.name, env, op_env, operands, &rest, 2, &hashf, &cmpf);
unless(TYPE(hashf) == TYPE_OPERATOR)
error("%s: first argument must be a procedure", operator->operator.name);
unless(TYPE(cmpf) == TYPE_OPERATOR)
error("%s: first argument must be a procedure", operator->operator.name);
if (hashf->operator.entry == entry_eq_hash
&& cmpf->operator.entry == entry_eqp)
return make_hashtable(operator, rest, eq_hash, eqp);
if (hashf->operator.entry == entry_eqv_hash
&& cmpf->operator.entry == entry_eqvp)
return make_hashtable(operator, rest, eqv_hash, eqvp);
if (hashf->operator.entry == entry_string_hash
&& cmpf->operator.entry == entry_string_equalp)
return make_hashtable(operator, rest, string_hash, string_equalp);
error("%s: arguments not supported", operator->operator.name);
return obj_undefined;
}
/* (hashtable? hashtable)
* Returns #t if hashtable is a hashtable, #f otherwise.
* See R6RS Library 13.2.
*/
static obj_t entry_hashtablep(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_bool(TYPE(arg) == TYPE_TABLE);
}
/* (hashtable-size hashtable)
* Returns the number of keys contained in hashtable as an exact
* integer object.
* See R6RS Library 13.2.
*/
static obj_t entry_hashtable_size(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_TABLE)
error("%s: argument must be a hash table", operator->operator.name);
return make_integer(table_size(arg));
}
/* (hashtable-ref hashtable key default)
* Returns the value in hashtable associated with key. If hashtable
* does not contain an association for key, default is returned.
* See R6RS Library 13.2.
*/
static obj_t entry_hashtable_ref(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t tbl, key, def, value;
eval_args(operator->operator.name, env, op_env, operands, 3, &tbl, &key, &def);
unless(TYPE(tbl) == TYPE_TABLE)
error("%s: first argument must be a hash table", operator->operator.name);
value = table_ref(tbl, key);
if (value) return value;
return def;
}
/* (hashtable-set! hashtable key value)
* Changes hashtable to associate key with obj, adding a new
* association or replacing any existing association for key, and
* returns unspecified values.
* See R6RS Library 13.2.
*/
static obj_t entry_hashtable_set(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t tbl, key, value;
eval_args(operator->operator.name, env, op_env, operands, 3, &tbl, &key, &value);
unless(TYPE(tbl) == TYPE_TABLE)
error("%s: first argument must be a hash table", operator->operator.name);
table_set(tbl, key, value);
return obj_undefined;
}
/* (hashtable-delete! hashtable key)
* Removes any association for key within hashtable and returns
* unspecified values.
* See R6RS Library 13.2.
*/
static obj_t entry_hashtable_delete(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t tbl, key;
eval_args(operator->operator.name, env, op_env, operands, 2, &tbl, &key);
unless(TYPE(tbl) == TYPE_TABLE)
error("%s: first argument must be a hash table", operator->operator.name);
table_delete(tbl, key);
return obj_undefined;
}
/* (hashtable-contains? hashtable key)
* Returns #t if hashtable contains an association for key, #f otherwise.
* See R6RS Library 13.2.
*/
static obj_t entry_hashtable_containsp(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t tbl, key;
eval_args(operator->operator.name, env, op_env, operands, 2, &tbl, &key);
unless(TYPE(tbl) == TYPE_TABLE)
error("%s: first argument must be a hash table", operator->operator.name);
return make_bool(table_ref(tbl, key) != NULL);
}
/* (hashtable-keys hashtable)
* Returns a vector of all keys in hashtable. The order of the vector
* is unspecified.
* See R6RS Library 13.2.
*/
static obj_t entry_hashtable_keys(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
size_t i, j = 0;
obj_t tbl, vector;
eval_args(operator->operator.name, env, op_env, operands, 1, &tbl);
unless(TYPE(tbl) == TYPE_TABLE)
error("%s: argument must be a hash table", operator->operator.name);
vector = make_vector(table_size(tbl), obj_undefined);
for(i = 0; i < tbl->table.buckets->buckets.length; ++i) {
struct bucket_s *b = &tbl->table.buckets->buckets.bucket[i];
if(b->key != NULL && b->key != obj_deleted)
vector->vector.vector[j++] = b->value;
}
assert(j == vector->vector.length);
return vector;
}
/* (gc)
* Run a full garbage collection now.
*/
static obj_t entry_gc(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
eval_args(operator->operator.name, env, op_env, operands, 0);
GC_gcollect();
return obj_undefined;
}
/* INITIALIZATION */
/* special table */
static struct {char *name; obj_t *varp;} sptab[] = {
{"()", &obj_empty},
{"#[eof]", &obj_eof},
{"#[error]", &obj_error},
{"#t", &obj_true},
{"#f", &obj_false},
{"#[undefined]", &obj_undefined},
{"#[tail]", &obj_tail},
{"#[deleted]", &obj_deleted}
};
/* initial symbol table */
static struct {char *name; obj_t *varp;} isymtab[] = {
{"quote", &obj_quote},
{"lambda", &obj_lambda},
{"begin", &obj_begin},
{"else", &obj_else},
{"quasiquote", &obj_quasiquote},
{"unquote", &obj_unquote},
{"unquote-splicing", &obj_unquote_splic}
};
/* operator table */
static struct {char *name; entry_t entry;} optab[] = {
{"quote", entry_quote},
{"define", entry_define},
{"set!", entry_set},
{"lambda", entry_lambda},
{"begin", entry_begin},
{"cond", entry_cond},
{"if", entry_if},
{"and", entry_and},
{"or", entry_or},
{"let", entry_let},
{"let*", entry_let_star},
{"letrec", entry_letrec},
{"do", entry_do},
{"delay", entry_delay},
{"quasiquote", entry_quasiquote}
};
/* function table */
static struct {char *name; entry_t entry;} funtab[] = {
{"not", entry_not},
{"boolean?", entry_booleanp},
{"eqv?", entry_eqvp},
{"eq?", entry_eqp},
{"equal?", entry_equalp},
{"pair?", entry_pairp},
{"cons", entry_cons},
{"car", entry_car},
{"cdr", entry_cdr},
{"set-car!", entry_setcar},
{"set-cdr!", entry_setcdr},
{"null?", entry_nullp},
{"list?", entry_listp},
{"list", entry_list},
{"length", entry_length},
{"append", entry_append},
{"integer?", entry_integerp},
{"zero?", entry_zerop},
{"positive?", entry_positivep},
{"negative?", entry_negativep},
{"symbol?", entry_symbolp},
{"procedure?", entry_procedurep},
{"apply", entry_apply},
{"+", entry_add},
{"-", entry_subtract},
{"*", entry_multiply},
{"/", entry_divide},
{"<", entry_lessthan},
{">", entry_greaterthan},
{"reverse", entry_reverse},
{"list-tail", entry_list_tail},
{"list-ref", entry_list_ref},
{"the-environment", entry_environment},
{"open-input-file", entry_open_input_file},
{"open-output-file", entry_open_output_file},
{"close-input-port", entry_close_port},
{"close-output-port", entry_close_port},
{"write", entry_write},
{"write-string", entry_write_string},
{"newline", entry_newline},
{"load", entry_load},
{"force", entry_force},
{"char?", entry_charp},
{"char->integer", entry_char_to_integer},
{"integer->char", entry_integer_to_char},
{"vector?", entry_vectorp},
{"make-vector", entry_make_vector},
{"vector", entry_vector},
{"vector-length", entry_vector_length},
{"vector-ref", entry_vector_ref},
{"vector-set!", entry_vector_set},
{"vector->list", entry_vector_to_list},
{"list->vector", entry_list_to_vector},
{"vector-fill!", entry_vector_fill},
{"eval", entry_eval},
{"error", entry_error},
{"symbol->string", entry_symbol_to_string},
{"string->symbol", entry_string_to_symbol},
{"string?", entry_stringp},
{"make-string", entry_make_string},
{"string", entry_string},
{"string-length", entry_string_length},
{"string-ref", entry_string_ref},
{"string=?", entry_string_equalp},
{"substring", entry_substring},
{"string-append", entry_string_append},
{"string->list", entry_string_to_list},
{"list->string", entry_list_to_string},
{"string-copy", entry_string_copy},
{"make-eq-hashtable", entry_make_eq_hashtable},
{"make-eqv-hashtable", entry_make_eqv_hashtable},
{"make-hashtable", entry_make_hashtable},
{"hashtable?", entry_hashtablep},
{"hashtable-size", entry_hashtable_size},
{"hashtable-ref", entry_hashtable_ref},
{"hashtable-set!", entry_hashtable_set},
{"hashtable-delete!", entry_hashtable_delete},
{"hashtable-contains?", entry_hashtable_containsp},
{"hashtable-keys", entry_hashtable_keys},
{"string-hash", entry_string_hash},
{"eq-hash", entry_eq_hash},
{"eqv-hash", entry_eqv_hash},
{"gc", entry_gc},
};
/* MAIN PROGRAM */
int main(int argc, char *argv[])
{
FILE *input = stdin;
size_t i;
volatile obj_t env, op_env, obj;
jmp_buf jb;
GC_INIT();
GC_enable_incremental();
total = (size_t)0;
symtab_size = 16;
symtab = GC_MALLOC(sizeof(obj_t) * symtab_size);
if(symtab == NULL) error("out of memory");
for(i = 0; i < symtab_size; ++i)
symtab[i] = NULL;
error_handler = &jb;
if(!setjmp(*error_handler)) {
for(i = 0; i < LENGTH(sptab); ++i)
*sptab[i].varp = make_special(sptab[i].name);
for(i = 0; i < LENGTH(isymtab); ++i)
*isymtab[i].varp = intern(isymtab[i].name);
env = make_pair(obj_empty, obj_empty);
op_env = make_pair(obj_empty, obj_empty);
for(i = 0; i < LENGTH(funtab); ++i)
define(env,
intern(funtab[i].name),
make_operator(funtab[i].name, funtab[i].entry,
obj_empty, obj_empty, env, op_env));
for(i = 0; i < LENGTH(optab); ++i)
define(op_env,
intern(optab[i].name),
make_operator(optab[i].name, optab[i].entry,
obj_empty, obj_empty, env, op_env));
} else {
fprintf(stderr,
"Fatal error during initialization: %s\n",
error_message);
abort();
}
if(argc >= 2) {
/* Non-interactive file execution */
if(setjmp(*error_handler) != 0) {
fprintf(stderr, "%s\n", error_message);
return EXIT_FAILURE;
}
load(env, op_env, argv[1]);
return EXIT_SUCCESS;
} else {
/* Interactive read-eval-print loop */
puts("Scheme Test Harness");
for(;;) {
if(setjmp(*error_handler) != 0)
fprintf(stderr, "%s\n", error_message);
printf("%lu> ", (unsigned long)total);
obj = read(input);
if(obj == obj_eof) break;
obj = eval(env, op_env, obj);
if(obj != obj_undefined) {
print(obj, 6, stdout);
putc('\n', stdout);
}
}
puts("Bye.");
return EXIT_SUCCESS;
}
}
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2013 Ravenbrook Limited <http://www.ravenbrook.com/>.
* All rights reserved. This is an open source license. Contact
* Ravenbrook for commercial licensing options.
*
* 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. Redistributions in any form must be accompanied by information on how
* to obtain complete source code for this software and any accompanying
* software that uses this software. The source code must either be
* included in the distribution or be available for no more than the cost
* of distribution plus a nominal fee, and must be freely redistributable
* under reasonable conditions. For an executable file, complete source
* code means the source code for all modules it contains. It does not
* include source code for modules or files that typically accompany the
* major components of the operating system on which the executable file
* runs.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
* IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
* PURPOSE, OR NON-INFRINGEMENT, ARE DISCLAIMED. IN NO EVENT SHALL THE
* COPYRIGHT HOLDERS AND CONTRIBUTORS 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.
*/