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

implement bootstrap-cherry with runtime environment

parent 15de1954
...@@ -35,6 +35,7 @@ struct value* Define = NULL; ...@@ -35,6 +35,7 @@ struct value* Define = NULL;
struct value* Let = NULL; struct value* Let = NULL;
struct value* Lambda = NULL; struct value* Lambda = NULL;
struct value* If = NULL; struct value* If = NULL;
struct value* Begin = NULL;
static void static void
failure(const byte_t* format, ...) failure(const byte_t* format, ...)
...@@ -149,13 +150,23 @@ primitive(const primitive_t fun_value) ...@@ -149,13 +150,23 @@ primitive(const primitive_t fun_value)
return v; return v;
} }
struct value*
foreign(pointer_t value)
{
struct value* v = alloc_value();
v->tag = FOREIGN;
v->foreign_value = value;
return v;
}
struct value* struct value*
lambda(struct value* param, struct value* body) procedure(struct value* env, struct value* param, struct value* body)
{ {
struct value* v = alloc_value(); struct value* v = alloc_value();
v->tag = LAMBDA; v->tag = PROCEDURE;
v->lambda.param = param; v->procedure.env = env;
v->lambda.body = body; v->procedure.param = param;
v->procedure.body = body;
return v; return v;
} }
...@@ -239,11 +250,70 @@ initialize(void) ...@@ -239,11 +250,70 @@ initialize(void)
global_symbollist = Emptylist; global_symbollist = Emptylist;
Quote = symbol("quote"); Quote = symbol("quote");
Define = symbol("define");
Let = symbol("let"); Let = symbol("let");
Lambda = symbol("lambda"); Lambda = symbol("lambda");
If = symbol("If"); If = symbol("if");
Define = symbol("define");
Begin = symbol("begin");
}
static struct value*
core_environment(void)
{
struct value* env = INITIAL_ENV;
#define proc_to_env(ENV, STR, FUN) \
env_let(ENV, symbol(STR), primitive(FUN))
proc_to_env(env, "println", core_println);
return env;
}
// ----------------------------------------------------------------------------
// Primitives
// ----------------------------------------------------------------------------
struct value*
core_println(struct value* env, struct value* args)
{
struct value* v;
while(!IS_NULL(args)) {
v = HEAD(args);
switch(v->tag) {
case BOOLEAN:
if(IS_TRUE(v))
printf("true");
else
printf("false");
break;
case STRING:
printf("%s", v->string_value);
break;
case SYMBOL:
printf("%s", v->symbol_value);
break;
case FIXNUM:
printf("%ld", v->fixnum_value);
break;
case FLOAT:
printf("%lf", v->float_value);
break;
default:
failure("cherry.core.println: Argument not accepted");
break;
}
args = TAIL(args);
}
printf("\n");
return True;
} }
// ---------------------------------------------------------------------------- // ----------------------------------------------------------------------------
...@@ -437,7 +507,7 @@ lex_char(byte_t** begin, byte_t* buffer, size_t buffer_size) ...@@ -437,7 +507,7 @@ lex_char(byte_t** begin, byte_t* buffer, size_t buffer_size)
buffer++; buffer++;
p++; p++;
} else } else
failure("Bufferoverflow in character literal"); failure("Read: Bufferoverflow in character scanning");
} }
*buffer = '\0'; *buffer = '\0';
...@@ -457,6 +527,9 @@ lex_raw_string(byte_t** begin, byte_t* buffer, size_t buffer_size) ...@@ -457,6 +527,9 @@ lex_raw_string(byte_t** begin, byte_t* buffer, size_t buffer_size)
p++; // remove beginning delimeter p++; // remove beginning delimeter
while(*p != '\0' && *p != '~') { while(*p != '\0' && *p != '~') {
printf("STREAM %s\n", p);
fflush(stdout);
if(*p == '\r' || *p == '\n') if(*p == '\r' || *p == '\n')
failure("Unexpected newline/carriage return found in raw string"); failure("Unexpected newline/carriage return found in raw string");
...@@ -466,15 +539,11 @@ lex_raw_string(byte_t** begin, byte_t* buffer, size_t buffer_size) ...@@ -466,15 +539,11 @@ lex_raw_string(byte_t** begin, byte_t* buffer, size_t buffer_size)
buffer++; buffer++;
p++; p++;
} else } else
failure("Bufferoverflow in raw string literal"); failure("Read: Bufferoverflow in raw string scanning");
buffer++;
p++;
} }
*buffer = '\0'; *buffer = '\0';
*begin = (*p != '\0') ? p : p + 1; *begin = (*p != '\0') ? p + 1 : p;
return TOK_STRING; return TOK_STRING;
} }
...@@ -564,13 +633,13 @@ lex_string(byte_t** begin, byte_t* buffer, size_t buffer_size) ...@@ -564,13 +633,13 @@ lex_string(byte_t** begin, byte_t* buffer, size_t buffer_size)
} }
*buffer = *p; *buffer = *p;
if(buffer < buf_end)
buffer++;
else
failure("Read: Bufferoverflow in string scanning");
NO_BUFFER_APPEND: NO_BUFFER_APPEND:
if(buffer < buf_end) { p++;
buffer++;
p++;
} else
failure("Bufferoverflow in string scanning");
} }
RETURN_TOKEN: RETURN_TOKEN:
...@@ -821,9 +890,10 @@ env_set(struct value* env, struct value* var, struct value* val) ...@@ -821,9 +890,10 @@ env_set(struct value* env, struct value* var, struct value* val)
vals = FRAME_VALUES(frame); vals = FRAME_VALUES(frame);
while(!IS_NULL(vars)) { while(!IS_NULL(vars)) {
if(var == HEAD(vars)) if(var == HEAD(vars)) {
HEAD(vals) = val; HEAD(vals) = val;
return True; return True;
}
vars = TAIL(vars); vars = TAIL(vars);
vals = TAIL(vals); vals = TAIL(vals);
...@@ -836,16 +906,9 @@ env_set(struct value* env, struct value* var, struct value* val) ...@@ -836,16 +906,9 @@ env_set(struct value* env, struct value* var, struct value* val)
} }
struct value*
env_add_binding_to_frame(struct value* frame, struct value* var, struct value* val)
{
HEAD(frame) = cons(var, HEAD(frame));
TAIL(frame) = cons(val, TAIL(frame));
}
struct value* struct value*
env_define(struct value* env, struct value* var, struct value* val) env_let(struct value* env, struct value* var, struct value* val)
{ {
struct value* frame = FIRST_FRAME(env); struct value* frame = FIRST_FRAME(env);
struct value* vars = FRAME_VARIABLES(frame); struct value* vars = FRAME_VARIABLES(frame);
...@@ -861,7 +924,9 @@ env_define(struct value* env, struct value* var, struct value* val) ...@@ -861,7 +924,9 @@ env_define(struct value* env, struct value* var, struct value* val)
vals = TAIL(vals); vals = TAIL(vals);
} }
env_add_binding_to_frame(var, val, frame); HEAD(frame) = cons(var, HEAD(frame));
TAIL(frame) = cons(val, TAIL(frame));
return True; return True;
} }
...@@ -871,19 +936,69 @@ env_define(struct value* env, struct value* var, struct value* val) ...@@ -871,19 +936,69 @@ env_define(struct value* env, struct value* var, struct value* val)
// compile // compile
// ---------------------------------------------------------------------------- // ----------------------------------------------------------------------------
static struct value*
struct closure* eval_values(struct value* env, struct value* args)
cherry_compile(struct value* ast, struct value* env)
{ {
struct value* last = Emptylist;
struct value* begin = last;
return NULL; while(!IS_NULL(args)) {
} last = TAIL(last) = cons(cherry_eval(env, HEAD(args)), Emptylist);
args = TAIL(args);
}
return TAIL(begin);
}
struct value* struct value*
cherry_eval(struct closure* code) cherry_eval(struct value* env, struct value* value)
{ {
return EXECUTE(code); while(TRUE) {
if(IS_SELF_EVALUATING(value))
return value;
else if(IS_VARIABLE(value))
return env_lookup(env, value);
struct value* fn = HEAD(value);
struct value* args = TAIL(value);
if(fn == Let) {
return env_let(env, HEAD(args), cherry_eval(env, HEAD(TAIL(args))));
} else if(fn == Quote) {
return HEAD(args);
} else if(fn == Lambda) {
return procedure(env, HEAD(args), TAIL(args));
} else if(fn == Begin) {
while(!IS_NULL(TAIL(args))) {
cherry_eval(env, HEAD(args));
args = TAIL(args);
}
value = HEAD(args);
} else if(fn == If) {
value = IS_TRUE(cherry_eval(env, HEAD(args)))
? HEAD(TAIL(args))
: HEAD(TAIL(TAIL(args)));
} else if(IS_SYMBOL(fn)) {
fn = cherry_eval(env, fn);
args = eval_values(env, args);
if(IS_PRIMITIVE(fn))
value = (fn->fun_value)(env, args);
else if(IS_PROCEDURE(fn)) {
env = EXTEND_ENV(fn->procedure.env, fn->procedure.param, args);
value = cons(Begin, fn->procedure.body);
} else
failure("Eval: Unknown procedure type found");
} else
failure("Eval: no proper cherry operation found");
}
} }
// ---------------------------------------------------------------------------- // ----------------------------------------------------------------------------
...@@ -926,6 +1041,14 @@ cherry_write_pair(FILE* out, struct value* value) ...@@ -926,6 +1041,14 @@ cherry_write_pair(FILE* out, struct value* value)
} }
void
cherry_writeln(FILE* out, struct value* value)
{
cherry_write(out, value);
fprintf(out, "\n");
fflush(out);
}
void void
cherry_write(FILE* out, struct value* value) cherry_write(FILE* out, struct value* value)
{ {
...@@ -1030,12 +1153,16 @@ cherry_write(FILE* out, struct value* value) ...@@ -1030,12 +1153,16 @@ cherry_write(FILE* out, struct value* value)
fprintf(out, "\""); fprintf(out, "\"");
break; break;
case FOREIGN:
fprintf(out, "#foreign");
break;
case PRIMITIVE: case PRIMITIVE:
fprintf(out, "#primitive-procedure"); fprintf(out, "#primitive");
break; break;
case LAMBDA: case PROCEDURE:
fprintf(out, "#lambda-procedure"); fprintf(out, "#procedure");
break; break;
case PAIR: case PAIR:
...@@ -1053,6 +1180,9 @@ cherry_write(FILE* out, struct value* value) ...@@ -1053,6 +1180,9 @@ cherry_write(FILE* out, struct value* value)
default: default:
failure("cannot write an unknown value type"); failure("cannot write an unknown value type");
} }
fprintf(out, "\n");
fflush(out);
} }
...@@ -1072,10 +1202,10 @@ void cherry_main(const char* filename, const byte_t* method, struct value* args) ...@@ -1072,10 +1202,10 @@ void cherry_main(const char* filename, const byte_t* method, struct value* args)
byte_t* p = text(port); byte_t* p = text(port);
struct value* exp = cherry_read(&p, buffer, SCANNER_BUFFERSIZE); struct value* exp = cherry_read(&p, buffer, SCANNER_BUFFERSIZE);
struct value* env = core_environment();
while(exp != 0) { while(exp != 0) {
cherry_write(stdout, exp); cherry_eval(env, exp);
fprintf(stdout, "\n");
exp = cherry_read(&p, buffer, SCANNER_BUFFERSIZE); exp = cherry_read(&p, buffer, SCANNER_BUFFERSIZE);
} }
...@@ -1136,7 +1266,6 @@ int main(int argc, char** argv) ...@@ -1136,7 +1266,6 @@ int main(int argc, char** argv)
last = TAIL(last) = cons(string(argv[optind++]), Emptylist); last = TAIL(last) = cons(string(argv[optind++]), Emptylist);
} }
if(filename) if(filename)
cherry_main(filename, method, TAIL(arguments)); cherry_main(filename, method, TAIL(arguments));
else else
......
...@@ -40,7 +40,8 @@ typedef uint32_t unicode_t; ...@@ -40,7 +40,8 @@ typedef uint32_t unicode_t;
typedef struct value* (*primitive_t)(struct value* env, struct value* args); typedef struct value* (*primitive_t)(struct value* env, struct value* args);
enum tag { enum tag {
EMPTYLIST, BOOLEAN, DOT, FIXNUM, FLOAT, STRING, CHARACTER, PAIR, TUPLE, SYMBOL, PRIMITIVE, LAMBDA EMPTYLIST, BOOLEAN, DOT, FIXNUM, FLOAT, STRING, CHARACTER,
PAIR, TUPLE, SYMBOL, PRIMITIVE, PROCEDURE, FOREIGN
}; };
struct value { struct value {
...@@ -53,6 +54,7 @@ struct value { ...@@ -53,6 +54,7 @@ struct value {
primitive_t fun_value; primitive_t fun_value;
const byte_t* string_value; const byte_t* string_value;
const byte_t* symbol_value; const byte_t* symbol_value;
pointer_t foreign_value;
struct { struct {
struct value* head; struct value* head;
...@@ -65,9 +67,10 @@ struct value { ...@@ -65,9 +67,10 @@ struct value {
} tuple; } tuple;
struct { struct {
struct value* env;
struct value* param; struct value* param;
struct value* body; struct value* body;
} lambda; } procedure;
}; };
}; };
...@@ -83,7 +86,7 @@ struct value { ...@@ -83,7 +86,7 @@ struct value {
#define IS_CHARACTER(value) (value->tag == CHARACTER) #define IS_CHARACTER(value) (value->tag == CHARACTER)
#define IS_PAIR(value) (value->tag == PAIR) #define IS_PAIR(value) (value->tag == PAIR)
#define IS_PRIMITIVE(value) (value->tag == PRIMITIVE) #define IS_PRIMITIVE(value) (value->tag == PRIMITIVE)
#define IS_LAMBDA(value) (value->tag == LAMBDA) #define IS_PROCEDURE(value) (value->tag == PROCEDURE)
#define HEAD(obj) (obj->pair.head) #define HEAD(obj) (obj->pair.head)
#define TAIL(obj) (obj->pair.tail) #define TAIL(obj) (obj->pair.tail)
...@@ -91,8 +94,8 @@ struct value { ...@@ -91,8 +94,8 @@ struct value {
#define TUPLE_DATA(obj) (obj->tuple.data) #define TUPLE_DATA(obj) (obj->tuple.data)
#define TUPLE_SIZE(obj) (obj->tuple.size) #define TUPLE_SIZE(obj) (obj->tuple.size)
#define LAMBDA_PARAM(obj) (obj->lambda.param) #define PROC_PARAM(obj) (obj->procedure.param)
#define LAMBDA_BODY(obj) (obj->lambda.body) #define PROC_BODY(obj) (obj->procedure.body)
extern struct value* True; extern struct value* True;
extern struct value* False; extern struct value* False;
...@@ -101,7 +104,9 @@ extern struct value* Dot; ...@@ -101,7 +104,9 @@ extern struct value* Dot;
extern struct value* Let; extern struct value* Let;
extern struct value* Lambda; extern struct value* Lambda;
extern struct value* If; extern struct value* If;
extern struct value* Begin;
struct value* dup(struct value* value);
struct value* alloc_value(void); struct value* alloc_value(void);
struct value* symbol(const byte_t* symbol_value); struct value* symbol(const byte_t* symbol_value);
...@@ -110,12 +115,12 @@ struct value* floatpoint(float_t float_value); ...@@ -110,12 +115,12 @@ struct value* floatpoint(float_t float_value);
struct value* character(unicode_t character_value); struct value* character(unicode_t character_value);
struct value* string(const byte_t* string_value); struct value* string(const byte_t* string_value);
struct value* primitive(const primitive_t fun_value); struct value* primitive(const primitive_t fun_value);
struct value* lambda(struct value* param, struct value* body); struct value* procedure(struct value* env, struct value* param, struct value* body);
struct value* foreign(pointer_t value);
struct value* tuple(size_t size, ...); struct value* tuple(size_t size, ...);
struct value* cons(struct value* head, struct value* tail);
struct value* dup(struct value* value);
struct value* cons(struct value* head, struct value* tail);
#define list2(A, B) cons(A cons(B, emptylist)) #define list2(A, B) cons(A cons(B, emptylist))
#define list3(A, B, C) cons(A, cons(B, cons(C, emptylist))) #define list3(A, B, C) cons(A, cons(B, cons(C, emptylist)))
...@@ -126,7 +131,7 @@ struct value* cons(struct value* head, struct value* tail); ...@@ -126,7 +131,7 @@ struct value* cons(struct value* head, struct value* tail);
#define SYMBOL_RIGHT(node) TAIL(TAIL(node)) #define SYMBOL_RIGHT(node) TAIL(TAIL(node))
#define EXTEND_ENV(env, vars, vals) cons(cons(vars,vals), env) #define EXTEND_ENV(env, vars, vals) cons(cons(vars,vals), env)
#define INTIAL_ENV EXTEND_ENV(Emptylist, Emptylist, Emptylist) #define INITIAL_ENV EXTEND_ENV(Emptylist, Emptylist, Emptylist)
#define FIRST_FRAME(env) HEAD(env) #define FIRST_FRAME(env) HEAD(env)
#define PARENT_FRAMES(env) TAIL(env) #define PARENT_FRAMES(env) TAIL(env)
#define FRAME_VARIABLES(frame) HEAD(frame) #define FRAME_VARIABLES(frame) HEAD(frame)
...@@ -134,22 +139,20 @@ struct value* cons(struct value* head, struct value* tail); ...@@ -134,22 +139,20 @@ struct value* cons(struct value* head, struct value* tail);
struct value* env_lookup(struct value* env, struct value* var); 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_set(struct value* env, struct value* var, struct value* val);
struct value* env_define(struct value* env, struct value* var, struct value* val); struct value* env_let(struct value* env, struct value* var, struct value* val);
struct value* env_add_binding_to_frame(struct value* frame, struct value* var, struct value* val);
#define IS_FALSE(val) (IS_BOOLEAN(val) && !val->fixnum_value)
#define IS_TRUE(val) (!IS_FALSE(val))
struct closure { #define IS_SELF_EVALUATING(val) \
struct value* (*execute)(struct closure* self); (IS_BOOLEAN(val) || IS_FIXNUM(val) || IS_CHARACTER(val) || IS_STRING(val) || IS_FLOAT(val))
struct value* args;
};
#define IS_CONTINUATION(closure) (((struct closure*) closure)->execute != NULL) #define IS_VARIABLE(val) IS_SYMBOL(val)
#define EXECUTE(obj) (((struct closure*) obj)->execute((struct closure*)obj))
void cherry_initialize(void); void cherry_initialize(void);
struct value* cherry_read(byte_t** begin, byte_t* buffer, size_t buffer_size); struct value* cherry_read(byte_t** begin, byte_t* buffer, size_t buffer_size);
struct closure* cherry_compile(struct value* ast, struct value* env); struct value* cherry_eval(struct value* env, struct value* code);
struct value* cherry_eval(struct closure* code);
void cherry_write(FILE* out, struct value* v); void cherry_write(FILE* out, struct value* v);
void cherry_writeln(FILE* out, struct value* v);
struct value* core_println(struct value* env, struct value* args);
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment