#include "sl.h"#include "operators.h"#include "cvalues.h"#include "types.h"#include "print.h"#include "read.h"#include "timefuncs.h"#include "equal.h"#include "hashing.h"#include "table.h"#include "io.h"#include "compress.h"#include "slmath.h"#include "str.h" sl_v sl_builtinssym, sl_quote, sl_lambda, sl_comma, sl_commaat;sl_v sl_commadot, sl_trycatch, sl_backquote;sl_v sl_conssym, sl_symsym, sl_fixnumsym, sl_vecsym, sl_builtinsym, sl_vu8sym;sl_v sl_defsym, sl_defmacrosym, sl_forsym, sl_setqsym, sl_listsym;sl_v sl_boolsym, sl_nullsym, sl_evalsym, sl_fnsym, sl_trimsym, sl_strsym;sl_v sl_errio, sl_errparse, sl_errtype, sl_errarg, sl_errmem, sl_errconst;sl_v sl_errdiv0, sl_errbounds, sl_err, sl_errkey, sl_errunbound, sl_erroom;sl_v sl_emptyvec, sl_emptystr, sl_vecstructsym, sl_structsym; static sl_v sl_errarity; sl_v sl_tablesym, sl_arrsym;sl_v sl_s8sym, sl_u8sym, sl_s16sym, sl_u16sym, sl_s32sym, sl_u32sym;sl_v sl_s64sym, sl_u64sym, sl_p32sym, sl_p64sym, sl_ptrsym, sl_bignumsym;sl_v sl_utf8sym, sl_runesym, sl_f32sym, sl_f64sym; sl_type *sl_bignumtype, *sl_builtintype;sl_type *sl_s8type, *sl_u8type;sl_type *sl_s16type, *sl_u16type;sl_type *sl_s32type, *sl_u32type;sl_type *sl_s64type, *sl_u64type;sl_type *sl_p32type, *sl_p64type;sl_type *sl_f32type, *sl_f64type;sl_type *sl_utf8type, *sl_runetype;sl_type *sl_strtype; sl_thread(sl_proc *slp);sl_vm slvm_ = {0}; typedef struct {	const char *name;	sl_builtinfn fptr;}sl_builtinspec; boolisbuiltin(sl_v x){	int i;	return tag(x) == TAG_FN && (i = uintval(x)) < nelem(builtins) && builtins[i].name != nil;} static sl_v apply_cl(int nargs) sl_hotfn; // error utilities ------------------------------------------------------------ voidfree_readstate(sl_readstate *rs){	htable_free(&rs->backrefs);	htable_free(&rs->gensyms);} _Noreturn voidsl_exit(const char *status){	if(!slvm.exiting){		slvm.exiting = true;		sl_applyn(			1,			sym_value(mk_sym("__finish", false)),			status == nil ? sl_nil : cvalue_static_cstr(status)		);		sl_gc(false);	}	exits(status);} #define SL_TRY \	sl_exctx _ctx; int l__tr, l__ca; \	_ctx.osp = sl.sp - sl.stack; _ctx.frame = sl.curr_frame; \	_ctx.rdst = sl.readstate; _ctx.prev = sl.exctx; \	_ctx.ngchnd = slvm.ngchandles; sl.exctx = &_ctx; \	if(!sl_setjmp(_ctx.buf)) \		for(l__tr = 1; l__tr; l__tr = 0, (void)(sl.exctx = sl.exctx->prev)) #define SL_CATCH_INC \	l__ca = 0, sl.lasterror = sl_nil, sl.throwing_frame = 0, \	sl.sp = sl.stack + _ctx.osp, sl.curr_frame = _ctx.frame #define SL_CATCH \	else \		for(l__ca = 1; l__ca; SL_CATCH_INC) #define SL_CATCH_NO_INC \	else \		for(l__ca = 1; l__ca;) voidsl_savestate(sl_exctx *_ctx){	_ctx->osp = sl.sp - sl.stack;	_ctx->frame = sl.curr_frame;	_ctx->rdst = sl.readstate;	_ctx->prev = sl.exctx;	_ctx->ngchnd = slvm.ngchandles;} voidsl_restorestate(sl_exctx *_ctx){	sl.lasterror = sl_nil;	sl.throwing_frame = 0;	sl.sp = sl.stack + _ctx->osp;	sl.curr_frame = _ctx->frame;} static sl_vmk_loc(sl_v io, ios_loc *l){	return mk_listn(3, io, fixnum(l->lineno), fixnum(l->colno));} _Noreturn voidsl_raise(sl_v e){	ios_flush(ios_stdout);	ios_flush(ios_stderr); 	if(sl.readstate != sl.exctx->rdst){		sl_gc_handle(&e);		e = mk_cons(mk_loc(sl.readstate->source, &sl.readstate->errloc), e);		sl_free_gc_handles(1);	} 	sl.lasterror = e;	// unwind read state	while(sl.readstate != sl.exctx->rdst){		free_readstate(sl.readstate);		sl.readstate = sl.readstate->prev;	}	if(sl.throwing_frame == 0)		sl.throwing_frame = sl.curr_frame;	slvm.ngchandles = sl.exctx->ngchnd;	sl_exctx *thisctx = sl.exctx;	if(sl.exctx->prev)   // don't throw past toplevel		sl.exctx = sl.exctx->prev;	sl_longjmp(thisctx->buf, 1);} _Noreturn voidlerrorf(sl_v e, const char *format, ...){	char msgbuf[256];	va_list args; 	PUSH(e);	va_start(args, format);	vsnprintf(msgbuf, sizeof(msgbuf), format, args);	sl_v msg = str_from_cstr(msgbuf);	va_end(args); 	e = POP();	sl_raise(mk_list2(e, msg));} _Noreturn voidtype_error(const char *what, const char *expected, sl_v got){	if(what == nil)		sl_raise(mk_listn(3, sl_errtype, mk_sym(expected, false), got));	sl_raise(mk_listn(4, sl_errtype, mk_sym(expected, false), got, mk_sym(what, false)));} _Noreturn voidbounds_error(sl_v arr, sl_v ind){	sl_raise(mk_listn(3, sl_errbounds, arr, ind));} _Noreturn voidconst_error(sl_v sym){	sl_raise(mk_list2(sl_errconst, sym));} _Noreturn voidunbound_error(sl_v sym){	sl_raise(mk_listn(2, sl_errunbound, sym));} _Noreturn voidarity_error(int nargs, int c){	sl_raise(mk_listn(3, sl_errarity, size_wrap(c), size_wrap(nargs)));} // safe cast operators -------------------------------------------------------- #define SAFECAST_OP(type, ctype, cnvt) \	ctype to##type(sl_v v) \	{ \		if(sl_likely(is##type(v))) \			return (ctype)cnvt(v); \		cthrow(type_error("value", #type, v), v); \	}SAFECAST_OP(cons, sl_cons*, ptr)SAFECAST_OP(sym, sl_sym*, ptr)SAFECAST_OP(fixnum, sl_fx, numval)//SAFECAST_OP(cvalue, sl_cv*, ptr)SAFECAST_OP(str, char*, cvalue_data) // symbol table --------------------------------------------------------------- static sl_sym *alloc_sym(const char *str, int len, bool copy){	sl_sym *sym = MEM_ALLOC(sizeof(*sym) + (copy ? len+1 : 0));	sym->numtype = NONNUMERIC;	if(str[0] == ':' && str[1] != 0){		sl_v s = tagptr(sym, TAG_SYM);		sym->flags = FLAG_KEYWORD;		setc(s, s);	}else{		sym->binding = sl_unbound;		sym->flags = 0;	}	sym->type = nil;	sym->hash = memhash32(str, len)^0xAAAAAAAAU; // sing along	if(copy){		memcpy((char*)(sym+1), str, len+1);		sym->name = (const char*)(sym+1);	}else{		sym->name = str;	}	sym->size = 0;	return sym;} sl_vmk_sym(const char *str, bool copy){	int len = strlen(str);	sl_sym *v;	const char *k;	if(!Tgetkv(slvm.symbols, str, len, &k, (void**)&v)){		v = alloc_sym(str, len, copy);		slvm.symbols = Tsetl(slvm.symbols, v->name, len, v);	}	if(v->binding == sl_lambda)		return sl_lambda;	return tagptr(v, TAG_SYM);} sl_vmk_csym_(const char *str, int len){	sl_sym *v = alloc_sym(str, len, false);	slvm.symbols = Tsetl(slvm.symbols, str, len, v);	return tagptr(v, TAG_SYM);} BUILTIN("gensym", gensym){	argcount(nargs, 0);	sl_gensym *gs = alloc_words(sizeof(sl_gensym)/sizeof(sl_v));	gs->id = slvm.gensym_ctr++;	gs->binding = sl_unbound;	gs->type = nil;	return tagptr(gs, TAG_SYM);} sl_vmk_gensym(void){	return fn_builtin_gensym(nil, 0);} sl_purefnBUILTIN("gensym?", gensymp){	argcount(nargs, 1);	return isgensym(args[0]) ? sl_t : sl_nil;} char *uint2str(char *dest, usize len, u64int num, int base){	int i = len-1;	u64int b = (u64int)base;	char ch;	dest[i--] = '\0';	while(i >= 0){		ch = (char)(num % b);		if(ch < 10)			ch += '0';		else			ch = ch-10+'A';		dest[i--] = ch;		num /= b;		if(num == 0)			break;	}	return &dest[i+1];} const char *sym_name(sl_v v){	char *n = (char*)sym_name_(v);	if(n != nil)		return n;	assert(ismanaged(v));	sl_gensym *gs = ptr(v);	slvm.gsnameno = 1-slvm.gsnameno;	n = uint2str(slvm.gsname[slvm.gsnameno]+1, sizeof(slvm.gsname[0])-1, gs->id, 10);	*(--n) = 'g';	return n;} // conses --------------------------------------------------------------------- sl_valloc_cons(void){	sl_cons *c; 	if(sl_unlikely(slvm.curheap > slvm.lim))		sl_gc(false);	c = (sl_cons*)slvm.curheap;	slvm.curheap += sizeof(sl_cons);	return tagptr(c, TAG_CONS);} void *alloc_words(usize n){	sl_v *first; 	// force 8-byte alignment (32-bit) and always two cells (to forward)	assert(n > 0);	if(n & 1)		n++;	if(sl_unlikely((sl_v*)slvm.curheap > (sl_v*)slvm.lim+2-n)){		sl_gc(false);		while(sl_unlikely((sl_v*)slvm.curheap > (sl_v*)slvm.lim+2-n))			sl_gc(true);	}	first = (sl_v*)slvm.curheap;	slvm.curheap += n*sizeof(sl_v);	return first;} sl_valloc_vec(usize n, bool init){	if(n == 0)		return sl_emptyvec;	sl_v *c = alloc_words(n+1);	sl_v v = tagptr(c, TAG_VEC);	vec_setsize(v, n, VEC_VEC);	if(init){		for(usize i = 0; i < n; i++)			vec_elt(v, i) = sl_void;	}	return v;} voidsl_stack_grow(void){	sl_v *s = MEM_REALLOC(sl.stack, 2*sl.nstack*sizeof(sl.stack));	if(s == nil)		sl_raise(sl_erroom);	sl.nstack *= 2;	sl.sp = s + (sl.sp - sl.stack);	sl.stackend = s + sl.nstack;	sl.stack = s;} // collector ------------------------------------------------------------------ voidsl_gc_handle(sl_v *pv){	if(sl_unlikely(slvm.ngchandles == slvm.maxgchandles)){		sl_v **gh = MEM_REALLOC(slvm.gchandles, slvm.maxgchandles*2*sizeof(sl_v*));		if(gh == nil)			cthrow(lerrorf(sl_errmem, "out of gc handles"), pv);		slvm.maxgchandles *= 2;		slvm.gchandles = gh;	}	slvm.gchandles[slvm.ngchandles++] = pv;} voidsl_free_gc_handles(int n){	assert(slvm.ngchandles >= n);	slvm.ngchandles -= n;} sl_vsl_relocate(sl_v v){	sl_v a, d, nc, first, *pcdr; 	if(isfixnum(v) || isunboxed(v) || isspecial(v))		return v; 	uintptr t = tag(v);	if(t == TAG_CONS){		// iterative implementation allows arbitrarily long cons chains		pcdr = &first;		do{			a = car_(v);			if(sl_unlikely(isforwarded(v))){				*pcdr = forwardloc(v);				return first;			}			d = cdr_(v);			*pcdr = nc = tagptr((sl_cons*)slvm.curheap, TAG_CONS);			slvm.curheap += sizeof(sl_cons);			forward(v, nc);			car_(nc) = ismanaged(a) ? sl_relocate(a) : a;			pcdr = &cdr_(nc);			v = d;		}while(iscons(v));		*pcdr = d == sl_nil ? sl_nil : sl_relocate(d);		return first;	} 	if(!ismanaged(v))		return v;	if(isforwarded(v))		return forwardloc(v); 	if(t == TAG_CVALUE){		if(sl_unlikely(slvm.exiting)){			sweep_cv(ptr(v));			return sl_nil;		}		return cvalue_relocate(v);	}	if(t == TAG_VEC){		// N.B.: 0-length vectors secretly have space for a first element		usize i, sz = vec_size(v);		if(sl_unlikely(vec_elt(v, -1) & VEC_GROWN)){			// grown vector			nc = sl_relocate(vec_elt(v, 0));			forward(v, nc);		}else{			nc = tagptr(alloc_words(sz+1), TAG_VEC);			vec_setsize(nc, sz, vec_type(v));			a = vec_elt(v, 0);			forward(v, nc);			if(sl_likely(sz > 0)){				vec_elt(nc, 0) = sl_relocate(a);				for(i = 1; i < sz; i++)					vec_elt(nc, i) = sl_relocate(vec_elt(v, i));			}		}		return nc;	}	if(t == TAG_FN){		sl_fn *fn = ptr(v), f;		f.vals = sl_relocate(fn->vals);		f.bcode = sl_relocate(fn->bcode);		f.env = fn->env == sl_nil ? sl_nil : sl_relocate(fn->env);		f.name = sl_relocate(fn->name);		f.maxstack = fn->maxstack;		sl_fn *nfn = alloc_words(sizeof(sl_fn)/sizeof(sl_v));		*nfn = f;		assert(!ismanaged(nfn->vals));		assert(!ismanaged(nfn->bcode));		assert(!ismanaged(nfn->env));		assert(!ismanaged(nfn->name));		nc = tagptr(nfn, TAG_FN);		forward(v, nc);		return nc;	}	if(t == TAG_SYM){		sl_gensym *gs = ptr(v);		sl_gensym *ng = alloc_words(sizeof(sl_gensym)/sizeof(sl_v));		ng->id = gs->id;		ng->binding = gs->binding;		ng->type = gs->type;		ng->name = gs->name;		nc = tagptr(ng, TAG_SYM);		forward(v, nc);		if(ng->binding != sl_unbound)			ng->binding = sl_relocate(ng->binding);		return nc;	}	return v;

Lines 1–500 of 1516. Load more