1 files changed, 101 insertions, 0 deletions
diff --git a/def.lisp b/def.lisp
new file mode 100644
index 0000000..9944505
--- /dev/null
+++ b/def.lisp
@@ -0,0 +1,101 @@
+;;;; def.lisp
+
+(in-package #:def)
+
+(defmacro var (name &key doc (init nil initp))
+  "DEFVAR with optional documentation and optional initform. Lets you
+easily document uninitialized special variables."
+  (assert (good-muffed-var-name-p name) (name)
+          "Special variable ~s is not wearing earmuffs :(")
+  `(progn
+     (defvar ,name)
+     ,@(when initp
+         (list `(setf ,name ,init)))
+     ,@(when doc
+         (list `(setf (documentation ',name 'cl:variable) ,doc)))))
+
+(defmacro const (name value &optional doc)
+  "Define a constant in a way that is redefinable whenever the form is
+reevaluated."
+  (assert (good-muffed-var-name-p name :muffer "+"))
+  `(progn
+     (handler-bind ((error
+                      (lambda (&rest ignore)
+                        (declare (ignore ignore))
+                        (invoke-restart 'cl:continue))))
+       (makunbound ',name))
+     (defconstant ,name ,value ,@(when doc (list doc)))))
+
+(defmacro class (name (&rest supers) &body slots-and-options)
+  "Define a class. 
+
+SLOTS-AND-OPTIONS := (SLOT-SPEC1 ... SLOT-SPECN . CLASS-OPTIONS)
+
+Each SLOT-SPEC is a list of slot names followed by keyword slot
+options, E.g:
+
+(X Y Z :type real :initform 0)
+
+Would expand into three slot definitions 
+(X :accessor X :initarg :X :type real :initform 0)
+(Y :accessor Y :initarg :Y :type real :initform 0)
+(Z :accessor Z :initarg :Z :type real :initform 0)
+
+There are a few flag style slot definition arguments. Flags do not
+have an value after them, all flags must come before other options. Flags are:
+  :prefix - prefix the accessor by the class name
+  :ro     - only define a reader 
+  :wo     - only define a writer 
+
+By default an accessor is defined.
+
+CLASS-OPTIONS is a PLIST of class options.
+
+E.g.
+
+(def:class pt (thing)
+  (x y z :prefix :type real :initform 0) 
+  (label :type :string)
+"
+  (labels
+      ((make-accessor-name (slot &optional prefix?)
+         (if prefix?
+             (intern (format nil "~a-~a" name slot))
+             slot))
+       (singlep (x)
+         (find x '(:prefix :ro :wo) :test #'eq))
+       (parse-slot-spec-expr (expr)
+         " (names ... &key kwargs)"
+         (multiple-value-bind (slot-names kwargs) (take-until #'keywordp expr)
+           (multiple-value-bind (singles kwargs) (partition #'singlep kwargs)
+             (let ((prefix-accessor? (find ':prefix singles :test #'eq))
+                   (read-only? (find ':ro singles :test #'eq))
+                   (write-only? (find ':wo singles :test #'eq)))
+               (assert (not (and read-only? write-only?)) ()
+                       "A slot cannot be both read-only (:ro) and write-only (:wo).")
+               (loop
+                 :with accessor-type := (cond (read-only? :reader)
+                                              (write-only? :writer)
+                                              (t :accessor))
+                 :for slot :in slot-names
+                 :collect `(,slot
+                            ,accessor-type ,(make-accessor-name slot prefix-accessor?)
+                            :initarg ,(alexandria:make-keyword slot)
+                            ,@kwargs))))))
+
+       (parse-class-options (kwargs)
+         (loop :for (key val . more) :on kwargs :by #'cddr
+               :collect (list key val))))
+
+    (let* ((slot-defs (loop :for expr :in slots-and-options
+                            :while (listp expr)
+                            :append (parse-slot-spec-expr expr)))
+           (options (parse-class-options
+                     (nth-value 1 (take-until #'keywordp slots-and-options)))))
+
+      `(defclass ,name ,supers
+         (,@slot-defs)
+         ,@options))))
+
+
+