structures-01.lsp 2.26 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat May  2 21:45:32 1998
;;;; Contains: Test code for structures, part 01

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

;;; Tests for structures
;;;
;;; The CL Spec leaves undefined just what will happen when a structure is
;;; redefined.  These tests don't redefine structures, but reloading a file
;;; with structure definition will do so.  I assume that this leaves the
;;; structure type unchanged.

;; Test simple defstruct (fields, no options)

(defstruct s-1
  foo bar)

;; Test that make-s-1 produces objects
;; of the correct type
(deftest structure-1-1
24
  (notnot-mv (typep (make-s-1) 's-1))
25 26 27 28
  t)

;; Test that the -p predicate exists
(deftest structure-1-2
29
  (notnot-mv (s-1-p (make-s-1)))
30 31 32 33 34
  t)

;; Test that all the objects in the universe are
;; not of this type
(deftest structure-1-3
35
  (count-if #'s-1-p *universe*)
36 37 38
  0)

(deftest structure-1-4
39
  (count-if #'(lambda (x) (typep x 's-1)) *universe*)
40 41 42 43
  0)

;; Check that the fields can be read after being initialized
(deftest structure-1-5
44
  (s-1-foo (make-s-1 :foo 'a))
45 46 47
  a)

(deftest structure-1-6
48
  (s-1-bar (make-s-1 :bar 'b))
49 50 51
  b)

(deftest structure-1-7
52 53
  (let ((s (make-s-1 :foo 'c :bar 'd)))
    (list (s-1-foo s) (s-1-bar s)))
54 55 56 57
  (c d))

;; Can setf the fields
(deftest structure-1-8
58 59 60 61
  (let ((s (make-s-1)))
    (setf (s-1-foo s) 'e)
    (setf (s-1-bar s) 'f)
    (list (s-1-foo s) (s-1-bar s)))
62 63 64
  (e f))

(deftest structure-1-9
65 66 67 68
  (let ((s (make-s-1 :foo 'a :bar 'b)))
    (setf (s-1-foo s) 'e)
    (setf (s-1-bar s) 'f)
    (list (s-1-foo s) (s-1-bar s)))
69 70 71 72
  (e f))

;; copier function defined
(deftest structure-1-10
73 74 75 76 77
  (let ((s (make-s-1 :foo 'a :bar 'b)))
    (let ((s2 (copy-s-1 s)))
      (setf (s-1-foo s) nil)
      (setf (s-1-bar s) nil)
      (list (s-1-foo s2)
sds's avatar
sds committed
78
            (s-1-bar s2))))
79 80 81 82
  (a b))

;; Make produces unique items
(deftest structure-1-11
83
  (eqt (make-s-1) (make-s-1))
84 85 86
  nil)

(deftest structure-1-12
87 88
  (eqt (make-s-1 :foo 'a :bar 'b)
       (make-s-1 :foo 'a :bar 'b))
89 90 91 92 93
  nil)

;; More type and class checks

(deftest structure-1-13
94
  (notnot-mv (typep (class-of (make-s-1)) 'structure-class))
95 96 97
  t)

(deftest structure-1-14
98
  (notnot-mv (typep (make-s-1) 'structure-object))
99 100 101
  t)

(deftest structure-1-15
102
  (subtypep* 's-1 'structure-object)
103
  t t)