#include "inc/priv.h"#include "inc/bitvector.h"#include "inc/cvalues.h"#include "inc/equal.h"#include "inc/hashing.h"#include "inc/operators.h"#include "inc/print.h"#include "inc/read.h"#include "inc/io.h"#include "inc/process.h"#include "inc/str.h"#include "inc/table.h"#include "inc/time.h"#include "inc/types.h"#include "tbl.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_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;sl_v sl_minsym, sl_maxsym, sl_extrasym; 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; const sl_type *sl_bignumtype, *sl_builtintype;const sl_type *sl_s8type, *sl_u8type;const sl_type *sl_s16type, *sl_u16type;const sl_type *sl_s32type, *sl_u32type;const sl_type *sl_s64type, *sl_u64type;const sl_type *sl_p32type, *sl_p64type;const sl_type *sl_f32type, *sl_f64type;const sl_type *sl_utf8type, *sl_runetype;const sl_type *sl_strtype; #if 0// FIXME(sigrid): stays disabled until it becomes usefulsl_thread(sl_proc *slp);sl_thread(sl_vm *slvmp);#elsesl_proc *slp;sl_vm *slvmp;#endif typedef struct {	const char *name;	sl_builtinfn fptr;}sl_builtinspec; boolisbuiltin(sl_v v){	int i;	return (i = u32numval(v)) < nelem(builtins) && tag(v) == TAG_FN && builtins[i].name != nil;} // error utilities ------------------------------------------------------------ voidfree_readstate(sl_readstate *rs){	htable_free(&rs->backrefs);	htable_free(&rs->gensyms);} _Noreturn voidsl_exit(const char *status, int code){	if(code == 0 && status != nil)		code = 1;	else if(code != 0 && status == nil)		status = "error";	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);	}	USED(code);	sys_exit(status, code);} voidsl_savestate(sl_exctx *_ctx){	_ctx->osp = sl.sp - sl.stack;	_ctx->frame = sl.curr_frame;	_ctx->rs = sl.rs;	_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;} sl_nonnull(2)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);	assert(sl.exctx != nil); 	if(sl.rs != sl.exctx->rs){		sl_gc_handle(&e);		e = mk_cons(mk_loc(sl.rs->io, &sl.rs->errloc), e);		sl_free_gc_handles(1);	} 	sl.lasterror = e;	// unwind read state	while(sl.rs != sl.exctx->rs){		free_readstate(sl.rs);		sl.rs = sl.rs->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 voidsl_error(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 voidsl_type_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 voidsl_bounds_error(sl_v arr, sl_v ind){	sl_raise(mk_listn(3, sl_errbounds, arr, ind));} _Noreturn voidsl_const_error(sl_v sym){	sl_raise(mk_list2(sl_errconst, sym));} _Noreturn voidsl_unbound_error(sl_v sym){	sl_raise(mk_list2(sl_errunbound, sym));} _Noreturn voidsl_arity_error(int nargs, int c, sl_v r){	sl_raise(mk_listn(4, sl_errarity, fixnum(c), fixnum(nargs), r));} _Noreturn voidsl_divide_by_0_error(void){	sl_error(sl_errdiv0, "/: division by zero");} // safe cast operators -------------------------------------------------------- sl_cons *tocons(sl_v v){	if(sl_likely(iscons(v)))		return ptr(sl_cons, v);	cthrow(type_error("value", "cons", v), v);} sl_sym *tosym(sl_v v){	if(sl_likely(issym(v)))		return ptr(sl_sym, v);	cthrow(type_error("value", "sym", v), v);} sl_fxtofixnum(sl_v v){	if(sl_likely(isfixnum(v)))		return numval(v);	cthrow(type_error("value", "fixnum", v), v);} char *tostr(sl_v v){	if(sl_likely(isstr(v)))		return cvalue_data(v);	cthrow(type_error("value", "str", v), v);} // symbol table --------------------------------------------------------------- sl_nonnull(1)sl_returns_nonnullstatic sl_sym *alloc_sym(const char *str, int len, bool copy){	sl_sym *sym = MEM_ALLOC(sizeof(*sym) + (copy ? len+1 : 0));	assert(sym != nil);	sym->numtype = T_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);} sl_vmk_gensym(void){	sl_sym *gs = alloc_words(sizeof(sl_sym)/sizeof(sl_v));	gs->id = slvm.gensym_ctr++;	gs->numtype = T_NONNUMERIC;	gs->binding = sl_unbound;	gs->type = nil;	gs->flags = FLAG_GENSYM;	return tagptr(gs, TAG_SYM);} BUILTIN("gensym", gensym){	noargs();	return mk_gensym();} BUILTIN("gensym?", gensymp){	argcount(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){	sl_sym *s = ptr(sl_sym, v);	const char *n = s->name;	if(sl_likely(n != nil))		return n;	assert(s->flags & FLAG_GENSYM);	slvm.gsnameno = 1-slvm.gsnameno;	char *tmp = uint2str(slvm.gsname[slvm.gsnameno]+1, sizeof(slvm.gsname[0])-1, s->id, 10);	assert(tmp > slvm.gsname[slvm.gsnameno]);	*(--tmp) = 'g';	return tmp;} // 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; 	assert(n > 0);#if !defined(BITS64)	// 8-byte alignment (only 32-bit platforms need it)	if(n & 1)		n++;#endif	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(sl_unlikely(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(sl_unlikely(init)){		for(usize i = 0; i < n; i++)			vec_elt(v, i) = sl_void;	}	return v;} voidsl_stack_grow(int dummy){	sl_v *s = MEM_REALLOC(sl.stack, 2*sl.nstack*sizeof(sl.stack));	if(sl_unlikely(s == nil))		cthrow(raise(sl_erroom), dummy);	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(error(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) || isespecial(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(sl_cv, 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(sl_fn, 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);

Lines 1–500 of 1552. Load more