Start work on objects

CMakeLists.txt

@@ -15,8 +15,8 @@ FetchContent_Declare(
 
 FetchContent_MakeAvailable(refcount)
 
-add_compile_options(-fsanitize=address,leak,undefined)
+# add_compile_options(-fsanitize=address,leak,undefined)
-add_link_options(-fsanitize=address,leak,undefined)
+# add_link_options(-fsanitize=address,leak,undefined)
 
 add_executable(simple-lisp src/main.c src/lisp.c src/read.c)
 target_link_libraries(simple-lisp PUBLIC refcount)

src/kernel.sl

@@ -3,24 +3,38 @@
 (fset 'null 'not)
 (fset 'list (lambda (&rest r) (declare (name list)) r))
 
+;; these versions do not support (declare) forms
 (fset 'defmacro
       (lambda (name args &rest body)
         (declare (name defmacro) macro)
-        (list 'progn
         (list 'fset (list '\' name)
               (apply 'list 'lambda args
+                     (if (and (stringp (head body)) (not (null (tail body))))
+                         (progn
+                           (apply 'list
+                                  (head body)
+                                  (list 'declare (list 'name name)
+                                        'macro)
+                                  body))
+                       (apply 'list
                               (list 'declare (list 'name name) 'macro)
-                           body)))))
+                              body))))))
 
 (defmacro defun (name args &rest body)
-  (list 'progn
   (list 'fset (list '\' name)
         (apply 'list 'lambda args
+               (if (and (stringp (head body)) (not (null (tail body))))
+                   (progn
+                     (apply 'list
+                            (head body)
                             (list 'declare (list 'name name))
-                     body))))
+                            (tail body)))
+                 (progn
+                   (list 'declare (list 'name name))
+                   body)))))
 
 (defun ensure-list (arg)
-  (if (pairp arg)
+  (if (or (null arg) (pairp arg))
       arg
     (list arg)))
 
@@ -62,7 +76,7 @@
                         (list 'head tail-var))
                   (list 'setq tail-var (list 'tail tail-var))))
            (second vars)))
-   (make-symbol "tail")))
+   '::tail))
 
 (defun maphead (func list)
   (funcall
@@ -106,14 +120,13 @@
            (throw 'argument-error))))
      (apply 'list 'funcall (apply 'list 'lambda
                                   (reverse vars)
-                                  (list 'declare (list 'name
+                                  (list 'declare (list 'name '::let))
-                                                       (make-symbol "let")))
                                    body)
             (reverse vals)))))
 
 (defmacro let* (bindings &rest body)
   (list 'funcall (apply 'list 'lambda (apply 'list '&opt bindings)
-                        (list 'declare (list 'name (make-symbol "let*")))
+                        (list 'declare (list 'name '::let*))
                         body)))
 
 (defun lasttail (list)
@@ -124,12 +137,72 @@
             list (tail list)))
     out))
 
+(defun mapconcat (func list)
+  (let (start end)
+    (dolist (elt list)
+      (if (not start)
+          (setq start (copy-list (funcall func elt))
+                end (lasttail start))
+        (settail end (copy-list (funcall func elt)))
+        (setq end (lasttail end))))
+    start))
+
+(defun identity (e) e)
+
+(defun complement (fn)
+  (lambda (&rest args) (not (apply fn args))))
+
+(defun append (&rest lists)
+  ;; another implementation
+  ;; (mapconcat 'identity lists)
+  (let* ((start (copy-list (head lists)))
+         (end (lasttail start)))
+    (dolist (list (tail lists))
+      (settail end (copy-list list))
+      (setq end (lasttail end)))
+    start))
+
+(defmacro prog1 (first-form &rest body)
+  (let ((rval '::rval))
+    (list 'let (list (list rval first-form))
+          (apply 'list 'progn body)
+          rval)))
+
+;; these versions support (declare) forms
+(defmacro defmacro (name args &rest body)
+  (list 'fset (list '\' name)
+        (append (list 'lambda args)
+                (when (and (stringp (head body)) (not (null (tail body))))
+                  (prog1 (list (head body))
+                    (setq body (tail body))))
+                (list
+                 (apply 'list 'declare (list 'name name) 'macro
+                        (when (and (pairp (head body))
+                                   (eq (head (head body)) 'declare))
+                          (prog1 (tail (head body))
+                            (setq body (tail body))))))
+                body)))
+
+(defmacro defun (name args &rest body)
+  (list 'fset (list '\' name)
+        (append (list 'lambda args)
+                (when (and (stringp (head body)) (not (null (tail body))))
+                  (prog1 (list (head body))
+                    (setq body (tail body))))
+                (list
+                 (apply 'list 'declare (list 'name name)
+                        (when (and (pairp (head body))
+                                   (eq (head (head body)) 'declare))
+                          (prog1 (tail (head body))
+                            (setq body (tail body))))))
+                body)))
+
 (defun internal-expand-single-cond (cond)
   (if (tail cond)
       (let ((res (list 'if (head cond)
                        (apply 'list 'progn (tail cond)))))
         (pair res res))
-    (let* ((res-var (make-symbol "res"))
+    (let* ((res-var '::res)
            (if-stmt (list 'if res-var res-var)))
       (pair (list 'let (list (list res-var (head cond)))
                   if-stmt)
@@ -158,7 +231,7 @@
 (defmacro define-type-predicate (name args &rest body)
   (cond
    ((eq args 'alias)
-    (let ((var (make-symbol "var")))
+    (let ((var '::var))
       (list 'put (list '\' name) ''type-predicate
             (list 'lambda (list var) (list 'typep var (pair '\' body))))))
    ((and (symbolp args) (null body))
@@ -179,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)
@@ -220,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))
@@ -233,7 +311,7 @@
   (get symbol 'type-predicate))
 
 (defmacro tcase (obj &rest conds)
-  (let ((obj-var (make-symbol "obj")))
+  (let ((obj-var '::obj))
     (list 'let (list (list obj-var obj))
           (pair
            'cond
@@ -253,7 +331,7 @@
   (list 'return-from nil value))
 
 (defmacro dotails (vars &rest body)
-  (let ((cur (make-symbol "cur")))
+  (let ((cur '::cur))
     (list 'let (list (list cur (second vars)))
           (list 'while (list 'pairp cur)
                 (apply 'list 'let (list (list (first vars) cur))
@@ -284,28 +362,6 @@
       (return-from find-if cur)))
   default)
 
-(defun mapconcat (func list)
-  (let (start end)
-    (dolist (elt list)
-      (if (not start)
-          (setq start (copy-list (funcall func elt))
-                end (lasttail start))
-        (settail end (copy-list (funcall func elt)))
-        (setq end (lasttail end))))
-    start))
-
-(defun identity (e) e)
-
-(defun append (&rest lists)
-  ;; another implementation
-  ;; (mapconcat 'identity lists)
-  (let* ((start (copy-list (head lists)))
-         (end (lasttail start)))
-    (dolist (list (tail lists))
-      (settail end (copy-list list))
-      (setq end (lasttail end)))
-    start))
-
 (defmacro macrolet (macros &rest body)
   (let* ((found-macros (make-hash-table))
          (macro-fns (mapconcat (lambda (entry)
@@ -371,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)
@@ -378,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))
@@ -435,12 +498,175 @@
 (defun char-code (str)
   (aref str 0))
 
-(defun print-readably (obj &opt (newline t) stream)
+(defmacro defvar (name value &opt doc)
-  (unless (readablep obj)
+  (unless (symbolp name)
-    (throw 'type-error '(readablep) obj))
+    (throw 'type-error '(symbolp) name))
-  (tcase obj
+  (unless (or (not doc) (stringp doc))
-    (symbol (print (quote-symbol-for-read obj :as-needed)))
+    (throw 'type-error '(null stringp) doc))
-    (string (print (quote-string obj)))
+  (apply 'list 'progn
-    (t (print obj)))
+         (list 'make-symbol-special (list '\' name))
-  (when newline
+         (list 'setq name value)
-    (println)))
+         (when doc
+           (list (list 'set-symbol-value-docstr
+                       (list '\' name) doc)))))
+
+;; 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 #
@@ -39,7 +28,10 @@ LispSymbol _Qnil = {
     .plist = Qnil,
     .function = Qnil,
     .value = Qnil,
-    .is_constant = true,
+    .value_doc = Qnil,
+    .is_const_value = true,
+    .is_const_func = false,
+    .is_special_var = true,
 };
 
 DEF_STATIC_STRING(_Qunbound_name, "unbound");
@@ -50,7 +42,10 @@ LispSymbol _Qunbound = {
     .plist = Qnil,
     .function = Qnil,
     .value = Qunbound,
-    .is_constant = true,
+    .value_doc = Qnil,
+    .is_const_value = true,
+    .is_const_func = true,
+    .is_special_var = true,
 };
 
 DEF_STATIC_STRING(_Qt_name, "t");
@@ -61,7 +56,10 @@ LispSymbol _Qt = {
     .plist = Qnil,
     .function = Qnil,
     .value = Qt,
-    .is_constant = true,
+    .value_doc = Qnil,
+    .is_const_value = true,
+    .is_const_func = true,
+    .is_special_var = true,
 };
 
 // ###########################
@@ -78,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 #
 // ############################
@@ -136,6 +143,7 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
         *held = refcount_list_push(*held, ((LispSymbol *) obj)->function);
         *held = refcount_list_push(*held, ((LispSymbol *) obj)->plist);
         *held = refcount_list_push(*held, ((LispSymbol *) obj)->value);
+        *held = refcount_list_push(*held, ((LispSymbol *) obj)->value_doc);
         return true;
     case TYPE_PAIR:
         *held = refcount_list_push(*held, ((LispPair *) obj)->head);
@@ -186,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();
     }
@@ -221,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:
@@ -260,7 +277,10 @@ LispVal *make_lisp_symbol(LispVal *name) {
     self->plist = Qnil;
     self->function = Qnil;
     self->value = Qunbound;
-    self->is_constant = false;
+    self->value_doc = Qnil;
+    self->is_const_value = false;
+    self->is_const_func = false;
+    self->is_special_var = false;
     return LISPVAL(self);
 }
 
@@ -395,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:
@@ -417,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();
     }
@@ -440,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);
@@ -522,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;
@@ -538,6 +596,10 @@ DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)",
         }
         return Qt;
     }
+    case TYPE_RECORD: {
+        // TODO implement this
+        return Qnil;
+    }
     default:
         abort();
     }
@@ -562,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)",
@@ -579,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 #
 // ##################################
@@ -634,7 +717,8 @@ static LispVal **process_builtin_args(LispVal *fname, LispFunction *func,
                 goto key_no_val;
             }
             vec[oad->index] = refcount_ref(HEAD(arg));
-        } else if (KEYWORDP(arg) && !func->allow_other_keys && NILP(rest)) {
+        } else if (KEYWORDP(arg) && !func->allow_other_keys
+                   && NILP(func->rest_arg)) {
             goto unknown_key;
         } else if (NILP(func->rest_arg)) {
             goto too_many;
@@ -732,6 +816,14 @@ static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args,
     return retval;
 }
 
+static void new_lexical_var(LispVal **lexenv, LispVal *name, LispVal *value) {
+    if (SPECIALP(name)) {
+        push_to_lexenv(&the_stack->dynenv, name, value);
+    } else {
+        push_to_lexenv(lexenv, name, value);
+    }
+}
+
 static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
                               LispVal **lexenv) {
     LispVal *added_kwds = make_lisp_hashtable(Qnil, Qnil);
@@ -747,7 +839,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
                 mode = OPT;
                 continue; // skip increment
             }
-            push_to_lexenv(lexenv, HEAD(rargs), arg);
+            new_lexical_var(lexenv, HEAD(rargs), arg);
             rargs = TAIL(rargs);
         } break;
         case OPT: {
@@ -756,9 +848,9 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
                 continue; // skip increment
             }
             struct OptArgDesc *oad = USERPTR(struct OptArgDesc, HEAD(oargs));
-            push_to_lexenv(lexenv, oad->name, arg);
+            new_lexical_var(lexenv, oad->name, arg);
             if (!NILP(oad->pred_var)) {
-                push_to_lexenv(lexenv, oad->pred_var, Qt);
+                new_lexical_var(lexenv, oad->pred_var, Qt);
             }
             oargs = TAIL(oargs);
         } break;
@@ -782,9 +874,9 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
             }
             LispVal *value = HEAD(args);
             puthash(added_kwds, oad->name, Qt);
-            push_to_lexenv(lexenv, oad->name, value);
+            new_lexical_var(lexenv, oad->name, value);
             if (!NILP(oad->pred_var)) {
-                push_to_lexenv(lexenv, oad->pred_var, Qt);
+                new_lexical_var(lexenv, oad->pred_var, Qt);
             }
             break;
         case REST:
@@ -800,7 +892,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
                     goto too_many_args;
                 }
             }
-            push_to_lexenv(lexenv, func->rest_arg, args);
+            new_lexical_var(lexenv, func->rest_arg, args);
             // done processing
             goto done_adding;
         }
@@ -815,24 +907,24 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
         // only check the current function's lexenv and not its parents'
         if (NILP(gethash(added_kwds, oad->name, Qnil))) {
             LispVal *eval_res = Feval(oad->default_form, the_stack->lexenv);
-            push_to_lexenv(lexenv, oad->name, eval_res);
+            new_lexical_var(lexenv, oad->name, eval_res);
             refcount_unref(eval_res);
             if (!NILP(oad->pred_var)) {
-                push_to_lexenv(lexenv, oad->pred_var, Qnil);
+                new_lexical_var(lexenv, oad->pred_var, Qnil);
             }
         }
     }
     FOREACH(arg, oargs) {
         struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg);
         LispVal *default_val = Feval(oad->default_form, the_stack->lexenv);
-        push_to_lexenv(lexenv, oad->name, default_val);
+        new_lexical_var(lexenv, oad->name, default_val);
         refcount_unref(default_val);
         if (!NILP(oad->pred_var)) {
-            push_to_lexenv(lexenv, oad->pred_var, Qnil);
+            new_lexical_var(lexenv, oad->pred_var, Qnil);
         }
     }
     if (!NILP(func->rest_arg)) {
-        push_to_lexenv(lexenv, func->rest_arg, Qnil);
+        new_lexical_var(lexenv, func->rest_arg, Qnil);
     }
 done_adding:
     cancel_cleanup(cl_handle);
@@ -891,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)) {
@@ -949,14 +1036,27 @@ static inline LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
     return Fplist_get(lexenv, key, Qunbound, Qnil);
 }
 
+static inline LispVal *find_dynamic_value_on_stack(LispVal *key) {
+    if (!the_stack) {
+        return Qunbound;
+    }
+    return Fplist_get(the_stack->dynenv, key, Qunbound, Qnil);
+}
+
 static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
-    if (!NILP(lexenv)) {
+    CHECK_TYPE(TYPE_SYMBOL, key);
+    if (SPECIALP(key)) {
+        LispVal *local = find_dynamic_value_on_stack(key);
+        if (local != Qunbound) {
+            return local;
+        }
+    } else if (!NILP(lexenv)) {
         LispVal *local = find_in_lexenv(lexenv, key);
         if (local != Qunbound) {
             return local;
         }
     }
-    LispVal *sym_val = Fsymbol_value(key);
+    LispVal *sym_val = Fsymbol_value(key, Qt);
     if (sym_val != Qunbound) {
         return sym_val;
     }
@@ -973,13 +1073,13 @@ 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:
         if (KEYWORDP(form)) {
             return refcount_ref(form);
         } else {
-            // this refs its return value
             return symbol_value_in_lexenv(lexenv, form);
         }
     case TYPE_VECTOR: {
@@ -1363,13 +1463,20 @@ DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil),
 
 static void set_symbol_in_lexenv(LispVal *key, LispVal *newval,
                                  LispVal *lexenv) {
-    LispVal *lexval = Fplist_assoc(lexenv, key, Qnil);
+    if (VALUE_CONSTANTP(key)) {
-    if (PAIRP(lexval)) {
+        Fthrow(Qconstant_value_error, Fpair(key, Qnil));
-        Fsethead(TAIL(lexval), newval);
+    }
+    LispVal *val_pair = Qnil;
+    if (SPECIALP(key)) {
+        val_pair = Fplist_assoc(the_stack->dynenv, key, Qnil);
+    } else {
+        val_pair = Fplist_assoc(lexenv, key, Qnil);
+    }
+    if (PAIRP(val_pair)) {
+        Fsethead(TAIL(val_pair), newval);
     } else {
-        refcount_ref(newval);
         refcount_unref(((LispSymbol *) key)->value);
-        ((LispSymbol *) key)->value = newval;
+        ((LispSymbol *) key)->value = refcount_ref(newval);
     }
 }
 
@@ -1388,7 +1495,9 @@ DEFMACRO(
         LispVal *name = HEAD(tail);
         tail = TAIL(tail);
         retval = Feval(HEAD(tail), the_stack->lexenv);
-        set_symbol_in_lexenv(name, retval, the_stack->lexenv);
+        WITH_CLEANUP(retval, {
+            set_symbol_in_lexenv(name, retval, the_stack->lexenv); //
+        });
     }
     return retval;
 }
@@ -2382,11 +2491,40 @@ DEFUN(keywordp, "keywordp", (LispVal * val), "(obj)",
     return LISP_BOOL(KEYWORDP(val));
 }
 
+DEFUN(const_value_p, "const-value-p", (LispVal * val), "(obj)",
+      "Return non-nil if OBJ's value is constant.") {
+    CHECK_TYPE(TYPE_SYMBOL, val);
+    return LISP_BOOL(VALUE_CONSTANTP(val));
+}
+
+DEFUN(const_func_p, "const-func-p", (LispVal * val), "(obj)",
+      "Return non-nil if OBJ's value as a function is constant.") {
+    CHECK_TYPE(TYPE_SYMBOL, val);
+    return LISP_BOOL(FUNC_CONSTANTP(val));
+}
+
+DEFUN(specialp, "specialp", (LispVal * val), "(obj)",
+      "Return non-nil if OBJ is a special variable.") {
+    CHECK_TYPE(TYPE_SYMBOL, val);
+    return LISP_BOOL(SPECIALP(val));
+}
+
 DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)",
       "Return a new uninterned symbol named NAME.") {
     return make_lisp_symbol(name);
 }
 
+DEFUN(make_symbol_special, "make-symbol-special", (LispVal * sym), "(sym)",
+      "Make it so that SYM is a special symbol, that is, it is dynamically "
+      "bound.") {
+    CHECK_TYPE(TYPE_SYMBOL, sym);
+    if (VALUE_CONSTANTP(sym)) {
+        Fthrow(Qconstant_value_error, Fpair(sym, Qnil));
+    }
+    ((LispSymbol *) sym)->is_special_var = true;
+    return refcount_ref(sym);
+}
+
 DEFUN(symbol_package, "symbol-package", (LispVal * symbol), "(symbol)",
       "Return the package of SYMBOL.") {
     CHECK_TYPE(TYPE_SYMBOL, symbol);
@@ -2413,12 +2551,72 @@ DEFUN(symbol_function, "symbol-function", (LispVal * symbol, LispVal *resolve),
     return refcount_ref(symbol);
 }
 
-DEFUN(symbol_value, "symbol-value", (LispVal * symbol), "(symbol)",
+DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func), "(symbol func)",
-      "Return the global value of SYMBOL.") {
+      "Set the value as a function of SYMBOL to FUNC.") {
+    CHECK_TYPE(TYPE_SYMBOL, sym);
+    LispSymbol *sobj = ((LispSymbol *) sym);
+    if (FUNC_CONSTANTP(sobj)) {
+        Fthrow(Qconstant_function_error, Fpair(sym, Qnil));
+    }
+    refcount_ref(new_func);
+    refcount_unref(sobj->function);
+    sobj->function = new_func;
+    return refcount_ref(new_func);
+}
+
+DEFUN(symbol_value, "symbol-value", (LispVal * symbol, LispVal *default_only),
+      "(symbol &opt default-only)", "Return the global value of SYMBOL.") {
     CHECK_TYPE(TYPE_SYMBOL, symbol);
+    if (KEYWORDP(symbol)) {
+        return refcount_ref(symbol);
+    } else if (SPECIALP(symbol) && NILP(default_only)) {
+        LispVal *dynenv_entry = Fplist_assoc(the_stack->dynenv, symbol, Qnil);
+        if (!NILP(dynenv_entry)) {
+            return refcount_ref(HEAD(TAIL(dynenv_entry)));
+        }
+    }
     return refcount_ref(((LispSymbol *) symbol)->value);
 }
 
+DEFUN(set, "set", (LispVal * symbol, LispVal *value, LispVal *default_only),
+      "(symbol value &opt default-only)",
+      "Set the global value of SYMBOL to VALUE.") {
+    CHECK_TYPE(TYPE_SYMBOL, symbol);
+    if (VALUE_CONSTANTP(symbol)) {
+        Fthrow(Qconstant_value_error, Fpair(symbol, Qnil));
+    }
+    if (SPECIALP(symbol) && NILP(default_only)) {
+        LispVal *dynenv_entry = Fplist_assoc(the_stack->dynenv, symbol, Qnil);
+        if (!NILP(dynenv_entry)) {
+            Fsethead(TAIL(dynenv_entry), value);
+            return refcount_ref(value);
+        }
+    }
+    LispSymbol *sobj = (LispSymbol *) symbol;
+    refcount_unref(sobj->value);
+    sobj->value = refcount_ref(value);
+    return refcount_ref(value);
+}
+
+DEFUN(symbol_value_docstr, "symbol-value-docstr", (LispVal * symbol),
+      "(symbol)", "Return the documentation for SYMBOL's value.") {
+    CHECK_TYPE(TYPE_SYMBOL, symbol);
+    return refcount_ref(((LispSymbol *) symbol)->value_doc);
+}
+
+DEFUN(set_symbol_value_docstr, "set-symbol-value-docstr",
+      (LispVal * symbol, LispVal *docstr), "(symbol value)",
+      "Set the documentation for SYMBOL's value.") {
+    CHECK_TYPE(TYPE_SYMBOL, symbol);
+    if (VALUE_CONSTANTP(symbol)) {
+        Fthrow(Qconstant_value_error, Fpair(symbol, Qnil));
+    }
+    LispSymbol *sobj = (LispSymbol *) symbol;
+    refcount_unref(sobj->value_doc);
+    sobj->value_doc = refcount_ref(docstr);
+    return refcount_ref(docstr);
+}
+
 DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol), "(symbol)",
       "Return the plist of SYMBOL.") {
     CHECK_TYPE(TYPE_SYMBOL, symbol);
@@ -2434,23 +2632,14 @@ DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist),
     return Qnil;
 }
 
-DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func), "(symbol func)",
-      "Set the value as a function of SYMBOL to FUNC.") {
-    CHECK_TYPE(TYPE_SYMBOL, sym);
-    LispSymbol *sobj = ((LispSymbol *) sym);
-    // TODO make sure this is not constant
-    refcount_ref(new_func);
-    refcount_unref(sobj->function);
-    sobj->function = new_func;
-    return refcount_ref(new_func);
-}
-
 DEFUN(exported_symbol_p, "exported-symbol-p", (LispVal * symbol), "(symbol)",
       "Return non-nil if SYMBOL is exported by its package.") {
     CHECK_TYPE(TYPE_SYMBOL, symbol);
     LispSymbol *sym = (LispSymbol *) symbol;
     if (NILP(sym->package)) {
         return Qnil;
+    } else if (KEYWORDP(symbol)) {
+        return Qt;
     }
     LispPackage *pkg = (LispPackage *) sym->package;
     return Fgethash(pkg->exported_sym_table, LISPVAL(sym), Qnil);
@@ -2568,7 +2757,13 @@ DEFUN(quote_symbol_for_read, "quote-symbol-for-read",
     LispSymbol *sym = (LispSymbol *) target;
     LispString *sym_name =
         (LispString *) Fquote_symbol_name(LISPVAL(sym->name));
-    if (NILP(include_package)) {
+    if (KEYWORDP(target)) {
+        size_t size = sym_name->length + 1;
+        char *new_name = lisp_malloc(size + 1);
+        snprintf(new_name, size + 1, ":%s", sym_name->data);
+        refcount_unref(sym_name);
+        return make_lisp_string(new_name, size, true, false);
+    } else if (NILP(include_package)) {
         return LISPVAL(sym_name);
     } else if (include_package == Qkw_as_needed) {
         void *cl_handler =
@@ -3368,7 +3563,7 @@ LispVal *sprintf_lisp(const char *format, ...) {
     va_end(args_measure);
     char *buffer = lisp_malloc(size);
     vsnprintf(buffer, size, format, args);
-    LispVal *obj = make_lisp_string(buffer, size, true, false);
+    LispVal *obj = make_lisp_string(buffer, size - 1, true, false);
     va_end(args);
     return obj;
 }
@@ -3384,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 #
 // ################
@@ -3398,24 +3662,39 @@ static inline int CHECK_IO_RESULT(int res, int fd) {
     return res;
 }
 
-static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
+static int64_t internal_print(void *obj, int64_t fd, bool readably,
+                              bool first_in_list) {
     switch (TYPEOF(obj)) {
     case TYPE_STRING: {
+        if (readably) {
+            LispVal *quoted = Fquote_string(obj);
+            int64_t rval = 0;
+            WITH_CLEANUP(quoted, {
+                rval = internal_print(quoted, fd, false, true); //
+            });
+            return rval;
+        } else {
             LispString *str = obj;
             return CHECK_IO_RESULT(write(fd, str->data, str->length), fd);
         }
+    }
     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, true); //
+            np = internal_print(name, fd, false, true); //
         });
         return np;
     } break;
     case TYPE_PAIR: {
         if (HEAD(obj) == Qquote && PAIRP(TAIL(obj)) && NILP(TAIL(TAIL(obj)))) {
             int64_t np = CHECK_IO_RESULT(dprintf(fd, "'"), fd);
-            np += internal_print(HEAD(TAIL(obj)), fd, true);
+            np += internal_print(HEAD(TAIL(obj)), fd, readably, true);
             return np;
         }
         int64_t np;
@@ -3424,11 +3703,11 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
         } else {
             np = CHECK_IO_RESULT(dprintf(fd, " "), fd);
         }
-        np += internal_print(HEAD(obj), fd, true);
+        np += internal_print(HEAD(obj), fd, readably, true);
         if (TAIL(obj) == Qnil) {
             np = CHECK_IO_RESULT(dprintf(fd, ")"), fd);
         } else {
-            np += internal_print(TAIL(obj), fd, false);
+            np += internal_print(TAIL(obj), fd, readably, false);
         }
         return np;
     }
@@ -3436,7 +3715,7 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
         LispVector *v = obj;
         int64_t np = CHECK_IO_RESULT(dprintf(fd, "["), fd);
         for (size_t i = 0; i < v->length; ++i) {
-            np += internal_print(v->data[i], fd, true);
+            np += internal_print(v->data[i], fd, readably, true);
             np += CHECK_IO_RESULT(dprintf(fd, " "), fd);
         }
         np += CHECK_IO_RESULT(dprintf(fd, "]"), fd);
@@ -3468,7 +3747,7 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
             np = CHECK_IO_RESULT(dprintf(fd, "<function "), fd);
         }
         if (need_name) {
-            np += internal_print(fn->name, fd, true);
+            np += internal_print(fn->name, fd, readably, true);
             np += CHECK_IO_RESULT(dprintf(fd, " "), fd);
         }
         np += CHECK_IO_RESULT(dprintf(fd, "at %#jx>", (uintmax_t) obj), fd);
@@ -3479,21 +3758,26 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
         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, true);
+        np += internal_print(eq_fn, fd, readably, true);
         np += CHECK_IO_RESULT(dprintf(fd, " hash-fn="), fd);
-        np += internal_print(hash_fn, fd, true);
+        np += internal_print(hash_fn, fd, readably, true);
         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);
         LispVal *name_str = Fquote_string(LISPVAL(pkg->name));
         WITH_CLEANUP(name_str, {
-            np += internal_print(name_str, fd, true); //
+            np += internal_print(name_str, fd, readably, true); //
         });
         np += CHECK_IO_RESULT(
             dprintf(fd, " interned=%ju at %#jx>",
@@ -3502,20 +3786,30 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
             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();
     }
 }
 
-DEFUN_DISTINGUISHED(print, "print", (LispVal * obj, LispVal *stream),
+DEFUN_DISTINGUISHED(print, "print",
-                    "(obj &opt stream)",
+                    (LispVal * obj, LispVal *readably, LispVal *stream),
+                    "(obj &opt readably stream)",
                     "Write a human readable representation of OBJ to STREAM, "
-                    "defaulting to the standard output.") {
+                    "defaulting to the standard output. With READABLY non-nil, "
+                    "print OBJ in a way that it can be read back.") {
     int64_t fd;
     if (stream == Qunbound) {
         fd = 1;
@@ -3526,12 +3820,15 @@ DEFUN_DISTINGUISHED(print, "print", (LispVal * obj, LispVal *stream),
             Fthrow(Qtype_error, const_list(true, 1, stream));
         }
     }
-    return make_lisp_integer(internal_print(obj, fd, false));
+    bool readably_bool = readably != Qunbound && !NILP(readably);
+    return make_lisp_integer(internal_print(obj, fd, readably_bool, true));
 }
 
 DEFUN_DISTINGUISHED(
-    println, "println", (LispVal * obj, LispVal *stream), "(obj &opt stream)",
+    println, "println", (LispVal * obj, LispVal *readably, LispVal *stream),
-    "Call print with OBJ and STREAM, then write a newline to STREAM.") {
+    "(obj &opt readably stream)",
+    "Call print with OBJ and STREAM, then write a newline to STREAM. With "
+    "READABLY non-nil, print OBJ in a way that it can be read back.") {
     static char NEWLINE = '\n';
     int64_t fd;
     if (stream == Qunbound) {
@@ -3545,7 +3842,8 @@ DEFUN_DISTINGUISHED(
     }
     int64_t np = 0;
     if (obj != Qunbound) {
-        np += internal_print(obj, fd, true);
+        bool readably_bool = readably != Qunbound && !NILP(readably);
+        np += internal_print(obj, fd, readably_bool, true);
     }
     np += CHECK_IO_RESULT(write(fd, &NEWLINE, 1), fd);
     fsync(fd);
@@ -3603,11 +3901,14 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest), "(signal &rest rest)",
             LispVal *var = HEAD(handler);
             LispVal *form = TAIL(handler);
             WITH_PUSH_FRAME(Qnil, Qnil, true, {
+                WITH_CLEANUP(error_arg, {
                     if (!NILP(var)) {
-                    // TODO make sure this isn't constant
+                        CHECK_TYPE(TYPE_SYMBOL, var);
+                        if (VALUE_CONSTANTP(var)) {
+                            Fthrow(Qconstant_value_error, Fpair(var, Qnil));
+                        }
                         push_to_lexenv(&the_stack->lexenv, var, error_arg);
                     }
-                WITH_CLEANUP(error_arg, {
                     stack_return = Feval(form, the_stack->lexenv); //
                 });
             });
@@ -3656,6 +3957,7 @@ void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
     if (inherit && the_stack) {
         frame->lexenv = refcount_ref(the_stack->lexenv);
     }
+    frame->dynenv = the_stack ? refcount_ref(the_stack->dynenv) : Qnil;
     frame->enable_handlers = true;
     frame->handlers = make_lisp_hashtable(Qnil, Qnil);
     frame->unwind_form = Qnil;
@@ -3672,6 +3974,7 @@ void stack_leave(void) {
     refcount_unref(frame->return_tag);
     refcount_unref(frame->detail);
     refcount_unref(frame->lexenv);
+    refcount_unref(frame->dynenv);
     refcount_unref(frame->handlers);
     while (frame->cleanup_handlers) {
         frame->cleanup_handlers->fun(frame->cleanup_handlers->data);
@@ -3741,9 +4044,12 @@ void cancel_cleanup(void *handle) {
 // # Errors and Conditions #
 // #########################
 DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
+DEF_STATIC_SYMBOL(error, "error");
 DEF_STATIC_SYMBOL(type_error, "type-error");
 DEF_STATIC_SYMBOL(read_error, "read-error");
 DEF_STATIC_SYMBOL(unclosed_error, "read-error");
+DEF_STATIC_SYMBOL(constant_function_error, "constant-function-error");
+DEF_STATIC_SYMBOL(constant_value_error, "constant-value-error");
 DEF_STATIC_SYMBOL(eof_error, "eof-error");
 DEF_STATIC_SYMBOL(void_variable_error, "void-variable-error");
 DEF_STATIC_SYMBOL(void_function_error, "void-function-error");
@@ -3859,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);
@@ -3917,14 +4231,25 @@ static void register_symbols_and_functions(void) {
     REGISTER_SYMBOL(comma);
     REGISTER_SYMBOL(comma_at);
     REGISTER_SYMBOL(backquote);
-    REGISTER_SYMBOL_INTO(kw_success, keyword_package);
+    REGISTER_SYMBOL(symbol);
-    REGISTER_SYMBOL_INTO(kw_finally, keyword_package);
+    REGISTER_SYMBOL(integer);
-    REGISTER_SYMBOL_INTO(kw_as_needed, keyword_package);
+    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);
     REGISTER_SYMBOL(shutdown_signal);
+    REGISTER_SYMBOL(error);
     REGISTER_SYMBOL(type_error);
     REGISTER_SYMBOL(read_error);
     REGISTER_SYMBOL(eof_error);
     REGISTER_SYMBOL(unclosed_error);
+    REGISTER_SYMBOL(constant_function_error);
+    REGISTER_SYMBOL(constant_value_error);
     REGISTER_SYMBOL(void_variable_error);
     REGISTER_SYMBOL(void_function_error);
     REGISTER_SYMBOL(circular_error);
@@ -3955,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 #
@@ -4032,14 +4359,21 @@ static void register_symbols_and_functions(void) {
     // ####################
     REGISTER_FUNCTION(symbolp);
     REGISTER_FUNCTION(keywordp);
+    REGISTER_FUNCTION(const_value_p);
+    REGISTER_FUNCTION(const_func_p);
+    REGISTER_FUNCTION(specialp);
     REGISTER_FUNCTION(make_symbol);
+    REGISTER_FUNCTION(make_symbol_special);
     REGISTER_FUNCTION(symbol_package);
     REGISTER_FUNCTION(symbol_name);
     REGISTER_FUNCTION(symbol_function);
+    REGISTER_FUNCTION(fset);
     REGISTER_FUNCTION(symbol_value);
+    REGISTER_FUNCTION(set);
+    REGISTER_FUNCTION(symbol_value_docstr);
+    REGISTER_FUNCTION(set_symbol_value_docstr);
     REGISTER_FUNCTION(symbol_plist);
     REGISTER_FUNCTION(setplist);
-    REGISTER_FUNCTION(fset);
     REGISTER_FUNCTION(exported_symbol_p);
     REGISTER_FUNCTION(intern_soft);
     REGISTER_FUNCTION(intern);
@@ -4093,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;
 
@@ -67,7 +65,10 @@ typedef struct {
     LispVal *plist;
     LispVal *function;
     LispVal *value;
-    bool is_constant;
+    LispVal *value_doc;
+    unsigned int is_const_value : 1;
+    unsigned int is_const_func : 1;
+    unsigned int is_special_var : 1;
 } LispSymbol;
 
 typedef struct {
@@ -164,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 #
@@ -198,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 #
 // ############################
@@ -213,7 +223,9 @@ extern LispVal *current_package;
 #define TYPEOF(v)  (LISPVAL(v)->type)
 
 // only use on symbols!
-#define VALUE_CONSTANTP(v) (((LispSymbol *) (v))->is_constant)
+#define VALUE_CONSTANTP(v) (((LispSymbol *) (v))->is_const_value || KEYWORDP(v))
+#define FUNC_CONSTANTP(v)  (((LispSymbol *) (v))->is_const_func)
+#define SPECIALP(v)        (((LispSymbol *) (v))->is_special_var)
 
 #define NILP(v)           (((void *) (v)) == (void *) Qnil)
 #define STRINGP(v)        (TYPEOF(v) == TYPE_STRING)
@@ -226,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)
 
@@ -260,7 +273,10 @@ inline static bool NUMBERP(LispVal *v) {
         .plist = Qnil,                                     \
         .function = Qnil,                                  \
         .value = Qunbound,                                 \
-        .is_constant = false,                              \
+        .value_doc = Qnil,                                 \
+        .is_const_value = false,                           \
+        .is_const_func = false,                            \
+        .is_special_var = false,                           \
     };                                                     \
     LispVal *Q##c_name = LISPVAL(&_Q##c_name)
 #define DECLARE_FUNCTION(c_name, args) \
@@ -295,8 +311,11 @@ inline static bool NUMBERP(LispVal *v) {
         .package = Qnil,                                                \
         .plist = Qnil,                                                  \
         .value = Qunbound,                                              \
+        .value_doc = Qnil,                                              \
         .function = LISPVAL(&_Q##c_name##_function),                    \
-        .is_constant = false,                                           \
+        .is_const_value = false,                                        \
+        .is_const_func = true,                                          \
+        .is_special_var = false,                                        \
     };                                                                  \
     LispVal *Q##c_name = (LispVal *) &_Q##c_name;                       \
     static_kw LispVal *F##c_name c_args
@@ -329,6 +348,11 @@ inline static bool NUMBERP(LispVal *v) {
 #define REGISTER_SYMBOL_INTO(sym, pkg) \
     REGISTER_SYMBOL_NOINTERN(sym)      \
     REGISTER_DO_INTERN(sym, pkg)
+#define REGISTER_KEYWORD(sym)                       \
+    REGISTER_SYMBOL_NOINTERN(sym)                   \
+    REGISTER_DO_INTERN(sym, keyword_package)        \
+    ((LispSymbol *) Q##sym)->is_const_value = true; \
+    ((LispSymbol *) Q##sym)->is_special_var = true;
 #define REGISTER_SYMBOL(sym) REGISTER_SYMBOL_INTO(sym, system_package)
 #define REGISTER_STATIC_FUNCTION(name)                                    \
     REGISTER_SYMBOL_NOINTERN(name);                                       \
@@ -393,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);
 
@@ -413,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 #
@@ -506,14 +542,22 @@ LispVal *find_package(const char *name, size_t length);
 // ####################
 DECLARE_FUNCTION(symbolp, (LispVal * val));
 DECLARE_FUNCTION(keywordp, (LispVal * val));
+DECLARE_FUNCTION(const_value_p, (LispVal * val));
+DECLARE_FUNCTION(const_func_p, (LispVal * val));
+DECLARE_FUNCTION(specialp, (LispVal * val));
 DECLARE_FUNCTION(make_symbol, (LispVal * name));
+DECLARE_FUNCTION(make_symbol_special, (LispVal * sym));
 DECLARE_FUNCTION(symbol_package, (LispVal * symbol));
 DECLARE_FUNCTION(symbol_name, (LispVal * symbol));
 DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve));
-DECLARE_FUNCTION(symbol_value, (LispVal * symbol));
+DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
+DECLARE_FUNCTION(symbol_value, (LispVal * symbol, LispVal *default_only));
+DECLARE_FUNCTION(set,
+                 (LispVal * symbol, LispVal *value, LispVal *default_only));
+DECLARE_FUNCTION(symbol_value_docstr, (LispVal * symbol));
+DECLARE_FUNCTION(set_symbol_value_docstr, (LispVal * symbol, LispVal *docstr));
 DECLARE_FUNCTION(symbol_plist, (LispVal * symbol));
 DECLARE_FUNCTION(setplist, (LispVal * symbol, LispVal *plist));
-DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
 DECLARE_FUNCTION(exported_symbol_p, (LispVal * symbol));
 DECLARE_FUNCTION(intern_soft, (LispVal * name, LispVal *def, LispVal *package,
                                LispVal *included_too));
@@ -586,11 +630,23 @@ 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 #
 // ################
-DECLARE_FUNCTION(print, (LispVal * obj, LispVal *stream));
+DECLARE_FUNCTION(print, (LispVal * obj, LispVal *readably, LispVal *stream));
-DECLARE_FUNCTION(println, (LispVal * obj, LispVal *stream));
+DECLARE_FUNCTION(println, (LispVal * obj, LispVal *readably, LispVal *stream));
 
 // ########################
 // # Lexenv and the Stack #
@@ -615,6 +671,7 @@ typedef struct StackFrame {
     LispVal *return_tag;
     LispVal *detail; // function arguments
     LispVal *lexenv; // symbol -> value
+    LispVal *dynenv; // symbol -> value (for dynamic variables)
     bool enable_handlers;
     LispVal *handlers; // symbol -> (error-var form)
     LispVal *unwind_form;
@@ -693,10 +750,13 @@ void cancel_cleanup(void *handle);
 // # Errors and Conditions #
 // #########################
 extern LispVal *Qshutdown_signal;
+extern LispVal *Qerror;
 extern LispVal *Qtype_error;
 extern LispVal *Qread_error;
 extern LispVal *Qeof_error;
 extern LispVal *Qunclosed_error;
+extern LispVal *Qconstant_function_error;
+extern LispVal *Qconstant_value_error;
 extern LispVal *Qvoid_variable_error;
 extern LispVal *Qvoid_function_error;
 extern LispVal *Qcircular_error;

src/main.c

@@ -23,14 +23,19 @@ STATIC_DEFUN(toplevel_error_handler, "toplevel-error-handler",
     LispVal *backtrace = HEAD(TAIL(except));
     fprintf(stderr, "Caught signal of type ");
     debug_dump(stderr, type, true);
+    LispVal *stream = make_lisp_integer(fileno(stderr));
     if (!NILP(detail)) {
         fprintf(stderr, "Details: ");
-        debug_dump(stderr, detail, true);
+        Fprintln(detail, Qt, stream);
     }
     fprintf(stderr, "\nBacktrace (toplevel comes last):\n");
     FOREACH(frame, backtrace) {
         fprintf(stderr, "  ");
-        debug_dump(stderr, frame, true);
+        Fprint(frame, Qt, stream);
+        if (SYMBOLP(HEAD(frame)) && !NILP(Fmacrop(HEAD(frame), Qnil))) {
+            fprintf(stderr, " ;; macro");
+        }
+        fputc('\n', stderr);
     }
     exit_status = 1;
     return Qnil;