first commit

bltin.c

@@ -0,0 +1,53 @@
+#include "dat.h"
+#include "fn.h"
+
+Object Nil	= (Object){.type=OSYMBOL, .sym="nil"};
+Object True	= (Object){.type=OSYMBOL, .sym="true"};
+Object False= (Object){.type=OSYMBOL, .sym="false"};
+Object Minus= (Object){.type=OBLTIN, .sym="-"};
+Object Plus	= (Object){.type=OBLTIN, .sym="+"};
+Object Lambda= (Object){.type=OBLTIN, .sym="lambda"};
+Object Car	= (Object){.type=OBLTIN, .sym="car"};
+Object Cdr	= (Object){.type=OBLTIN, .sym="cdr"};
+Object Quote= (Object){.type=OBLTIN, .sym="'"};
+Object Cons	= (Object){.type=OBLTIN, .sym="cons"};
+Object Define= (Object){.type=OBLTIN, .sym="define"};
+Object Setq	= (Object){.type=OBLTIN, .sym="setq"};
+
+extern Object* fnplus(Object *, Object *);
+extern Object* fnlambda(Object *, Object *);
+extern Object* fndefine(Object *, Object *);
+extern Object* fnsetq(Object *, Object *);
+extern Object* fnundef(Object *, Object *);
+/*extern Object* fnminus(Object *, Object *);*/
+/*extern Object* fncons(Object *, Object *);*/
+/*extern Object* fnquote(Object *, Object *);*/
+/*extern Object* fncar(Object *, Object *);*/
+/*extern Object* fncdr(Object *, Object *);*/
+
+Bltinfn
+bltinlookup(Object *obj)
+{
+	static struct
+	{
+		Object *sym;
+		Bltinfn fn;
+	}bltins[] = {
+		{&Lambda , fnlambda},
+		{&Plus , fnplus},
+		{&Define ,fndefine},
+		{&Setq ,fnsetq},
+		{&Minus ,0},
+		{&Cons ,0},
+		{&Quote ,0},
+		{&Car ,0},
+		{&Cdr ,0},
+		0,
+	};
+
+	for(int i = 0; bltins[i].sym; ++i){
+		if(obj == bltins[i].sym)
+			return bltins[i].fn;
+	}
+	return 0;
+}

dat.h

@@ -0,0 +1,65 @@
+typedef struct Object Object;
+typedef Object* (*Bltinfn)(Object *env, Object *args);
+typedef struct Object Object;
+
+enum OType
+{
+	OERROR,
+	OCELL,
+	OSYMBOL,
+	OIDENT,
+	OINT,
+	OSTRING,
+	OLAMBDA,
+	OBLTIN,
+	OFUNC,
+	OENV,
+};
+
+struct Object
+{
+	enum OType type; /* type */
+	int flag; 		/* flag */
+	Object *next;   /* for gc */
+	union{
+		/* int */
+		long num;
+		/* cell */
+		struct{
+			Object *car;
+			Object *cdr;
+		};
+		/* string & ident */
+		char *sym;
+		struct{
+			char *beg;
+			char *ptr;
+			char *end;
+		};
+		/* function */
+		struct{
+			Object *params;
+			Object *body;
+			Object *env;
+		};
+		/* env */ 
+		struct{
+			Object *name;
+			Object *up;
+			Object *vars;
+		};
+	};
+};
+
+extern Object Nil;
+extern Object True;
+extern Object False;
+extern Object Minus;
+extern Object Plus;
+extern Object Lambda;
+extern Object Car;
+extern Object Cdr;
+extern Object Quote;
+extern Object Cons;
+extern Object Define;
+extern Object Setq;

error.c

@@ -0,0 +1,32 @@
+#include "dat.h"
+#include "fn.h"
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdarg.h>
+#include <setjmp.h>
+
+void
+panic(char *fmt, ...)
+{
+	va_list ap;
+	va_start(ap, fmt);
+	vfprintf(stderr, fmt, ap);
+	va_end(ap);
+	fprintf(stderr, "\n");
+	exit(1);
+}
+
+void
+error(char *fmt, ...)
+{
+	extern jmp_buf err;
+	va_list ap;
+
+	va_start(ap, fmt);
+	fprintf(stderr, "ERROR => ");
+	vfprintf(stderr, fmt, ap);
+	va_end(ap);
+	fprintf(stderr, "\n");
+	longjmp(err, 1);
+	exit(1);
+}

eval.c

@@ -0,0 +1,167 @@
+#include "dat.h"
+#include "fn.h"
+
+static Object* evallist(Object *env, Object *list);
+
+static int
+exprlen(Object *expr)
+{
+	int l = 0;
+	for(;expr->type==OCELL; expr=expr->cdr)
+		++l;	
+	if(expr != &Nil)
+		error("Not list type");
+	return l;
+}
+
+static int
+islist(Object *obj)
+{
+	return obj == &Nil || obj->type == OCELL;
+}
+
+static Object*
+find(Object *env, Object *obj)
+{
+	for(Object *cur=env; cur!=&Nil; cur=cur->up){
+		for(Object *p=cur->vars; p!=&Nil; p=p->cdr)
+			if(strequal(obj, p->car->car))
+				return p->car;
+	}
+	return 0;
+}
+
+static Object*
+enter(Object *env, Object *vars, Object *args)
+{
+	Object *map = &Nil;
+	for(;vars->type==OCELL; vars=vars->cdr,args=args->cdr){
+		if(args->type!=OCELL)
+			error("Cna't apply function argment dose not match");
+		Object *id  = vars->car;
+		Object *val = args->car;
+		map = newacons(id, val, map);
+	}
+	return newenv(&Nil, map, env);
+}
+
+Object*
+fnlambda(Object *env, Object *l)
+{
+	if(l->type!=OCELL || islist(l->car)==0 || l->cdr->type!=OCELL)
+		error("malformed function");
+	for(Object *p=l->car; p->type==OCELL; p=p->cdr){
+		if(p->car->type!=OIDENT)
+			error("parameter is not IDNET");
+	}
+	Object *params = l->car;
+	Object *body = l->cdr;
+	return newfn(env, params, body);
+}
+
+Object*
+fnsetq(Object *env, Object *list)
+{
+	if(exprlen(list)!=2 || list->car->type!=OIDENT)
+		error("Malformed setq");
+	Object *obj = find(env, list->car);
+	if(obj == 0)
+		error("Not exist variable");
+	return obj->cdr = eval(env, list->cdr->car);
+}
+
+Object*
+fndefine(Object *env, Object *list)
+{
+	if(exprlen(list)!=2 || list->car->type!=OIDENT)
+		error("Malformed define");
+	Object *val = eval(env, list->cdr->car);
+	Object *obj = find(env, list->car);
+	if(obj)
+		return obj->cdr = val;
+	return env->vars = newacons(list->car, val, env->vars);
+}
+
+Object*
+fnplus(Object *env, Object *list)
+{
+	long sum = 0;
+	for(Object *p=evallist(env, list); p!=&Nil; p=p->cdr){
+		if(p->car->type != OINT)
+			error("+ take only number");
+		sum += p->car->num;
+	}
+	return newint(sum);
+}
+
+static Object*
+evallist(Object *env, Object *list)
+{
+	if(list == &Nil)
+		return &Nil;
+	if(list->type != OCELL)
+		error("type is not list");
+	Object *car = eval(env, list->car);
+	Object *cdr = evallist(env, list->cdr);
+	return newcons(car, cdr);
+}
+
+static Object*
+applyfn(Object *fn, Object *args)
+{
+	Object *env = enter(fn->env, fn->params, args);
+	Object *r = 0;
+	for(Object *p=fn->body; p!=&Nil; p=p->cdr){
+		r = p->car;
+		r = eval(env, r);
+	}
+	return r;
+}
+
+static Object*
+apply(Object *env, Object *fn, Object *args)
+{
+	if(islist(args) == 0)
+		error("args is not list type");
+	switch(fn->type){
+	case OBLTIN:
+		Bltinfn blt = bltinlookup(fn);
+		if(blt==0)
+			error("not builtin type!");
+		return blt(env, args);
+	case OFUNC:{
+			Object *elist = evallist(env, args);
+			Object*res = applyfn(fn, elist);
+			return res;
+		}
+	}
+	error("can't apply");
+	return 0;
+}
+
+Object*
+eval(Object *env, Object *obj)
+{
+	switch(obj->type){
+	case OINT:
+	case OSTRING:
+	case OBLTIN:
+	case OSYMBOL:
+		return obj;
+	case OIDENT:{
+			Object* val = find(env, obj);
+			if(val == 0)
+				error("not exist '%s'", obj->beg);
+			return val->cdr;
+		}
+	case OCELL:{
+			Object *fn = eval(env, obj->car);
+			if(fn->type!=OFUNC&&fn->type!=OBLTIN)
+				error("expected function type");
+			Object *res = apply(env, fn, obj->cdr);
+			return res;
+		}
+	}
+	error("can't apply");
+	return 0;
+}

fn.h

@@ -0,0 +1,37 @@
+/* parser.c */
+Object* nextexpr(void);
+void skipline(void);
+
+/* eval.c */
+Object* eval(Object *env, Object *expr);
+
+/* new */
+
+Object* newint(long);
+Object* newcons(Object*,Object*);
+Object* newenv(Object*name, Object *vars, Object *up);
+Object* newacons(Object*, Object*, Object*);
+Object* newsymbol(char*, int);
+Object* newstr(int);
+Object* newfn(Object *env, Object *params, Object *body);
+
+/* gc.c */
+void gcstatus(void);
+Object* newobj(enum OType);
+void* xalloc(int);
+void* xralloc(void*, int);
+void gcinit(void *top, int cap);
+void gcrun(void);
+
+/* str.c */
+void strputc(Object*, int);
+void strputs(Object*, char*);
+int strequal(Object*, Object*);
+
+/* error.c */
+void panic(char *fmt, ...);
+void error(char *fmt, ...);
+
+/* builtin */
+Bltinfn bltinlookup(Object *obj);
+void printexpr(Object *obj);

gc.c

@@ -0,0 +1,182 @@
+#include "dat.h"
+#include "fn.h"
+#include <stdlib.h>
+#include <stdint.h>
+#include <setjmp.h>
+#include <stdint.h>
+#include <string.h>
+
+enum
+{
+	USING = 1 << 1,
+};
+
+typedef struct
+{
+	int total;
+	int using;
+	uintptr_t top;
+	uintptr_t beg;
+	uintptr_t end;
+	Object objs;
+	Object freed;
+}GC;
+
+GC gc = {0};
+
+static void
+pushobj(Object *list, Object *obj)
+{
+	Object *l = list;
+	Object *c = l->next;
+	while(c){
+		l = c;
+		c=c->next;
+	}
+	l->next = obj;
+}
+
+static void
+mark(Object *obj)
+{
+	if(obj == 0 || obj->flag & USING)
+		return;
+	obj->flag = USING;
+	switch(obj->type){
+	case OCELL:
+		mark(obj->car);
+		mark(obj->cdr);
+		break;
+	case OENV:
+		mark(obj->name);
+		mark(obj->vars);
+		mark(obj->up);
+		break;
+	case OFUNC:
+		mark(obj->params);
+		mark(obj->body);
+		mark(obj->env);
+		break;
+	}
+}
+
+static int
+isobj(uintptr_t val)
+{
+	if(val < gc.beg || val >= gc.end)
+		return 0;
+	val -= gc.beg;
+	uintptr_t mod = val % sizeof(Object);
+	return mod == 0;
+}
+
+static void
+freeobj(Object *obj)
+{
+	switch(obj->type){
+	case OSTRING:
+	case OIDENT:
+		printf("freed => '%s'\n", obj->beg);
+		free(obj->beg);
+		break;
+	}
+	memset(obj, 0, sizeof(*obj));
+	pushobj(&gc.freed, obj);
+	gc.using -= sizeof(Object);
+}
+
+static void
+gcsweep(void)
+{
+	Object *l = &gc.objs;
+	Object *c = l->next;
+	while(c){
+		if(c->flag&USING){
+			c->flag = 0;
+			l = c;
+			c = c->next;
+			continue;
+		}
+		Object *t = c;
+		l->next = c->next;
+		c = c->next;
+		freeobj(t);
+	}
+}
+
+static void
+gcmark(void)
+{
+	void *_ = 0;
+	uintptr_t bot = (uintptr_t)&_;
+	for(; bot < gc.top; bot += sizeof(bot)){
+		uintptr_t val = (uintptr_t)*(void**)bot;
+		if(isobj(val))
+			mark((Object*)val);
+	}
+}
+
+void
+gcrun(void)
+{
+	jmp_buf reg;
+	setjmp(reg);
+	gcmark();
+	gcsweep();
+	gcstatus();
+}
+
+void
+gcstatus(void)
+{
+	printf("curren=> total:%d using:%d remain:%d\n", gc.total, gc.using, gc.total-gc.using);
+}
+
+void*
+xalloc(int sz)
+{
+	int *res = calloc(1, sz);
+	if(res == 0)
+		panic("Can't allocated %d byte", sz);
+	return res;
+}
+
+void*
+xralloc(void *src, int sz)
+{
+	int *p = realloc(src, sz);
+	if(p == 0)
+		panic("Can't allocated %d byte", sz);
+	return p;
+}
+
+Object* 
+newobj(enum OType type)
+{
+	gcrun();
+	Object *obj = 0;
+	if(gc.freed.next){
+		obj = gc.freed.next;
+		gc.freed.next = obj->next;
+		obj->next = 0;
+	}else
+		panic("not impl yet");
+	obj->type = type;
+	pushobj(&gc.objs, obj);
+	gc.using += sizeof(Object);
+	return obj;
+}
+
+void
+gcinit(void *top, int cap)
+{
+	gc.total = cap;
+	gc.using = 0;
+	gc.top = (uintptr_t)top;
+	gc.beg = (uintptr_t)xalloc(cap);
+	gc.end = gc.beg + cap;
+	Object *p = &gc.freed;
+	for(uintptr_t i = gc.beg; i < gc.end; i+=sizeof(Object)){
+		p = p->next = (Object*)i;
+	}
+}

main.c

@@ -0,0 +1,79 @@
+#include "dat.h"
+#include "fn.h"
+#include <setjmp.h>
+#include <stdio.h>
+
+jmp_buf err;
+
+static void
+SExprint(Object *obj)
+{
+	if(obj == 0)
+		return;
+	switch(obj->type){
+	case OCELL:
+		printf("(");
+		SExprint(obj->car);
+		printf(" . ");
+		SExprint(obj->cdr);
+		printf(")");
+		break;
+	case OINT:
+		printf("%ld", obj->num);
+		break;
+	case OIDENT:
+		printf("%s", obj->beg);
+		break;
+	case OSTRING:
+		printf("\"%s\"", obj->beg);
+		break;
+	case OBLTIN:
+	case OSYMBOL:
+		printf("%s", obj->sym);
+		break;
+	case OENV:
+		printf("<env>");
+		break;
+	case OLAMBDA:
+		printf("<lambda>");
+		goto func;
+	case OFUNC:
+		printf("<func>");
+func:
+		printf("<");
+		SExprint(obj->params);
+		SExprint(obj->body);
+		printf(">");
+		break;
+	}
+}
+
+void
+printexpr(Object *obj)
+{
+	SExprint(obj);
+	printf("\n");
+}
+
+static void
+loop(void)
+{
+	Object *root = newenv(&Nil, &Nil, &Nil);
+	if(setjmp(err) == 1){
+		skipline();
+		gcrun();
+	}
+	while(1){
+		gcstatus();
+		Object *res = nextexpr();
+		res = eval(root, res);
+		printexpr(res);
+	}
+}
+
+int
+main(int argc, char *argv[])
+{
+	gcinit(&argc, 3000);
+	loop();
+}

makefile

@@ -0,0 +1,26 @@
+NAME=lisp
+OFILES=\
+	bltin.o\
+	error.o\
+	eval.o\
+	main.o\
+	gc.o\
+	obj.o\
+	str.o\
+	parser.o
+
+AS=$(CC) -c
+CFLAGS=-c  -g -O2
+
+all: $(NAME)
+
+%.o: %.c
+	$(CC) $(CFLAGS) $*.c
+
+$(NAME): $(OFILES)
+	$(CC) -o $(NAME) $(OFILES)
+	
+$(OFILES): dat.h fn.h
+
+clean:
+	rm -f $(NAME) $(OFILES)

obj.c

@@ -0,0 +1,76 @@
+#include "dat.h"
+#include "fn.h"
+#include <stdlib.h>
+#include <string.h>
+
+Object*
+newint(long val)
+{
+	Object *obj = newobj(OINT);
+	obj->num = val;
+	return obj;
+}
+
+Object*
+newcons(Object *car, Object *cdr)
+{
+	Object *obj = newobj(OCELL);
+	obj->car = car;
+	obj->cdr = cdr;
+	return obj;
+}
+
+Object*
+newenv(Object* name, Object *vars, Object *up)
+{
+	Object *obj = newobj(OENV);
+	obj->name = name;
+	obj->up = up;
+	obj->vars = vars;
+	return obj;
+}
+
+Object*
+newacons(Object *x, Object *y, Object *z)
+{
+	Object *cons = newcons(x, y);
+	return newcons(cons, z);
+}
+
+Object*
+newfn(Object *env, Object *params, Object *body)
+{
+	Object *fn = newobj(OFUNC);
+	fn->params = params;
+	fn->body = body;
+	fn->env = env; 
+	return fn;
+}
+
+Object*
+newsymbol(char *str, int len)
+{
+	static Object *syms[] = {
+		&Nil, &True, &False, &Minus, &Plus,
+		&Lambda, &Car, &Cdr, &Quote, &Cons, &Define, &Setq,
+	};
+	for(int i = 0; i < sizeof(syms)/sizeof(syms[0]); ++i){
+		Object *c = syms[i];
+		if(strlen(c->sym)==len && memcmp(c->sym, str, len) == 0)
+			return c;
+	}
+	Object *obj = newobj(OIDENT);
+	obj->beg = xalloc(len + 1);
+	obj->end = obj->ptr = obj->beg + len;	
+	memcpy(obj->beg, str, len+1);
+	return obj;
+}
+
+Object*
+newstr(int len)
+{
+	Object *obj = newobj(OSTRING); 
+	obj->ptr = obj->beg = xalloc(len + 1);
+	obj->end = obj->beg + len;
+	return obj; 
+}

parser.c

@@ -0,0 +1,183 @@
+#include "dat.h"
+#include "fn.h" 
+#include <stdio.h>
+#include <ctype.h>
+#include <string.h>
+
+#define SYMBOL_LEN 64
+
+const char symbolchars[] = "*-=+<>";
+
+static Object* lparlist(void);
+static Object* list(void);
+
+static char
+get(void)
+{
+	char c = getchar();
+	if(c == EOF)
+		panic("EOF");
+	return c;
+}
+
+static void
+expect(char x)
+{
+	char y = get();
+	if(x != y)
+		error("expected '%c', actual '%c'", x, y);
+}
+
+static char
+lookup(void)
+{
+	char c = get();
+	ungetc(c, stdin);
+	return c;
+}
+
+/* skip space */
+static char
+slookup(void)
+{
+	char c = -1;
+	while(1){
+		c = get();
+		if(isspace(c) == 0)
+			break;
+	}
+	ungetc(c, stdin);
+	return c;
+}
+
+static Object*
+symbol(char c)
+{
+	char buf[SYMBOL_LEN+1] = {0,};
+	int len = 0;
+	buf[len++] = c;
+	while(isalnum(lookup()) || strchr(symbolchars, lookup())){
+		if(len >= sizeof(buf)-1)
+			error("Symbol too long");
+		buf[len++] = get();
+	}
+	buf[len] = 0;
+	return newsymbol(buf, len);
+}
+
+static long
+number(void)
+{
+	long val = get() - '0';
+	while(isdigit(lookup()))
+		val = val * 10 + (get() - '0');
+	return val;
+}
+
+static Object*
+quote(void)
+{
+	Object *car = &Quote;
+	Object *ccdr = list();
+	Object *cdr = newcons(ccdr, &Nil);
+	return newcons(car, cdr);
+}
+
+static Object*
+string(void)
+{
+	Object *str = newstr(16);
+	while(lookup() != '\"'){
+		strputc(str, get());
+	}
+	expect('\"');
+	return str;
+}
+
+static Object*
+atom(char c)
+{
+	if(isdigit(c))
+		return newint(number());
+	get();
+	if(c == '-'){
+		if(isdigit(lookup()))
+			return newint(-number());
+		else
+			return symbol('-');
+	}
+	if(c == '"'){
+		return string();
+	}
+	if(isalpha(c) || strchr(symbolchars, c)){
+		return symbol(c);
+	}
+	error("bad char in list '%c'", c);
+}
+
+static Object*
+lparlist(void)
+{
+	Object *car = 0;
+	Object *cdr = 0;
+	char c = slookup();
+	switch(c){
+	case '\'':
+		get();
+		car = quote();
+		cdr = lparlist();
+		return newcons(car, cdr);
+	case '.':
+		get();	
+		return list();
+	case '(':
+		car = list();
+		cdr = lparlist();
+		return newcons(car, cdr);
+	case ')':
+		return &Nil;
+	}
+	car = atom(c);
+	cdr = lparlist();
+	return newcons(car ,cdr);
+}
+
+static Object*
+list(void)
+{
+	char c = slookup();
+	switch(c){
+	case '\'':
+		get();
+		return quote();
+	case '(':{
+		get();
+		Object *obj = lparlist();
+		slookup();
+		expect(')');
+		return obj;
+		}
+	}	
+	return atom(c);
+}
+
+void
+skipline(void)
+{
+	for(;;){
+		switch(get()){
+		case '\n':
+			return;
+		case '\r':
+			if(lookup() == '\n')
+				get();
+			return;
+		}
+	}
+}
+
+Object*
+nextexpr(void)
+{
+	return list();
+}

str.c

@@ -0,0 +1,41 @@
+#include "dat.h"
+#include "fn.h"
+#include <string.h>
+
+static void
+raise(Object *s, int ns)
+{
+	int pos = s->ptr - s->beg;
+	char *ptr = xralloc(s->beg, ns + 1);
+	s->beg = ptr;
+	s->ptr = s->beg + pos;
+	s->end = s->beg + ns;
+}
+
+void
+strputc(Object *s, int c)
+{
+	if(s->ptr >= s->end)
+		raise(s, (s->end - s->beg) * 2);
+	*s->ptr++ = c;
+	*s->ptr = 0;
+}
+
+void
+strputs(Object *s, char *ptr)
+{
+	int l = strlen(ptr);
+	if(s->ptr + l >= s->end)
+		raise(s, s->end - s->beg + l);
+	memcpy(s->ptr, ptr, l);
+	s->ptr += l;
+	s->ptr[0] = 0;
+}
+
+int
+strequal(Object *a, Object *b)
+{
+	int la = a->ptr - a->beg;
+	int lb = b->ptr - b->beg;
+	return la == lb && memcmp(a->beg, b->beg, la) == 0;
+}