ref: 0cc160518d4d3653064fe3a6cd3dfd476e999f5a
dir: /flisp.h/
#ifndef FLISP_H
#define FLISP_H
/* functions needed to implement the value interface (cvtable_t) */
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;
#define NONNUMERIC (0xff)
#define valid_numtype(v) ((v) <= T_DOUBLE)
typedef uintptr_t value_t;
typedef lltint_t fixnum_t;
#ifdef BITS64
#define T_FIXNUM T_INT64
#define fits_fixnum(x) (((x)>>61) == 0 || (~((x)>>61)) == 0)
#define mk_xlong mk_int64
#else
#define T_FIXNUM T_INT32
#define fits_fixnum(x) (((x)>>29) == 0 || (~((x)>>29)) == 0)
#define mk_xlong mk_long
#endif
typedef struct {
value_t car;
value_t cdr;
}cons_t;
typedef struct _symbol_t {
value_t binding; // global value binding
uint32_t hash;
uint8_t numtype;
uint8_t size;
uint8_t align;
uint8_t flags;
struct _fltype_t *type;
void *dlcache; // dlsym address
// below fields are private
struct _symbol_t *left;
struct _symbol_t *right;
union {
char name[1];
void *_pad; // ensure field aligned to pointer size
};
}symbol_t;
typedef struct {
value_t isconst;
value_t binding; // global value binding
struct _fltype_t *type;
uint32_t id;
}gensym_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,
};
#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)((fixnum_t)(x))<<2)
#define numval(x) (((fixnum_t)(x))>>2)
#define fits_bits(x, b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
#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)
int isbuiltin(value_t x);
#define isvector(x) (tag(x) == TAG_VECTOR)
#define iscvalue(x) (tag(x) == TAG_CVALUE)
#define iscprim(x) (tag(x) == TAG_CPRIM)
#define selfevaluating(x) (tag(x) < 6)
// comparable with ==
#define eq_comparable(a, b) (!(((a)|(b))&1))
#define eq_comparablep(a) (!((a)&1))
// doesn't lead to other values
#define leafp(a) (((a)&3) != 3)
#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)) >= fromspace) && (((uint8_t*)ptr(v)) < fromspace+heapsize))
#define isgensym(x) (issymbol(x) && ismanaged(x))
value_t gensym(void);
#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)) == 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)
extern value_t printprettysym, printreadablysym, printwidthsym, printlengthsym;
extern value_t printlevelsym, builtins_table_sym;
extern value_t QUOTE;
extern value_t FL_NIL, FL_T, FL_F, FL_EOF;
#define FL_UNSPECIFIED FL_T
int num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp);
void fl_gc_handle(value_t *pv);
void fl_free_gc_handles(uint32_t n);
int fl_isnumber(value_t v);
void fl_init(size_t initial_heapsize);
int fl_load_system_image(value_t ios);
/* 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, ...);
value_t symbol(char *str);
char *symbol_name(value_t v);
int fl_is_keyword_name(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);
/* 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;
extern fl_exception_context_t *fl_ctx;
extern uint32_t fl_throwing_frame;
extern value_t fl_lasterror;
#define FL_TRY_EXTERN \
fl_exception_context_t _ctx; int l__tr, l__ca; \
fl_savestate(&_ctx); fl_ctx = &_ctx; \
if(!setjmp(_ctx.buf)) \
for(l__tr=1; l__tr; l__tr=0, (void)(fl_ctx = fl_ctx->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, 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(char *expected, value_t got);
_Noreturn void bounds_error(value_t arr, value_t ind);
_Noreturn void unbound_error(value_t sym);
extern value_t ArgError, IOError, KeyError, MemoryError, EnumerationError;
#define argcount(nargs, c) \
do{ \
if(__unlikely(nargs != c)) \
lerrorf(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;
value_t relocate_lispvalue(value_t v);
typedef int (*cvinitfunc_t)(struct _fltype_t*, value_t, void*);
typedef struct _fltype_t {
value_t type;
cvtable_t *vtable;
struct _fltype_t *eltype; // for arrays
struct _fltype_t *artype; // (array this)
cvinitfunc_t init;
size_t size;
size_t elsz;
int marked;
numerictype_t numtype;
}fltype_t;
typedef struct {
fltype_t *type;
void *data;
size_t len; // length of *data in bytes
union {
value_t parent; // optional
char _space[1]; // variable size
};
}cvalue_t;
#define CVALUE_NWORDS 4
typedef struct {
fltype_t *type;
char _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 MAX_INL_SIZE 384
#define CV_OWNED_BIT 0x1
#define CV_PARENT_BIT 0x2
#define owned(cv) ((uintptr_t)(cv)->type & CV_OWNED_BIT)
#define hasparent(cv) ((uintptr_t)(cv)->type & CV_PARENT_BIT)
#define isinlined(cv) ((cv)->data == &(cv)->_space[0])
#define cv_class(cv) ((fltype_t*)(((uintptr_t)((cvalue_t*)cv)->type)&~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 == 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)cv_data((cvalue_t*)ptr(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)) : cv_data(ptr(v)))
#define BUILTIN(lname, cname) \
value_t fn_builtin_##cname(value_t *args, int nargs)
typedef value_t (*builtin_t)(value_t*, int);
typedef struct {
char *name;
builtin_t fptr;
}builtinspec_t;
//--------------------------------------------------
// Nothing changed here...just grouping by file.
//--------------------------------------------------
//--------------------------------------------------read.c
value_t fl_read_sexpr(value_t f);
int isnumtok_base(char *tok, value_t *pval, int base);
//--------------------------------------------------read.c
//--------------------------------------------------builtins.c
size_t llength(value_t v);
//--------------------------------------------------builtins.c
//--------------------------------------------------equal.c
value_t fl_compare(value_t a, value_t b); // -1, 0, or 1
value_t fl_equal(value_t a, value_t b); // T or nil
int equal_lispvalue(value_t a, value_t b);
uintptr_t hash_lispvalue(value_t a);
//--------------------------------------------------equal.c
//--------------------------------------------------print.c
void fl_print(ios_t *f, value_t v);
void print_traverse(value_t v);
void fl_print_chr(char c, ios_t *f);
void fl_print_str(char *s, ios_t *f);
void fl_print_child(ios_t *f, value_t v);
//--------------------------------------------------print.c
//--------------------------------------------------cvalues.c
extern value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
extern value_t int64sym, uint64sym, mpintsym;
extern value_t longsym, ulongsym, bytesym, wcharsym;
extern value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
extern value_t stringtypesym, wcstringtypesym, emptystringsym;
extern value_t unionsym, floatsym, doublesym;
extern fltype_t *bytetype, *wchartype;
extern fltype_t *stringtype, *wcstringtype;
extern fltype_t *builtintype;
value_t cvalue(fltype_t *type, size_t sz);
void add_finalizer(cvalue_t *cv);
void cv_autorelease(cvalue_t *cv);
void cv_pin(cvalue_t *cv);
size_t ctype_sizeof(value_t type, int *palign);
value_t cvalue_copy(value_t v);
value_t cvalue_from_data(fltype_t *type, void *data, size_t sz);
value_t cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent);
value_t cbuiltin(char *name, builtin_t f);
size_t cvalue_arraylen(value_t v);
value_t size_wrap(size_t sz);
size_t toulong(value_t n);
off_t tooffset(value_t n);
value_t cvalue_string(size_t sz);
value_t cvalue_static_cstring(const char *str);
value_t string_from_cstr(char *str);
value_t string_from_cstrn(char *str, size_t n);
int fl_isstring(value_t v);
value_t cvalue_compare(value_t a, value_t b);
int numeric_compare(value_t a, value_t b, int eq, int eqnans, int typeerr);
void to_sized_ptr(value_t v, char **pdata, size_t *psz);
value_t mk_double(double n);
value_t mk_float(float n);
value_t mk_int32(int32_t n);
value_t mk_uint32(uint32_t n);
value_t mk_int64(int64_t n);
value_t mk_uint64(uint64_t n);
value_t mk_wchar(int32_t n);
value_t return_from_uint64(uint64_t Uaccum);
value_t return_from_int64(int64_t Saccum);
//--------------------------------------------------cvalues.c
//--------------------------------------------------iostream.c
int fl_isiostream(value_t v);
ios_t *fl_toiostream(value_t v);
//--------------------------------------------------iostream.c
//--------------------------------------------------types.c
fltype_t *get_type(value_t t);
fltype_t *get_array_type(value_t eltype);
fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, cvinitfunc_t init);
//--------------------------------------------------types.c
//--------------------------------------------------operators.c
double conv_to_double(void *data, numerictype_t tag);
void conv_from_double(void *data, double d, numerictype_t tag);
mpint *conv_to_mpint(void *data, numerictype_t tag);
int64_t conv_to_int64(void *data, numerictype_t tag);
uint64_t conv_to_uint64(void *data, numerictype_t tag);
int32_t conv_to_int32(void *data, numerictype_t tag);
uint32_t conv_to_uint32(void *data, numerictype_t tag);
#if defined(ULONG64)
#define conv_to_long conv_to_int64
#define conv_to_ulong conv_to_uint64
#else
#define conv_to_long conv_to_int32
#define conv_to_ulong conv_to_uint32
#endif
//--------------------------------------------------operators.c
//--------------------------------------------------------------------------------
// New declarations here.. needed to permit files splitting
// (and grouped by files).
//--------------------------------------------------------------------------------
extern value_t *Stack;
extern uint32_t SP;
extern uint32_t N_STACK;
extern uint32_t curr_frame;
extern char *curr_fname;
#define PUSH(v) \
do{ \
Stack[SP++] = (v); \
}while(0)
#define POP() (Stack[--SP])
#define POPN(n) \
do{ \
SP -= (n); \
}while(0)
extern value_t NIL, LAMBDA, IF, TRYCATCH;
extern value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
extern value_t pairsym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym;
extern value_t definesym, defmacrosym, forsym, setqsym;
extern value_t tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym, fnsym;
extern value_t nulsym, alarmsym, backspacesym, tabsym, linefeedsym, newlinesym;
extern value_t vtabsym, pagesym, returnsym, escsym, spacesym, deletesym;
void *alloc_words(int n);
value_t relocate(value_t v);
extern fl_readstate_t *readstate;
void free_readstate(fl_readstate_t *rs);
extern uint8_t *fromspace;
extern uint32_t heapsize;//bytes
extern uint8_t *tospace;
extern uint8_t *curheap;
extern uint8_t *lim;
extern uint32_t *consflags;
void gc(int mustgrow);
extern value_t IOError, ParseError, TypeError, ArgError, MemoryError;
extern value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
// 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*)fromspace))
#define ismarked(c) bitvector_get(consflags, cons_index(c))
#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
typedef struct Builtin Builtin;
struct Builtin {
char *name;
int nargs;
};
#define ANYARGS -10000
extern value_t the_empty_vector;
value_t mk_cons(void);
#define BUILTIN_FN(l, c) extern BUILTIN(l, c);
#include "builtin_fns.h"
#undef BUILTIN_FN
//--------------------------------------------------cvalues.c
void cvalues_init(void);
value_t fl_idiv2(value_t a, value_t b);
value_t fl_div2(value_t a, value_t b);
value_t fl_mul_any(value_t *args, uint32_t nargs, int64_t Saccum);
value_t fl_neg(value_t n);
value_t fl_add_any(value_t *args, uint32_t nargs, fixnum_t carryIn);
value_t cvalue_array_aset(value_t *args);
value_t cvalue_array_aref(value_t *args);
value_t cvalue_relocate(value_t v);
void sweep_finalizers(void);
extern htable_t TypeTable;
extern htable_t reverse_dlsym_lookup_table;
extern fltype_t *mpinttype;
int cvalue_array_init(fltype_t *ft, value_t arg, void *dest);
int cvalue_enum_init(fltype_t *ft, value_t arg, void *dest);
value_t mk_mpint(mpint *n);
#ifdef BITS64
#define NWORDS(sz) (((sz)+7)>>3)
#else
#define NWORDS(sz) (((sz)+3)>>2)
#endif
int isarray(value_t v);
_Noreturn void DivideByZeroError(void);
//--------------------------------------------------cvalues.c
//--------------------------------------------------read.c
int isnumtok(char *tok, value_t *pval);
// defines which characters are ordinary symbol characters.
// exceptions are '.', which is an ordinary symbol character
// unless it's the only character in the symbol, and '#', which is
// an ordinary symbol character unless it's the first character.
inline int
symchar(char c)
{
//static char *special = "()[]'\";`,\\| \a\b\f\n\r\t\v";
char *special = "()[]'\";`,\\| \a\b\f\n\r\t\v";
return !strchr(special, c);
}
//--------------------------------------------------read.c
//--------------------------------------------------types.c
void relocate_typetable(void);
//--------------------------------------------------types.c
//--------------------------------------------------equal.c
value_t compare_(value_t a, value_t b, int eq);
//--------------------------------------------------equal.c
//--------------------------------------------------print.c
extern htable_t printconses;
extern int SCR_WIDTH;
//--------------------------------------------------print.c
#endif