#include <u.h>#include <libc.h>#include <bio.h>#include "aa.h"#include "qp.h" #define CAR(x)        ( (x)->car.o )#define CDR(x)        ( (x)->cdr.o )#define TAG(x)        ( (x)->car.c )#define ISUNBOUND(x)  ( (x) == nil )#define ISNULL(x)     ( (x) == &Null )#define ISTRUE(x)     ( (x) == &True )#define ISFALSE(x)    ( (x) == &False )#define TYPE(x)       ( TAG(x) & 0x1 ? TAG(x) >> 2 : AA_TPAIR )#define SETTYPE(x,t)  ( TAG(x) = (t) << 2 | 1 )#define NUMBER(x)     ( (x)->cdr.n )#define PRIM(x)       ( (x)->cdr.c )#define CFUNC(x)      ( (x)->cdr.f )#define STRBUF(x)     ( &(x)->car.c + 1 ) #define STRBUFSIZE    ( (int)sizeof(aaValue) - 1 )#define GCMARKBIT     ( 0x2 ) #define MAX(a,b) ((a)>(b)?(a):(b))#define MIN(a,b) ((a)<(b)?(a):(b)) #define evalarg() (nargs++, eval(ctx, aa_nextarg(ctx, &arg, 0), env, nil)) #define arithop(op, init) { \	aaNumber x = {init}; \	while(!ISNULL(arg)){ \		aaNumber y = aa_tonumber(ctx, evalarg()); \		x.r = x.r op y.r; \	} \	res = aa_number(ctx, x); \} #define numcmpop(op) { \	int c; \	va = checktype(ctx, evalarg(), AA_TNUMBER); \	vb = checktype(ctx, evalarg(), AA_TNUMBER); \	while((c = (NUMBER(va).r op NUMBER(vb).r)) && !ISNULL(arg)){ \		va = vb; \		vb = checktype(ctx, evalarg(), AA_TNUMBER); \	} \	res = aa_bool(ctx, c); \} enum {	P_LET,	P_DEFINE,	P_SET_YAS,	P_IF,	P_LAMBDA,	P_MAC,	P_WHILE,	P_QUOTE,	P_EVAL,	P_AND,	P_OR,	P_BEGIN,	P_CONS,	P_CAR,	P_CDR,	P_SETCAR,	P_SETCDR,	P_LIST,	P_NOT,	P_DISPLAY,	P_EQ_HUH,	P_EQUAL_HUH,	P_ATOM_HUH,	P_NUMBER_HUH,	P_BOOLEAN_HUH,	P_PORT_HUH,	P_DEFINED_HUH,	P_STRING_HUH,	P_NAN_HUH,	P_INF_HUH,	P_EQN,	P_LT,	P_GT,	P_LTE,	P_GTE,	P_ADD,	P_SUB,	P_MUL,	P_DIV,	P_MAX,	P_MIN, 	Numprims}; static const char *primnames[Numprims] = {	[P_LET] = "let",	[P_DEFINE] = "define",	[P_SET_YAS] = "set!",	[P_IF] = "if",	[P_LAMBDA] = "lambda",	[P_MAC] = "mac",	[P_WHILE] = "while",	[P_QUOTE] = "quote",	[P_EVAL] = "eval",	[P_AND] = "and",	[P_OR] = "or",	[P_BEGIN] = "begin",	[P_CONS] = "cons",	[P_CAR] = "car",	[P_CDR] = "cdr",	[P_SETCAR] = "setcar",	[P_SETCDR] = "setcdr",	[P_LIST] = "list",	[P_NOT] = "not",	[P_DISPLAY] = "display",	[P_EQ_HUH] = "eq?",	[P_EQUAL_HUH] = "equal?",	[P_ATOM_HUH] = "atom?",	[P_NUMBER_HUH] = "number?",	[P_BOOLEAN_HUH] = "boolean?",	[P_PORT_HUH] = "port?",	[P_DEFINED_HUH] = "defined?",	[P_STRING_HUH] = "string?",	[P_NAN_HUH] = "nan?",	[P_INF_HUH] = "infinite?",	[P_EQN] = "=",	[P_LT] = "<",	[P_GT] = ">",	[P_LTE] = "<=",	[P_GTE] = ">=",	[P_ADD] = "+",	[P_SUB] = "-",	[P_MUL] = "*",	[P_DIV] = "/",	[P_MAX] = "max",	[P_MIN] = "min",}; static const char *typenames[AA_TMAX] = {	[AA_TPAIR] = "pair",	[AA_TFREE] = "free",	[AA_TNUMBER] = "number",	[AA_TSYMBOL] = "symbol",	[AA_TSTRING] = "string",	[AA_TFUNC] = "func",	[AA_TMACRO] = "macro",	[AA_TPRIM] = "prim",	[AA_TCFUNC] = "cfunc",	[AA_TPTR] = "ptr",	[AA_TBOOL] = "bool",	[AA_TPORT] = "port",}; aaObject Null = {{ (void*)(AA_TPAIR << 2 | 1) }, { nil }};aaObject False = {{ (void*)(AA_TBOOL << 2 | 1) }, { nil }};aaObject True = {{ (void*)(AA_TBOOL << 2 | 1) }, { nil }};static aaObject rparen; static char prelude[] = "\(define newline (lambda () (display \"\\n\")))\(define square (lambda (x) (* x x)))\(define null? (lambda (x) (eq? x ())))\(define finite? (lambda (x) (not (infinite? x))))\"; static aaObject *eval(aaContext *ctx, aaObject *obj, aaObject *env, aaObject **bind); aaHandlers *aa_handlers(aaContext *ctx){	return &ctx->handlers;} voidaa_error(aaContext *ctx, const char *fmt, ...){	char buf[128];	va_list arg;	aaObject *cl = ctx->calllist; 	/* reset context state */	ctx->calllist = &Null; 	va_start(arg, fmt);	vsnprint(buf, sizeof(buf), fmt, arg);	va_end(arg); 	/* do error handler */	if(ctx->handlers.error)		ctx->handlers.error(ctx, buf, cl); 	/* error handler returned -- print error and traceback, exit */	Bprint(ctx->fd[2], "error: %s\n", buf);	for(; !ISNULL(cl); cl = CDR(cl))		Bprint(ctx->fd[2], "=> %ß\n", CAR(cl)); 	exits(buf);} aaObject *aa_nextarg(aaContext *ctx, aaObject **arg, int optional){	aaObject *a = *arg; 	if(TYPE(a) != AA_TPAIR)		aa_error(ctx, "dotted pair in argument list");	if(ISNULL(a)){		if(optional)			return nil;		aa_error(ctx, "too few arguments");	} 	*arg = CDR(a); 	return CAR(a);} static aaObject *checktype(aaContext *ctx, aaObject *obj, int type){	if(TYPE(obj) != type)		aa_error(ctx, "expected %s, got %s", typenames[type], typenames[TYPE(obj)]); 	return obj;} intaa_type(aaContext *ctx, aaObject *obj){	USED(ctx);	return TYPE(obj);} voidaa_pushgc(aaContext *ctx, aaObject *obj){	if(ctx->gcstack_idx == GCSTACKSIZE)		aa_error(ctx, "gc stack overflow"); 	ctx->gcstack[ctx->gcstack_idx++] = obj;} voidaa_restoregc(aaContext *ctx, int idx){	ctx->gcstack_idx = idx;} intaa_savegc(aaContext *ctx){	return ctx->gcstack_idx;} voidaa_mark(aaContext *ctx, aaObject *obj){	aaObject *car; begin:	if(ISNULL(obj) || (TAG(obj) & GCMARKBIT) != 0)		return;	car = CAR(obj); /* store car before modifying it with GCMARKBIT */	TAG(obj) |= GCMARKBIT; 	switch(TYPE(obj)){	case AA_TPAIR:		aa_mark(ctx, car);		/* fall through */ 	case AA_TFUNC:	case AA_TMACRO:	case AA_TSYMBOL:	case AA_TSTRING:		obj = CDR(obj);		goto begin; 	case AA_TPTR:		if(ctx->handlers.mark)			ctx->handlers.mark(ctx, obj);		break;	}} static voidcollectgarbage(aaContext *ctx){	aaObject *obj;	int i; 	/* mark */	for(i = 0; i < ctx->gcstack_idx; i++)		aa_mark(ctx, ctx->gcstack[i]); 	aa_mark(ctx, ctx->symlist); 	/* sweep and unmark */	for(i = 0; i < ctx->object_count; i++){		obj = &ctx->objects[i]; 		if(TYPE(obj) == AA_TFREE)			continue; 		if(~TAG(obj) & GCMARKBIT){			if(TYPE(obj) == AA_TPTR && ctx->handlers.gc)				ctx->handlers.gc(ctx, obj); 			SETTYPE(obj, AA_TFREE);			CDR(obj) = ctx->freelist;			ctx->freelist = obj;		}else{			TAG(obj) &= ~GCMARKBIT;		}	}} static intequal(aaObject *a, aaObject *b){	if(a == b)		return 1; 	if(TYPE(a) != TYPE(b) || TYPE(a) == AA_TBOOL)		return 0; 	if(TYPE(a) == AA_TNUMBER)		return NUMBER(a).r == NUMBER(b).r; 	if(TYPE(a) == AA_TSTRING){		for(; !ISNULL(a); a = CDR(a), b = CDR(b)){			if(CAR(a) != CAR(b))				return 0;		}		return a == b;	} 	for(; TYPE(a) == AA_TPAIR && TYPE(b) == AA_TPAIR && !ISNULL(a) && !ISNULL(b) && a != b; a = CDR(a), b = CDR(b)){		if(!equal(CAR(a), CAR(b)))			return 0;	} 	return a == b;} static intstreq(aaObject *obj, const char *str){	int i; 	while(!ISNULL(obj)){		for(i = 0; i < STRBUFSIZE; i++){			if(STRBUF(obj)[i] != *str)				return 0;			if(*str)				str++;		}		obj = CDR(obj);	} 	return *str == 0;} static aaObject *object(aaContext *ctx){	aaObject *obj; 	/* do gc if freelist has no more objects */	if(ISNULL(ctx->freelist)){		collectgarbage(ctx);		if(ISNULL(ctx->freelist))			aa_error(ctx, "out of memory");	} 	/* get object from freelist and push to the gcstack */	obj = ctx->freelist;	ctx->freelist = CDR(obj);	aa_pushgc(ctx, obj); 	return obj;} aaObject *aa_cons(aaContext *ctx, aaObject *car, aaObject *cdr){	aaObject *obj = object(ctx); 	CAR(obj) = car;	CDR(obj) = cdr; 	return obj;} aaObject *aa_bool(aaContext *ctx, int b){	USED(ctx);	return b ? &True : &False;} aaObject *aa_number(aaContext *ctx, aaNumber n){	aaObject *obj = object(ctx); 	SETTYPE(obj, AA_TNUMBER);	NUMBER(obj) = n; 	return obj;} static aaObject *buildstring(aaContext *ctx, aaObject *tail, int chr){	aaObject *obj; 	if(!tail || STRBUF(tail)[STRBUFSIZE - 1] != '\0'){		obj = aa_cons(ctx, nil, &Null);		SETTYPE(obj, AA_TSTRING);		if(tail){			CDR(tail) = obj;			ctx->gcstack_idx--;		}		tail = obj;	}	STRBUF(tail)[strlen(STRBUF(tail))] = chr; 	return tail;} aaObject *aa_string(aaContext *ctx, const char *str){	aaObject *obj = buildstring(ctx, nil, '\0');	aaObject *tail = obj; 	while(*str)		tail = buildstring(ctx, tail, *str++); 	return obj;} aaObject *aa_symbol_find(aaContext *ctx, const char *name){	aaObject *obj;	char *pk; 	obj = nil;	qpget(ctx->symtrie, name, 0, &pk, &obj); 	return obj;} aaObject *aa_symbol(aaContext *ctx, const char *name){	aaObject *obj; 	/* try to find it first */	if((obj = aa_symbol_find(ctx, name)) != nil)		return obj; 	/* create new object, push to symlist and return */	obj = object(ctx);	SETTYPE(obj, AA_TSYMBOL);	CDR(obj) = aa_cons(ctx, aa_string(ctx, name), nil); /* nil not &Null, because it's unbound */	ctx->symlist = aa_cons(ctx, obj, ctx->symlist);	ctx->symtrie = qpset(ctx->symtrie, strdup(name), 0, obj); 	return obj;} aaObject *aa_cfunc(aaContext *ctx, aaCFunc fn){	aaObject *obj = object(ctx); 	SETTYPE(obj, AA_TCFUNC);	CFUNC(obj) = fn; 	return obj;} aaObject *aa_ptr(aaContext *ctx, void *ptr){	aaObject *obj = object(ctx); 	SETTYPE(obj, AA_TPTR);	CDR(obj) = ptr; 	return obj;} aaObject *aa_list(aaContext *ctx, aaObject **objs, int n){	aaObject *res = &Null; 

Lines 1–500 of 1147. Load more