Skip to content
Snippets Groups Projects
Commit b2af4d89 authored by pfdietz's avatar pfdietz
Browse files

Added more infrastructure for testing defclass.

parent f36e37b9
No related branches found
No related tags found
No related merge requests found
......@@ -13,6 +13,35 @@
(defparameter *defclass-slot-writers* nil)
(defparameter *defclass-slot-accessors* nil)
(defstruct my-class
(name nil :type symbol)
(direct-superclass-names nil :type list)
(slots nil :type list)
(default-initargs nil :type list)
(metaclass 'standard-class :type symbol)
(documentation nil :type (or null string))
)
(defstruct my-slot
(name nil :type symbol)
(has-initform nil :type boolean)
initform
(initargs nil :type list)
(documentation nil :type (or null string))
(readers nil :type list)
(writers nil :type list)
(accessors nil :type list)
(allocation :instance :type (member :instance :class))
(type t)
)
(defparameter *my-classes* (make-hash-table)
"Hash table mapping names of classes defined using DEFCLASS-WITH-TESTS
to their my-class objects.")
(defun find-my-class (class-name)
(gethash class-name *my-classes*))
(defmacro defclass-with-tests
(&whole args
class-name superclasses slot-specifiers
......@@ -35,7 +64,7 @@
(assert (eql (length class-options)
(length (remove-duplicates class-options))))
(let* ((default-initargs (second (assoc :default-initargs class-options)))
(let* ((default-initargs (rest (assoc :default-initargs class-options)))
(metaclass (or (second (assoc :metaclass class-options))
'standard-class))
(doc (second (assoc :documentation class-options)))
......@@ -62,7 +91,7 @@
append (collect-properties slot-option :accessor)))
(allocations
(loop for slot-option in slot-options
collect (or (get :allocation slot-option)
collect (or (get slot-option :allocation)
:instance)))
(initargs
(loop for slot-option in slot-options
......@@ -87,6 +116,40 @@
(setf *defclass-slot-accessors*
(append accessors *defclass-slot-accessors*))
;;; Store away information about the class and its slots
;;; in a my-class object and associated my-slot objects.
(let* ((my-slots
(loop for name in slot-names
for slot-option in slot-options
for readers = (collect-properties slot-option :reader)
for writers = (collect-properties slot-option :writer)
for accessors = (collect-properties slot-option :accessor)
for documentation = (getf slot-option :documentation)
for initarg-list in initargs
for type-list in types
for initform-list in initforms
for allocation in allocations
collect
(make-my-slot
:name name
:has-initform (notnot initform-list)
:initform (first initform-list)
:documentation documentation
:readers readers
:writers writers
:accessors accessors
:type (if type-list (first type-list) t)
)))
(my-class-obj
(make-my-class :name class-name
:direct-superclass-names superclasses
:default-initargs default-initargs
:documentation doc
:metaclass metaclass
:slots my-slots)))
(setf (gethash class-name *my-classes*) my-class-obj))
`(progn
(eval-when (load eval compile)
......@@ -113,13 +176,31 @@
t))
(deftest ,(make-defclass-test-name class-name
"-INSTANCES-CLASS-IS-THIS-ONE")
(let ((class (find-class ',class-name)))
(eqlt (class-of (allocate-instance class)) class))
t)
"-ALLOCATE-INSTANCE")
(defclass-allocate-instance-test ',class-name ',slot-names)
nil)
)))
(defun defclass-allocate-instance-test (class-name slot-names)
(let* ((class (find-class class-name))
(instance (allocate-instance class)))
(append
(unless (eql (class-of instance) class)
(list (list 'not-instance-of class-name)))
(loop for slot in slot-names
when (slot-boundp instance slot)
collect (list 'is-bound slot))
(loop for slot in slot-names
(unless (equal (multiple-value-list
(notnot-mv (slot-exists-p instance slot)))
'(t))
(list 'does-not-exist slot)))
(let ((bad-slot #:foo))
(when (slot-exists-p instance bad-slot)
(list (list 'should-not-exist bad-slot))))
)))
(defmacro generate-slot-tests ()
"Generate generic tests from the read/writer/accessor functions
for slots from defclass-with-tests."
......@@ -142,3 +223,15 @@
'generic-function))
'(,sym))))
nil))))
#|
(defun compute-class-precedence-list (class-name)
"Compute the class precdence list for classes defined using
DEFCLASS-WITH-TESTS."
(let ((classes nil)
(classes-to-consider class-name))
;; Find all classes
|#
\ No newline at end of file
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment