Initial high level prototype for lisp
This commit is contained in:
Jeremiah Orians
parent
23ee396135
commit
4af5f5156e
|
|
@ -0,0 +1,26 @@
|
|||
#include "lisp.h"
|
||||
#include <stdint.h>
|
||||
|
||||
/* 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;
|
||||
}
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <stdarg.h>
|
||||
#include <string.h>
|
||||
#include <ctype.h>
|
||||
|
||||
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;
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -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));
|
||||
}
|
||||
|
|
@ -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, "#<PRIMOP>"); break;
|
||||
case PROC: fprintf(ofp, "#<PROC>"); break;
|
||||
default: exit(1);
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,238 @@
|
|||
#include "lisp.h"
|
||||
#include <stdbool.h>
|
||||
#include <stdint.h>
|
||||
#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;
|
||||
}
|
||||
|
|
@ -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}
|
||||
Loading…
Reference in New Issue