structure-00.lsp 21 KB
Newer Older
1 2 3 4 5 6 7 8 9
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat May  9 11:21:25 1998
;;;; Contains: Common code for creating structure tests

(in-package :cl-test)
(declaim (optimize (safety 3)))

(defun make-struct-test-name (structure-name n)
10 11 12
  ;; (declare (type (or string symbol character) structure-name)
  ;;  (type fixnum n))
  (assert (typep structure-name '(or string symbol character)))
13
  ;; (assert (typep n 'fixnum))
14 15
  (setf structure-name (string structure-name))
  (intern (concatenate 'string
sds's avatar
sds committed
16 17 18
            structure-name
            "/"
            (princ-to-string n))))
19 20

(defun make-struct-p-fn (structure-name)
21
  (assert (typep structure-name '(or string symbol character)))
22 23
  (setf structure-name (string structure-name))
  (intern (concatenate 'string
sds's avatar
sds committed
24 25
            structure-name
            (string '#:-p))))
26 27

(defun make-struct-copy-fn (structure-name)
28 29 30
  (assert (typep structure-name '(or string symbol character)))
  (setf structure-name (string structure-name))
  (intern (concatenate 'string
sds's avatar
sds committed
31 32
                       (string '#:copy-)
                       structure-name)))
33

34
(defun make-struct-field-fn (conc-name field-name)
35
  "Make field accessor for a field in a structure"
36 37 38 39 40 41 42 43
  (cond
   ((null conc-name) field-name)
   (t
    (assert (typep conc-name '(or string symbol character)))
    (assert (typep field-name '(or string symbol character)))
    (setf conc-name (string conc-name))
    (setf field-name (string field-name))
    (intern (concatenate 'string conc-name field-name)))))
44 45 46

(defun make-struct-make-fn (structure-name)
  "Make the make- function for a structure"
47
  (assert (typep structure-name '(or string symbol character)))
48 49
  (setf structure-name (string structure-name))
  (intern (concatenate 'string
sds's avatar
sds committed
50
            (string '#:make-) structure-name)))
51 52 53 54 55

(defun create-instance-of-type (type)
  "Return an instance of a type.  Signal an error if
  it can't figure out a value for the type."
  (cond
56
   ((eqt type t)  ;; anything
57
    'a)
58
   ((eqt type 'symbol)
59
    'b)
60 61 62 63 64 65 66 67
   ((eqt type 'null) nil)
   ((eqt type 'boolean) t)
   ((eqt type 'keyword) :foo)
   ((eqt type nil) (error "Cannot obtain element of type ~S~%" type))
   ((eqt type 'cons) (cons 'a 'b))
   ((eqt type 'list) (list 1 2 3))
   ((eqt type 'fixnum) 17)
   ((eqt type 'bignum)
68 69
    (let ((x 1))
      (loop until (typep x 'bignum)
sds's avatar
sds committed
70
          do (setq x (* 2 x)))
71 72
      x))
   ((and (symbolp type)
sds's avatar
sds committed
73
         (typep type 'structure-class))
74
    (let ((make-fn
sds's avatar
sds committed
75 76
           (intern (concatenate 'string (string '#:make-) (symbol-name type))
                   (symbol-package type))))
77
      (eval (list make-fn))))
78 79
   ((eqt type 'character) #\w)
   ((eqt type 'base-char) #\z)
80
   ((member type '(integer unsigned-byte signed-byte)) 35)
81
   ((eqt type 'bit) 1)
82
   ((and (consp type)
sds's avatar
sds committed
83 84 85 86 87
         (consp (cdr type))
         (consp (cddr type))
         (null (cdddr type))
         (eqt (car type) 'integer)
         (integerp (second type)))
88 89 90 91
    (second type))
   ((member type '(float single-float long-float double-float short-float))
    0.0)
   ((and (consp type)
sds's avatar
sds committed
92 93
         (eqt (car type) 'member)
         (consp (cdr type)))
94 95
    (second type))
   ((and (consp type)
sds's avatar
sds committed
96 97
         (eqt (car type) 'or)
         (consp (second type)))
98 99 100
    (create-instance-of-type (second type)))
   (t (error "Cannot generate element for type ~S~%" type))))

101 102
(defun find-option (option-list option &optional default)
  (loop for opt in option-list
sds's avatar
sds committed
103 104 105 106 107
        when (or (eq opt option)
                 (and (consp opt)
                      (eq (car opt) option)))
        return opt
        finally (return default)))
108

109 110 111
(defvar *defstruct-with-tests-names* nil
  "Names of structure types defined with DEFSRUCT-WITH-TESTS.")

112
#|
113 114 115 116 117 118
(defvar *subtypep-works-with-classes* t
  "Becomes NIL if SUBTYPEP doesn't work with classes.  We test this first to avoid
   repeated test failures that cause GCL to bomb.")

(deftest subtypep-works-with-classes
  (let ((c1 (find-class 'vector)))
119
    ;; (setq *subtypep-works-with-classes* nil)
120 121
    (subtypep c1 'vector)
    (subtypep 'vector c1)
122
    ;; (setq *subtypep-works-with-classes* t))
123 124 125 126 127 128 129 130
  t)

(defvar *typep-works-with-classes* t
  "Becomes NIL if TYPEP doesn't work with classes.  We test this first to avoid
   repeated test failures that cause GCL to bomb.")

(deftest typep-works-with-classes
  (let ((c1 (find-class 'vector)))
131
    ;; (setq *typep-works-with-classes* nil)
132
    (typep #(0 0) c1)
133
    ;; (setq *typep-works-with-classes* t))
134
  t)
135
|#
136

137 138 139 140 141 142 143 144 145 146
;;
;; There are a number of standardized tests for
;; structures.  The following macro generates the
;; structure definition and the tests.
;;

(defmacro defstruct-with-tests
    (name-and-options &body slot-descriptions-and-documentation)
"Construct standardized tests for a defstruct, and also
do the defstruct."
147 148 149 150
  (defstruct-with-tests-fun name-and-options
    slot-descriptions-and-documentation))

(defun defstruct-with-tests-fun (name-and-options
sds's avatar
sds committed
151
                                 slot-descriptions-and-documentation)
152 153
  ;; Function called from macro defstruct-with-tests
  (let* (
sds's avatar
sds committed
154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264
         ;; Either NIL or the documentation string for the structure
         (doc-string
          (when (and (consp slot-descriptions-and-documentation)
                     (stringp (car slot-descriptions-and-documentation)))
            (car slot-descriptions-and-documentation)))

         ;; The list of slot descriptions that follows either the
         ;; name and options or the doc string
         (slot-descriptions
          (if doc-string (cdr slot-descriptions-and-documentation)
            slot-descriptions-and-documentation))

         ;; The name of the structure (should be a symbol)
         (name (if (consp name-and-options)
                   (car name-and-options)
                 name-and-options))

         ;; The options list, or NIL if there were no options
         (options (if (consp name-and-options)
                      (cdr name-and-options)
                    nil))

         ;; List of symbols that are the names of the slots
         (slot-names
          (loop
           for x in slot-descriptions collect
           (if (consp x) (car x) x)))

         ;; List of slot types, if any
         (slot-types
          (loop
           for x in slot-descriptions collect
           (if (consp x)
               (getf (cddr x) :type :none)
             :none)))

         ;; read-only flags for slots
         (slot-read-only
          (loop
           for x in slot-descriptions collect
           (and (consp x)
                (getf (cddr x) :read-only))))

         ;; Symbol obtained by prepending MAKE- to the name symbol
         (make-fn (make-struct-make-fn name))

         ;; The type option, if specified
         (type-option (find-option options :type))
         (struct-type (second type-option))

         (named-option (find-option options :named))
         (include-option (find-option options :include))

         ;; The :predicate option entry from OPTIONS, or NIL if none
         (predicate-option (find-option options :predicate))

         ;; The name of the -P function, either the default or the
         ;; one specified in the :predicate option
         (p-fn-default (make-struct-p-fn name))
         (p-fn (cond
                ((and type-option (not named-option)) nil)
                ((or (eq predicate-option :predicate)
                     (null (cdr predicate-option)))
                 p-fn-default)
                ((cadr predicate-option) (cadr predicate-option))
                (t nil)))

         ;; The :copier option, or NIL if no such option specified
         (copier-option (find-option options :copier))
         ;; The name of the copier function, either the default or
         ;; one speciefied in the :copier option
         (copy-fn-default (make-struct-copy-fn name))
         (copy-fn (cond
                   ((or (eq copier-option :copier)
                        (null (cdr copier-option)))
                    copy-fn-default)
                   ((cadr copier-option) (cadr copier-option))
                   (t nil)))

         ;; The :conc-name option, or NIL if none specified
         (conc-option (find-option options :conc-name))
         ;; String to be prepended to slot names to get the
         ;; slot accessor function
         (conc-prefix-default (concatenate 'string (string name) "-"))
         (conc-prefix (cond
                       ((null conc-option)
                        conc-prefix-default)
                       ((or (eq conc-option :conc-name)
                            (null (cadr conc-option)))
                        nil)
                       (t (string (cadr conc-option)))))

         (initial-offset-option (find-option options :initial-offset))
         (initial-offset (second initial-offset-option))

         ;; Accessor names
         (field-fns
          (loop for slot-name in slot-names
                collect (make-struct-field-fn conc-prefix slot-name)))

         ;; a list of initial values
         (initial-value-alist
          (loop
           for slot-desc in slot-descriptions
           for slot-name in slot-names
           for type      in slot-types
           for i from 1
           collect (if (not (eq type :none))
                       (cons slot-name (create-instance-of-type type))
                     (cons slot-name (defstruct-maketemp name "SLOTTEMP" i)))))
         )
265
    (declare (ignorable initial-offset))
266
    ;; Build the tests in an eval-when form
267 268 269
    `(eval-when (:load-toplevel :compile-toplevel :execute)

       (report-and-ignore-errors
sds's avatar
sds committed
270 271 272 273 274
        (eval '(defstruct ,name-and-options
                 ,@slot-descriptions-and-documentation))
        ,(unless (or type-option include-option)
           `(pushnew ',name *defstruct-with-tests-names*))
        nil)
275 276 277

       ;; Test that structure is of the correct type
       (deftest ,(make-struct-test-name name 1)
sds's avatar
sds committed
278 279 280 281 282 283 284
         (and (fboundp (quote ,make-fn))
              (functionp (function ,make-fn))
              (symbol-function (quote ,make-fn))
              (typep (,make-fn) (quote ,(if type-option struct-type
                                          name)))
              t)
         t)
285 286 287

       ;; Test that the predicate exists
       ,@(when p-fn
sds's avatar
sds committed
288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303
           `((deftest ,(make-struct-test-name name 2)
               (let ((s (,make-fn)))
                 (and (fboundp (quote ,p-fn))
                      (functionp (function ,p-fn))
                      (symbol-function (quote ,p-fn))
                      (notnot (funcall #',p-fn s))
                      (notnot-mv (,p-fn s))
                      ))
               t)
             (deftest ,(make-struct-test-name name "ERROR.1")
               (signals-error (,p-fn) program-error)
               t)
             (deftest ,(make-struct-test-name name "ERROR.2")
               (signals-error (,p-fn (,make-fn) nil) program-error)
               t)
             ))
304 305 306

       ;; Test that the elements of *universe* are not
       ;; of this type
307
       ,@(when p-fn
sds's avatar
sds committed
308 309 310
           `((deftest ,(make-struct-test-name name 3)
               (count-if (function ,p-fn) *universe*)
               0)))
311
       ,@(unless type-option
sds's avatar
sds committed
312 313 314 315
           `((deftest ,(make-struct-test-name name 4)
               (count-if (function (lambda (x) (typep x (quote ,name))))
                         *universe*)
               0)))
316 317 318

       ;; Check that the fields can be read after being initialized
       (deftest ,(make-struct-test-name name 5)
sds's avatar
sds committed
319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338
         ,(let ((inits nil)
                (tests nil)
                (var (defstruct-maketemp name "TEMP-5")))
            (loop
             for (slot-name . initval) in initial-value-alist
             for field-fn in field-fns
             do
             (setf inits
                   (list* (intern (string slot-name) "KEYWORD")
                          (list 'quote initval)
                          inits))
             (push `(and
                     (eqlt (quote ,initval)
                           (,field-fn ,var))
                     (eqlt (quote ,initval)
                           (funcall #',field-fn ,var)))
                   tests))
            `(let ((,var (,make-fn . ,inits)))
               (and ,@tests t)))
         t)
339

340
       (deftest ,(make-struct-test-name name "ERROR.3")
sds's avatar
sds committed
341 342 343 344 345 346 347 348 349 350 351 352
         (remove nil
                 (list
                  ,@(loop
                     for (slot-name . initval) in initial-value-alist
                     for field-fn in field-fns
                     collect
                     `(multiple-value-bind
                          (x val)
                          (signals-error (,field-fn) program-error)
                        (unless x
                          (list ',slot-name ',field-fn val))))))
         nil)
353 354

       (deftest ,(make-struct-test-name name "ERROR.4")
sds's avatar
sds committed
355 356 357 358 359 360 361 362 363 364 365 366 367
         (remove nil
                 (list
                  ,@(loop
                     for (slot-name . initval) in initial-value-alist
                     for field-fn in field-fns
                     collect
                     `(multiple-value-bind
                          (x val)
                          (signals-error (,field-fn (,make-fn) nil)
                                         program-error)
                        (unless x
                          (list ',slot-name ',field-fn val))))))
         nil)
368

369 370
       ;; Check that two invocations return different structures
       (deftest ,(make-struct-test-name name 6)
sds's avatar
sds committed
371 372
         (eqt (,make-fn) (,make-fn))
         nil)
373 374 375

       ;; Check that we can setf the fields
       (deftest ,(make-struct-test-name name 7)
sds's avatar
sds committed
376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391
         ,(let* ((var (defstruct-maketemp name "TEMP-7-1"))
                 (var2 (defstruct-maketemp name "TEMP-7-2"))
                 (tests
                  (loop
                   for (slot-name . initval) in initial-value-alist
                   for read-only-p in slot-read-only
                   for slot-desc in slot-descriptions
                   for field-fn in field-fns
                   unless read-only-p
                   collect
                   `(let ((,var2 (quote ,initval)))
                      (setf (,field-fn ,var) ,var2)
                      (eqlt (,field-fn ,var) ,var2)))))
            `(let ((,var (,make-fn)))
               (and ,@tests t)))
         t)
392 393 394

       ;; Check that the copy function exists
       ,@(when copy-fn
sds's avatar
sds committed
395 396 397 398 399 400 401 402 403 404 405 406 407
           `((deftest ,(make-struct-test-name name 8)
               (and (fboundp (quote ,copy-fn))
                    (functionp (function ,copy-fn))
                    (symbol-function (quote ,copy-fn))
                    t)
               t)
             (deftest ,(make-struct-test-name name "ERROR.5")
               (signals-error (,copy-fn) program-error)
               t)
             (deftest ,(make-struct-test-name name "ERROR.6")
               (signals-error (,copy-fn (,make-fn) nil) program-error)
               t)
             ))
408 409 410

       ;; Check that the copy function properly copies fields
       ,@(when copy-fn
sds's avatar
sds committed
411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435
           `((deftest ,(make-struct-test-name name 9)
               ,(let* ((var 'XTEMP-9)
                       (var2 'YTEMP-9)
                       (var3 'ZTEMP-9))
                  `(let ((,var (,make-fn
                                ,@(loop
                                   for (slot-name . initval)
                                   in initial-value-alist
                                   nconc (list (intern (string slot-name)
                                                       "KEYWORD")
                                               `(quote ,initval))))))
                     (let ((,var2 (,copy-fn ,var))
                           (,var3 (funcall #',copy-fn ,var)))
                       (and
                        (not (eqlt ,var ,var2))
                        (not (eqlt ,var ,var3))
                        (not (eqlt ,var2 ,var3))
                        ,@(loop
                           for (slot-name . nil) in initial-value-alist
                           for fn in field-fns
                           collect
                           `(and (eqlt (,fn ,var) (,fn ,var2))
                                 (eqlt (,fn ,var) (,fn ,var3))))
                        t))))
               t)))
436 437 438 439 440 441

       ;; When the predicate is not the default, check
       ;; that the default is not defined.  Tests should
       ;; be designed so that this function name doesn't
       ;; collide with anything else.
       ,@(unless (eq p-fn p-fn-default)
sds's avatar
sds committed
442 443 444
           `((deftest ,(make-struct-test-name name 10)
               (fboundp (quote ,p-fn-default))
               nil)))
445 446 447 448 449 450

       ;; When the copy function name is not the default, check
       ;; that the default function is not defined.  Tests should
       ;; be designed so that this name is not accidently defined
       ;; for something else.
       ,@(unless (eq copy-fn copy-fn-default)
sds's avatar
sds committed
451 452 453
           `((deftest ,(make-struct-test-name name 11)
               (fboundp (quote ,copy-fn-default))
               nil)))
454 455 456 457

       ;; When there are read-only slots, test that the SETF
       ;; form for them is not FBOUNDP
       ,@(when (loop for x in slot-read-only thereis x)
sds's avatar
sds committed
458 459 460 461 462 463 464 465 466
           `((deftest ,(make-struct-test-name name 12)
               (and
                ,@(loop for slot-name in slot-names
                        for read-only in slot-read-only
                        for field-fn in field-fns
                        when read-only
                        collect `(not-mv (fboundp '(setf ,field-fn))))
                t)
               t)))
467 468 469 470

       ;; When the structure is a true structure type, check that
       ;; the various class relationships hold
       ,@(unless type-option
sds's avatar
sds committed
471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513
           `(
             (deftest ,(make-struct-test-name name 13)
               (notnot-mv (typep (,make-fn) (find-class (quote ,name))))
               t)
             (deftest ,(make-struct-test-name name 14)
               (let ((class (find-class (quote ,name))))
                 (notnot-mv (typep class 'structure-class)))
               t)
             (deftest ,(make-struct-test-name name 15)
               (notnot-mv (typep (,make-fn) 'structure-object))
               t)
             (deftest ,(make-struct-test-name name 16)
               (loop for type in *disjoint-types-list*
                     unless (and
                             (equalt (multiple-value-list
                                      (subtypep* type (quote ,name)))
                                     '(nil t))
                             (equalt (multiple-value-list
                                      (subtypep* (quote ,name) type))
                                     '(nil t)))
                     collect type)
               nil)
             (deftest ,(make-struct-test-name name 17)
               (let ((class (find-class (quote ,name))))
                 (loop for type in *disjoint-types-list*
                       unless (and
                               (equalt (multiple-value-list
                                        (subtypep* type class))
                                       '(nil t))
                               (equalt (multiple-value-list
                                        (subtypep* class type))
                                       '(nil t)))
                       collect type))
               nil)
             (deftest ,(make-struct-test-name name "15A")
               (let ((class (find-class (quote ,name))))
                 (notnot-mv (subtypep class 'structure-object)))
               t t)
             (deftest ,(make-struct-test-name name "15B")
               (notnot-mv (subtypep (quote ,name) 'structure-object))
               t t)

             ))
514

515 516 517
       ;;; Documentation tests

       ,(when doc-string
sds's avatar
sds committed
518 519 520 521
          `(deftest ,(make-struct-test-name name 18)
             (let ((doc (documentation ',name 'structure)))
               (or (null doc) (equalt doc ',doc-string)))
             t))
522 523

       ,(when (and doc-string (not type-option))
sds's avatar
sds committed
524 525 526 527
          `(deftest ,(make-struct-test-name name 19)
             (let ((doc (documentation ',name 'type)))
               (or (null doc) (equalt doc ',doc-string)))
             t))
pfdietz's avatar
pfdietz committed
528 529 530 531

       ;; Test that COPY-STRUCTURE works, if this is a structure
       ;; type
       ,@(unless type-option
sds's avatar
sds committed
532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551
           `((deftest ,(make-struct-test-name name 20)
               ,(let* ((var 'XTEMP-20)
                       (var2 'YTEMP-20))
                  `(let ((,var (,make-fn
                                ,@(loop
                                   for (slot-name . initval)
                                   in initial-value-alist
                                   nconc (list (intern (string slot-name)
                                                       "KEYWORD")
                                               `(quote ,initval))))))
                     (let ((,var2 (copy-structure ,var)))
                       (and
                        (not (eqlt ,var ,var2))
                        ,@(loop
                           for (slot-name . nil) in initial-value-alist
                           for fn in field-fns
                           collect
                           `(eqlt (,fn ,var) (,fn ,var2)))
                        t))))
               t)))
552
       nil
553
       )))
554

555 556 557
(defun defstruct-maketemp (stem suffix1 &optional suffix2)
  "Make a temporary variable for DEFSTRUCT-WITH-TESTS."
  (intern (if suffix2 (format nil "~A-~A-~A" stem suffix1 suffix2)
sds's avatar
sds committed
558
            (format nil "~A-~A" stem suffix1))))