Skip to content

GitLab

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

implement bootstrap-cherry with runtime environment

parent 15de1954
Hide whitespace changes
Inline Side-by-side
source/bootstrap.c
View file @ d2625b25
......@@ -35,6 +35,7 @@ struct value* Define = NULL;
struct value* Let = NULL;
struct value* Lambda = NULL;
struct value* If = NULL;
struct value* Begin = NULL;
static void
failure(const byte_t* format, ...)
......@@ -149,13 +150,23 @@ primitive(const primitive_t fun_value)
return v;
}
struct value*
foreign(pointer_t value)
{
struct value* v = alloc_value();
v->tag = FOREIGN;
v->foreign_value = value;
return v;
}
struct value*
lambda(struct value* param, struct value* body)
procedure(struct value* env, struct value* param, struct value* body)
{
struct value* v = alloc_value();
v->tag = LAMBDA;
v->lambda.param = param;
v->lambda.body = body;
v->tag = PROCEDURE;
v->procedure.env = env;
v->procedure.param = param;
v->procedure.body = body;
return v;
}
......@@ -239,11 +250,70 @@ initialize(void)
global_symbollist = Emptylist;
Quote = symbol("quote");
Define = symbol("define");
Quote = symbol("quote");
Let = symbol("let");
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)
buffer++;
p++;
} else
failure("Bufferoverflow in character literal");
failure("Read: Bufferoverflow in character scanning");
}
*buffer = '\0';
......@@ -457,6 +527,9 @@ lex_raw_string(byte_t** begin, byte_t* buffer, size_t buffer_size)
p++; // remove beginning delimeter
while(*p != '\0' && *p != '~') {
printf("STREAM %s\n", p);
fflush(stdout);
if(*p == '\r' || *p == '\n')
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)
buffer++;
p++;
} else
failure("Bufferoverflow in raw string literal");
buffer++;
p++;
failure("Read: Bufferoverflow in raw string scanning");
}
*buffer = '\0';
*begin = (*p != '\0') ? p : p + 1;
*begin = (*p != '\0') ? p + 1 : p;
return TOK_STRING;
}
......@@ -564,13 +633,13 @@ lex_string(byte_t** begin, byte_t* buffer, size_t buffer_size)
}
*buffer = *p;
if(buffer < buf_end)
buffer++;
else
failure("Read: Bufferoverflow in string scanning");
NO_BUFFER_APPEND:
if(buffer < buf_end) {
buffer++;
p++;
} else
failure("Bufferoverflow in string scanning");
p++;
}
RETURN_TOKEN:
......@@ -821,9 +890,10 @@ env_set(struct value* env, struct value* var, struct value* val)
vals = FRAME_VALUES(frame);
while(!IS_NULL(vars)) {
if(var == HEAD(vars))
if(var == HEAD(vars)) {
HEAD(vals) = val;
return True;
}
vars = TAIL(vars);
vals = TAIL(vals);
......@@ -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*
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* vars = FRAME_VARIABLES(frame);
......@@ -861,7 +924,9 @@ env_define(struct value* env, struct value* var, struct value* val)
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;
}
......@@ -871,19 +936,69 @@ env_define(struct value* env, struct value* var, struct value* val)
// compile
// ----------------------------------------------------------------------------
struct closure*
cherry_compile(struct value* ast, struct value* env)
static struct value*
eval_values(struct value* env, struct value* args)
{
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*
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)
}
void
cherry_writeln(FILE* out, struct value* value)
{
cherry_write(out, value);
fprintf(out, "\n");
fflush(out);
}
void
cherry_write(FILE* out, struct value* value)
{
......@@ -1030,12 +1153,16 @@ cherry_write(FILE* out, struct value* value)
fprintf(out, "\"");
break;
case FOREIGN:
fprintf(out, "#foreign");
break;
case PRIMITIVE:
fprintf(out, "#primitive-procedure");
fprintf(out, "#primitive");
break;
case LAMBDA:
fprintf(out, "#lambda-procedure");
case PROCEDURE:
fprintf(out, "#procedure");
break;
case PAIR:
......@@ -1053,6 +1180,9 @@ cherry_write(FILE* out, struct value* value)
default:
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)
byte_t* p = text(port);
struct value* exp = cherry_read(&p, buffer, SCANNER_BUFFERSIZE);
struct value* env = core_environment();
while(exp != 0) {
cherry_write(stdout, exp);
fprintf(stdout, "\n");
cherry_eval(env, exp);
exp = cherry_read(&p, buffer, SCANNER_BUFFERSIZE);
}
......@@ -1136,7 +1266,6 @@ int main(int argc, char** argv)
last = TAIL(last) = cons(string(argv[optind++]), Emptylist);
}
if(filename)
cherry_main(filename, method, TAIL(arguments));
else
......
source/bootstrap.h
View file @ d2625b25
......@@ -40,7 +40,8 @@ typedef uint32_t unicode_t;
typedef struct value* (*primitive_t)(struct value* env, struct value* args);
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 {
......@@ -53,6 +54,7 @@ struct value {
primitive_t fun_value;
const byte_t* string_value;
const byte_t* symbol_value;
pointer_t foreign_value;
struct {
struct value* head;
......@@ -65,9 +67,10 @@ struct value {
} tuple;
struct {
struct value* env;
struct value* param;
struct value* body;
} lambda;
} procedure;
};
};
......@@ -83,7 +86,7 @@ struct value {
#define IS_CHARACTER(value) (value->tag == CHARACTER)
#define IS_PAIR(value) (value->tag == PAIR)
#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 TAIL(obj) (obj->pair.tail)
......@@ -91,8 +94,8 @@ struct value {
#define TUPLE_DATA(obj) (obj->tuple.data)
#define TUPLE_SIZE(obj) (obj->tuple.size)
#define LAMBDA_PARAM(obj) (obj->lambda.param)
#define LAMBDA_BODY(obj) (obj->lambda.body)
#define PROC_PARAM(obj) (obj->procedure.param)
#define PROC_BODY(obj) (obj->procedure.body)
extern struct value* True;
extern struct value* False;
......@@ -101,7 +104,9 @@ extern struct value* Dot;
extern struct value* Let;
extern struct value* Lambda;
extern struct value* If;
extern struct value* Begin;
struct value* dup(struct value* value);
struct value* alloc_value(void);
struct value* symbol(const byte_t* symbol_value);
......@@ -110,12 +115,12 @@ struct value* floatpoint(float_t float_value);
struct value* character(unicode_t character_value);
struct value* string(const byte_t* string_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* 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 list3(A, B, C) cons(A, cons(B, cons(C, emptylist)))
......@@ -126,7 +131,7 @@ struct value* cons(struct value* head, struct value* tail);
#define SYMBOL_RIGHT(node) TAIL(TAIL(node))
#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 PARENT_FRAMES(env) TAIL(env)
#define FRAME_VARIABLES(frame) HEAD(frame)
......@@ -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_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_add_binding_to_frame(struct value* frame, struct value* var, struct value* val);
struct value* env_let(struct value* env, 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 {
struct value* (*execute)(struct closure* self);
struct value* args;
};
#define IS_SELF_EVALUATING(val) \
(IS_BOOLEAN(val) || IS_FIXNUM(val) || IS_CHARACTER(val) || IS_STRING(val) || IS_FLOAT(val))
#define IS_CONTINUATION(closure) (((struct closure*) closure)->execute != NULL)
#define EXECUTE(obj) (((struct closure*) obj)->execute((struct closure*)obj))
#define IS_VARIABLE(val) IS_SYMBOL(val)
void cherry_initialize(void);
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 closure* code);
struct value* cherry_eval(struct value* env, struct value* code);
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