shithub: femtolisp

ref: 7bcf6ac7b612306d197d063aaf6d971ca5dd2e3f
dir: /flisp.h/

View raw version
#pragma once

#include "platform.h"
#include "utf8.h"
#include "ios.h"
#include "bitvector.h"
#include "htableh.inc"
HTPROT(ptrhash)

typedef struct fltype_t fltype_t;

enum {
	TAG_NUM,
	TAG_CPRIM,
	TAG_FUNCTION,
	TAG_VECTOR,
	TAG_NUM1,
	TAG_CVALUE,
	TAG_SYM,
	TAG_CONS,
};

enum {
	FLAG_CONST = 1<<0,
	FLAG_KEYWORD = 1<<1,
};

typedef enum {
	T_INT8, T_UINT8,
	T_INT16, T_UINT16,
	T_INT32, T_UINT32,
	T_INT64, T_UINT64,
	T_MPINT,
	T_FLOAT,
	T_DOUBLE,
}numerictype_t;

#ifdef BITS64
typedef uint64_t value_t;
typedef int64_t fixnum_t;
#define FIXNUM_BITS 62
#define TOP_BIT (1ULL<<63)
#define T_FIXNUM T_INT64
#else
typedef uint32_t value_t;
typedef int32_t fixnum_t;
#define FIXNUM_BITS 30
#define TOP_BIT (1U<<31)
#define T_FIXNUM T_INT32
#endif

#define ALIGNED(x, sz) (((x) + (sz-1)) & (-sz))

typedef struct {
	value_t car;
	value_t cdr;
}cons_t;

typedef struct _symbol_t {
	fltype_t *type;
	const char *name;
	void *dlcache;	 // dlsym address
	struct _symbol_t *left;
	struct _symbol_t *right;
	value_t binding;   // global value binding
	uint32_t hash;
	uint8_t numtype;
	uint8_t size;
	uint8_t align;
	uint8_t flags;
}symbol_t;

typedef struct {
	fltype_t *type;
	value_t binding;   // global value binding
	uint32_t id;
}gensym_t;

typedef struct Builtin Builtin;

struct Builtin {
	const char *name;
	int nargs;
};

typedef value_t (*builtin_t)(value_t*, uint32_t);

#define fits_bits(x, b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
#define fits_fixnum(x) fits_bits(x, FIXNUM_BITS)

#define ANYARGS -10000
#define NONNUMERIC (0xff)
#define valid_numtype(v) ((v) <= T_DOUBLE)
#define UNBOUND ((value_t)0x1) // an invalid value
#define TAG_FWD UNBOUND
#define tag(x) ((x) & 0x7)
#define ptr(x) ((void*)((x) & (~(value_t)0x7)))
#define tagptr(p, t) ((value_t)(p) | (t))
#define fixnum(x) ((value_t)(x)<<2)
#define numval(x)  ((fixnum_t)(x)>>2)
#define uintval(x) (((unsigned int)(x))>>3)
#define builtin(n) tagptr(((int)n<<3), TAG_FUNCTION)
#define iscons(x) (tag(x) == TAG_CONS)
#define issymbol(x) (tag(x) == TAG_SYM)
#define isfixnum(x) (((x)&3) == TAG_NUM)
#define bothfixnums(x, y) ((((x)|(y)) & 3) == TAG_NUM)
#define isvector(x) (tag(x) == TAG_VECTOR)
#define iscvalue(x) (tag(x) == TAG_CVALUE)
#define iscprim(x)  (tag(x) == TAG_CPRIM)
// doesn't lead to other values
#define leafp(a) (((a)&3) != 3)

// allocate n consecutive conses
#define cons_reserve(n) tagptr(alloc_words((n)*2), TAG_CONS)
#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)FL(fromspace)))
#define ismarked(c) bitvector_get(FL(consflags), cons_index(c))
#define mark_cons(c) bitvector_set(FL(consflags), cons_index(c))
#define unmark_cons(c) bitvector_reset(FL(consflags), cons_index(c))

#define isforwarded(v) (((value_t*)ptr(v))[0] == TAG_FWD)
#define forwardloc(v) (((value_t*)ptr(v))[1])
#define forward(v, to) \
	do{ \
		(((value_t*)ptr(v))[0] = TAG_FWD); \
		(((value_t*)ptr(v))[1] = to); \
	}while (0)

#define vector_size(v) (((size_t*)ptr(v))[0]>>2)
#define vector_setsize(v, n) (((size_t*)ptr(v))[0] = ((n)<<2))
#define vector_elt(v, i) (((value_t*)ptr(v))[1+(i)])
#define vector_grow_amt(x) ((x)<8 ? 5 : 6*((x)>>3))
// functions ending in _ are unsafe, faster versions
#define car_(v) (((cons_t*)ptr(v))->car)
#define cdr_(v) (((cons_t*)ptr(v))->cdr)
#define car(v) (tocons((v))->car)
#define cdr(v) (tocons((v))->cdr)
#define fn_bcode(f) (((value_t*)ptr(f))[0])
#define fn_vals(f) (((value_t*)ptr(f))[1])
#define fn_env(f) (((value_t*)ptr(f))[2])
#define fn_name(f) (((value_t*)ptr(f))[3])
#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
#define setc(s, v) \
	do{ \
		((symbol_t*)ptr(s))->flags |= FLAG_CONST; \
		((symbol_t*)ptr(s))->binding = (v); \
	}while (0)
#define isconstant(s) ((s)->flags & FLAG_CONST)
#define iskeyword(s) ((s)->flags & FLAG_KEYWORD)
#define symbol_value(s) (((symbol_t*)ptr(s))->binding)
#define sym_to_numtype(s) (((symbol_t*)ptr(s))->numtype)
#define ismanaged(v) ((((uint8_t*)ptr(v)) >= FL(fromspace)) && (((uint8_t*)ptr(v)) < FL(fromspace)+FL(heapsize)))
#define isgensym(x)  (issymbol(x) && ismanaged(x))
#define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS<<3))
#define isclosure(x) isfunction(x)
#define iscbuiltin(x) (iscvalue(x) && cv_class(ptr(x)) == FL(builtintype))
// utility for iterating over all arguments in a builtin
// i=index, i0=start index, arg = var for each arg, args = arg array
// assumes "nargs" is the argument count
#define FOR_ARGS(i, i0, arg, args) for(i=i0; i<nargs && ((arg=args[i]) || 1); i++)
#define N_BUILTINS ((int)N_OPCODES)

#define PUSH(v) \
	do{ \
		FL(stack)[FL(sp)++] = (v); \
	}while(0)
#define POPN(n) \
	do{ \
		FL(sp) -= (n); \
	}while(0)
#define POP() (FL(stack)[--FL(sp)])

bool isbuiltin(value_t x);
void fl_init(size_t initial_heapsize);
int fl_load_system_image(value_t ios);

_Noreturn void fl_exit(int status);

/* collector */
value_t relocate(value_t v);
void gc(int mustgrow);
void fl_gc_handle(value_t *pv);
void fl_free_gc_handles(uint32_t n);

/* symbol table */
value_t gensym(void);
value_t symbol(const char *str, bool copy);
const char *symbol_name(value_t v);

/* read, eval, print main entry points */
value_t fl_toplevel_eval(value_t expr);
value_t fl_apply(value_t f, value_t l);
value_t fl_applyn(uint32_t n, value_t f, ...);

/* object model manipulation */
value_t fl_cons(value_t a, value_t b);
value_t fl_list2(value_t a, value_t b);
value_t fl_listn(size_t n, ...);
bool fl_isnumber(value_t v);
bool fl_is_keyword_name(const char *str, size_t len);
value_t alloc_vector(size_t n, int init);

/* safe casts */
cons_t *tocons(value_t v);
symbol_t *tosymbol(value_t v);
fixnum_t tofixnum(value_t v);
char *tostring(value_t v);
double todouble(value_t a);

/* conses */
value_t mk_cons(void);
void *alloc_words(uint32_t n);

char *uint2str(char *dest, size_t len, uint64_t num, uint32_t base);

/* error handling */
typedef struct _fl_readstate_t {
	htable_t backrefs;
	htable_t gensyms;
	value_t source;
	struct _fl_readstate_t *prev;
}fl_readstate_t;

typedef struct _ectx_t {
	jmp_buf buf;
	uint32_t sp;
	uint32_t frame;
	uint32_t ngchnd;
	fl_readstate_t *rdst;
	struct _ectx_t *prev;
}fl_exception_context_t;

void free_readstate(fl_readstate_t *rs);

#define FL_TRY_EXTERN \
	fl_exception_context_t _ctx; int l__tr, l__ca; \
	fl_savestate(&_ctx); FL(exctx) = &_ctx; \
	if(!setjmp(_ctx.buf)) \
		for(l__tr=1; l__tr; l__tr=0, (void)(FL(exctx) = FL(exctx)->prev))

#define FL_CATCH_EXTERN_NO_RESTORE \
	else \
		for(l__ca=1; l__ca;)

#define FL_CATCH_EXTERN \
	else \
		for(l__ca=1; l__ca; l__ca=0, fl_restorestate(&_ctx))

_Noreturn void lerrorf(value_t e, const char *format, ...);
void fl_savestate(fl_exception_context_t *_ctx);
void fl_restorestate(fl_exception_context_t *_ctx);
_Noreturn void fl_raise(value_t e);
_Noreturn void type_error(const char *expected, value_t got);
_Noreturn void bounds_error(value_t arr, value_t ind);
_Noreturn void unbound_error(value_t sym);

#define argcount(nargs, c) \
	do{ \
		if(__unlikely(nargs != c)) \
			lerrorf(FL(ArgError), "arity mismatch: wanted %d, got %d", c, nargs); \
	}while(0)

typedef struct {
	void (*print)(value_t self, ios_t *f);
	void (*relocate)(value_t oldv, value_t newv);
	void (*finalize)(value_t self);
	void (*print_traverse)(value_t self);
} cvtable_t;

typedef int (*cvinitfunc_t)(fltype_t*, value_t, void*);

struct fltype_t {
	value_t type;
	cvtable_t *vtable;
	fltype_t *eltype;  // for arrays
	fltype_t *artype;  // (array this)
	cvinitfunc_t init;
	size_t size;
	size_t elsz;
	numerictype_t numtype;
};

typedef struct {
	fltype_t *type;
	void *data;
	size_t len;			// length of *data in bytes
	union {
		value_t parent;	// optional
		uint8_t _space[1];	// variable size
	};
}cvalue_t;

typedef struct {
	fltype_t *type;
	uint8_t _space[1];
}cprim_t;

typedef struct {
	value_t bcode;
	value_t vals;
	value_t env;
	value_t name;
}function_t;

#define CPRIM_NWORDS 2
#define cv_class(cv) ((fltype_t*)(((uintptr_t)((cvalue_t*)cv)->type)&~(uintptr_t)3))
#define cv_len(cv) (((cvalue_t*)(cv))->len)
#define cv_type(cv) (cv_class(cv)->type)
#define cv_data(cv) (((cvalue_t*)(cv))->data)
#define cv_isstr(cv) (cv_class(cv)->eltype == FL(bytetype))
#define cv_isPOD(cv) (cv_class(cv)->init != nil)
#define cvalue_data(v) cv_data((cvalue_t*)ptr(v))
#define cvalue_len(v) cv_len((cvalue_t*)ptr(v))
#define value2c(type, v) ((type)cvalue_data(v))
#define cp_class(cp) (((cprim_t*)(cp))->type)
#define cp_type(cp)	(cp_class(cp)->type)
#define cp_numtype(cp) (cp_class(cp)->numtype)
#define cp_data(cp)	(&((cprim_t*)(cp))->_space[0])
// WARNING: multiple evaluation!
#define cptr(v) (iscprim(v) ? cp_data(ptr(v)) : cvalue_data(v))

#define BUILTIN(lname, cname) \
	value_t fn_builtin_##cname(value_t *args, uint32_t nargs)

#define BUILTIN_FN(l, c) extern BUILTIN(l, c);
#include "builtin_fns.h"
#undef BUILTIN_FN

#include "opcodes.h"

enum {
	FL_nil = builtin(OP_LOADNIL),
	FL_t = builtin(OP_LOADT),
	FL_f = builtin(OP_LOADF),
	FL_void = builtin(OP_LOADVOID),
	FL_eof = builtin(OP_EOF_OBJECT),
};

#define N_GC_HANDLES 1024

typedef struct Fl Fl;

struct Fl {
	value_t *stack;
	uint32_t sp;
	uint32_t heapsize;//bytes
	uint8_t *fromspace;
	uint32_t curr_frame;
	uint32_t nstack;

	uint8_t *tospace;
	uint8_t *curheap;
	uint8_t *lim;

	size_t malloc_pressure;

	value_t quote;
	value_t lambda, trycatch;
	value_t backquote, comma, commaat, commadot, function;

	bool grew;

	cvalue_t **finalizers;
	size_t nfinalizers;
	size_t maxfinalizers;

	value_t *gchandles[N_GC_HANDLES];
	uint32_t ngchandles;

	fl_readstate_t *readstate;
	symbol_t *symtab;

	// saved execution state for an unwind target
	fl_exception_context_t *exctx;
	uint32_t throwing_frame;  // active frame when exception was thrown
	value_t lasterror;

	value_t printwidthsym, printreadablysym, printprettysym, printlengthsym;
	value_t printlevelsym, builtins_table_sym;
	value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym;
	value_t definesym, defmacrosym, forsym, setqsym;
	value_t tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym, fnsym;
	// for reading characters
	value_t nulsym, alarmsym, backspacesym, tabsym, linefeedsym, newlinesym;
	value_t vtabsym, pagesym, returnsym, escsym, spacesym, deletesym;

	value_t IOError, ParseError, TypeError, ArgError, MemoryError;
	value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
	value_t UnboundError;

	value_t the_empty_vector;
	value_t the_empty_string;
	value_t memory_exception_value;

	value_t tablesym;
	fltype_t *tabletype;

	value_t iostreamsym, rdsym, wrsym, apsym, crsym, truncsym;
	value_t instrsym, outstrsym;
	fltype_t *iostreamtype;

	value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
	value_t int64sym, uint64sym, bignumsym;
	value_t longsym, ulongsym, bytesym, runesym;
	value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
	value_t stringtypesym, runestringtypesym;
	value_t unionsym, floatsym, doublesym;

	htable_t TypeTable;
	htable_t reverse_dlsym_lookup_table;
	fltype_t *mpinttype;
	fltype_t *int8type, *uint8type;
	fltype_t *int16type, *uint16type;
	fltype_t *int32type, *uint32type;
	fltype_t *int64type, *uint64type;
	fltype_t *longtype, *ulongtype;
	fltype_t *floattype, *doubletype;
	fltype_t *bytetype, *runetype;
	fltype_t *stringtype, *runestringtype;
	fltype_t *builtintype;

	uint32_t gensym_ctr;
	// two static buffers for gensym printing so there can be two
	// gensym names available at a time, mostly for compare()
	char gsname[2][16];
	int gsnameno;

	bool exiting;

	value_t fsosym;
	fltype_t *fsotype;

	uint32_t *consflags;
	size_t gccalls;

	htable_t printconses;
	uint32_t printlabel;
	int print_pretty;
	int print_princ;
	fixnum_t print_length;
	fixnum_t print_level;
	fixnum_t p_level;
	int scr_width;
	int hpos, vpos;
};

extern
#ifdef NDEBUG
__thread
#endif
Fl *fl;

#define FL(f) fl->f

extern double D_PNAN, D_NNAN, D_PINF, D_NINF;
extern float F_PNAN, F_NNAN, F_PINF, F_NINF;

_Noreturn void flmain(const uint8_t *boot, int bootsz, int argc, char **argv);