Start work on objects

CMakeLists.txt

@@ -15,8 +15,8 @@ FetchContent_Declare(
 
 FetchContent_MakeAvailable(refcount)
 
-add_compile_options(-fsanitize=address,leak,undefined)
-add_link_options(-fsanitize=address,leak,undefined)
+# add_compile_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
-                           (list 'declare (list 'name name) 'macro)
-                           body)))))
-
-(defmacro defun (name args &rest body)
-  (list 'progn
         (list 'fset (list '\' name)
               (apply 'list 'lambda args
-                     (list 'declare (list 'name name))
-                     body))))
+                     (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))))))
+
+(defmacro defun (name args &rest body)
+  (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))
+                            (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
-                                                       (make-symbol "let")))
+                                  (list 'declare (list 'name '::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)
-  (unless (readablep obj)
-    (throw 'type-error '(readablep) obj))
-  (tcase obj
-    (symbol (print (quote-symbol-for-read obj :as-needed)))
-    (string (print (quote-string obj)))
-    (t (print obj)))
-  (when newline
-    (println)))
+(defmacro defvar (name value &opt doc)
+  (unless (symbolp name)
+    (throw 'type-error '(symbolp) name))
+  (unless (or (not doc) (stringp doc))
+    (throw 'type-error '(null stringp) doc))
+  (apply 'list 'progn
+         (list 'make-symbol-special (list '\' name))
+         (list 'setq name value)
+         (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.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 {
@@ -161,6 +162,15 @@ typedef struct {
     LispVal *imported; // list of (package . (str -> bool))
 } LispPackage;
 
+typedef struct {
+    LISP_OBJECT_HEADER;
+
+    LispVal *record_type;
+    LispVal *function;
+    size_t length;
+    LispVal **data;
+} LispRecord;
+
 // #######################
 // # nil, unbound, and t #
 // #######################
@@ -188,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 #
 // ############################
@@ -203,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)
@@ -216,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)
 
@@ -250,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) \
@@ -258,7 +284,9 @@ inline static bool NUMBERP(LispVal *v) {
     extern LispVal *Q##c_name
 // The args and doc fields are filled when the function is registered
 #define _INTERNAL_DEFUN_EXTENDED(macrop, du, c_name, lisp_name, c_args, \
-                                 static_kw)                             \
+                                 static_kw, lisp_args, doc_cstr)        \
+    static const char _F##c_name##lisp_args_cstr[] = lisp_args;         \
+    static const char _F##c_name##doccstr[] = doc_cstr;                 \
     static_kw LispVal *F##c_name c_args;                                \
     DEF_STATIC_STRING(_Q##c_name##_fnnamestr, lisp_name);               \
     static LispSymbol _Q##c_name;                                       \
@@ -283,21 +311,29 @@ 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
-#define DEFUN(c_name, lisp_name, c_args) \
-    _INTERNAL_DEFUN_EXTENDED(false, false, c_name, lisp_name, c_args, )
-#define DEFUN_DISTINGUISHED(c_name, lisp_name, c_args) \
-    _INTERNAL_DEFUN_EXTENDED(false, true, c_name, lisp_name, c_args, )
-#define DEFMACRO(c_name, lisp_name, c_args) \
-    _INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, )
-#define STATIC_DEFUN(c_name, lisp_name, c_args) \
-    _INTERNAL_DEFUN_EXTENDED(false, false, c_name, lisp_name, c_args, static)
-#define STATIC_DEFMACRO(c_name, lisp_name, c_args) \
-    _INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, static)
+#define DEFUN(c_name, lisp_name, c_args, lisp_args, doc_cstr)           \
+    _INTERNAL_DEFUN_EXTENDED(false, false, c_name, lisp_name, c_args, , \
+                             lisp_args, doc_cstr)
+#define DEFUN_DISTINGUISHED(c_name, lisp_name, c_args, lisp_args, doc_cstr) \
+    _INTERNAL_DEFUN_EXTENDED(false, true, c_name, lisp_name, c_args, ,      \
+                             lisp_args, doc_cstr)
+#define DEFMACRO(c_name, lisp_name, c_args, lisp_args, doc_cstr)       \
+    _INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, , \
+                             lisp_args, doc_cstr)
+#define STATIC_DEFUN(c_name, lisp_name, c_args, lisp_args, doc_cstr)          \
+    _INTERNAL_DEFUN_EXTENDED(false, false, c_name, lisp_name, c_args, static, \
+                             lisp_args, doc_cstr)
+#define STATIC_DEFMACRO(c_name, lisp_name, c_args, lisp_args, doc_cstr)      \
+    _INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, static, \
+                             lisp_args, doc_cstr)
 
 // registration
 #define REGISTER_SYMBOL_NOINTERN(sym)                        \
@@ -312,21 +348,26 @@ 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, args, docstr)           \
-    REGISTER_SYMBOL_NOINTERN(name);                            \
-    {                                                          \
-        LispVal *obj = ((LispSymbol *) Q##name)->function;     \
-        refcount_init_static(obj);                             \
-        ((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \
-        LispVal *src = STATIC_STRING(args);                    \
-        LispVal *a = Fread(src, system_package);               \
-        set_function_args((LispFunction *) (obj), a);          \
-        refcount_unref(src);                                   \
-        refcount_unref(a);                                     \
+#define REGISTER_STATIC_FUNCTION(name)                                    \
+    REGISTER_SYMBOL_NOINTERN(name);                                       \
+    {                                                                     \
+        LispVal *obj = ((LispSymbol *) Q##name)->function;                \
+        refcount_init_static(obj);                                        \
+        ((LispFunction *) (obj))->doc = STATIC_STRING(_F##name##doccstr); \
+        LispVal *src = STATIC_STRING(_F##name##lisp_args_cstr);           \
+        LispVal *a = Fread(src, system_package);                          \
+        set_function_args((LispFunction *) (obj), a);                     \
+        refcount_unref(src);                                              \
+        refcount_unref(a);                                                \
     }
-#define REGISTER_FUNCTION(fn, args, docstr)                         \
-    REGISTER_STATIC_FUNCTION(fn, args, docstr);                     \
+#define REGISTER_FUNCTION(fn)                                       \
+    REGISTER_STATIC_FUNCTION(fn);                                   \
     ((LispSymbol *) Q##fn)->package = refcount_ref(system_package); \
     puthash(((LispPackage *) system_package)->obarray,              \
             LISPVAL(((LispSymbol *) Q##fn)->name), Q##fn);
@@ -376,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);
 
@@ -396,12 +438,22 @@ 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 #
 // ##################################
-DECLARE_FUNCTION(eval_in_env, (LispVal * form, LispVal *lexenv));
-DECLARE_FUNCTION(eval, (LispVal * form));
+DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv));
 DECLARE_FUNCTION(funcall, (LispVal * function, LispVal *rest));
 DECLARE_FUNCTION(apply, (LispVal * function, LispVal *rest));
 DECLARE_FUNCTION(macroexpand_1, (LispVal * form, LispVal *lexical_macros));
@@ -490,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));
@@ -507,7 +567,7 @@ DECLARE_FUNCTION(quote_symbol_name, (LispVal * name));
 DECLARE_FUNCTION(symbol_accessible_p, (LispVal * symbol, LispVal *package));
 extern LispVal *Qkw_as_needed;
 DECLARE_FUNCTION(quote_symbol_for_read,
-                 (LispVal * target, LispVal *include_package));
+                 (LispVal * target, LispVal *include_package, LispVal *from));
 LispVal *intern(const char *name, size_t length, bool take, LispVal *package,
                 bool included_too);
 
@@ -521,7 +581,7 @@ DECLARE_FUNCTION(hash_table_count, (LispVal * table));
 DECLARE_FUNCTION(maphash, (LispVal * func, LispVal *table));
 DECLARE_FUNCTION(puthash, (LispVal * table, LispVal *key, LispVal *value));
 DECLARE_FUNCTION(gethash, (LispVal * table, LispVal *key, LispVal *def));
-DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key));
+DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key, LispVal *def));
 struct HashtableDataArray {
     size_t size;
     struct HashtableEntry *entries;
@@ -531,7 +591,7 @@ void free_hash_table_data_array(void *data);
 // Don't ref their return value
 LispVal *puthash(LispVal *table, LispVal *key, LispVal *value);
 LispVal *gethash(LispVal *table, LispVal *key, LispVal *def);
-LispVal *remhash(LispVal *table, LispVal *key);
+void remhash(LispVal *table, LispVal *key);
 
 // #####################
 // # Numeric Functions #
@@ -570,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(println, (LispVal * obj, LispVal *stream));
+DECLARE_FUNCTION(print, (LispVal * obj, LispVal *readably, LispVal *stream));
+DECLARE_FUNCTION(println, (LispVal * obj, LispVal *readably, LispVal *stream));
 
 // ########################
 // # Lexenv and the Stack #
@@ -599,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;
@@ -677,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

@@ -3,8 +3,8 @@
 
 static int exit_status = 0;
 
-STATIC_DEFUN(toplevel_exit_handler, "toplevel-exit-handler",
-             (LispVal * except)) {
+STATIC_DEFUN(toplevel_exit_handler, "toplevel-exit-handler", (LispVal * except),
+             "(except)", "Internal function.") {
     LispVal *detail = TAIL(HEAD(except));
     if (NILP(detail) || NILP(HEAD(detail))) {
         exit_status = 0;
@@ -17,20 +17,25 @@ STATIC_DEFUN(toplevel_exit_handler, "toplevel-exit-handler",
 }
 
 STATIC_DEFUN(toplevel_error_handler, "toplevel-error-handler",
-             (LispVal * except)) {
+             (LispVal * except), "(except)", "Internal function.") {
     LispVal *type = HEAD(HEAD(except));
     LispVal *detail = TAIL(HEAD(except));
     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;
@@ -56,8 +61,8 @@ int main(int argc, const char **argv) {
     fclose(in);
     lisp_init();
     REGISTER_SYMBOL(toplevel_read);
-    REGISTER_STATIC_FUNCTION(toplevel_error_handler, "(e)", "");
-    REGISTER_STATIC_FUNCTION(toplevel_exit_handler, "(e)", "");
+    REGISTER_STATIC_FUNCTION(toplevel_error_handler);
+    REGISTER_STATIC_FUNCTION(toplevel_exit_handler);
     size_t pos = 0;
     WITH_PUSH_FRAME(Qtoplevel, Qnil, false, {
         the_stack->hidden = false;
@@ -92,7 +97,7 @@ int main(int argc, const char **argv) {
                     && list_length(tv) == 2) {
                     refcount_unref(Fset_current_package(HEAD(TAIL(tv))));
                 } else {
-                    refcount_unref(Feval(tv)); //
+                    refcount_unref(Feval(tv, the_stack->lexenv)); //
                 }
             });
         }

src/read.c

@@ -575,7 +575,8 @@ size_t read_from_buffer(const char *text, size_t length, LispVal *package,
     return state.off;
 }
 
-DEFUN(read, "read", (LispVal * source, LispVal *package)) {
+DEFUN(read, "read", (LispVal * source, LispVal *package), "(source package)",
+      "Read a single form from SOURCE.") {
     LispString *str = (LispString *) source;
     CHECK_TYPE(TYPE_STRING, source);
     struct ReadState state = {
@@ -600,3 +601,7 @@ DEFUN(read, "read", (LispVal * source, LispVal *package)) {
         return res;
     }
 }
+
+void register_reader_functions(void) {
+    REGISTER_FUNCTION(read);
+}

src/read.h

@@ -13,4 +13,6 @@ size_t read_from_buffer(const char *text, size_t length, LispVal *package,
 
 DECLARE_FUNCTION(read, (LispVal * source, LispVal *package));
 
+void register_reader_functions(void);
+
 #endif