ref: 14c196a5da48284123d615418c80b6fbc87d7f46
dir: /flisp.h/
#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 unspecified t #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 #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 Nil, t, f; value_t eof, 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 pairsym, 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 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, emptystringsym; 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);