;;; Use inline expansions of slot accessors, if possible, to read and
;;; write a structure slot.
(defun read-slot-inline (conc-name slot-name instance)
(funcall (compile nil
;;; Use inline expansions of slot accessors, if possible, to read and
;;; write a structure slot.
(defun read-slot-inline (conc-name slot-name instance)
(funcall (compile nil
;;; Read a structure slot, checking that the inline and out-of-line
;;; accessors give the same result.
(defun read-slot (conc-name slot-name instance)
(let ((inline-value (read-slot-inline conc-name slot-name instance))
;;; Read a structure slot, checking that the inline and out-of-line
;;; accessors give the same result.
(defun read-slot (conc-name slot-name instance)
(let ((inline-value (read-slot-inline conc-name slot-name instance))
(defmacro test-variant (defstructname &key colontype boa-constructor-p)
`(progn
(format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
(defstruct (,defstructname
(defmacro test-variant (defstructname &key colontype boa-constructor-p)
`(progn
(format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
(defstruct (,defstructname
- ,@(when boa-constructor-p
- '(1))
- :home (find-package :cl)
- :hash (+ 14 most-positive-fixnum)
- ,@(unless boa-constructor-p
- `(:refcount 1)))))
-
- ;; Check that ctor set up slot values correctly.
+ ,@(when boa-constructor-p
+ '(1))
+ :home (find-package :cl)
+ :hash (+ 14 most-positive-fixnum)
+ ,@(unless boa-constructor-p
+ `(: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)
(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)
- (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 "~&/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
(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))))))))
-
+ ;; 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))))))))
+
- ;; Compare the tagged reference values with raw reffer results.
- (destructuring-bind (j a b c d e)
- (manyraw-unraw-slot-just-for-variety m)
- (assert (eql i j))
- (assert (= (manyraw-a m) a))
- (assert (= (manyraw-b m) b))
- (assert (= (manyraw-c m) c))
- (assert (= (manyraw-d m) d))
- (assert (= (manyraw-e m) e)))
- ;; Test the funny out-of-line OAOOM-style closures, too.
- (mapcar (lambda (fn value)
- (assert (= (funcall fn m) value)))
- (list #'manyraw-a
- #'manyraw-b
- #'manyraw-c
- #'manyraw-d
- #'manyraw-e)
- (cdr (manyraw-unraw-slot-just-for-variety m)))))
+ ;; Compare the tagged reference values with raw reffer results.
+ (destructuring-bind (j a b c d e)
+ (manyraw-unraw-slot-just-for-variety m)
+ (assert (eql i j))
+ (assert (= (manyraw-a m) a))
+ (assert (= (manyraw-b m) b))
+ (assert (= (manyraw-c m) c))
+ (assert (= (manyraw-d m) d))
+ (assert (= (manyraw-e m) e)))
+ ;; Test the funny out-of-line OAOOM-style closures, too.
+ (mapcar (lambda (fn value)
+ (assert (= (funcall fn m) value)))
+ (list #'manyraw-a
+ #'manyraw-b
+ #'manyraw-c
+ #'manyraw-d
+ #'manyraw-e)
+ (cdr (manyraw-unraw-slot-just-for-variety m)))))
- (b (random most-positive-single-float))
- (c (random most-positive-double-float))
- (d (complex
- (random most-positive-single-float)
- (random most-positive-single-float)))
- (e (complex
- (random most-positive-double-float)
- (random most-positive-double-float))))
+ (b (random most-positive-single-float))
+ (c (random most-positive-double-float))
+ (d (complex
+ (random most-positive-single-float)
+ (random most-positive-single-float)))
+ (e (complex
+ (random most-positive-double-float)
+ (random most-positive-double-float))))
;;; and further :CONC-NAME NIL was being wrongly treated:
(defpackage "DEFSTRUCT-TEST-SCRATCH")
(defstruct (conc-name-nil :conc-name)
defstruct-test-scratch::conc-name-nil-slot)
(assert (= (defstruct-test-scratch::conc-name-nil-slot
;;; and further :CONC-NAME NIL was being wrongly treated:
(defpackage "DEFSTRUCT-TEST-SCRATCH")
(defstruct (conc-name-nil :conc-name)
defstruct-test-scratch::conc-name-nil-slot)
(assert (= (defstruct-test-scratch::conc-name-nil-slot
-(defstruct (bug-332a-aux (:type vector)
- (:initial-offset 5) :named))
-(defstruct (bug-332b-aux (:type vector)
- (:initial-offset 2) :named
- (:include bug-332a-aux)))
+(defstruct (bug-332a-aux (:type vector)
+ (:initial-offset 5) :named))
+(defstruct (bug-332b-aux (:type vector)
+ (:initial-offset 2) :named
+ (:include bug-332a-aux)))