ref: 64ed7785525654984f16cc4aadd25bd5e3a3331e
dir: /src/sl.h/
#pragma once
#include "platform.h"
#include "utf8.h"
#include "ios.h"
#include "tbl.h"
#include "bitvector.h"
#include "htable_h.h"
HTPROT(ptrhash)
typedef struct sl_type sl_type;
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_S8, T_U8,
T_S16, T_U16,
T_S32, T_U32,
T_S64, T_U64,
T_MP,
T_FLOAT,
T_DOUBLE,
}sl_numtype;
typedef uintptr sl_v;
#if defined(BITS64)
typedef s64int sl_fx;
#define FIXNUM_BITS 62
#define TOP_BIT (1ULL<<63)
#define T_FIXNUM T_S64
#define PRIdFIXNUM PRId64
#else
typedef s32int sl_fx;
#define FIXNUM_BITS 30
#define TOP_BIT (1U<<31)
#define T_FIXNUM T_S32
#define PRIdFIXNUM PRId32
#endif
#if !defined(FWD_BIT)
#define FWD_BIT TOP_BIT
#endif
typedef struct {
sl_v car;
sl_v cdr;
}sl_aligned(8) sl_cons;
// NOTE: sl_sym MUST have the same fields as sl_gensym first
// there are places where gensyms are treated as normal symbols
typedef struct {
u64int hash;
sl_type *type;
sl_v binding; // global value binding
u8int numtype;
u8int size;
u8int flags;
u8int _dummy;
const char *name;
}sl_aligned(8) sl_sym;
typedef struct {
u64int id;
sl_type *type;
sl_v binding;
}sl_aligned(8) sl_gensym;
typedef struct Builtin Builtin;
struct Builtin {
const char *name;
int nargs;
};
typedef sl_v (*builtin_t)(sl_v*, 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 ((sl_v)1) // an invalid value
#define tag(x) ((x) & 7)
#define ptr(x) ((void*)((uintptr)(x) & (~(uintptr)7)))
#define tagptr(p, t) ((sl_v)(p) | (t))
#define fixnum(x) ((sl_v)(x)<<2)
#define numval(x) ((sl_fx)(x)>>2)
#define uintval(x) (((unsigned int)(x))>>3)
#define builtin(n) tagptr(((sl_v)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) (((sl_cons*)ptr(c))-((sl_cons*)slg.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) (*(sl_v*)ptr(v) & FWD_BIT)
#define forwardloc(v) (*(sl_v*)ptr(v) ^ FWD_BIT)
#define forward(v, to) \
do{ \
*(sl_v*)ptr(v) = (sl_v)(to) | FWD_BIT; \
}while(0)
#define vector_size(v) (((usize*)ptr(v))[0]>>2)
#define vector_setsize(v, n) (((usize*)ptr(v))[0] = ((n)<<2))
#define vector_elt(v, i) (((sl_v*)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) (((sl_cons*)ptr(v))->car)
#define cdr_(v) (((sl_cons*)ptr(v))->cdr)
#define car(v) (tocons(v)->car)
#define cdr(v) (tocons(v)->cdr)
#define fn_bcode(f) (((sl_fn*)ptr(f))->bcode)
#define fn_vals(f) (((sl_fn*)ptr(f))->vals)
#define fn_env(f) (((sl_fn*)ptr(f))->env)
#define fn_name(f) (((sl_fn*)ptr(f))->name)
#define set(s, v) (((sl_sym*)ptr(s))->binding = (v))
#define setc(s, v) \
do{ \
sl_sym *sy = (sl_sym*)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) (((sl_sym*)ptr(s))->binding)
#define sym_to_numtype(s) (((sl_sym*)ptr(s))->numtype)
#define ismanaged(v) ((((u8int*)ptr(v)) >= slg.fromspace) && (((u8int*)ptr(v)) < slg.fromspace+slg.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(sl_v x) sl_constfn sl_hotfn;
int sl_init(usize heapsize, usize stacksize);
int sl_load_system_image(sl_v ios);
_Noreturn void sl_exit(int status);
/* collector */
sl_v sl_relocate(sl_v v) sl_hotfn;
void sl_gc(bool mustgrow);
void sl_gc_handle(sl_v *pv);
void sl_free_gc_handles(int n);
/* symbol table */
sl_v gensym(void);
sl_v symbol(const char *str, bool copy) sl_hotfn;
sl_v csymbol_(const char *str, int len);
#define csymbol(str) csymbol_(str, sizeof(str)-1)
const char *symbol_name(sl_v v);
/* read, eval, print main entry points */
sl_v sl_toplevel_eval(sl_v expr);
sl_v sl_apply(sl_v f, sl_v l);
sl_v sl_applyn(int n, sl_v f, ...);
/* object model manipulation */
sl_v mk_cons(sl_v a, sl_v b);
sl_v mk_list2(sl_v a, sl_v b);
sl_v mk_listn(int n, ...);
bool sl_isnumber(sl_v v) sl_purefn;
sl_v alloc_vector(usize n, bool init);
/* consistent iswprint and wcwidth */
int sl_iswprint(Rune c) sl_constfn;
int sl_wcwidth(Rune c) sl_constfn;
/* safe casts */
sl_cons *tocons(sl_v v) sl_purefn;
sl_sym *tosymbol(sl_v v) sl_purefn;
sl_fx tofixnum(sl_v v) sl_purefn;
char *tostring(sl_v v) sl_purefn;
double todouble(sl_v a) sl_purefn;
/* conses */
sl_v alloc_cons(void) sl_hotfn;
void *alloc_words(int n) sl_hotfn;
char *uint2str(char *dest, usize len, u64int num, int base);
/* error handling */
typedef struct _sl_readstate {
sl_htable backrefs;
sl_htable gensyms;
sl_v source;
struct _sl_readstate *prev;
}sl_readstate;
typedef struct _ectx_t {
sl_readstate *rdst;
struct _ectx_t *prev;
jmp_buf buf;
sl_v *sp;
sl_v *frame;
int ngchnd;
}sl_exctx;
void free_readstate(sl_readstate *rs);
#define sl_TRY_EXTERN \
sl_exctx _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(sl_v e, const char *format, ...) sl_printfmt(2, 3);
void sl_savestate(sl_exctx *_ctx);
void sl_restorestate(sl_exctx *_ctx);
_Noreturn void sl_raise(sl_v e);
_Noreturn void type_error(const char *expected, sl_v got);
_Noreturn void bounds_error(sl_v arr, sl_v ind);
_Noreturn void unbound_error(sl_v 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)(sl_v self, sl_ios *f);
void (*relocate)(sl_v oldv, sl_v newv);
void (*finalize)(sl_v self);
void (*print_traverse)(sl_v self);
} sl_cvtable;
typedef void (*cvinitfunc_t)(sl_type*, sl_v, void*);
struct sl_type {
sl_v type;
sl_cvtable *vtable;
sl_type *eltype; // for arrays
sl_type *artype; // (array this)
cvinitfunc_t init;
usize size;
usize elsz;
sl_numtype numtype;
};
typedef struct {
sl_type *type;
union {
void *data;
builtin_t cbuiltin;
};
usize len; // length of *data in bytes
u8int _space[]; // variable size
}sl_aligned(8) csl_v;
typedef struct {
sl_type *type;
u8int _space[];
}sl_aligned(8) sl_cprim;
typedef struct {
sl_v vals;
sl_v bcode;
sl_v env;
sl_v name;
}sl_aligned(8) sl_fn;
#define CPRIM_NWORDS sizeof(sl_cprim)/sizeof(sl_v)
#define cv_class(cv) ((sl_type*)(((uintptr)((csl_v*)cv)->type)&~(uintptr)3))
#define cv_len(cv) (((csl_v*)(cv))->len)
#define cv_type(cv) (cv_class(cv)->type)
#define cv_data(cv) (((csl_v*)(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((csl_v*)ptr(v))
#define cvalue_len(v) cv_len((csl_v*)ptr(v))
#define value2c(type, v) ((type)cvalue_data(v))
#define cp_class(cp) (((sl_cprim*)(cp))->type)
#define cp_type(cp) (cp_class(cp)->type)
#define cp_numtype(cp) (cp_class(cp)->numtype)
#define cp_data(cp) (((sl_cprim*)(cp))->_space)
// WARNING: multiple evaluation!
#define cptr(v) (iscprim(v) ? cp_data(ptr(v)) : cvalue_data(v))
#define ismp(v) (iscvalue(v) && cp_numtype(ptr(v)) == T_MP)
#define tomp(v) (*(mpint**)cv_data(ptr(v)))
#define BUILTIN(lname, cname) \
sl_v fn_builtin_##cname(sl_v *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),
};
enum {
N_GC_HANDLES = 1024,
};
typedef struct Sl Sl;
typedef struct Slg Slg;
struct Sl {
sl_v *sp;
sl_v *curr_frame;
// saved execution state for an unwind target
sl_exctx *exctx;
sl_v *throwing_frame; // active frame when exception was thrown
sl_v lasterror;
sl_readstate *readstate;
u32int *consflags;
sl_v *stack;
u32int nstack;
sl_htable printconses;
u32int printlabel;
int print_pretty;
int print_princ;
sl_fx print_length;
sl_fx print_level;
sl_fx p_level;
int scr_width;
ssize hpos, vpos;
};
struct Slg {
u8int *curheap;
u8int *lim;
usize malloc_pressure;
csl_v **finalizers;
usize nfinalizers;
usize maxfinalizers;
Tbl *symbols;
u32int 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;
int ngchandles;
sl_v *gchandles[N_GC_HANDLES];
usize gccalls;
sl_htable reverse_dlsym_lookup;
sl_htable types;
u8int *fromspace;
u8int *tospace;
uintptr heapsize; // bytes
};
extern sl_thread(Sl *slp);
#define sl (*slp)
extern Slg slg;
extern sl_v sl_builtinssym, sl_quote, sl_lambda, sl_function, sl_comma, sl_commaat;
extern sl_v sl_commadot, sl_trycatch, sl_backquote;
extern sl_v sl_conssym, sl_symbolsym, sl_fixnumsym, sl_vectorsym, sl_builtinsym, sl_vu8sym;
extern sl_v sl_defsym, sl_defmacrosym, sl_forsym, sl_setqsym;
extern sl_v sl_booleansym, sl_nullsym, sl_evalsym, sl_fnsym;
extern sl_v sl_nulsym, sl_alarmsym, sl_backspacesym, sl_tabsym, sl_linefeedsym, sl_newlinesym;
extern sl_v sl_vtabsym, sl_pagesym, sl_returnsym, sl_escsym, sl_spacesym, sl_deletesym;
extern sl_v sl_errio, sl_errparse, sl_errtype, sl_errarg, sl_errmem;
extern sl_v sl_errdiv0, sl_errbounds, sl_err, sl_errkey, sl_errunbound, sl_erroom;
extern sl_v sl_emptyvec, sl_emptystr;
extern sl_v sl_printwidthsym, sl_printreadablysym, sl_printprettysym, sl_printlengthsym;
extern sl_v sl_printlevelsym;
extern sl_v sl_arraysym;
extern sl_v sl_iostreamsym, sl_rdsym, sl_wrsym, sl_apsym, sl_crsym, sl_truncsym;
extern sl_v sl_instrsym, sl_outstrsym;
extern sl_v sl_s8sym, sl_u8sym, sl_s16sym, sl_u16sym, sl_s32sym, sl_u32sym;
extern sl_v sl_s64sym, sl_u64sym, sl_bignumsym;
extern sl_v sl_bytesym, sl_runesym, sl_floatsym, sl_doublesym;
extern sl_v sl_stringtypesym, sl_runestringtypesym;
extern sl_type *sl_mptype, *sl_builtintype;
extern sl_type *sl_s8type, *sl_u8type;
extern sl_type *sl_s16type, *sl_u16type;
extern sl_type *sl_s32type, *sl_u32type;
extern sl_type *sl_s64type, *sl_u64type;
extern sl_type *sl_floattype, *sl_doubletype;
extern sl_type *sl_bytetype, *sl_runetype;
extern sl_type *sl_stringtype, *sl_runestringtype;
_Noreturn void slmain(const u8int *boot, int bootsz, int argc, char **argv);