Simplify with a loop.

This commit is contained in:
Kyle 2015-04-10 23:53:55 -07:00
parent 5f5b2e495e
commit 4ecb46794e
1 changed files with 4 additions and 14 deletions

View File

@ -56,16 +56,6 @@ additional args provided to the lambda."
"Create a keyword from its arguments." "Create a keyword from its arguments."
(intern (string (apply #'mksymb args)) "KEYWORD")) (intern (string (apply #'mksymb args)) "KEYWORD"))
(defun build-slot (class-name slot)
(let* ((slot-sym (mksymb slot))
(accessor (mksymb class-name "-" slot-sym)))
(list slot-sym
:initarg (mkkw slot-sym)
:accessor accessor)))
(defun build-slot-list (class-name &rest slots)
(mapcar (partial #'build-slot class-name) slots))
(defun build-arg-list (slots) (defun build-arg-list (slots)
(mapcar (lambda (slot) (list (mkkw slot) (mksymb slot))) slots)) (mapcar (lambda (slot) (list (mkkw slot) (mksymb slot))) slots))
@ -80,15 +70,15 @@ additional args provided to the lambda."
(list :documentation (first body)))) (list :documentation (first body))))
(supers (mapcar (compose #'class-name #'find-class #'mksymb) superclass)) (supers (mapcar (compose #'class-name #'find-class #'mksymb) superclass))
(body (if docstring (rest body) body)) (body (if docstring (rest body) body))
(slot-list (if (null slots)
'()
(apply #'build-slot-list name slots)))
(ctor (mksymb "make-" name)) (ctor (mksymb "make-" name))
(all-slots (flatten (append (inherited-slots superclass) slots)))) (all-slots (flatten (append (inherited-slots superclass) slots))))
`(progn `(progn
(closer-mop:ensure-finalized (closer-mop:ensure-finalized
(defclass ,name ,supers (defclass ,name ,supers
,slot-list ,(loop for slot in slots collecting
(list slot
:initarg (mkkw slot)
:accessor (mksymb name #\- slot)))
,docstring ,docstring
,@body)) ,@body))
(defun ,ctor (&key ,@(append (inherited-slots (defun ,ctor (&key ,@(append (inherited-slots