Kenny Tilton 的 class 定義 defmodel

(defmacro defmd (class superclasses &rest mdspec)
`(defmodel ,class (,@superclasses model)
,@(let (definitargs class-options slots)
(loop with skip
for (spec next) on mdspec
if skip
do (setf skip nil)
else do (etypecase spec
(cons
(cond
((keywordp (car spec))
(assert (find (car spec) '(:documentation
:metaclass)))
(push spec class-options))
((find (cadr spec) '(:initarg :type :ps
:persistable :cell :initform :allocation :reader :writer :accessor
:documentation))
(push (apply 'defmd-canonicalize-slot spec)
slots))
(t ;; shortform (slotname initform &rest
slotdef-key-values)
(push (apply 'defmd-canonicalize-slot
(list* (car spec) :initform (cadr
spec) (cddr spec))) slots))))
(keyword
(setf definitargs (append definitargs (list spec
next)))
(setf skip t))
(symbol (push (list spec :initform nil
:initarg (intern (symbol-name
spec) :keyword)
:accessor spec) slots)))
finally
(return (list* (nreverse slots)
(delete nil
(list* `(:default-initargs ,@definitargs)
(nreverse class-options)))))))))