diff --git a/src/kernel.sl b/src/kernel.sl index 2690c5d..d5bd362 100644 --- a/src/kernel.sl +++ b/src/kernel.sl @@ -149,6 +149,9 @@ (defun identity (e) e) +(defun complement (fn) + (lambda (&rest args) (not (apply fn args)))) + (defun append (&rest lists) ;; another implementation ;; (mapconcat 'identity lists) @@ -249,10 +252,6 @@ (throw 'type-error)) (apply pred obj args))) -(defun callablep (obj) - (or (functionp obj) - (and (pairp obj) (eq (head obj) 'lambda)))) - (define-type-predicate any (obj) t) (define-type-predicate t alias any) (define-type-predicate or (obj &rest preds) @@ -290,10 +289,19 @@ (define-type-predicate callable callablep) (define-type-predicate hash-table hash-table-p) (define-type-predicate user-pointer user-pointer-p) +(define-type-predicate record recordp) +(define-type-predicate native-record (obj &opt backing-type) + (and (recordp obj) + (record-native-p obj) + (or (not backing-type) + (typep (record-native-backing obj) backing-type)))) (define-type-predicate number (obj &opt min max) (typep obj (list 'or (list 'float min max) (list 'integer min max)))) -(define-type-predicate readable alias (or number vector pair symbol string)) +(define-type-predicate callable-record alias (and record callable)) + +(defun callable-record-p (obj) + (typep obj 'callable-record)) (defun readablep (obj) (typep obj 'readable)) @@ -419,6 +427,7 @@ (list (list-length seq)) ((or vector string) (vector-length seq)) (hash-table (hash-table-count seq)) + (record (record-length seq)) (t (throw 'type-error)))) (fset 'copy-vector 'subvector) @@ -426,6 +435,12 @@ (defun zerop (n) (= n 0)) +(defun plusp (n) + (> n 0)) + +(defun minusp (n) + (< n 0)) + (defun nth (n list) (unless (integerp n) (throw 'type-error '(integerp) n)) @@ -495,4 +510,163 @@ (list (list 'set-symbol-value-docstr (list '\' name) doc))))) -(set-symbol-value-docstr :a "d") +;; Object stuff +(defun symbol-class (symbol) + (unless (symbolp symbol) + (throw 'type-error '(symbolp) symbol)) + (get symbol 'class)) + +(defun set-symbol-class (symbol class) + (unless (symbolp symbol) + (throw 'type-error '(symbolp) symbol)) + (put symbol 'class class)) + +(defun classp (obj) + (or (eq (type-of obj) 'class))) +(define-type-predicate class classp) + +(defun %default-slot-value (class obj slot) + (let* ((slots (record-slot class 3)) + (unbound ::unbound) + (res (gethash slots slot unbound))) + (when (eq res unbound) + (throw 'slot-error slot)) + (record-slot obj res))) + +(defun %default-set-slot-value (class obj slot value) + (let* ((slots (record-slot class 3)) + (unbound ::unbound) + (res (gethash slots slot unbound))) + (when (eq res unbound) + (throw 'slot-error slot)) + (set-record-slot obj res value))) + +(defun %default-lookup-method (class method) + (let* ((methods (record-slot class 4)) + (unbound ::unbound) + (res (gethash methods method unbound))) + (unless (eq res unbound) + res))) + +(defun %default-define-method (class method function) + (let* ((methods (record-slot class 4))) + (puthash methods method function))) + +(defun %construct-class (class name superclass &rest slots) + nil) + +;; Objects are records that have a class object as their first slot +;; Classes are records with their type set to 'class. The slots are +;; - class (class) +;; - name (symbol) +;; - superclass (class) +;; - slots (hash-table[symbol->integer]) +;; - methods (hash-table[symbol->function]) +;; +;; Special methods: +;; - (@construct obj &rest args) +;; Called when a new instance of this class is created. The newly allocated +;; object is passed to OBJ and the arguments to 'make-instance are passed to +;; ARGS. +;; - (@print obj stream) +;; Called to write OBJ out to STREAM. +(set-symbol-class 'class (make-record 'class 3)) +(let ((class (symbol-class 'standard-class)) + (slots (make-hash-table)) + (methods (make-hash-table))) + (set-record-slot class 0 class) + (set-record-slot class 1 'class) + (set-record-slot class 2 class) + (set-record-slot class 3 slots) + (set-record-slot class 4 methods) + + (puthash slots 'name 1) + (puthash slots 'superclass 2) + (puthash slots 'slots 3) + (puthash slots 'methods 4) + + (puthash methods '@construct '%construct-class) + (puthash methods '@slot-value '%default-slot-value) + (puthash methods '@set-slot-value '%default-set-slot-value) + (puthash methods '@lookup-method '%default-lookup-method) + (puthash methods '@define-method '%default-define-method)) + +(defun objectp (obj) + "Return non-nil if OBJ is an object." + (and (recordp obj) + (plusp (length obj)) + (classp (record-slot obj 0)))) +(define-type-predicate object objectp) + +(defun object-class (obj) + "Return the class of OBJ." + (unless (objectp obj) + (throw 'type-error '(objectp) obj)) + (record-slot obj 0)) + +(defun methodp (obj) + "Return non-nil if OBJ is a method object." + (if (symbolp obj) + (methodp (symbol-function obj t)) + (and (eq (type-of obj) 'method) + (= (length obj) 1) + (callable-record-p obj)))) +(define-type-predicate method methodp) + +;; Methods are callable records of length 1. The first slot is a hash table +;; mapping extra types to functions. +(defun make-method () + "Return a new empty method object." + (let ((record (make-record 'method 1)) + (extra-types (make-hash-table))) + (flet ((call-default (obj &rest args) + (let* ((unbound ::unbound) + (res (gethash extra-types t unbound))) + (when (eq res unbound) + (throw 'no-applicable-method-error obj)) + (apply res obj args)))) + (set-record-function + record + (lambda (obj &rest args) + (if (objectp obj) + (let ((method ())))) + (cond + ((and (objectp obj))))))) + (set-record-slot record 0 extra-types) + record)) + +(defun %class-max-slot-index (class) + "Return the highest slot index of CLASS." + (let ((max 0)) + (foreach (lambda (key val) + (when (> val max) + (setq max val))) + (record-slot class 2)) + max)) + +(defun make-instance (class &rest args) + (tcase class + (symbol (setq class (symbol-class class))) + ((not class) (throw 'type-error '(classp) class))) + (let ((constructor (gethash (record-slot class 3) '@construct)) + (object (make-record (record-slot class + (%class-max-slot-index class))))) + (when (functionp constructor) + (apply constructor object args)) + object)) + +(defmacro defclass (name &rest rest) + (unless (symbolp name) + (throw 'type-error '(symbolp) name)) + (let (doc) + (when (stringp (head rest)) + (setq doc (head rest) + rest (head rest))) + ())) + +(println (make-instance ())) + +(println (symbol-class 'standard-class)) +(doindex (i (symbol-class 'standard-class)) + (print "- ") + (println (record-slot (symbol-class 'standard-class) i))) diff --git a/src/lisp.c b/src/lisp.c index 3de88c2..75379c6 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -15,18 +15,7 @@ // used to fix up some indentation or syntax highlighting problems #define IGNORE() struct __ignored_struct -struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = { - [TYPE_STRING] = {"string", sizeof("string") - 1}, - [TYPE_SYMBOL] = {"symbol", sizeof("symbol") - 1}, - [TYPE_PAIR] = {"pair", sizeof("pair") - 1}, - [TYPE_INTEGER] = {"integer", sizeof("integer") - 1}, - [TYPE_FLOAT] = {"float", sizeof("float") - 1}, - [TYPE_VECTOR] = {"vector", sizeof("vector") - 1}, - [TYPE_FUNCTION] = {"function", sizeof("function") - 1}, - [TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1}, - [TYPE_USER_POINTER] = {"user-pointer", sizeof("user-pointer") - 1}, - [TYPE_PACKAGE] = {"package", sizeof("package") - 1}, -}; +LispVal *LISP_TYPE_SYMS[N_LISP_TYPES] = {NULL}; // ####################### // # nil, unbound, and t # @@ -87,6 +76,15 @@ DEF_STATIC_SYMBOL(rest, "&rest"); DEF_STATIC_SYMBOL(declare, "declare"); DEF_STATIC_SYMBOL(name, "name"); +DEF_STATIC_SYMBOL(symbol, "symbol"); +DEF_STATIC_SYMBOL(integer, "integer"); +DEF_STATIC_SYMBOL(float, "float"); +DEF_STATIC_SYMBOL(function, "function"); +DEF_STATIC_SYMBOL(hash_table, "hash_table"); +DEF_STATIC_SYMBOL(user_pointer, "user_pointer"); +DEF_STATIC_SYMBOL(package, "package"); +DEF_STATIC_SYMBOL(record, "record"); + // ############################ // # Global Package Variables # // ############################ @@ -196,6 +194,14 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) { *held = refcount_list_push(*held, pkg->exported_sym_table); return true; } + case TYPE_RECORD: { + LispRecord *rec = obj; + *held = refcount_list_push(*held, rec->record_type); + for (size_t i = 0; i < rec->length; ++i) { + *held = refcount_list_push(*held, rec->data[i]); + } + return true; + } default: abort(); } @@ -231,6 +237,7 @@ static void free_obj_callback(void *obj, void *ignored) { case TYPE_INTEGER: case TYPE_FLOAT: case TYPE_PACKAGE: + case TYPE_RECORD: // no internal data to free break; default: @@ -408,6 +415,18 @@ LispVal *make_lisp_package(LispVal *name) { return LISPVAL(self); } +LispVal *make_lisp_record(LispVal *type, size_t length) { + CONSTRUCT_OBJECT(self, LispRecord, TYPE_RECORD); + self->record_type = refcount_ref(type); + self->function = Qnil; + self->data = lisp_malloc(sizeof(LispVal *) * length); + for (size_t i = 0; i < length; ++i) { + self->data[i] = Qnil; + } + self->length = length; + return LISPVAL(self); +} + LispVal *predicate_for_type(LispType type) { switch (type) { case TYPE_STRING: @@ -430,6 +449,8 @@ LispVal *predicate_for_type(LispType type) { return Quser_pointer_p; case TYPE_PACKAGE: return Qpackagep; + case TYPE_RECORD: + return Qrecordp; default: abort(); } @@ -453,6 +474,18 @@ void lisp_init(void) { REGISTER_SYMBOL_NOINTERN(nil); REGISTER_SYMBOL_NOINTERN(t); + LISP_TYPE_SYMS[TYPE_STRING] = Qstring; + LISP_TYPE_SYMS[TYPE_SYMBOL] = Qsymbol; + LISP_TYPE_SYMS[TYPE_PAIR] = Qpair; + LISP_TYPE_SYMS[TYPE_INTEGER] = Qinteger; + LISP_TYPE_SYMS[TYPE_FLOAT] = Qfloat; + LISP_TYPE_SYMS[TYPE_VECTOR] = Qvector; + LISP_TYPE_SYMS[TYPE_FUNCTION] = Qfunction; + LISP_TYPE_SYMS[TYPE_HASHTABLE] = Qhash_table; + LISP_TYPE_SYMS[TYPE_USER_POINTER] = Quser_pointer; + LISP_TYPE_SYMS[TYPE_PACKAGE] = Qpackage; + LISP_TYPE_SYMS[TYPE_RECORD] = Qrecord; + package_table = make_lisp_hashtable(Qstrings_equal, Qhash_string); LispVal *sys_package_name = STATIC_STRING("sys"); system_package = make_lisp_package(sys_package_name); @@ -535,7 +568,19 @@ DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", case TYPE_FLOAT: return LISP_BOOL(((LispFloat *) obj1)->value == ((LispFloat *) obj2)->value); - case TYPE_VECTOR: + case TYPE_VECTOR: { + LispVector *v1 = (LispVector *) obj1; + LispVector *v2 = (LispVector *) obj2; + if (v1->length != v2->length) { + return Qnil; + } + for (size_t i = 0; i < v1->length; ++i) { + if (!Fequal(v1->data[i], v2->data[i])) { + return Qnil; + } + } + return Qt; + } case TYPE_HASHTABLE: { LispHashtable *t1 = (LispHashtable *) obj1; LispHashtable *t2 = (LispHashtable *) obj2; @@ -551,6 +596,10 @@ DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", } return Qt; } + case TYPE_RECORD: { + // TODO implement this + return Qnil; + } default: abort(); } @@ -575,16 +624,12 @@ DEFUN(not, "not", (LispVal * obj), "(obj)", DEFUN( type_of, "type-of", (LispVal * obj), "(obj)", "Return a symbol that describes the type of OBJ. This is for informational " - "purpoese only, don't use this to test for objects of a specific type.") { - if (obj->type < 0 || obj->type >= N_LISP_TYPES) { - return Qnil; + "purposes only, don't use this to test for objects of a specific type.") { + if (TYPEOF(obj) != TYPE_RECORD) { + return refcount_ref(LISP_TYPE_SYMS[TYPEOF(obj)]); + } else { + return refcount_ref(((LispRecord *) obj)->record_type); } - LispVal *name = - make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name, - LISP_TYPE_NAMES[obj->type].len, true, true); - LispVal *sym = Fintern(name, system_package, Qnil); - refcount_unref(name); - return sym; } DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val), "(obj)", @@ -592,6 +637,31 @@ DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val), "(obj)", return LISP_BOOL(USER_POINTER_P(val)); } +DEFUN(callablep, "callablep", (LispVal * val), "(obj)", + "Return non-nil if OBJ is callable.") { + if (FUNCTIONP(val)) { + return refcount_ref(val); + } else if (SYMBOLP(val)) { + return Fcallablep(Fsymbol_function(val, Qt)); + } else if (PAIRP(val) && HEAD(val) == Qlambda) { + return refcount_ref(val); + } else if (CALLABLE_RECORD_P(val)) { + return Fcallablep(((LispRecord *) val)->function); + } + return Qnil; +} + +DEFUN(native_type_p, "native-type-p", (LispVal * sym), "(sym)", + "Return non-nil if SYM names a native type.") { + CHECK_TYPE(TYPE_SYMBOL, sym); + for (size_t i = 0; i < N_LISP_TYPES; ++i) { + if (!NILP(Feq(LISP_TYPE_SYMS[i], sym))) { + return Qt; + } + } + return Qnil; +} + // ################################## // # Evaluation and Macro Expansion # // ################################## @@ -913,16 +983,11 @@ static inline void setup_return_handler(LispVal *tag, LispVal *dest) { static LispVal *call_function(LispVal *func, LispVal *args, LispVal *args_lexenv, bool eval_args, bool allow_macro) { - LispFunction *fobj = (LispFunction *) Qnil; - if (FUNCTIONP(func)) { - fobj = (LispFunction *) refcount_ref(func); - } else if (SYMBOLP(func)) { - fobj = (LispFunction *) Fsymbol_function(func, Qt); - } else if (PAIRP(func) && HEAD(func) == Qlambda) { - fobj = (LispFunction *) Feval(func, args_lexenv); - assert(FUNCTIONP(fobj)); - } else { - Fthrow(Qinvalid_function_error, Fpair(func, Qnil)); + LispFunction *fobj = (LispFunction *) Fcallablep(func); + if (PAIRP(fobj)) { + LispVal *real_fobj = Feval(LISPVAL(fobj), args_lexenv); + refcount_unref(fobj); + fobj = (LispFunction *) real_fobj; } void *cl_handle = register_cleanup(refcount_unref_as_callback, fobj); if (NILP(fobj)) { @@ -1008,6 +1073,7 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), "(eval &opt lexenv)", case TYPE_HASHTABLE: case TYPE_USER_POINTER: case TYPE_PACKAGE: + case TYPE_RECORD: // the above all are self-evaluating return refcount_ref(form); case TYPE_SYMBOL: @@ -3513,6 +3579,75 @@ bool strings_equal_nocase(const char *s1, const char *s2, size_t n) { return true; } +// #################### +// # Record Functions # +// #################### +DEFUN(recordp, "recordp", (LispVal * val), "(obj)", + "Return non-nil if OBJ is a record.") { + return LISP_BOOL(RECORDP(val)); +} + +DEFUN_DISTINGUISHED(make_record, "make-record", + (LispVal * type, LispVal *length), + "(type length &opt native-backing)", + "Return a new record object of TYPE.") { + CHECK_TYPE(TYPE_INTEGER, length); + int64_t real_length = ((LispInteger *) length)->value; + if (real_length < 0) { + Fthrow(Qout_of_bounds_error, Qnil); + } + return make_lisp_record(type, real_length); +} + +DEFUN(record_function, "record-function", (LispVal * record), "(record)", + "Return the function associated with RECORD.") { + CHECK_TYPE(TYPE_RECORD, record); + return refcount_ref(((LispRecord *) record)->function); +} + +DEFUN(set_record_function, "set-record-function", + (LispVal * record, LispVal *value), "(record value)", + "Set the function of RECORD to VALUE.") { + CHECK_TYPE(TYPE_RECORD, record); + LispRecord *rec = (LispRecord *) record; + refcount_unref(rec->function); + rec->function = refcount_ref(value); + return refcount_ref(value); +} + +DEFUN(record_length, "record-length", (LispVal * record), "(record)", + "Return the length of RECORD.") { + CHECK_TYPE(TYPE_RECORD, record); + return make_lisp_integer(((LispRecord *) record)->length); +} + +DEFUN(record_slot, "record-slot", (LispVal * record, LispVal *index), + "(obj index)", "Return the INDEXth slot of RECORD.") { + CHECK_TYPE(TYPE_RECORD, record); + CHECK_TYPE(TYPE_INTEGER, index); + LispRecord *rec = (LispRecord *) record; + int64_t real_index = ((LispInteger *) index)->value; + if (real_index < 0 || real_index > rec->length) { + Fthrow(Qout_of_bounds_error, Fpair(index, Qnil)); + } + return refcount_ref(rec->data[real_index]); +} + +DEFUN(set_record_slot, "set-record-slot", + (LispVal * record, LispVal *index, LispVal *value), + "(record index value)", "Set the INDEXth slot of RECORD to VALUE.") { + CHECK_TYPE(TYPE_RECORD, record); + CHECK_TYPE(TYPE_INTEGER, index); + LispRecord *rec = (LispRecord *) record; + int64_t real_index = ((LispInteger *) index)->value; + if (real_index < 0 || real_index > rec->length) { + Fthrow(Qout_of_bounds_error, Fpair(index, Qnil)); + } + refcount_unref(rec->data[real_index]); + rec->data[real_index] = refcount_ref(value); + return Qnil; +} + // ################ // # IO Functions # // ################ @@ -3544,7 +3679,12 @@ static int64_t internal_print(void *obj, int64_t fd, bool readably, } } case TYPE_SYMBOL: { - LispVal *name = Fquote_symbol_for_read(obj, Qkw_as_needed, Qnil); + LispVal *name = Qnil; + if (readably) { + name = Fquote_symbol_for_read(obj, Qkw_as_needed, Qnil); + } else { + name = refcount_ref(((LispSymbol *) obj)->name); + } int64_t np; WITH_CLEANUP(name, { np = internal_print(name, fd, false, true); // @@ -3618,7 +3758,7 @@ static int64_t internal_print(void *obj, int64_t fd, bool readably, LispVal *hash_fn = NILP(ht->hash_fn) ? Qid : ht->hash_fn; LispVal *eq_fn = NILP(ht->eq_fn) ? Qeq : ht->eq_fn; int64_t np = CHECK_IO_RESULT( - dprintf(fd, "", (uintmax_t) obj), fd); return np; } + case TYPE_USER_POINTER: + return CHECK_IO_RESULT(dprintf(fd, "", + (uintmax_t) USERPTR(void *, obj), + (uintmax_t) obj), + fd); case TYPE_PACKAGE: { LispPackage *pkg = obj; int64_t np = CHECK_IO_RESULT(dprintf(fd, "", - (uintmax_t) USERPTR(void *, obj), - (uintmax_t) obj), - fd); + case TYPE_RECORD: { + // TODO implement + LispRecord *rec = (LispRecord *) obj; + int64_t np = CHECK_IO_RESULT( + dprintf(fd, + "<%srecord type=", NILP(rec->function) ? "" : "callable-"), + fd); + np += internal_print(rec->record_type, fd, readably, true); + np += CHECK_IO_RESULT(dprintf(fd, " length=%ju at %#jx>", + (uintmax_t) rec->length, (uintmax_t) obj), + fd); + return np; + } break; default: abort(); } @@ -4012,6 +4165,14 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) { fprintf(stream, " obarray-size=%zu at %#jx>", ((LispHashtable *) pkg->obarray)->count, (uintmax_t) obj); } break; + case TYPE_RECORD: { + LispRecord *rec = (LispRecord *) obj; + fprintf(stream, + "<%srecord type=", NILP(rec->function) ? "" : "callable-"); + debug_dump_real(stream, rec->record_type, true); + fprintf(stream, " length=%ju at %#jx>", (uintmax_t) rec->length, + (uintmax_t) obj); + } break; default: fprintf(stream, "", (uintmax_t) LISPVAL(obj)->type, (uintmax_t) obj); @@ -4070,6 +4231,14 @@ static void register_symbols_and_functions(void) { REGISTER_SYMBOL(comma); REGISTER_SYMBOL(comma_at); REGISTER_SYMBOL(backquote); + REGISTER_SYMBOL(symbol); + REGISTER_SYMBOL(integer); + REGISTER_SYMBOL(float); + REGISTER_SYMBOL(function); + REGISTER_SYMBOL(hash_table); + REGISTER_SYMBOL(user_pointer); + REGISTER_SYMBOL(package); + REGISTER_SYMBOL(record); REGISTER_KEYWORD(kw_success); REGISTER_KEYWORD(kw_finally); REGISTER_KEYWORD(kw_as_needed); @@ -4111,6 +4280,8 @@ static void register_symbols_and_functions(void) { REGISTER_FUNCTION(not); REGISTER_FUNCTION(type_of); REGISTER_FUNCTION(user_pointer_p); + REGISTER_FUNCTION(callablep); + REGISTER_FUNCTION(native_type_p); // ################################## // # Evaluation and Macro Expansion # @@ -4256,6 +4427,17 @@ static void register_symbols_and_functions(void) { REGISTER_FUNCTION(quote_string); REGISTER_FUNCTION(concat); + // #################### + // # Record Functions # + // #################### + REGISTER_FUNCTION(recordp); + REGISTER_FUNCTION(make_record); + REGISTER_FUNCTION(record_function); + REGISTER_FUNCTION(set_record_function); + REGISTER_FUNCTION(record_length); + REGISTER_FUNCTION(record_slot); + REGISTER_FUNCTION(set_record_slot); + // ################ // # IO Functions # // ################ diff --git a/src/lisp.h b/src/lisp.h index 24dc1bc..21f2738 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2,6 +2,7 @@ #define INCLUDED_LISP_H #include +#include #include #include #include @@ -33,15 +34,10 @@ typedef enum { TYPE_HASHTABLE, TYPE_USER_POINTER, TYPE_PACKAGE, + TYPE_RECORD, N_LISP_TYPES, } LispType; -struct _TypeNameEntry { - const char *name; - size_t len; -}; -extern struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES]; - #define LISP_OBJECT_HEADER \ LispType type; \ RefcountEntry refcount @@ -51,6 +47,8 @@ typedef struct { } LispVal; #define LISPVAL(obj) ((LispVal *) (obj)) +extern LispVal *LISP_TYPE_SYMS[N_LISP_TYPES]; + typedef struct { LISP_OBJECT_HEADER; @@ -167,12 +165,11 @@ typedef struct { typedef struct { LISP_OBJECT_HEADER; - LispVal *class; -} LispObject; - -typedef struct { - LispObject as_obj; -} LispClass; + LispVal *record_type; + LispVal *function; + size_t length; + LispVal **data; +} LispRecord; // ####################### // # nil, unbound, and t # @@ -201,6 +198,16 @@ extern LispVal *Qrest; extern LispVal *Qdeclare; extern LispVal *Qname; +// Type symbols not defined elsewhere +extern LispVal *Qsymbol; +extern LispVal *Qinteger; +extern LispVal *Qfloat; +extern LispVal *Qfunction; +extern LispVal *Qhash_table; +extern LispVal *Quser_pointer; +extern LispVal *Qpackage; +extern LispVal *Qrecord; + // ############################ // # Global Package Variables # // ############################ @@ -231,6 +238,7 @@ extern LispVal *current_package; #define HASHTABLEP(v) (TYPEOF(v) == TYPE_HASHTABLE) #define USER_POINTER_P(v) (TYPEOF(v) == TYPE_USER_POINTER) #define PACKAGEP(v) (TYPEOF(v) == TYPE_PACKAGE) +#define RECORDP(v) (TYPEOF(v) == TYPE_RECORD) #define ATOM(v) (TYPEOF(v) != TYPE_PAIR) @@ -409,6 +417,7 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *)); #define ALLOC_USERPTR(type, free_func) \ (make_user_pointer(lisp_malloc(sizeof(type)), &free_func)) LispVal *make_lisp_package(LispVal *name); +LispVal *make_lisp_record(LispVal *type, size_t length); LispVal *predicate_for_type(LispType type); @@ -429,6 +438,17 @@ DECLARE_FUNCTION(breakpoint, (LispVal * id)); DECLARE_FUNCTION(not, (LispVal * obj)); DECLARE_FUNCTION(type_of, (LispVal * val)); DECLARE_FUNCTION(user_pointer_p, (LispVal * val)); +DECLARE_FUNCTION(callablep, (LispVal * val)); +inline static bool CALLABLEP(LispVal *v) { + LispVal *res = Fcallablep(v); + bool rv = !NILP(res); + refcount_unref(res); + return rv; +} +inline static bool CALLABLE_RECORD_P(LispVal *v) { + return RECORDP(v) && CALLABLEP(v); +} +DECLARE_FUNCTION(native_type_p, (LispVal * sym)); // ################################## // # Evaluation and Macro Expansion # @@ -610,6 +630,18 @@ DECLARE_FUNCTION(concat, (LispVal * strings)); LispVal *sprintf_lisp(const char *format, ...) PRINTF_FORMAT(1, 2); bool strings_equal_nocase(const char *s1, const char *s2, size_t n); +// #################### +// # Record Functions # +// #################### +DECLARE_FUNCTION(recordp, (LispVal * val)); +DECLARE_FUNCTION(make_record, (LispVal * type, LispVal *length)); +DECLARE_FUNCTION(record_function, (LispVal * record)); +DECLARE_FUNCTION(set_record_function, (LispVal * record, LispVal *value)); +DECLARE_FUNCTION(record_length, (LispVal * record)); +DECLARE_FUNCTION(record_slot, (LispVal * record, LispVal *index)); +DECLARE_FUNCTION(set_record_slot, + (LispVal * record, LispVal *index, LispVal *value)); + // ################ // # IO Functions # // ################