defclass-aux.lsp 12.2 KB
Newer Older
1 2 3 4 5 6 7 8 9
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon Mar 24 03:40:24 2003
;;;; Contains: Auxiliary functions for testing CLOS

(in-package :cl-test)

(defun make-defclass-test-name (&rest args)
  (intern (apply #'concatenate 'string (mapcar #'string args))
sds's avatar
sds committed
10
          (find-package :cl-test)))
11

12 13 14 15
(defparameter *defclass-slot-readers* nil)
(defparameter *defclass-slot-writers* nil)
(defparameter *defclass-slot-accessors* nil)

16 17 18 19 20 21 22
(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))
23 24 25 26 27 28
  ;; Internal fields
  (preds nil :type list)
  (succs nil :type list)
  (count 0 :type integer)
  (index nil)
  (min-pred-index 1000000)
29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50
  )

(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*))

51 52 53 54
;;; This macro will assume that all the superclasses have already
;;; been defined.  Tests will be written with defclass itself
;;; to test forward referenced superclasses

55 56
(defmacro defclass-with-tests
  (&whole args
sds's avatar
sds committed
57 58
          class-name superclasses slot-specifiers
          &rest class-options)
59

60 61 62
  (assert (typep class-name '(and (not null) symbol)))
  (assert (listp superclasses))
  (assert (every #'(lambda (x) (typep x '(and (not null) symbol)))
sds's avatar
sds committed
63
                 superclasses))
64 65
  (assert (listp slot-specifiers))
  (assert (every #'(lambda (s)
sds's avatar
sds committed
66 67
                     (or (symbolp s) (and (consp s) (symbolp (car s)))))
                 slot-specifiers))
68
  (assert (every #'(lambda (x)
sds's avatar
sds committed
69 70 71 72 73
                     (and (consp x)
                          (member (car x) '(:default-initargs
                                            :documentation
                                            :metaclass))))
                 class-options))
74
  (assert (eql (length class-options)
sds's avatar
sds committed
75
               (length (remove-duplicates class-options))))
76

77
  (let* ((default-initargs (rest (assoc :default-initargs class-options)))
sds's avatar
sds committed
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
         (metaclass (or (second (assoc :metaclass class-options))
                        'standard-class))
         (doc (second (assoc :documentation class-options)))
         (slot-names
          (loop for slot-spec in slot-specifiers
                collect (cond
                         ((symbolp slot-spec) slot-spec)
                         (t (assert (consp slot-spec))
                            (assert (symbolp (car slot-spec)))
                            (car slot-spec)))))
         (slot-options
          (loop for slot-spec in slot-specifiers
                collect (if (consp slot-spec)
                            (cdr slot-spec)
                          nil)))
         (readers
          (loop for slot-option in slot-options
                append (collect-properties slot-option :reader)))
         (writers
          (loop for slot-option in slot-options
                append (collect-properties slot-option :writer)))
         (accessors
          (loop for slot-option in slot-options
                append (collect-properties slot-option :accessor)))
         (allocations
          (loop for slot-option in slot-options
                collect (or (get slot-option :allocation)
                            :instance)))
         (initargs
          (loop for slot-option in slot-options
                collect (collect-properties slot-option :initarg)))
         (types
          (loop for slot-option in slot-options
                collect (collect-properties slot-option :type)))
         (initforms
          (loop for slot-option in slot-options
                collect (collect-properties slot-option :initform)))
         (class-var-name
          (intern (concatenate 'string "*CLASS-" (symbol-name class-name)
                               "-RETURNED-BY-DEFCLASS*")
                  (find-package :cl-test)))
         )
120 121

    (declare (ignorable readers writers accessors allocations
sds's avatar
sds committed
122 123
                        initargs types initforms default-initargs
                        doc))
124 125 126 127 128 129 130

    (assert (loop for e in types always (< (length e) 2)))
    (assert (loop for e in initforms always (< (length e) 2)))

    (setf *defclass-slot-readers* (append readers *defclass-slot-readers*))
    (setf *defclass-slot-writers* (append writers *defclass-slot-writers*))
    (setf *defclass-slot-accessors*
sds's avatar
sds committed
131
          (append accessors *defclass-slot-accessors*))
132

133 134
    ;;; Store away information about the class and its slots
    ;;; in a my-class object and associated my-slot objects.
sds's avatar
sds committed
135

136
    (let* ((my-slots
sds's avatar
sds committed
137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
           (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)))
165 166
      (setf (gethash class-name *my-classes*) my-class-obj))

167
    `(progn
168
       (declaim (special ,class-var-name))
sds's avatar
sds committed
169

170
       (report-and-ignore-errors (setq ,class-var-name
sds's avatar
sds committed
171
                                       (defclass ,@(cdr args))))
172 173

       (deftest ,(make-defclass-test-name class-name "-DEFCLASS-RETURNS-CLASS")
sds's avatar
sds committed
174 175
         (eqt (find-class ',class-name) ,class-var-name)
         t)
176 177

       (deftest ,(make-defclass-test-name class-name
sds's avatar
sds committed
178 179 180
                                          "-IS-IN-ITS-METACLASS")
         (notnot-mv (typep (find-class ',class-name) ',metaclass))
         t)
181 182

       ,@(when (eq metaclass 'standard-class)
sds's avatar
sds committed
183 184 185 186
           `((deftest ,(make-defclass-test-name class-name
                                                "S-ARE-STANDARD-OBJECTS")
               (subtypep* ',class-name 'standard-object)
               t t)))
187

188
       ,@(loop for slot-name in slot-names
sds's avatar
sds committed
189 190 191 192 193 194 195
               collect
               `(deftest ,(make-defclass-test-name class-name
                                                   "-HAS-SLOT-NAMED-"
                                                   slot-name)
                  (notnot-mv (slot-exists-p (make-instance ',class-name)
                                            ',slot-name))
                  t))
196 197

       (deftest ,(make-defclass-test-name class-name
sds's avatar
sds committed
198 199 200
                                          "-ALLOCATE-INSTANCE")
         (defclass-allocate-instance-test ',class-name ',slot-names)
         nil)
201 202 203

       )))

204 205
(defun defclass-allocate-instance-test (class-name slot-names)
  (let* ((class (find-class class-name))
sds's avatar
sds committed
206
         (instance (allocate-instance class)))
207 208 209 210
    (append
     (unless (eql (class-of instance) class)
       (list (list 'not-instance-of class-name)))
     (loop for slot in slot-names
sds's avatar
sds committed
211 212
           when (slot-boundp instance slot)
           collect (list 'is-bound slot))
213
     (loop for slot in slot-names
sds's avatar
sds committed
214 215 216 217
           unless (equal (multiple-value-list
                           (notnot-mv (slot-exists-p instance slot)))
                          '(t))
           collect (list 'does-not-exist slot))
218
     (let ((bad-slot '#:foo))
219
       (when (slot-exists-p instance bad-slot)
sds's avatar
sds committed
220
         (list (list 'should-not-exist bad-slot))))
221
     )))
sds's avatar
sds committed
222

223 224 225 226
(defmacro generate-slot-tests ()
  "Generate generic tests from the read/writer/accessor functions
   for slots from defclass-with-tests."
  (let ((funs (remove-duplicates
sds's avatar
sds committed
227 228 229
               (append *defclass-slot-readers*
                       *defclass-slot-writers*
                       *defclass-slot-accessors*))))
230 231
    `(progn
       (deftest class-readers/writers/accessors-are-generic-functions
sds's avatar
sds committed
232 233 234 235 236
         (loop for sym in ',funs
               unless (typep (symbol-function sym) 'generic-function)
               collect sym)
         nil)

237
       (deftest class-accessors-have-generic-setf-functions
sds's avatar
sds committed
238 239 240 241 242 243 244
         (append
          ,@(loop for sym in *defclass-slot-accessors*
                  collect
                  `(and (not (typep (function (setf ,sym))
                                    'generic-function))
                        '(,sym))))
         nil))))
245

246
(defun my-compute-class-precedence-list (class-name)
247 248
  "Compute the class precdence list for classes defined using
   DEFCLASS-WITH-TESTS."
249
  (let ((class-names nil)
sds's avatar
sds committed
250 251
        (class-names-to-consider (list class-name))
        classes)
252
    ;; Find all classes
253 254 255
    (loop
     while class-names-to-consider
     do (let ((name (pop class-names-to-consider)))
sds's avatar
sds committed
256 257 258 259 260 261 262
          (unless (member name class-names)
            (push name class-names)
            (let ((my-class (find-my-class name)))
              (assert my-class)
              (setq class-names-to-consider
                    (append (my-class-direct-superclass-names my-class)
                            class-names-to-consider))))))
263 264 265 266 267 268 269 270
    (setq class-names (reverse class-names))
    (assert (eq class-name (first class-names)))
    ;; class-names now contains class-name (which occurs first) and
    ;; the names of all its superclasses except T
    (setq classes (mapcar #'find-my-class class-names))
    ;; Walk the classes and set the predecessor links in the
    ;; class precedence DAG
    (loop for c in classes
sds's avatar
sds committed
271 272 273 274 275 276 277 278
          for dsns = (my-class-direct-superclass-names c)
          do (let ((pred c))
               (loop for superclass-name in dsns
                     for superclass = (find-my-class superclass-name)
                     do (push pred (my-class-preds superclass))
                     do (pushnew superclass (my-class-succs pred))
                     do (incf (my-class-count superclass))
                     do (setq pred superclass))))
279 280 281 282
    ;; The list candidates will contain all the classes
    ;; for which the count is zero.  These are the candidates
    ;; for selection as the next class in the class precedence list
    (let ((candidates (loop for c in classes
sds's avatar
sds committed
283 284 285 286
                            when (zerop (my-class-count c))
                            collect c))
          (n 0)
          (result nil))
287 288 289 290
      (assert (equal candidates (list (first classes))))
      (loop
       while candidates
       do (let* ((next (first candidates))
sds's avatar
sds committed
291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311
                 (min-pred-index (my-class-min-pred-index next)))
            (loop
             for c in (rest candidates)
             for c-min-pred-index = (my-class-min-pred-index c)
             do
             (cond
              ((< c-min-pred-index min-pred-index)
               (setq next c
                     min-pred-index c-min-pred-index))
              (t (assert (not (= c-min-pred-index min-pred-index))))))
            (setq candidates (remove next candidates))
            (setf (my-class-index next) (incf n))
            (push next result)
            (loop
             for succ in (my-class-succs next)
             do (decf (my-class-count succ))
             do (setf (my-class-min-pred-index succ)
                      (min (my-class-min-pred-index succ)
                           n))
             do (when (zerop (my-class-count succ))
                  (push succ candidates)))))
312 313 314
      (assert (eql (length result) (length classes)))
      (setq result (reverse result))
      (mapcar #'my-class-name result))))