Start work on objects

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)))

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] = {
+LispVal *LISP_TYPE_SYMS[N_LISP_TYPES] = {NULL};
-    [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},
-};
 
 // #######################
 // # 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.") {
+    "purposes only, don't use this to test for objects of a specific type.") {
-    if (obj->type < 0 || obj->type >= N_LISP_TYPES) {
+    if (TYPEOF(obj) != TYPE_RECORD) {
-        return Qnil;
+        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;
+    LispFunction *fobj = (LispFunction *) Fcallablep(func);
-    if (FUNCTIONP(func)) {
+    if (PAIRP(fobj)) {
-        fobj = (LispFunction *) refcount_ref(func);
+        LispVal *real_fobj = Feval(LISPVAL(fobj), args_lexenv);
-    } else if (SYMBOLP(func)) {
+        refcount_unref(fobj);
-        fobj = (LispFunction *) Fsymbol_function(func, Qt);
+        fobj = (LispFunction *) real_fobj;
-    } else if (PAIRP(func) && HEAD(func) == Qlambda) {
-        fobj = (LispFunction *) Feval(func, args_lexenv);
-        assert(FUNCTIONP(fobj));
-    } else {
-        Fthrow(Qinvalid_function_error, Fpair(func, Qnil));
     }
     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, "<hash-table size=%#jx count=%#jx eq-fn=",
+            dprintf(fd, "<hash-table size=%ju count=%ju eq-fn=",
                     (uintmax_t) ht->table_size, (uintmax_t) ht->count),
             fd);
         np += internal_print(eq_fn, fd, readably, true);
@@ -3627,6 +3767,11 @@ static int64_t internal_print(void *obj, int64_t fd, bool readably,
         np += CHECK_IO_RESULT(dprintf(fd, " at %#jx>", (uintmax_t) obj), fd);
         return np;
     }
+    case TYPE_USER_POINTER:
+        return CHECK_IO_RESULT(dprintf(fd, "<user-pointer to %#jx at %#jx>",
+                                       (uintmax_t) USERPTR(void *, obj),
+                                       (uintmax_t) obj),
+                               fd);
     case TYPE_PACKAGE: {
         LispPackage *pkg = obj;
         int64_t np = CHECK_IO_RESULT(dprintf(fd, "<package "), fd);
@@ -3641,11 +3786,19 @@ static int64_t internal_print(void *obj, int64_t fd, bool readably,
             fd);
         return np;
     } break;
-    case TYPE_USER_POINTER:
+    case TYPE_RECORD: {
-        return CHECK_IO_RESULT(dprintf(fd, "<user-pointer to %#jx at %#jx>",
+        // TODO implement
-                                       (uintmax_t) USERPTR(void *, obj),
+        LispRecord *rec = (LispRecord *) obj;
-                                       (uintmax_t) 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, "<object type=%ju at %#jx>",
                 (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 #
     // ################

src/lisp.h

@@ -2,6 +2,7 @@
 #define INCLUDED_LISP_H
 
 #include <assert.h>
+#include <limits.h>
 #include <refcount/refcount.h>
 #include <setjmp.h>
 #include <stdarg.h>
@@ -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;
+    LispVal *record_type;
-} LispObject;
+    LispVal *function;
-
+    size_t length;
-typedef struct {
+    LispVal **data;
-    LispObject as_obj;
+} LispRecord;
-} LispClass;
 
 // #######################
 // # 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 #
 // ################