Commit d400fc14 authored by Chris Müller's avatar Chris Müller
Browse files

Massively simplify symboltables and environment frames

parent 6c88ec6f
......@@ -5,7 +5,6 @@ set(BOOTSTRAP_SOURCES
eval.c
value.c
unicode.c
tables.c
runtime.c)
add_executable(bootstrap-cherry ${BOOTSTRAP_SOURCES})
......
......@@ -58,13 +58,12 @@ process_file(const char* filename, const byte_t* method, struct value* arguments
{
const byte_t* src = get_text(filename, "rb");
struct environment* env = environment();
struct value* env = environment();
if(src == 0)
failure(0, "Could not load %s", filename);
struct context* c = context(src, filename, SUPRESS_COMMENTS);
struct value* exp = cherry_read(c);
while(exp != 0) {
......@@ -72,10 +71,11 @@ process_file(const char* filename, const byte_t* method, struct value* arguments
exp = cherry_read(c);
}
if(method) {
struct value* main = cons(symbol(method), arguments);
cherry_eval(env, main);
}
if(!method)
method = "main";
struct value* main = cons(symbol(method), arguments);
cherry_eval(env, main);
exit(EXIT_SUCCESS);
}
......@@ -86,7 +86,7 @@ start_repl(void)
{
printf("Welcome to bootstrap-cherry\n\n");
struct environment* env = environment();
struct value* env = environment();
byte_t* line = (byte_t*) readline("> ");
struct context* context = context_repl(line);
......
......@@ -23,7 +23,6 @@
#include <setjmp.h>
#include <string.h>
struct environment;
struct context;
struct value;
......@@ -41,7 +40,7 @@ typedef uint32_t unicode_t;
typedef uint32_t flags_t;
typedef struct value* (*primitive_t)(struct environment* env, struct value* args);
typedef struct value* (*primitive_t)(struct value* env, struct value* args);
enum value_type {
EMPTYLIST, BOOLEAN, DOT,
......@@ -81,7 +80,7 @@ struct value {
struct {
struct value* param;
struct value* body;
struct environment* env;
struct value* env;
} proc;
};
};
......@@ -136,33 +135,35 @@ struct value* value_dup(struct value* value);
#define list4(a, b, c, d) cons(a, cons(b, cons(c, cons(d, emptylist))))
struct value* cons(struct value* head, struct value* tail);
size_t list_length(struct value* value);
struct value* list_to_tuple(struct value* value);
struct value* list_reverse(struct value* value);
struct value* tuple_new(size_t size);
struct value* procedure(struct environment* env, struct value* param, struct value* body);
struct value* procedure(struct value* env, struct value* param, struct value* body);
// ----------------------------------------------------------------------------
// Symboltables and Environment
// ----------------------------------------------------------------------------
struct symbollist;
#define SYMBOL_ENTRY(sym, left, right) cons(sym, cons(left, right))
#define SYMBOL_LEFT(node) HEAD(TAIL(node))
#define SYMBOL_RIGHT(node) TAIL(TAIL(node))
struct symbollist* symbollist(void);
struct value* symbollist_get(struct symbollist* table, const byte_t* name);
#define EXTEND_ENV(env) cons(cons(emptylist,emptylist), env)
#define INITIAL_ENV EXTEND_ENV(emptylist)
#define FIRST_FRAME(env) HEAD(env)
#define PARENT_FRAMES(env) TAIL(env)
#define FRAME_VARIABLES(frame) HEAD(frame)
#define FRAME_VALUES(frame) TAIL(frame)
struct environment {
struct symbollist* mapping;
};
struct environment* env_push(struct environment* env);
struct environment* env_pop(struct environment* env);
struct value* env_lookup(struct environment* env, struct value* symbol);
int env_add(struct environment* env, struct value* symbol, struct value* value);
struct environment* environment(void);
struct value* environment(void);
struct value* env_lookup(struct value* env, struct value* var);
struct value* env_set(struct value* env, struct value* var, struct value* val);
struct value* env_let(struct value* env, struct value* var, struct value* val);
extern struct symbollist* global_symbollist;
extern struct value* global_symbollist;
extern struct value* emptylist;
extern struct value* True;
......@@ -230,7 +231,7 @@ extern struct value* symbol_else;
#define TEXT_OF_QUOTATION(value) \
HEAD(TAIL(value))
struct value* cherry_eval(struct environment* env, struct value* exp);
struct value* cherry_eval(struct value* env, struct value* exp);
void cherry_print(FILE* out, struct value* value);
struct value* cherry_read(struct context* context);
......
......@@ -19,43 +19,16 @@
#include "bootstrap.h"
static struct value*
eval_let(struct environment* env, struct value* exp)
eval_values(struct value* env, struct value* args)
{
struct value* symbol = HEAD(exp);
struct value* value = HEAD(TAIL(exp));
if(env_add(env, symbol, cherry_eval(env, value)))
return True;
if(IS_NULL(args))
return args;
else
return False;
}
static struct value*
eval_values(struct environment* env, struct value* values)
{
if(IS_NULL(values))
return values;
struct value* begin = cons(cherry_eval(env, HEAD(values)), emptylist);
struct value* prev = begin;
struct value* head;
values = TAIL(values);
while(!IS_NULL(values)) {
head = cons(cherry_eval(env, HEAD(values)), emptylist);
TAIL(prev) = head;
prev = head;
values = TAIL(values);
}
return begin;
return cons(cherry_eval(env, HEAD(args)), eval_values(env, TAIL(args)));
}
struct value*
cherry_eval(struct environment* env, struct value* value)
cherry_eval(struct value* env, struct value* value)
{
struct value *proc, *args;
......@@ -64,20 +37,13 @@ tailcall:
return value;
else if(IS_VARIABLE(value)) {
struct value* v = env_lookup(env, value);
if(!v) {
fprintf(stderr, "Unbound value for %s found\n", value->symbol_value);
exit(EXIT_FAILURE);
}
return v;
return env_lookup(env, value);
} else if(IS_QUOTE(value))
return TEXT_OF_QUOTATION(value);
else if(IS_LET(value))
return eval_let(env, TAIL(value));
return env_let(env, HEAD(TAIL(value)), cherry_eval(env, HEAD(TAIL(TAIL(value)))));
else if(IS_BEGIN(value)) {
value = TAIL(value);
......@@ -104,33 +70,31 @@ tailcall:
if(IS_PRIMITIVE(proc))
return (proc->fun_value)(env, args);
else if(IS_PROCEDURE(proc)) {
env = PROC_ENV(proc);
env_push(env);
env = EXTEND_ENV(PROC_ENV(proc));
struct value* params = PROC_PARAM(proc);
if(IS_VARIABLE(params))
env_add(env, params, args);
env_let(env, params, args);
else {
while(!IS_NULL(params)) {
if(IS_DOT(HEAD(params)) && !IS_NULL(TAIL(params))) {
env_add(env, HEAD(TAIL(params)), args);
env_let(env, HEAD(TAIL(params)), args);
params = emptylist;
args = emptylist;
} else if(!IS_DOT(HEAD(params))) {
if(!IS_NULL(args)) {
env_add(env, HEAD(params), HEAD(args));
env_let(env, HEAD(params), HEAD(args));
args = TAIL(args);
} else {
// TODO Error msg
failure(0, "Eval: Dot operator given without a variable");
}
params = TAIL(params);
}
}
}
value = cons(symbol_begin, PROC_BODY(proc));
value = cons(symbol_begin, PROC_BODY(proc));
goto tailcall;
} else {
fprintf(stderr, "unknown procedure type\n");
......
......@@ -695,6 +695,23 @@ read_pair(struct context* context)
return cons(head, tail);
}
static struct value*
read_tuple(struct context* context)
{
const byte_t* p;
enum tok tok;
p = pos(context);
tok = lex(context);
if(tok == TOK_SQUARERIGHTBRACE || tok == TOK_EOF)
return emptylist;
repos(context, p);
return cons(cherry_read(context), read_tuple(context));
}
static struct value*
transform_define(struct value* value)
......@@ -857,6 +874,9 @@ cherry_read(struct context* context)
case TOK_ROUNDLEFTBRACE:
return transform(read_pair(context));
case TOK_SQUARELEFTBRACE:
return list_to_tuple(read_tuple(context));
case TOK_QUOTE:
return cons(symbol_quote, cons(cherry_read(context), emptylist));
......
......@@ -24,7 +24,7 @@
// globals
// ----------------------------------------------------------------------------
struct symbollist* global_symbollist;
struct value* global_symbollist;
struct value* emptylist;
struct value* True;
struct value* False;
......@@ -51,7 +51,6 @@ void
initialize(struct value* arguments)
{
GC_INIT();
global_symbollist = symbollist();
True = value_alloc();
True->tag = BOOLEAN;
......@@ -69,6 +68,8 @@ initialize(struct value* arguments)
HEAD(emptylist) = emptylist;
TAIL(emptylist) = emptylist;
global_symbollist = emptylist;
symbol_quote = symbol("quote");
symbol_define = symbol("define");
symbol_let = symbol("let");
......@@ -86,9 +87,83 @@ initialize(struct value* arguments)
STDERR = port(stderr);
}
struct value*
env_lookup(struct value* env, struct value* symbol)
{
struct value *frame, *vars, *vals;
while(!IS_NULL(env)) {
frame = FIRST_FRAME(env);
vars = FRAME_VARIABLES(frame);
vals = FRAME_VALUES(frame);
while(!IS_NULL(vars)) {
if(symbol == HEAD(vars))
return HEAD(vals);
vars = TAIL(vars);
vals = TAIL(vals);
}
env = PARENT_FRAMES(env);
}
failure(0, "Unbound variable found for symbol %s", symbol->symbol_value);
}
struct value*
env_set(struct value* env, struct value* var, struct value* val)
{
struct value *frame, *vars, *vals;
while(!IS_NULL(env)) {
frame = FIRST_FRAME(env);
vars = FRAME_VARIABLES(frame);
vals = FRAME_VALUES(frame);
while(!IS_NULL(vars)) {
if(var == HEAD(vars)) {
HEAD(vals) = val;
return True;
}
vars = TAIL(vars);
vals = TAIL(vals);
}
env = PARENT_FRAMES(env);
}
failure(0, "Unbound variable found for symbol %s", var->symbol_value);
}
struct value*
env_let(struct value* env, struct value* var, struct value* val)
{
struct value* frame = FIRST_FRAME(env);
struct value* vars = FRAME_VARIABLES(frame);
struct value* vals = FRAME_VALUES(frame);
while(!IS_NULL(vars)) {
if(var == HEAD(vars)) {
failure(0, "Overwrite declaration from variable %s", var->symbol_value);
}
vars = TAIL(vars);
vals = TAIL(vals);
}
HEAD(frame) = cons(var, HEAD(frame));
TAIL(frame) = cons(val, TAIL(frame));
return True;
}
struct value*
core_raise(struct environment* env, struct value* args)
core_raise(struct value* env, struct value* args)
{
fprintf(stderr, "ERROR --- ");
......@@ -102,7 +177,7 @@ core_raise(struct environment* env, struct value* args)
struct value*
core_type(struct environment* env, struct value* args)
core_type(struct value* env, struct value* args)
{
if(IS_NULL(args))
core_raise(env, string("cherry.core/type: type functions expects an argument"));
......@@ -137,7 +212,7 @@ core_type(struct environment* env, struct value* args)
struct value*
core_cons(struct environment* env, struct value* args)
core_cons(struct value* env, struct value* args)
{
if(IS_NULL(args) || IS_NULL(TAIL(args)) || !IS_NULL(TAIL(TAIL(args))))
core_raise(env, string("cherry.core/cons: only accept exactly two parameters"));
......@@ -149,14 +224,14 @@ core_cons(struct environment* env, struct value* args)
struct value*
core_list(struct environment* env, struct value* args)
core_list(struct value* env, struct value* args)
{
return args;
}
struct value*
core_is_list(struct environment* env, struct value* args)
core_is_list(struct value* env, struct value* args)
{
if(IS_NULL(args))
core_raise(env, string("cherry.core/list?: expects one value"));
......@@ -169,7 +244,7 @@ core_is_list(struct environment* env, struct value* args)
struct value*
core_is_null(struct environment* env, struct value* args)
core_is_null(struct value* env, struct value* args)
{
if(IS_NULL(args))
core_raise(env, string("cherry.core/null?: expects an operand"));
......@@ -180,7 +255,7 @@ core_is_null(struct environment* env, struct value* args)
struct value*
core_make_list(struct environment* env, struct value* args)
core_make_list(struct value* env, struct value* args)
{
if(IS_NULL(args) || !IS_FIXNUM(HEAD(args)) || IS_NULL(TAIL(args)))
core_raise(env, string("cherry.core/make-list: expects a length fixnum and an initialization element"));
......@@ -197,7 +272,7 @@ core_make_list(struct environment* env, struct value* args)
struct value*
core_head(struct environment* env, struct value* args)
core_head(struct value* env, struct value* args)
{
if(IS_NULL(args) || !IS_PAIR(HEAD(args)))
core_raise(env, string("cherry.core/head: no list is given for the first operand"));
......@@ -206,7 +281,7 @@ core_head(struct environment* env, struct value* args)
}
struct value*
core_tail(struct environment* env, struct value* args)
core_tail(struct value* env, struct value* args)
{
if(IS_NULL(args) || !IS_PAIR(HEAD(args)))
core_raise(env, string("cherry.core/tail: no list is given for the first operand"));
......@@ -216,7 +291,7 @@ core_tail(struct environment* env, struct value* args)
struct value*
core_length(struct environment* env, struct value* args)
core_length(struct value* env, struct value* args)
{
if(IS_NULL(args))
return fixnum(0);
......@@ -247,7 +322,7 @@ core_length(struct environment* env, struct value* args)
struct value*
core_nth(struct environment* env, struct value* args)
core_nth(struct value* env, struct value* args)
{
if(IS_NULL(args) || IS_NULL(TAIL(args)) || !IS_FIXNUM(HEAD(TAIL(args))))
core_raise(env, string("cherry.core/nth: expects a value and a following fixnum as index"));
......@@ -293,7 +368,7 @@ core_nth(struct environment* env, struct value* args)
struct value*
core_map(struct environment* env, struct value* args)
core_map(struct value* env, struct value* args)
{
if(IS_NULL(args) || IS_NULL(TAIL(args)) || !IS_PROCEDURE(HEAD(args)) || !IS_PAIR(HEAD(TAIL(args))))
core_raise(env, string("cherry.core/map: expects a function and a list"));
......@@ -318,7 +393,7 @@ core_map(struct environment* env, struct value* args)
struct value*
core_list_to_string(struct environment* env, struct value* args)
core_list_to_string(struct value* env, struct value* args)
{
if(IS_NULL(args) || !IS_PAIR(HEAD(args)))
core_raise(env, string("cherry.core/list->string: expects a pair for the first operand"));
......@@ -348,7 +423,7 @@ core_list_to_string(struct environment* env, struct value* args)
struct value*
core_list_to_tuple(struct environment* env, struct value* args)
core_list_to_tuple(struct value* env, struct value* args)
{
if(IS_NULL(args) || !IS_PAIR(HEAD(args)))
core_raise(env, string("cherry.core/list->tuple: expects a pair for the first operand"));
......@@ -376,7 +451,7 @@ core_list_to_tuple(struct environment* env, struct value* args)
struct value*
core_is_tuple(struct environment* env, struct value* args)
core_is_tuple(struct value* env, struct value* args)
{
if(IS_NULL(args))
return False;
......@@ -386,7 +461,7 @@ core_is_tuple(struct environment* env, struct value* args)
struct value*
core_tuple(struct environment* env, struct value* args)
core_tuple(struct value* env, struct value* args)
{
struct value* p = args;
size_t size = 0;
......@@ -409,7 +484,7 @@ core_tuple(struct environment* env, struct value* args)
}
struct value*
core_make_tuple(struct environment* env, struct value* args)
core_make_tuple(struct value* env, struct value* args)
{
if(IS_NULL(args) || !IS_FIXNUM(HEAD(args)) || !IS_NULL(TAIL(args)))
core_raise(env, string("cherry.core/make-tuple: expects a length fixnum and an initialization element"));
......@@ -428,7 +503,7 @@ core_make_tuple(struct environment* env, struct value* args)
struct value*
core_is_string(struct environment* env, struct value* args)
core_is_string(struct value* env, struct value* args)
{
if(IS_NULL(args))
return False;
......@@ -438,7 +513,7 @@ core_is_string(struct environment* env, struct value* args)
struct value*
core_string_to_list(struct environment* env, struct value* args)
core_string_to_list(struct value* env, struct value* args)
{
if(IS_NULL(args) || !IS_STRING(HEAD(args)))
core_raise(env, string("cherry.core/string->list: accepts only one string as argument"));
......@@ -458,7 +533,7 @@ core_string_to_list(struct environment* env, struct value* args)
struct value*
core_string_to_tuple(struct environment* env, struct value* args)
core_string_to_tuple(struct value* env, struct value* args)
{
if(IS_NULL(args) || !IS_STRING(HEAD(args)))
core_raise(env, string("cherry.core/string->tuple: accepts only one string as argument"));
......@@ -478,7 +553,7 @@ core_string_to_tuple(struct environment* env, struct value* args)
struct value*
core_string_to_number(struct environment* env, struct value* args)
core_string_to_number(struct value* env, struct value* args)
{
if(IS_NULL(args) || !IS_STRING(HEAD(args)))
core_raise(env, string("cherry.core/string->number: accepts only one string as argument"));
......@@ -493,7 +568,7 @@ core_string_to_number(struct environment* env, struct value* args)
struct value*
core_string_to_symbol(struct environment* env, struct value* args)
core_string_to_symbol(struct value* env, struct value* args)
{
if(IS_NULL(args) || !IS_STRING(HEAD(args)))
core_raise(env, string("cherry.core/string->symbol: accepts only one string as argument"));
......@@ -503,7 +578,7 @@ core_string_to_symbol(struct environment* env, struct value* args)
struct value*
core_is_symbol(struct environment* env, struct value* args)
core_is_symbol(struct value* env, struct value* args)
{
if(IS_NULL(args))
return False;
......@@ -513,7 +588,7 @@ core_is_symbol(struct environment* env, struct value* args)
struct value*
core_symbol_to_string(struct environment* env, struct value* args)
core_symbol_to_string(struct value* env, struct value* args)
{
if(IS_NULL(args) || !IS_SYMBOL(HEAD(args)))
core_raise(env, string("cherry.core/symbol->string: accepts only one symbol as argument"));
......@@ -524,7 +599,7 @@ core_symbol_to_string(struct environment* env, struct value* args)
struct value*
core_string_equal(struct environment* env, struct value* args)
core_string_equal(struct value* env, struct value* args)
{
if(IS_NULL(args) || IS_NULL(TAIL(args)) || !IS_STRING(HEAD(args)) || !IS_STRING(HEAD(TAIL(args))))
core_raise(env, string("cherry.core/string-equal?: expects only two strings"));
......@@ -540,7 +615,7 @@ core_string_equal(struct environment* env, struct value* args)
struct value*
core_add(struct environment* env, struct value* args)
core_add(struct value* env, struct value* args)
{
struct value* v = fixnum(0);
......@@ -575,7 +650,7 @@ core_add(struct environment* env, struct value* args)
}
struct value*
core_sub(struct environment* env, struct value* args)
core_sub(struct value* env, struct value* args)
{
if(IS_NULL(args))
return fixnum(0);
......@@ -616,7 +691,7 @@ core_sub(struct environment* env, struct value* args)
}
struct value*
core_mul(struct environment* env, struct value* args)
core_mul(struct value* env, struct value* args)
{
struct value* v = fixnum(1);
......@@ -652,7 +727,7 @@ core_mul(struct environment* env, struct value* args)
struct value*
core_div(struct environment* env, struct value* args)
core_div(struct value* env, struct value* args)
{
if(IS_NULL(args))
return fixnum(0);
......@@ -701,7 +776,7 @@ core_div(struct environment* env, struct value* args)
struct value*
core_not(struct environment* env, struct value* args)
core_not(struct value* env, struct value* args)