Commit b2af4d89 authored by pfdietz's avatar pfdietz

Added more infrastructure for testing defclass.

parent f36e37b9
......@@ -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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment