upscheme/c/flisp.h

typedef uintptr_t value_t;
typedef uintptr_t ufixnum_t;
typedef intptr_t fixnum_t;
#ifdef BITS64
#define T_FIXNUM T_INT64
#else
#define T_FIXNUM T_INT32
#endif

struct cons {
    value_t car;
    value_t cdr;
};

struct symbol {
    uintptr_t flags;
    value_t binding;  // global value binding
    struct fltype *type;
    uint32_t hash;
    void *dlcache;  // dlsym address
    // below fields are private
    struct symbol *left;
    struct symbol *right;
    union {
        char name[1];
        void *_pad;  // ensure field aligned to pointer size
    };
};

struct gensym {
    value_t isconst;
    value_t binding;  // global value binding
    struct fltype *type;
    uint32_t id;
};

#define TAG_NUM 0x0
#define TAG_CPRIM 0x1
#define TAG_FUNCTION 0x2
#define TAG_VECTOR 0x3
#define TAG_NUM1 0x4
#define TAG_CVALUE 0x5
#define TAG_SYM 0x6
#define TAG_CONS 0x7
#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)(((ufixnum_t)(fixnum_t)(x)) << 2))
#define numval(x) (((fixnum_t)(x)) >> 2)
#ifdef BITS64
#define fits_fixnum(x) (((x) >> 61) == 0 || (~((x) >> 61)) == 0)
#else
#define fits_fixnum(x) (((x) >> 29) == 0 || (~((x) >> 29)) == 0)
#endif
#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)
#define isbuiltin(x) ((tag(x) == TAG_FUNCTION) && uintval(x) <= OP_ASET)
#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) (((struct cons *)ptr(v))->car)
#define cdr_(v) (((struct cons *)ptr(v))->cdr)
#define car(v) (tocons((v), "car")->car)
#define cdr(v) (tocons((v), "cdr")->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) (((struct symbol *)ptr(s))->binding = (v))
#define setc(s, v)                                \
    do {                                          \
        ((struct symbol *)ptr(s))->flags |= 1;    \
        ((struct symbol *)ptr(s))->binding = (v); \
    } while (0)
#define isconstant(s) ((s)->flags & 0x1)
#define iskeyword(s) ((s)->flags & 0x2)
#define symbol_value(s) (((struct symbol *)ptr(s))->binding)
#define ismanaged(v)                             \
    ((((unsigned char *)ptr(v)) >= fromspace) && \
     (((unsigned char *)ptr(v)) < fromspace + 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((struct cvalue *)ptr(x)) == builtintype))

void fl_gc_handle(value_t *pv);
void fl_free_gc_handles(uint32_t n);

// 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; ((size_t)i) < nargs && ((arg = args[i]) || 1); i++)

#define N_BUILTINS ((int)N_OPCODES)

extern value_t FL_NIL, FL_T, FL_F, FL_EOF;

#define FL_UNSPECIFIED FL_T

/* read, eval, print main entry points */
value_t fl_read_sexpr(value_t f);
void fl_print(struct ios *f, value_t v);
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, ...);

extern value_t printprettysym, printreadablysym, printwidthsym;

/* 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);
size_t llength(value_t v);
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);
int isnumtok_base(char *tok, value_t *pval, int base);

/* safe casts */
struct cons *tocons(value_t v, char *fname);
struct symbol *tosymbol(value_t v, char *fname);
fixnum_t tofixnum(value_t v, char *fname);
char *tostring(value_t v, char *fname);

/* error handling */
struct fl_readstate {
    struct htable backrefs;
    struct htable gensyms;
    value_t source;
    struct fl_readstate *prev;
};

struct fl_exception_context {
    jmp_buf buf;
    uint32_t sp;
    uint32_t frame;
    uint32_t ngchnd;
    struct fl_readstate *rdst;
    struct fl_exception_context *prev;
};

extern struct fl_exception_context *fl_ctx;
extern uint32_t fl_throwing_frame;
extern value_t fl_lasterror;

#define FL_TRY_EXTERN                 \
    struct fl_exception_context _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 \
    else for (l__ca = 1; l__ca; l__ca = 0, fl_restorestate(&_ctx))

void lerrorf(value_t e, char *format, ...) __attribute__((__noreturn__));
void lerror(value_t e, const char *msg) __attribute__((__noreturn__));
void fl_savestate(struct fl_exception_context *_ctx);
void fl_restorestate(struct fl_exception_context *_ctx);
void fl_raise(value_t e) __attribute__((__noreturn__));
void type_error(char *fname, char *expected, value_t got)
__attribute__((__noreturn__));
void bounds_error(char *fname, value_t arr, value_t ind)
__attribute__((__noreturn__));
extern value_t ArgError, IOError, KeyError, MemoryError, EnumerationError;
extern value_t UnboundError;

struct cvtable {
    void (*print)(value_t self, struct ios *f);
    void (*relocate)(value_t oldv, value_t newv);
    void (*finalize)(value_t self);
    void (*print_traverse)(value_t self);
};

/* functions needed to implement the value interface (struct cvtable) */
typedef enum {
    T_INT8,
    T_UINT8,
    T_INT16,
    T_UINT16,
    T_INT32,
    T_UINT32,
    T_INT64,
    T_UINT64,
    T_FLOAT,
    T_DOUBLE
} numerictype_t;

#define N_NUMTYPES ((int)T_DOUBLE + 1)

#ifdef BITS64
#define T_LONG T_INT64
#define T_ULONG T_UINT64
#else
#define T_LONG T_INT32
#define T_ULONG T_UINT32
#endif

value_t relocate_lispvalue(value_t v);
void print_traverse(value_t v);
void fl_print_chr(char c, struct ios *f);
void fl_print_str(char *s, struct ios *f);
void fl_print_child(struct ios *f, value_t v);

typedef int (*cvinitfunc_t)(struct fltype *, value_t, void *);

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

struct cvalue {
    struct fltype *type;
    void *data;
    size_t len;  // length of *data in bytes
    union {
        value_t parent;  // optional
        char _space[1];  // variable size
    };
};

#define CVALUE_NWORDS 4

struct cprim {
    struct fltype *type;
    char _space[1];
};

struct function {
    value_t bcode;
    value_t vals;
    value_t env;
    value_t name;
};

#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) ((struct fltype *)(((uintptr_t)(cv)->type) & ~3))
#define cv_len(cv) ((cv)->len)
#define cv_type(cv) (cv_class(cv)->type)
#define cv_data(cv) ((cv)->data)
#define cv_isstr(cv) (cv_class(cv)->eltype == bytetype)
#define cv_isPOD(cv) (cv_class(cv)->init != NULL)

#define cvalue_data(v) cv_data((struct cvalue *)ptr(v))
#define cvalue_len(v) cv_len((struct cvalue *)ptr(v))
#define value2c(type, v) ((type)cv_data((struct cvalue *)ptr(v)))

#define valid_numtype(v) ((v) < N_NUMTYPES)
#define cp_class(cp) ((cp)->type)
#define cp_type(cp) (cp_class(cp)->type)
#define cp_numtype(cp) (cp_class(cp)->numtype)
#define cp_data(cp) (&(cp)->_space[0])

// WARNING: multiple evaluation!
#define cptr(v)                                   \
    (iscprim(v) ? cp_data((struct cprim *)ptr(v)) \
                : cv_data((struct cvalue *)ptr(v)))

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

extern value_t QUOTE;
extern value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
extern value_t int64sym, uint64sym;
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 struct fltype *bytetype, *wchartype;
extern struct fltype *stringtype, *wcstringtype;
extern struct fltype *builtintype;

value_t cvalue(struct fltype *type, size_t sz);
void add_finalizer(struct cvalue *cv);
void cv_autorelease(struct cvalue *cv);
void cv_pin(struct cvalue *cv);
size_t ctype_sizeof(value_t type, int *palign);
value_t cvalue_copy(value_t v);
value_t cvalue_from_data(struct fltype *type, void *data, size_t sz);
value_t cvalue_from_ref(struct fltype *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, char *fname);
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);
int fl_isnumber(value_t v);
int fl_isgensym(value_t v);
int fl_isiostream(value_t v);
struct ios *fl_toiostream(value_t v, char *fname);
value_t cvalue_compare(value_t a, value_t b);
int numeric_compare(value_t a, value_t b, int eq, int eqnans, char *fname);

void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz);

struct fltype *get_type(value_t t);
struct fltype *get_array_type(value_t eltype);
struct fltype *define_opaque_type(value_t sym, size_t sz,
                                  struct cvtable *vtab, cvinitfunc_t init);

value_t mk_double(double n);
value_t mk_float(float n);
value_t mk_uint32(uint32_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);

numerictype_t effective_numerictype(double r);
double conv_to_double(void *data, numerictype_t tag);
void conv_from_double(void *data, double d, 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);
#ifdef BITS64
#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

struct builtinspec {
    char *name;
    builtin_t fptr;
};

void assign_global_builtins(struct builtinspec *b);

/* builtins */
value_t fl_hash(value_t *args, uint32_t nargs);
value_t cvalue_byte(value_t *args, uint32_t nargs);
value_t cvalue_wchar(value_t *args, uint32_t nargs);

void fl_init(size_t initial_heapsize);
int fl_load_system_image(value_t ios);