kyle
/
kutils
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Still having problems with defclass!.

This commit is contained in:
Kyle 2015-04-12 06:59:30 -07:00
parent 7367fe65cc
commit 2e4476b36a
1 changed files with 35 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
kutils.lisp
View File

@ -56,6 +56,16 @@ 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))
@ -63,28 +73,39 @@ additional args provided to the lambda."
(mapcar #'closer-mop:slot-definition-name (mapcar #'closer-mop:slot-definition-name
(flatten (flatten
(mapcar #'closer-mop:class-slots (mapcar #'closer-mop:class-slots
(mapcar #'find-class supers))))) (mapcar (lambda (cls) (find-class cls t nil)) supers)))))
(defmacro defclass! (name superclass slots &body body) (defun superclasses (superclasses)
(let* ((docstring (when (stringp (first body)) (mapcar #'class-name
(list :documentation (first body)))) (mapcar (lambda (cls) (find-class cls t nil))
(supers (mapcar (compose #'class-name #'find-class #'mksymb) superclass)) superclasses)))
(defmacro defclass! (name superclass-spec slots &body body)
"Defines a new class and default constructor for name, based on the
superclasses and slots provided. If the first argument to body is a
string, it will be used as the class's docstring."
(let* ((name (mksymb name))
(docstring (if (stringp (first body))
(list :documentation (first body))
(list :documentation (format nil"Automatically generated class."))))
(supers (superclasses superclass-spec))
(body (if docstring (rest body) body)) (body (if docstring (rest body) body))
(ctor (mksymb "make-" name)) (ctor (mksymb "make-" name))
(all-slots (flatten (append (inherited-slots superclass) slots)))) (all-slots (flatten (append (inherited-slots supers) slots))))
(format t "supers: ~A~%" supers)
`(progn `(progn
(closer-mop:ensure-finalized (closer-mop:ensure-finalized
(defclass ,name ,supers (defclass ,name ,supers
,(loop for slot in slots collecting ,(loop for slot in slots collecting
(list slot (list slot :initarg (mksymb slot)
:initarg (mkkw slot) :accessor (mksymb name #\- slot)))
:accessor (mksymb name #\- slot)))
,docstring ,docstring
,@body)) ,@body))
(defun ,ctor (&key ,@(append (inherited-slots (defun ,ctor (&key ,@(append (inherited-slots supers)
superclass)
slots)) slots))
(make-instance ',name ,@(flatten (build-arg-list all-slots))))))) (make-instance (find-class ,name t nil)
,@(flatten (build-arg-list all-slots))))
t)))
;;; hash-table functions. ;;; hash-table functions.
@ -166,3 +187,5 @@ value :b, and :c stores the value :d.
(sethash (car elt) (cdr elt) m)) (sethash (car elt) (cdr elt) m))
m)) m))