+;;; bound during the tests so that we can get to it even if the
+;;; debugger is having a bad day
+(defvar *instance*)
+
+(defmacro test-variant (defstructname &key colontype)
+ `(progn
+
+ (format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
+
+ (defstruct (,defstructname
+ ,@(when colontype `((:type ,colontype))))
+ ;; some ordinary tagged slots
+ id
+ (home nil :type package :read-only t)
+ (comment "" :type simple-string)
+ ;; some raw slots
+ (weight 1.0 :type single-float)
+ (hash 1 :type (integer 1 #.(* 3 most-positive-fixnum)) :read-only t)
+ ;; more ordinary tagged slots
+ (refcount 0 :type (and unsigned-byte fixnum)))
+
+ (format t "~&/done with DEFSTRUCT~%")
+
+ (let* ((cn (string+ ',defstructname "-")) ; conc-name
+ (ctor (symbol-function (symbol+ "MAKE-" ',defstructname)))
+ (*instance* (funcall ctor
+ :id "some id"
+ :home (find-package :cl)
+ :hash (+ 14 most-positive-fixnum)
+ :refcount 1)))
+
+ ;; Check that ctor set up slot values correctly.
+ (format t "~&/checking constructed structure~%")
+ (assert (string= "some id" (read-slot cn "ID" *instance*)))
+ (assert (eql (find-package :cl) (read-slot cn "HOME" *instance*)))
+ (assert (string= "" (read-slot cn "COMMENT" *instance*)))
+ (assert (= 1.0 (read-slot cn "WEIGHT" *instance*)))
+ (assert (eql (+ 14 most-positive-fixnum)
+ (read-slot cn "HASH" *instance*)))
+ (assert (= 1 (read-slot cn "REFCOUNT" *instance*)))
+
+ ;; There should be no writers for read-only slots.
+ (format t "~&/checking no read-only writers~%")
+ (assert (not (fboundp `(setf ,(symbol+ cn "HOME")))))
+ (assert (not (fboundp `(setf ,(symbol+ cn "HASH")))))
+ ;; (Read-only slot values are checked in the loop below.)
+
+ (dolist (inlinep '(t nil))
+ (format t "~&/doing INLINEP=~S~%" inlinep)
+ ;; Fiddle with writable slot values.
+ (let ((new-id (format nil "~S" (random 100)))
+ (new-comment (format nil "~X" (random 5555)))
+ (new-weight (random 10.0)))
+ (write-slot new-id cn "ID" *instance* inlinep)
+ (write-slot new-comment cn "COMMENT" *instance* inlinep)
+ (write-slot new-weight cn "WEIGHT" *instance* inlinep)
+ (assert (eql new-id (read-slot cn "ID" *instance*)))
+ (assert (eql new-comment (read-slot cn "COMMENT" *instance*)))
+ ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
+ ;; (error "WEIGHT mismatch: ~S vs. ~S"
+ ;; new-weight (read-slot cn "WEIGHT" *instance*)))
+ (assert (eql new-weight (read-slot cn "WEIGHT" *instance*)))))
+ (format t "~&/done with INLINEP loop~%")
+
+ ;; :TYPE FOO objects don't go in the Lisp type system, so we
+ ;; can't test TYPEP stuff for them.
+ ;;
+ ;; FIXME: However, when they're named, they do define
+ ;; predicate functions, and we could test those.
+ ,@(unless colontype
+ `(;; Fiddle with predicate function.
+ (let ((pred-name (symbol+ ',defstructname "-P")))
+ (format t "~&/doing tests on PRED-NAME=~S~%" pred-name)
+ (assert (funcall pred-name *instance*))
+ (assert (not (funcall pred-name 14)))
+ (assert (not (funcall pred-name "test")))
+ (assert (not (funcall pred-name (make-hash-table))))
+ (let ((compiled-pred
+ (compile nil `(lambda (x) (,pred-name x)))))
+ (format t "~&/doing COMPILED-PRED tests~%")
+ (assert (funcall compiled-pred *instance*))
+ (assert (not (funcall compiled-pred 14)))
+ (assert (not (funcall compiled-pred #()))))
+ ;; Fiddle with TYPEP.
+ (format t "~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype)
+ (assert (typep *instance* ',defstructname))
+ (assert (not (typep 0 ',defstructname)))
+ (assert (funcall (symbol+ "TYPEP") *instance* ',defstructname))
+ (assert (not (funcall (symbol+ "TYPEP") nil ',defstructname)))
+ (let* ((typename ',defstructname)
+ (compiled-typep
+ (compile nil `(lambda (x) (typep x ',typename)))))
+ (assert (funcall compiled-typep *instance*))
+ (assert (not (funcall compiled-typep nil))))))))
+
+ (format t "~&/done with PROGN for COLONTYPE=~S~%" ',colontype)))
+
+(test-variant vanilla-struct)
+(test-variant vector-struct :colontype vector)
+(test-variant list-struct :colontype list)
+\f