defclass-aux.lsp 7.11 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
;-*- 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))
	  (find-package :cl-test)))

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
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
(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*))

45
46
47
48
(defmacro defclass-with-tests
  (&whole args
	  class-name superclasses slot-specifiers
	  &rest class-options)
49

50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
  (assert (typep class-name '(and (not null) symbol)))
  (assert (listp superclasses))
  (assert (every #'(lambda (x) (typep x '(and (not null) symbol)))
		 superclasses))
  (assert (listp slot-specifiers))
  (assert (every #'(lambda (s)
		     (or (symbolp s) (and (consp s) (symbolp (car s)))))
		 slot-specifiers))
  (assert (every #'(lambda (x)
		     (and (consp x)
			  (member (car x) '(:default-initargs
					    :documentation
					    :metaclass))))
		 class-options))
  (assert (eql (length class-options)
	       (length (remove-duplicates class-options))))
66

67
  (let* ((default-initargs (rest (assoc :default-initargs class-options)))
68
69
70
	 (metaclass (or (second (assoc :metaclass class-options))
			'standard-class))
	 (doc (second (assoc :documentation class-options)))
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
	 (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
94
		collect (or (get slot-option :allocation)
95
96
97
98
99
100
101
102
103
104
			    :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)))
105
	 )
106
107
108
109
110
111
112
113
114
115
116
117
118

    (declare (ignorable readers writers accessors allocations
			initargs types initforms default-initargs
			doc))

    (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*
	  (append accessors *defclass-slot-accessors*))

119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
    ;;; 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))

153
    `(progn
154

155
       (eval-when (load eval compile)
156
	 (ignore-errors (defclass ,@(cdr args))))
157
158
159
160
161
162
163
164
165

       (deftest ,(make-defclass-test-name class-name
					  "-IS-IN-ITS-METACLASS")
	 (notnot-mv (typep (find-class ',class-name) ',metaclass))
	 t)

       ,@(when (eq metaclass 'standard-class)
	   `((deftest ,(make-defclass-test-name class-name
						"S-ARE-STANDARD-OBJECTS")
166
	       (subtypep* ',class-name 'standard-object)
167
168
	       t t)))

169
170
171
172
173
174
175
176
177
178
       ,@(loop for slot-name in slot-names
	       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))

       (deftest ,(make-defclass-test-name class-name
179
180
181
					  "-ALLOCATE-INSTANCE")
	 (defclass-allocate-instance-test ',class-name ',slot-names)
	 nil)
182
183
184

       )))

185
186
187
188
189
190
191
192
193
194
(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
195
	   unless (equal (multiple-value-list
196
197
			   (notnot-mv (slot-exists-p instance slot)))
			  '(t))
198
199
	   collect (list 'does-not-exist slot))
     (let ((bad-slot '#:foo))
200
201
202
203
       (when (slot-exists-p instance bad-slot)
	 (list (list 'should-not-exist bad-slot))))
     )))
  
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
(defmacro generate-slot-tests ()
  "Generate generic tests from the read/writer/accessor functions
   for slots from defclass-with-tests."
  (let ((funs (remove-duplicates
	       (append *defclass-slot-readers*
		       *defclass-slot-writers*
		       *defclass-slot-accessors*))))
    `(progn
       (deftest class-readers/writers/accessors-are-generic-functions
	 (loop for sym in ',funs
	       unless (typep (symbol-function sym) 'generic-function)
	       collect sym)
	 nil)
       
       (deftest class-accessors-have-generic-setf-functions
	 (append
	  ,@(loop for sym in *defclass-slot-accessors*
		  collect
		  `(and (not (typep (function (setf ,sym))
				    'generic-function))
			'(,sym))))
	 nil))))
226
227
228
229
230
231
232
233
234
235
236
237

#|

(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

|#