From 4af5f5156e6bbba17be259f848b55e0ac39e765b Mon Sep 17 00:00:00 2001 From: Jeremiah Orians Date: Fri, 16 Dec 2016 20:59:57 -0500 Subject: [PATCH] Initial high level prototype for lisp --- stage2/High_level_prototypes/lisp.c | 26 +++ stage2/High_level_prototypes/lisp.h | 38 ++++ stage2/High_level_prototypes/lisp_cell.c | 44 ++++ stage2/High_level_prototypes/lisp_eval.c | 216 ++++++++++++++++++++ stage2/High_level_prototypes/lisp_print.c | 41 ++++ stage2/High_level_prototypes/lisp_read.c | 238 ++++++++++++++++++++++ stage2/High_level_prototypes/makefile | 14 ++ 7 files changed, 617 insertions(+) create mode 100644 stage2/High_level_prototypes/lisp.c create mode 100644 stage2/High_level_prototypes/lisp.h create mode 100644 stage2/High_level_prototypes/lisp_cell.c create mode 100644 stage2/High_level_prototypes/lisp_eval.c create mode 100644 stage2/High_level_prototypes/lisp_print.c create mode 100644 stage2/High_level_prototypes/lisp_read.c create mode 100644 stage2/High_level_prototypes/makefile diff --git a/stage2/High_level_prototypes/lisp.c b/stage2/High_level_prototypes/lisp.c new file mode 100644 index 0000000..d9a66cf --- /dev/null +++ b/stage2/High_level_prototypes/lisp.c @@ -0,0 +1,26 @@ +#include "lisp.h" +#include + +/* Prototypes */ +struct cell* eval(struct cell* exp, struct cell* env); +void init_sl3(); +uint32_t Readline(FILE* source_file, char* temp); +struct cell* parse(char* program, int32_t size); +void writeobj(FILE *ofp, struct cell* op); + +/*** Main Driver ***/ +int main() +{ + init_sl3(); + for(;;) + { + int read; + char* message = calloc(1024, sizeof(char)); + read = Readline(stdin, message); + struct cell* temp = parse(message, read); + temp = eval(temp, top_env); + writeobj(stdout, temp); + printf("\n"); + } + return 0; +} diff --git a/stage2/High_level_prototypes/lisp.h b/stage2/High_level_prototypes/lisp.h new file mode 100644 index 0000000..1c719b7 --- /dev/null +++ b/stage2/High_level_prototypes/lisp.h @@ -0,0 +1,38 @@ +#include +#include +#include +#include +#include + +enum otype +{ + INT = 1, + SYM = (1 << 1), + CONS = (1 << 2), + PROC = (1 << 3), + PRIMOP = (1 << 4), +}; + +typedef struct cell* (*Operation)(struct cell *); + +typedef struct cell +{ + enum otype type; + union + { + struct cell* car; + int value; + char* string; + Operation function; + }; + struct cell* cdr; + struct cell* env; +} cell; + +#define MAXLEN 256 + + +struct cell* make_cons(struct cell* a, struct cell* b); + +/* Global objects */ +struct cell *all_symbols, *top_env, *nil, *tee, *quote, *s_if, *s_lambda, *s_define, *s_setb; diff --git a/stage2/High_level_prototypes/lisp_cell.c b/stage2/High_level_prototypes/lisp_cell.c new file mode 100644 index 0000000..a9a31bf --- /dev/null +++ b/stage2/High_level_prototypes/lisp_cell.c @@ -0,0 +1,44 @@ +#include "lisp.h" + +struct cell* make_int(int a) +{ + struct cell* c = calloc(1, sizeof(cell)); + c->type = INT; + c->value = a; + return c; +} + +struct cell* make_sym(char* name) +{ + struct cell* c = calloc(1, sizeof(cell)); + c->type = SYM; + c->string = name; + return c; +} + +struct cell* make_cons(struct cell* a, struct cell* b) +{ + struct cell* c = calloc(1, sizeof(cell)); + c->type = CONS; + c->car = a; + c->cdr = b; + return c; +} + +struct cell* make_proc(struct cell* a, struct cell* b, struct cell* env) +{ + struct cell* c = calloc(1, sizeof(cell)); + c->type = PROC; + c->car = a; + c->cdr = b; + c->env = env; + return c; +} + +struct cell* make_prim(void* fun) +{ + struct cell* c = calloc(1, sizeof(cell)); + c->type = PRIMOP; + c->function = fun; + return c; +} diff --git a/stage2/High_level_prototypes/lisp_eval.c b/stage2/High_level_prototypes/lisp_eval.c new file mode 100644 index 0000000..927b5a0 --- /dev/null +++ b/stage2/High_level_prototypes/lisp_eval.c @@ -0,0 +1,216 @@ +#include "lisp.h" + +/* Support functions */ +struct cell* car(struct cell* a) +{ + return a->car; +} + +struct cell* cdr(struct cell* a) +{ + return a->cdr; +} + + +struct cell* findsym(char *name) +{ + struct cell* symlist; + for(symlist = all_symbols; nil != symlist; symlist = symlist->cdr) + { + if(!strcmp(name, symlist->car->string)) + { + return symlist; + } + } + return nil; +} + +struct cell* make_sym(char* name); + +struct cell* intern(char *name) +{ + struct cell* op = findsym(name); + if(nil != op) return op->car; + op = make_sym(name); + all_symbols = make_cons(op, all_symbols); + return op; +} + +/*** Environment ***/ +struct cell* extend(struct cell* env, struct cell* symbol, struct cell* value) +{ + return make_cons(make_cons((symbol), (value)), (env)); +} + +struct cell* multiple_extend(struct cell* env, struct cell* syms, struct cell* vals) +{ +if(nil == syms) + { + return env; + } + return multiple_extend(extend(env, car(syms), car(vals)), cdr(syms), cdr(vals)); +} + +struct cell* extend_top(struct cell* sym, struct cell* val) +{ + top_env->cdr = make_cons(make_cons(sym, val), cdr(top_env)); + return val; +} + +struct cell* assoc(struct cell* key, struct cell* alist) +{ + if(nil == alist) return nil; + if(car(car(alist)) == key) return car(alist); + return assoc(key, cdr(alist)); +} + +/*** Evaluator (Eval/Apply) ***/ +struct cell* eval(struct cell* exp, struct cell* env); +struct cell* make_proc(struct cell* a, struct cell* b, struct cell* env); +struct cell* evlis(struct cell* exps, struct cell* env) +{ + if(exps == nil) return nil; + return make_cons(eval(car(exps), env), evlis(cdr(exps), env)); +} + +struct cell* progn(struct cell* exps, struct cell* env) +{ + if(exps == nil) return nil; + for(;;) + { + if(cdr(exps) == nil) return eval(car(exps), env); + eval(car(exps), env); + exps = cdr(exps); + } +} + +struct cell* apply(struct cell* proc, struct cell* vals) +{ + struct cell* temp = nil; + if(proc->type == PRIMOP) + { + temp = (*(proc->function))(vals); + } + else if(proc->type == PROC) + { + temp = progn(proc->cdr, multiple_extend(proc->env, proc->car, vals)); + } + else + { + fprintf(stderr, "Bad argument to apply\n"); + exit(EXIT_FAILURE); + } + return temp; +} + +struct cell* eval(struct cell* exp, struct cell* env) +{ + if(exp == nil) return nil; + + switch(exp->type) + { + case INT: return exp; + case SYM: + { + struct cell* tmp = assoc(exp, env); + if(tmp == nil) + { + fprintf(stderr,"Unbound symbol\n"); + exit(EXIT_FAILURE); + } + return cdr(tmp); + } + case CONS: + { + if(car(exp) == s_if) + { + if(eval(car(cdr(exp)), env) != nil) + { + return eval(car(cdr(cdr(exp))), env); + } + return eval(car(cdr(cdr(cdr(exp)))), env); + } + if(car(exp) == s_lambda) return make_proc(car(cdr(exp)), cdr(cdr(exp)), env); + if(car(exp) == quote) return car(cdr(exp)); + if(car(exp) == s_define) return(extend_top(car(cdr(exp)), eval(car(cdr(cdr(exp))), env))); + if(car(exp) == s_setb) + { + struct cell* pair = assoc(car(cdr(exp)), env); + struct cell* newval = eval(car(cdr(cdr(exp))), env); + pair->cdr = newval; + return newval; + } + return apply(eval(car(exp), env), evlis(cdr(exp), env)); + } + case PRIMOP: return exp; + case PROC: return exp; + } + /* Not reached */ + return exp; +} + +/*** Primitives ***/ +struct cell* make_int(int a); +struct cell* prim_sum(struct cell* args) +{ + int sum; + for(sum = 0; nil != args; args = cdr(args)) + { + sum = sum + car(args)->value; + } + return make_int(sum); +} + +struct cell* prim_sub(struct cell* args) +{ + int sum = car(args)->value; + for(args = cdr(args); nil != args; args = cdr(args)) + { + sum = sum - car(args)->value; + } + return make_int(sum); +} + +struct cell* prim_prod(struct cell* args) +{ + int prod; + for(prod = 1; nil != args; args = cdr(args)) + { + prod = prod * car(args)->value; + } + return make_int(prod); +} + +struct cell* prim_numeq(struct cell* args) +{ + return car(args)->value == car(cdr(args))->value ? tee : nil; +} + +struct cell* prim_cons(struct cell* args) { return make_cons(car(args), car(cdr(args))); } +struct cell* prim_car(struct cell* args) { return car(car(args)); } +struct cell* prim_cdr(struct cell* args) { return cdr(car(args)); } + +/*** Initialization ***/ +struct cell* intern(char *name); +struct cell* make_prim(void* fun); +struct cell* make_sym(char* name); +void init_sl3() +{ + nil = make_sym("nil"); + all_symbols = make_cons(nil, nil); + top_env = make_cons(make_cons(nil, nil), nil); + tee = intern("t"); + extend_top(tee, tee); + quote = intern("quote"); + s_if = intern("if"); + s_lambda = intern("lambda"); + s_define = intern("define"); + s_setb = intern("set!"); + extend_top(intern("+"), make_prim(prim_sum)); + extend_top(intern("-"), make_prim(prim_sub)); + extend_top(intern("*"), make_prim(prim_prod)); + extend_top(intern("="), make_prim(prim_numeq)); + extend_top(intern("cons"), make_prim(prim_cons)); + extend_top(intern("car"), make_prim(prim_car)); + extend_top(intern("cdr"), make_prim(prim_cdr)); +} diff --git a/stage2/High_level_prototypes/lisp_print.c b/stage2/High_level_prototypes/lisp_print.c new file mode 100644 index 0000000..16cade9 --- /dev/null +++ b/stage2/High_level_prototypes/lisp_print.c @@ -0,0 +1,41 @@ +#include "lisp.h" + +void writeobj(FILE *ofp, struct cell* op) +{ + switch(op->type) + { + case INT: fprintf(ofp, "%d", op->value); break; + case CONS: + { + fprintf(ofp, "("); + for(;;) + { + writeobj(ofp, op->car); + if(nil == op->cdr) + { + fprintf(ofp, ")"); + break; + } + op = op->cdr; + if(op->type != CONS) + { + fprintf(ofp, " . "); + writeobj(ofp, op); + fprintf(ofp, ")"); + break; + } + fprintf(ofp, " "); + } + break; + } + case SYM: + { + if(nil == op) fprintf(ofp, "()"); + else fprintf(ofp, "%s", op->string); + break; + } + case PRIMOP: fprintf(ofp, "#"); break; + case PROC: fprintf(ofp, "#"); break; + default: exit(1); + } +} diff --git a/stage2/High_level_prototypes/lisp_read.c b/stage2/High_level_prototypes/lisp_read.c new file mode 100644 index 0000000..f5f4177 --- /dev/null +++ b/stage2/High_level_prototypes/lisp_read.c @@ -0,0 +1,238 @@ +#include "lisp.h" +#include +#include +#define max_string 255 + +FILE* source_file; +bool Reached_EOF; + +static struct cell* token_stack; +struct cell* make_sym(char* name); +struct cell* intern(char *name); +struct cell* findsym(char *name); + +struct cell* append_Cell(struct cell* head, struct cell* tail) +{ + if(NULL == head) + { + return tail; + } + + if(NULL == head->cdr) + { + head->cdr = tail; + return head; + } + + append_Cell(head->cdr, tail); + return head; +} + +/**************************************************************** + * def tokenize(s): * + * "Convert a string into a list of tokens." * + * return s.replace('(',' ( ').replace(')',' ) ').split() * + ****************************************************************/ + +struct cell* tokenize(struct cell* head, char* fullstring, int32_t size) +{ + int32_t c; + int32_t i = 0; + bool done = false; + if((0 >= size) || (0 == fullstring[0])) + { + return head; + } + + char *store = calloc(max_string + 1, sizeof(char)); + + do + { + c = fullstring[i]; + if((i > size) || (max_string <= i)) + { + done = true; + } + else + { + if((' ' == c) || ('\t' == c) || ('\n' == c) | ('\r' == c)) + { + i = i + 1; + done = true; + } + else + { + store[i] = c; + i = i + 1; + } + } + } while(!done); + + if(i > 1) + { + head = append_Cell(head, make_sym(store)); + } + else + { + free(store); + } + head = tokenize(head, (fullstring+i), (size - i)); + return head; +} + + +bool is_integer(char* a) +{ + if(('0' <= a[0]) && ('9' >= a[0])) + { + return true; + } + + return false; +} + + +/******************************************************************** + * def atom(token): * + * "Numbers become numbers; every other token is a symbol." * + * try: return int(token) * + * except ValueError: * + * try: return float(token) * + * except ValueError: * + * return Symbol(token) * + ********************************************************************/ + +struct cell* atom(struct cell* a) +{ + /* Check for integer */ + if(is_integer(a->string)) + { + a->type = INT; + a->value = atoi(a->string); + return a; + } + + /* Check for functions */ + struct cell* op = findsym(a->string); + if(nil != op) + { + return op->car; + } + + /* Assume new symbol */ + all_symbols = make_cons(a, all_symbols); + return a; +} + +/**************************************************************** + * def read_from_tokens(tokens): * + * "Read an expression from a sequence of tokens." * + * if len(tokens) == 0: * + * raise SyntaxError('unexpected EOF while reading') * + * token = tokens.pop(0) * + * if '(' == token: * + * L = [] * + * while tokens[0] != ')': * + * L.append(read_from_tokens(tokens)) * + * tokens.pop(0) # pop off ')' * + * return L * + * elif ')' == token: * + * raise SyntaxError('unexpected )') * + * else: * + * return atom(token) * + ****************************************************************/ + +struct cell* readlist(); +struct cell* readobj() +{ + cell* head = token_stack; + token_stack = head->cdr; + head->cdr = NULL; + if (! strncmp("(", head->string, max_string)) + { + return readlist(); + } + + return atom(head); +} + +struct cell* readlist() +{ + cell* head = token_stack; + if (! strncmp(")", head->string, max_string)) + { + token_stack = head->cdr; + return nil; + } + + cell* tmp = readobj(); +// token_stack = head->cdr; + return make_cons(tmp,readlist()); +} + +/**************************************************** + * def parse(program): * + * "Read a Scheme expression from a string." * + * return read_from_tokens(tokenize(program)) * + ****************************************************/ + +struct cell* parse(char* program, int32_t size) +{ + token_stack = tokenize(NULL, program, size); + if(NULL == token_stack) + { + return nil; + } + return readobj(); +} + +uint32_t Readline(FILE* source_file, char* temp) +{ + char store[max_string + 2] = {0}; + int32_t c; + uint32_t i; + uint32_t depth = 0; + + for(i = 0; i < max_string; i = i + 1) + { + c = fgetc(source_file); + if(-1 == c) + { + exit(EXIT_SUCCESS); + } + else if((0 == depth) && ((10 == c) || (13 == c) || (32 == c) || (9 == c))) + { + goto Line_complete; + } + else if(('(' == c) || (')' == c)) + { + if('(' == c) + { + depth = depth + 1; + } + + if(')' == c) + { + depth = depth - 1; + } + + store[i] = ' '; + store[i+1] = c; + store[i+2] = ' '; + i = i + 2; + } + else + { + store[i] = (char)c; + } + } + +Line_complete: + if(1 >= i) + { + return Readline(source_file, temp); + } + + strncpy(temp, store, max_string); + return i; +} diff --git a/stage2/High_level_prototypes/makefile b/stage2/High_level_prototypes/makefile new file mode 100644 index 0000000..d7324b9 --- /dev/null +++ b/stage2/High_level_prototypes/makefile @@ -0,0 +1,14 @@ +all: lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c + gcc -ggdb lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c -o lisp + +lisp: lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c + gcc lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c -o lisp + +coverage-test: lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c + gcc -fprofile-arcs -ftest-coverage lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c -o lisp + +clean: lisp + rm lisp + +Coverage-cleanup: + rm *.gc{da,no,ov}