ref: 29b1d01e4c8bd99be867ce986408362f8ae8d023
dir: /src/sl.h/
#pragma once
#include "platform.h"
#include "utf8.h"
#include "ios.h"
#include "tbl.h"
#include "bitvector.h"
#include "htableh.inc"
HTPROT(ptrhash)
typedef struct sltype_t sltype_t;
enum {
TAG_NUM,
TAG_CPRIM,
TAG_FUNCTION,
TAG_VECTOR,
TAG_NUM1,
TAG_CVALUE,
TAG_SYM,
TAG_CONS,
/* those were set to 7 and 3 strategically on purpose */
TAG_NONLEAF_MASK = TAG_CONS & TAG_VECTOR,
};
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;
typedef uintptr_t value_t;
#if defined(BITS64)
typedef int64_t fixnum_t;
#define FIXNUM_BITS 62
#define TOP_BIT (1ULL<<63)
#define T_FIXNUM T_INT64
#define PRIdFIXNUM PRId64
#else
typedef int32_t fixnum_t;
#define FIXNUM_BITS 30
#define TOP_BIT (1U<<31)
#define T_FIXNUM T_INT32
#define PRIdFIXNUM PRId32
#endif
#if !defined(FWD_BIT)
#define FWD_BIT TOP_BIT
#endif
typedef struct {
value_t car;
value_t cdr;
}sl_aligned(8) cons_t;
// NOTE: symbol_t MUST have the same fields as gensym_t first
// there are places where gensyms are treated as normal symbols
typedef struct {
uint64_t hash;
sltype_t *type;
value_t binding; // global value binding
uint8_t numtype;
uint8_t size;
uint8_t flags;
uint8_t _dummy;
const char *name;
}sl_aligned(8) symbol_t;
typedef struct {
uint64_t id;
sltype_t *type;
value_t binding;
}sl_aligned(8) gensym_t;
typedef struct Builtin Builtin;
struct Builtin {
const char *name;
int nargs;
};
typedef value_t (*builtin_t)(value_t*, int);
#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)1) // an invalid value
#define tag(x) ((x) & 7)
#define ptr(x) ((void*)((uintptr_t)(x) & (~(uintptr_t)7)))
#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(((value_t)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) (isfixnum(x) && isfixnum(y))
#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)&TAG_NONLEAF_MASK) != TAG_NONLEAF_MASK)
// 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*)SL(fromspace)))
#define ismarked(c) bitvector_get(SL(consflags), cons_index(c))
#define mark_cons(c) bitvector_set(SL(consflags), cons_index(c))
#define unmark_cons(c) bitvector_reset(SL(consflags), cons_index(c))
#define isforwarded(v) (*(value_t*)ptr(v) & FWD_BIT)
#define forwardloc(v) (*(value_t*)ptr(v) ^ FWD_BIT)
#define forward(v, to) \
do{ \
*(value_t*)ptr(v) = (value_t)(to) | FWD_BIT; \
}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) (((function_t*)ptr(f))->bcode)
#define fn_vals(f) (((function_t*)ptr(f))->vals)
#define fn_env(f) (((function_t*)ptr(f))->env)
#define fn_name(f) (((function_t*)ptr(f))->name)
#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
#define setc(s, v) \
do{ \
symbol_t *sy = (symbol_t*)ptr(s); \
sy->flags |= FLAG_CONST; \
sy->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)) >= SL(fromspace)) && (((uint8_t*)ptr(v)) < SL(fromspace)+SL(heapsize)))
#define isgensym(x) (issymbol(x) && ismanaged(x))
#define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS<<3))
#define iscbuiltin(x) (iscvalue(x) && cv_class(ptr(x)) == SL(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{ \
*SL(sp)++ = (v); \
}while(0)
#define POPN(n) \
do{ \
SL(sp) -= (n); \
}while(0)
#define POP() *(--SL(sp))
bool isbuiltin(value_t x) sl_constfn sl_hotfn;
int sl_init(size_t heapsize, size_t stacksize);
int sl_load_system_image(value_t ios);
_Noreturn void sl_exit(int status);
/* collector */
value_t relocate(value_t v) sl_hotfn;
void sl_gc(bool mustgrow);
void sl_gc_handle(value_t *pv);
void sl_free_gc_handles(int n);
/* symbol table */
value_t gensym(void);
value_t symbol(const char *str, bool copy) sl_hotfn;
value_t csymbol_(const char *str, int len);
#define csymbol(str) csymbol_(str, sizeof(str)-1)
const char *symbol_name(value_t v);
/* read, eval, print main entry points */
value_t sl_toplevel_eval(value_t expr);
value_t sl_apply(value_t f, value_t l);
value_t sl_applyn(int n, value_t f, ...);
/* object model manipulation */
value_t sl_cons(value_t a, value_t b);
value_t sl_list2(value_t a, value_t b);
value_t sl_listn(int n, ...);
bool sl_isnumber(value_t v) sl_purefn;
value_t alloc_vector(size_t n, bool init);
/* consistent iswprint and wcwidth */
int sl_iswprint(Rune c) sl_constfn;
int sl_wcwidth(Rune c) sl_constfn;
/* safe casts */
cons_t *tocons(value_t v) sl_purefn;
symbol_t *tosymbol(value_t v) sl_purefn;
fixnum_t tofixnum(value_t v) sl_purefn;
char *tostring(value_t v) sl_purefn;
double todouble(value_t a) sl_purefn;
/* conses */
value_t mk_cons(void) sl_hotfn;
void *alloc_words(int n) sl_hotfn;
char *uint2str(char *dest, size_t len, uint64_t num, int base);
/* error handling */
typedef struct _sl_readstate_t {
htable_t backrefs;
htable_t gensyms;
value_t source;
struct _sl_readstate_t *prev;
}sl_readstate_t;
typedef struct _ectx_t {
sl_readstate_t *rdst;
struct _ectx_t *prev;
jmp_buf buf;
value_t *sp;
value_t *frame;
int ngchnd;
}sl_exception_context_t;
void free_readstate(sl_readstate_t *rs);
#define sl_TRY_EXTERN \
sl_exception_context_t _ctx; int l__tr, l__ca; \
sl_savestate(&_ctx); 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_EXTERN_NO_RESTORE \
else \
for(l__ca=1; l__ca;)
#define sl_CATCH_EXTERN \
else \
for(l__ca=1; l__ca; l__ca=0, sl_restorestate(&_ctx))
_Noreturn void lerrorf(value_t e, const char *format, ...) sl_printfmt(2, 3);
void sl_savestate(sl_exception_context_t *_ctx);
void sl_restorestate(sl_exception_context_t *_ctx);
_Noreturn void sl_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);
_Noreturn void arity_error(int nargs, int c);
#define argcount(nargs, c) \
do{ \
if(sl_unlikely(nargs != c)) \
arity_error(nargs, c); \
}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 void (*cvinitfunc_t)(sltype_t*, value_t, void*);
struct sltype_t {
value_t type;
cvtable_t *vtable;
sltype_t *eltype; // for arrays
sltype_t *artype; // (array this)
cvinitfunc_t init;
size_t size;
size_t elsz;
numerictype_t numtype;
};
typedef struct {
sltype_t *type;
union {
void *data;
builtin_t cbuiltin;
};
size_t len; // length of *data in bytes
uint8_t _space[]; // variable size
}sl_aligned(8) cvalue_t;
typedef struct {
sltype_t *type;
uint8_t _space[];
}sl_aligned(8) cprim_t;
typedef struct {
value_t vals;
value_t bcode;
value_t env;
value_t name;
}sl_aligned(8) function_t;
#define CPRIM_NWORDS sizeof(cprim_t)/sizeof(value_t)
#define cv_class(cv) ((sltype_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 == SL(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)
// WARNING: multiple evaluation!
#define cptr(v) (iscprim(v) ? cp_data(ptr(v)) : cvalue_data(v))
#define ismpint(v) (iscvalue(v) && cp_numtype(ptr(v)) == T_MPINT)
#define tompint(v) (*(mpint**)cv_data(ptr(v)))
#define BUILTIN(lname, cname) \
value_t fn_builtin_##cname(value_t *args, int nargs)
#define BUILTIN_FN(l, c, attr) attr BUILTIN(l, c);
#include "builtin_fns.h"
#undef BUILTIN_FN
#include "opcodes.h"
enum {
sl_nil = builtin(OP_LOADNIL),
sl_t = builtin(OP_LOADT),
sl_void = builtin(OP_LOADVOID),
sl_eof = builtin(OP_EOF_OBJECT),
};
#define N_GC_HANDLES 1024
typedef struct Sl Sl;
struct Sl {
value_t *sp;
uint8_t *curheap;
value_t *curr_frame;
uint8_t *fromspace;
uint8_t *tospace;
uint8_t *lim;
value_t *stack;
uintptr_t heapsize;//bytes
size_t malloc_pressure;
uint32_t nstack;
cvalue_t **finalizers;
size_t nfinalizers;
size_t maxfinalizers;
sl_readstate_t *readstate;
Tbl *symtab;
// saved execution state for an unwind target
sl_exception_context_t *exctx;
value_t *throwing_frame; // active frame when exception was thrown
value_t lasterror;
sltype_t *tabletype;
sltype_t *iostreamtype;
value_t the_empty_vector;
value_t the_empty_string;
value_t memory_exception_value;
sltype_t *mpinttype;
sltype_t *int8type, *uint8type;
sltype_t *int16type, *uint16type;
sltype_t *int32type, *uint32type;
sltype_t *int64type, *uint64type;
sltype_t *floattype, *doubletype;
sltype_t *bytetype, *runetype;
sltype_t *stringtype, *runestringtype;
sltype_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 loading;
bool exiting;
bool grew;
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;
ssize_t hpos, vpos;
htable_t reverse_dlsym_lookup_table;
htable_t TypeTable;
int ngchandles;
value_t *gchandles[N_GC_HANDLES];
};
extern sl_thread(Sl *sl);
#define SL(f) sl->f
extern value_t sl_builtins_table_sym, sl_quote, sl_lambda, sl_function, sl_comma, sl_commaat;
extern value_t sl_commadot, sl_trycatch, sl_backquote;
extern value_t sl_conssym, sl_symbolsym, sl_fixnumsym, sl_vectorsym, sl_builtinsym, sl_vu8sym;
extern value_t sl_defsym, sl_defmacrosym, sl_forsym, sl_setqsym;
extern value_t sl_booleansym, sl_nullsym, sl_evalsym, sl_fnsym;
extern value_t sl_nulsym, sl_alarmsym, sl_backspacesym, sl_tabsym, sl_linefeedsym, sl_newlinesym;
extern value_t sl_vtabsym, sl_pagesym, sl_returnsym, sl_escsym, sl_spacesym, sl_deletesym;
extern value_t sl_errio, sl_errparse, sl_errtype, sl_errarg, sl_errmem;
extern value_t sl_errdiv0, sl_errbounds, sl_err, sl_errkey, sl_errunbound;
extern value_t sl_printwidthsym, sl_printreadablysym, sl_printprettysym, sl_printlengthsym;
extern value_t sl_printlevelsym;
extern value_t sl_arraysym;
extern value_t sl_iostreamsym, sl_rdsym, sl_wrsym, sl_apsym, sl_crsym, sl_truncsym;
extern value_t sl_instrsym, sl_outstrsym;
extern value_t sl_int8sym, sl_uint8sym, sl_int16sym, sl_uint16sym, sl_int32sym, sl_uint32sym;
extern value_t sl_int64sym, sl_uint64sym, sl_bignumsym;
extern value_t sl_bytesym, sl_runesym, sl_floatsym, sl_doublesym;
extern value_t sl_stringtypesym, sl_runestringtypesym;
_Noreturn void slmain(const uint8_t *boot, int bootsz, int argc, char **argv);