structure-00.lsp 14.7 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
13
  ;; (declare (type (or string symbol character) structure-name)
  ;;  (type fixnum n))
  (assert (typep structure-name '(or string symbol character)))
  (assert (typep n 'fixnum))
14
15
16
  (setf structure-name (string structure-name))
  (intern (concatenate 'string
	    structure-name
17
18
	    "/"
	    (princ-to-string n))))
19
20

(defun make-struct-p-fn (structure-name)
21
  (assert (typep structure-name '(or string symbol character)))
22
23
24
  (setf structure-name (string structure-name))
  (intern (concatenate 'string
	    structure-name
25
	    "-P")))
26
27

(defun make-struct-copy-fn (structure-name)
28
29
30
31
32
  (assert (typep structure-name '(or string symbol character)))
  (setf structure-name (string structure-name))
  (intern (concatenate '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
50
	    "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
70
71
72
73
74
75
76
77
    (let ((x 1))
      (loop until (typep x 'bignum)
	  do (setq x (* 2 x)))
      x))
   ((and (symbolp type)
	 (typep type 'structure-class))
    (let ((make-fn
	   (intern (concatenate 'string "MAKE-" (symbol-name type))
		   (symbol-package type))))
      (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
83
84
85
   ((and (consp type)
	 (consp (cdr type))
	 (consp (cddr type))
	 (null (cdddr type))
86
	 (eqt (car type) 'integer)
87
88
89
90
91
	 (integerp (second type)))
    (second type))
   ((member type '(float single-float long-float double-float short-float))
    0.0)
   ((and (consp type)
92
	 (eqt (car type) 'member)
93
94
95
	 (consp (cdr type)))
    (second type))
   ((and (consp type)
96
	 (eqt (car type) 'or)
97
98
99
100
	 (consp (second type)))
    (create-instance-of-type (second type)))
   (t (error "Cannot generate element for type ~S~%" type))))

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

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
151
152
153
154
155
156
157
158
159
160
161
  (defstruct-with-tests-fun name-and-options
    slot-descriptions-and-documentation))

(defun defstruct-with-tests-fun (name-and-options
				 slot-descriptions-and-documentation)
  ;; Function called from macro defstruct-with-tests
  (let* (
	 ;; 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
162
163
164
	 (slot-descriptions
	  (if doc-string (cdr slot-descriptions-and-documentation)
	    slot-descriptions-and-documentation))
165
166

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

171
	 ;; The options list, or NIL if there were no options
172
173
174
	 (options (if (consp name-and-options)
		      (cdr name-and-options)
		    nil))
175
176

	 ;; List of symbols that are the names of the slots
177
178
	 (slot-names
	  (loop
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
	   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))))
196
197

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

200
201
202
203
204
	 ;; The type option, if specified
	 (type-option (find-option options :type))
	 (struct-type (second type-option))

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

207
208
209
210
211
	 ;; 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
212
	 (p-fn-default (make-struct-p-fn name))
213
	 (p-fn (cond
214
		((and type-option (not named-option)) nil)
215
216
		((or (eq predicate-option :predicate)
		     (null (cdr predicate-option)))
217
		 p-fn-default)
218
219
220
221
222
223
224
		((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
225
	 (copy-fn-default (make-struct-copy-fn name))
226
227
228
	 (copy-fn (cond
		   ((or (eq copier-option :copier)
			(null (cdr copier-option)))
229
		    copy-fn-default)
230
231
232
233
234
235
236
		   ((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
237
	 (conc-prefix-default (concatenate 'string (string name) "-"))
238
239
	 (conc-prefix (cond
		       ((null conc-option)
240
			conc-prefix-default)
241
242
		       ((or (eq conc-option :conc-name)
			    (null (cadr conc-option)))
243
			nil)
244
245
		       (t (string (cadr conc-option)))))

246
247
248
	 (initial-offset-option (find-option options :initial-offset))
	 (initial-offset (second initial-offset-option))
	 
249
250
251
252
253
	 ;; Accessor names
	 (field-fns
	  (loop for slot-name in slot-names
		collect (make-struct-field-fn conc-prefix slot-name)))

254
255
256
	 ;; a list of initial values
	 (initial-value-alist
	  (loop
257
258
259
	   for slot-desc in slot-descriptions
	   for slot-name in slot-names
	   for type      in slot-types
260
	   for i from 1
261
262
	   collect (if (not (eq type :none))
		       (cons slot-name (create-instance-of-type type))
263
		     (cons slot-name (defstruct-maketemp name "SLOTTEMP" i)))))
264
	 )
265
266
    ;; Build the tests in an eval-when form
    `(eval-when (compile load eval)
267

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

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

       ;; Test that the predicate exists
       ,@(when p-fn
	   `((deftest ,(make-struct-test-name name 2)
288
289
	       (and (fboundp (quote ,p-fn))
		    (functionp (function ,p-fn))
290
		    (symbol-function (quote ,p-fn))
291
		    (notnot (funcall #',p-fn (,make-fn)))
292
293
294
295
296
		    (notnot (,p-fn (,make-fn))))
	       t)))

       ;; Test that the elements of *universe* are not
       ;; of this type
297
298
299
300
       ,@(when p-fn
	   `((deftest ,(make-struct-test-name name 3)
	       (count-if (function ,p-fn) *universe*)
	       0)))
301
302
303
304
305
       ,@(unless type-option
	   `((deftest ,(make-struct-test-name name 4)
	       (count-if (function (lambda (x) (typep x (quote ,name))))
			 *universe*)
	       0)))
306
307
308
309
310

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

       ;; Check that two invocations return different structures
       (deftest ,(make-struct-test-name name 6)
	 (eqt (,make-fn) (,make-fn))
	 nil)

       ;; Check that we can setf the fields
       (deftest ,(make-struct-test-name name 7)
336
337
	 ,(let* ((var (defstruct-maketemp name "TEMP-7-1"))
		 (var2 (defstruct-maketemp name "TEMP-7-2"))
338
339
340
		 (tests
		  (loop
		   for (slot-name . initval) in initial-value-alist
341
		   for read-only-p in slot-read-only
342
		   for slot-desc in slot-descriptions
343
344
		   for field-fn in field-fns
		   unless read-only-p
345
		   collect
346
347
348
		   `(let ((,var2 (quote ,initval)))
		      (setf (,field-fn ,var) ,var2)
		      (eqlt (,field-fn ,var) ,var2)))))
349
350
351
352
353
354
355
	    `(let ((,var (,make-fn)))
	       (and ,@tests t)))
	 t)

       ;; Check that the copy function exists
       ,@(when copy-fn
	   `((deftest ,(make-struct-test-name name 8)
356
357
	       (and (fboundp (quote ,copy-fn))
		    (functionp (function ,copy-fn))
358
359
360
361
362
363
364
		    (symbol-function (quote ,copy-fn))
		    t)
	       t)))

       ;; Check that the copy function properly copies fields
       ,@(when copy-fn
	   `((deftest ,(make-struct-test-name name 9)
365
	       ,(let* ((var 'XTEMP-9)
366
367
		       (var2 'YTEMP-9)
		       (var3 'ZTEMP-9))		       
368
369
370
371
372
373
374
		  `(let ((,var (,make-fn
				,@(loop
				   for (slot-name . initval)
				   in initial-value-alist
				   nconc (list (intern (string slot-name)
						       "KEYWORD")
					       `(quote ,initval))))))
375
376
		     (let ((,var2 (,copy-fn ,var))
			   (,var3 (funcall #',copy-fn ,var)))
377
378
		       (and
			(not (eqlt ,var ,var2))
379
380
			(not (eqlt ,var ,var3))
			(not (eqlt ,var2 ,var3))
381
382
			,@(loop
			   for (slot-name . nil) in initial-value-alist
383
			   for fn in field-fns
384
			   collect
385
386
			   `(and (eqlt (,fn ,var) (,fn ,var2))
				 (eqlt (,fn ,var) (,fn ,var3))))
387
388
			t))))
	       t)))
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418

       ;; 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)
	   `((deftest ,(make-struct-test-name name 10)
	       (fboundp (quote ,p-fn-default))
	       nil)))

       ;; 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)
	   `((deftest ,(make-struct-test-name name 11)
	       (fboundp (quote ,copy-fn-default))
	       nil)))

       ;; 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)
	   `((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 (fboundp '(setf ,field-fn))))
		t)
419
420
421
422
423
424
425
	       t)))

       ;; When the structure is a true structure type, check that
       ;; the various class relationships hold
       ,@(unless type-option
	   `(
	     (deftest ,(make-struct-test-name name 13)
426
	       (notnot (typep (,make-fn) (find-class (quote ,name))))
427
428
429
430
431
432
433
434
	       t)
	     (deftest ,(make-struct-test-name name 14)
	       (let ((class (find-class (quote ,name))))
		 (notnot (typep class 'structure-class)))
	       t)
	     (deftest ,(make-struct-test-name name 15)
	       (notnot (typep (,make-fn) 'structure-object))
	       t)
435
436
437
438
439
440
441
442
443
444
445
446
	     (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)
447
448
449
450
451
452
453
454
455
456
	       (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))
457
	       nil)
458
	     ))
459

460
461
462
463
464
465
466
467
468
469
470
471
472
       ;;; Documentation tests

       ,(when doc-string
	  `(deftest ,(make-struct-test-name name 18)
	     (let ((doc (documentation ',name 'structure)))
	       (or (null doc) (equalt doc ',doc-string)))
	     t))

       ,(when (and doc-string (not type-option))
	  `(deftest ,(make-struct-test-name name 19)
	     (let ((doc (documentation ',name 'type)))
	       (or (null doc) (equalt doc ',doc-string)))
	     t))
473
       nil
474
       )))
475

476
477
478
479
(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)
	    (format nil "~A-~A" stem suffix1))))