glisp/src/base.h

#ifndef INCLUDED_TYPES_H
#define INCLUDED_TYPES_H

#include "argcountmacro.h"
#include "gc.h"
#include "memory.h"

#include <assert.h>
#include <stdnoreturn.h>

// ###################
// # Base value type #
// ###################
typedef void LispVal;

// ##########################
// # Fixnum and float stuff #
// ##########################
typedef intptr_t fixnum_t;
#if LISP_WORD_BITS == 32
#    define LISP_FLOAT_SCANF "f"
typedef lisp_float32_t lisp_float_t;
#else
#    define LISP_FLOAT_SCANF "lf"
typedef lisp_float64_t lisp_float_t;
#endif

#define MOST_POSITIVE_FIXNUM ((intptr_t) ((INTPTR_MAX & ~(intptr_t) 3) >> 2))
#define MOST_NEGATIVE_FIXNUM ((intptr_t) ((INTPTR_MIN & ~(intptr_t) 3) >> 2))

static ALWAYS_INLINE uintptr_t EXTRACT_TAG(LispVal *val) {
    uintptr_t iv = (uintptr_t) val;
    return iv & (uintptr_t) 3;
}

#define LISP_TAG_BITS   2
#define LISP_OBJECT_TAG ((uintptr_t) 0)
// 0b01
#define FIXNUM_TAG ((uintptr_t) 1)
// 0b10
#define LISP_FLOAT_TAG ((uintptr_t) 2)

static ALWAYS_INLINE bool LISP_OBJECT_P(LispVal *val) {
    return EXTRACT_TAG(val) == LISP_OBJECT_TAG;
}

static ALWAYS_INLINE bool FIXNUMP(LispVal *val) {
    return EXTRACT_TAG(val) == FIXNUM_TAG;
}

static ALWAYS_INLINE fixnum_t XFIXNUM(LispVal *val) {
    assert(FIXNUMP(val));
    return ((fixnum_t) val) >> 2;
}

static ALWAYS_INLINE LispVal *MAKE_FIXNUM(fixnum_t fn) {
    return (LispVal *) ((((uintptr_t) fn) << 2) | FIXNUM_TAG);
}

static ALWAYS_INLINE bool LISP_FLOAT_P(LispVal *val) {
    return EXTRACT_TAG(val) == LISP_FLOAT_TAG;
}

static ALWAYS_INLINE lisp_float_t XLISP_FLOAT(LispVal *val) {
    assert(LISP_FLOAT_P(val));
    uintptr_t iv = (uintptr_t) val;
    iv &= ~(uintptr_t) 3;
    return INT_TO_FLOAT_BITS(iv);
}

static ALWAYS_INLINE LispVal *MAKE_LISP_FLOAT(lisp_float_t flt) {
    uintptr_t bits = FLOAT_TO_INT_BITS(flt);
    return (LispVal *) ((bits & ~(uintptr_t) 3) | LISP_FLOAT_TAG);
}

// ###############
// # Other types #
// ###############
typedef enum {
    TYPE_FIXNUM = 0,
    TYPE_FLOAT = 1,
    TYPE_CONS = 2,
    TYPE_STRING = 3,
    TYPE_SYMBOL = 4,
    TYPE_VECTOR = 5,
    TYPE_HASH_TABLE = 6,
    TYPE_FUNCTION = 7,
    N_LISP_TYPES,
} LispValType;
extern const char *LISP_TYPE_NAMES[N_LISP_TYPES];

typedef struct {
    LispValType type;
    ObjectGCInfo gc;
} LispObject;

extern bool lisp_gc_on_alloc;

#define LISP_OBJECT_ALIGNMENT (1 << LISP_TAG_BITS)
LispVal *lisp_alloc_object_no_gc(size_t size, LispValType type);
LispVal *lisp_alloc_object(size_t size, LispValType type);
void lisp_release_object(LispVal *val);

static ALWAYS_INLINE bool OBJECTP(LispVal *val) {
    return EXTRACT_TAG(val) == LISP_OBJECT_TAG;
}

static ALWAYS_INLINE ObjectGCSet OBJECT_GET_GC_SET(LispVal *val) {
    assert(OBJECTP(val));
    return ((LispObject *) val)->gc.set;
}

static ALWAYS_INLINE bool OBJECT_GC_SET_P(LispVal *val, ObjectGCSet set) {
    return OBJECT_GET_GC_SET(val) == set;
}

static ALWAYS_INLINE bool OBJECT_STATIC_P(LispVal *val) {
    assert(OBJECTP(val));
    return ((LispObject *) val)->gc.is_static;
}

static inline void MARK_OBJECT_ADDED(LispVal *val, LispVal *into) {
    if (OBJECTP(val) && OBJECTP(into) && OBJECT_GC_SET_P(into, GC_BLACK)
        && OBJECT_GC_SET_P(val, GC_WHITE)) {
        gc_move_to_set(val, GC_GREY);
    }
}

static ALWAYS_INLINE LispValType TYPE_OF(LispVal *val) {
    if (FIXNUMP(val)) {
        return TYPE_FIXNUM;
    } else if (LISP_FLOAT_P(val)) {
        return TYPE_FLOAT;
    } else {
        return ((LispObject *) val)->type;
    }
}

static ALWAYS_INLINE bool LISP_TYPEP(LispVal *val, LispValType type) {
    if (FIXNUMP(val)) {
        return type == TYPE_FIXNUM;
    } else if (LISP_FLOAT_P(val)) {
        return type == TYPE_FLOAT;
    } else {
        return ((LispObject *) val)->type == type;
    }
}

noreturn void
internal_CHECK_TYPE_signal_type_error(LispVal *obj, size_t count,
                                      const LispValType types[count]);
static ALWAYS_INLINE void internal_CHECK_TYPE(LispVal *obj, size_t count,
                                              LispValType v1, LispValType v2,
                                              LispValType v3, LispValType v4,
                                              LispValType v5, LispValType v6) {
    const LispValType types[] = {v1, v2, v3, v4, v5, v6};
    for (size_t i = 0; i < count; ++i) {
        if (LISP_TYPEP(obj, types[i])) {
            return;
        }
    }
    // Failed
    internal_CHECK_TYPE_signal_type_error(obj, count, types);
}
#define internal_CHECK_TYPE_SUB(obj, count, a1, a2, a3, a4, a5, a6, ...) \
    internal_CHECK_TYPE((obj), count, a1, a2, a3, a4, a5, a6)
#define CHECK_TYPE(obj, ...)                                             \
    internal_CHECK_TYPE_SUB((obj), COUNT_ARGS(__VA_ARGS__), __VA_ARGS__, \
                            TYPE_FIXNUM, TYPE_FIXNUM, TYPE_FIXNUM,       \
                            TYPE_FIXNUM, TYPE_FIXNUM, TYPE_FIXNUM)

noreturn void signal_type_error(LispVal *obj, LispVal *typespec);

#define DEFOBJTYPE(Name, NAME, NAME_P, body)         \
    typedef struct {                                 \
        LispObject header;                           \
        struct body;                                 \
    } Lisp##Name;                                    \
    static ALWAYS_INLINE bool NAME_P(LispVal *val) { \
        return LISP_TYPEP(val, TYPE_##NAME);         \
    }                                                \
    struct __ignored

DEFOBJTYPE(String, STRING, STRINGP, {
    size_t length;
    char *data;
    bool owned;
});

enum SymbolValueType {
    SYMBOL_NORMAL,
    SYMBOL_NATIVE,
};

enum SymbolFlags {
    SYMBOL_DYNAMIC = 1,
    SYMBOL_CONST_VALUE = 2,
    SYMBOL_CONST_FUNCTION = 4,
};

DEFOBJTYPE(Symbol, SYMBOL, SYMBOLP, {
    LispVal *name; // string
    enum SymbolValueType value_type : 1;
    enum SymbolFlags flags : 7;
    LispVal *function;
    union {
        LispVal *normal;
        LispVal **native;
    } value;
    LispVal *plist;
});

static ALWAYS_INLINE bool KEYWORDP(LispVal *val) {
    if (!SYMBOLP(val)) {
        return false;
    }
    LispString *sym = (LispString *) ((LispSymbol *) val)->name;
    return sym->length && *sym->data == ':';
}

DEFOBJTYPE(Vector, VECTOR, VECTORP, {
    size_t length;
    LispVal **data;
});

// Defined here instead of in function.h so that headers don't have to include
// it just to define functions
#define DECLARE_SYMBOL(cname)                         \
    extern const char *internal_Q##cname##_name;      \
    extern const size_t internal_Q##cname##_name_len; \
    extern LispVal *Q##cname

#define DECLARE_VARIABLE(cname)                     \
    DECLARE_SYMBOL(cname);                          \
    extern LispVal *internal_V##cname##_init(void); \
    extern LispVal *V##cname

#define DECLARE_FUNCTION(cname, cargs)                  \
    DECLARE_SYMBOL(cname);                              \
    extern const char *internal_F##cname##_argstr;      \
    extern const size_t internal_F##cname##_argstr_len; \
    extern const char *internal_F##cname##_docstr;      \
    extern const size_t internal_F##cname##_docstr_len; \
    LispVal *F##cname cargs

#define DEFINE_SYMBOL(cname, lisp_name)                                \
    const char *internal_Q##cname##_name = lisp_name;                  \
    const size_t internal_Q##cname##_name_len = sizeof(lisp_name) - 1; \
    LispVal *Q##cname

#define DEFVAR(cname, lisp_name, doc, init_val) \
    DEFINE_SYMBOL(cname, lisp_name);            \
    LispVal *internal_V##cname##_init(void) {   \
        return (init_val);                      \
    }                                           \
    LispVal *V##cname

#define DEFUN(cname, lisp_name, cargs, lisp_args, doc)                   \
    DEFINE_SYMBOL(cname, lisp_name);                                     \
    const char *internal_F##cname##_argstr = lisp_args;                  \
    const size_t internal_F##cname##_argstr_len = sizeof(lisp_args) - 1; \
    const char *internal_F##cname##_docstr = doc;                        \
    const size_t internal_F##cname##_docstr_len = sizeof(doc) - 1;       \
    LispVal *Q##cname;                                                   \
    LispVal *F##cname cargs
#define DEFSPECIAL(cname, lisp_name, cargs, lisp_args, doc) \
    DEFUN(cname, lisp_name, cargs, lisp_args, doc)

#define REGISTER_GLOBAL_SYMBOL(cname)                                     \
    {                                                                     \
        Q##cname = Fintern(make_lisp_string(internal_Q##cname##_name,     \
                                            internal_Q##cname##_name_len, \
                                            false, false));               \
        ((LispSymbol *) Q##cname)->value_type = SYMBOL_NORMAL;            \
        lisp_gc_register_static_object(Q##cname);                         \
    }
#define REGISTER_GLOBAL_VARIABLE(cname)                        \
    REGISTER_GLOBAL_SYMBOL(cname);                             \
    {                                                          \
        V##cname = internal_V##cname##_init();                 \
        ((LispSymbol *) Q##cname)->value_type = SYMBOL_NATIVE; \
        ((LispSymbol *) Q##cname)->value.native = &V##cname;   \
        ((LispSymbol *) Q##cname)->flags |= SYMBOL_DYNAMIC;    \
    }
#define REGISTER_GLOBAL_FUNCTION(cname)                                    \
    {                                                                      \
        REGISTER_GLOBAL_SYMBOL(cname);                                     \
        ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \
    }

#define REGISTER_GLOBAL_SPECIAL(cname)                                     \
    {                                                                      \
        REGISTER_GLOBAL_SYMBOL(cname);                                     \
        ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \
        ((LispFunction *) ((LispSymbol *) Q##cname)->function)             \
            ->impl.native.no_eval_args = true;                             \
    }

DECLARE_SYMBOL(nil);
DECLARE_SYMBOL(t);
DECLARE_SYMBOL(unbound);
DECLARE_VARIABLE(lexical_environment);

extern LispVal *Vlexical_environment;

static ALWAYS_INLINE bool NILP(LispVal *val) {
    return val == Qnil;
}

static ALWAYS_INLINE bool EQ(LispVal *val1, LispVal *val2) {
    return val1 == val2;
}

// Some core functions
DECLARE_FUNCTION(id, (LispVal * obj));
DECLARE_FUNCTION(eq, (LispVal * obj1, LispVal *obj2));
DECLARE_FUNCTION(quote, (LispVal * form));

// TODO probably move these to another file
LispVal *make_vector(LispVal **data, size_t length, bool take);
DECLARE_FUNCTION(make_symbol, (LispVal * name));
DECLARE_FUNCTION(intern, (LispVal * name));
DECLARE_FUNCTION(symbol_value, (LispVal * sym));
DECLARE_FUNCTION(symbol_function, (LispVal * sym, LispVal *resolve));
DECLARE_FUNCTION(symbol_plist, (LispVal * sym));
DECLARE_FUNCTION(set, (LispVal * sym, LispVal *value));
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *value));
DECLARE_FUNCTION(setplist, (LispVal * sym, LispVal *plist));
DECLARE_FUNCTION(get, (LispVal * sym, LispVal *key, LispVal *def));
DECLARE_FUNCTION(put, (LispVal * sym, LispVal *key, LispVal *val));

static ALWAYS_INLINE LispVal *SYMBOL_VALUE(LispVal *sym) {
    assert(SYMBOLP(sym));
    LispSymbol *s = (LispSymbol *) sym;
    switch (s->value_type) {
    case SYMBOL_NORMAL:
        return s->value.normal;
    case SYMBOL_NATIVE:
        return *s->value.native;
    }
}

static ALWAYS_INLINE bool CONST_VALUE_P(LispVal *sym) {
    assert(SYMBOLP(sym));
    return ((LispSymbol *) sym)->flags & SYMBOL_CONST_VALUE;
}

static ALWAYS_INLINE bool CONST_FUNCTION_P(LispVal *sym) {
    assert(SYMBOLP(sym));
    return ((LispSymbol *) sym)->flags & SYMBOL_CONST_FUNCTION;
}

static ALWAYS_INLINE bool DYNAMIC_SYMBOL_P(LispVal *sym) {
    assert(SYMBOLP(sym));
    return ((LispSymbol *) sym)->flags & SYMBOL_DYNAMIC;
}

static ALWAYS_INLINE void SET_SYMBOL_VALUE(LispVal *sym, LispVal *value) {
    assert(SYMBOLP(sym));
    LispSymbol *s = (LispSymbol *) sym;
    if (CONST_VALUE_P(sym)) {
        // TODO throw
        abort();
    }
    switch (s->value_type) {
    case SYMBOL_NORMAL:
        s->value.normal = value;
        break;
    case SYMBOL_NATIVE:
        *s->value.native = value;
        break;
    }
}

// condition stuff
DECLARE_SYMBOL(condition_class);
DECLARE_FUNCTION(condition_class_p, (LispVal * val));
DECLARE_FUNCTION(condition_subclass_p, (LispVal * child, LispVal *parent));

// Defined in lisp code (eventually) but used in read.c
DECLARE_SYMBOL(backquote);
DECLARE_SYMBOL(comma);
DECLARE_SYMBOL(comma_at);

#endif