;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
-;;;;
+;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
;;; somewhat bogus, but the requirement is clear.)
(defstruct person age (name 007 :type string)) ; not an error until 007 used
(make-person :name "James") ; not an error, 007 not used
+
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
(assert (raises-error? (make-person) type-error))
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
(assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
- type-error))
+ type-error))
;;; An &AUX variable in a boa-constructor without a default value
;;; means "do not initialize slot" and does not cause type error
(assert (eql (boa-saux-c s) 5)))
; these two checks should be
; kept separated
+
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
(let ((s (make-boa-saux)))
(locally (declare (optimize (safety 0))
(inline boa-saux-a))
;;; basic inheritance
(defstruct (astronaut (:include person)
- (:conc-name astro-))
+ (:conc-name astro-))
helmet-size
(favorite-beverage 'tang))
(let ((x (make-astronaut :name "Buzz" :helmet-size 17.5)))
operand-1
operand-2)
(defstruct (annotated-binop (:type list)
- (:initial-offset 3)
- (:include binop))
+ (:initial-offset 3)
+ (:include binop))
commutative associative identity)
(assert (equal (make-annotated-binop :operator '*
- :operand-1 'x
- :operand-2 5
- :commutative t
- :associative t
- :identity 1)
- '(nil nil binop * x 5 nil nil nil t t 1)))
+ :operand-1 'x
+ :operand-2 5
+ :commutative t
+ :associative t
+ :identity 1)
+ '(nil nil binop * x 5 nil nil nil t t 1)))
;;; effect of :NAMED on :TYPE
(defstruct (named-binop (:type list) :named)
area
watertowers
(firetrucks 1 :type fixnum)
- population
+ population
(elevation 5128 :read-only t))
(let ((town1 (make-town :area 0 :watertowers 0)))
(assert (town-p town1))
(assert (eql (town-population town1) 99))
(let ((town2 (copy-town town1)))
(dolist (slot-accessor-name '(town-area
- town-watertowers
- town-firetrucks
- town-population
- town-elevation))
+ town-watertowers
+ town-firetrucks
+ town-population
+ town-elevation))
(assert (eql (funcall slot-accessor-name town1)
- (funcall slot-accessor-name town2))))
+ (funcall slot-accessor-name town2))))
(assert (not (fboundp '(setf town-elevation)))))) ; 'cause it's :READ-ONLY
;;; example 2
(defstruct (clown (:conc-name bozo-))
- (nose-color 'red)
+ (nose-color 'red)
frizzy-hair-p
polkadots)
(let ((funny-clown (make-clown)))
(assert (eql (bozo-nose-color funny-clown) 'red)))
(defstruct (klown (:constructor make-up-klown)
- (:copier clone-klown)
- (:predicate is-a-bozo-p))
+ (:copier clone-klown)
+ (:predicate is-a-bozo-p))
nose-color
frizzy-hair-p
polkadots)
(defun string+ (&rest rest)
(apply #'concatenate 'string
- (mapcar #'string rest)))
+ (mapcar #'string rest)))
(defun symbol+ (&rest rest)
(values (intern (apply #'string+ rest))))
(funcall (accessor-name conc-name slot-name) instance))
(defun write-slot-notinline (new-value conc-name slot-name instance)
(funcall (fdefinition `(setf ,(accessor-name conc-name slot-name)))
- new-value instance))
+ new-value instance))
;;; 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
- `(lambda (instance)
- (,(accessor-name conc-name slot-name) instance)))
- instance))
+ `(lambda (instance)
+ (,(accessor-name conc-name slot-name) instance)))
+ instance))
(defun write-slot-inline (new-value conc-name slot-name instance)
(funcall (compile nil
- `(lambda (new-value instance)
- (setf (,(accessor-name conc-name slot-name) instance)
- new-value)))
- new-value
- instance))
+ `(lambda (new-value instance)
+ (setf (,(accessor-name conc-name slot-name) instance)
+ new-value)))
+ new-value
+ 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))
- (notinline-value (read-slot-notinline conc-name slot-name instance)))
+ (notinline-value (read-slot-notinline conc-name slot-name instance)))
(assert (eql inline-value notinline-value))
inline-value))
;;; bound during the tests so that we can get to it even if the
;;; debugger is having a bad day
(defvar *instance*)
-
+
+(declaim (optimize (debug 2)))
+
(defmacro test-variant (defstructname &key colontype boa-constructor-p)
`(progn
(format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
(defstruct (,defstructname
- ,@(when colontype `((:type ,colontype)))
+ ,@(when colontype `((:type ,colontype)))
,@(when boa-constructor-p
`((:constructor ,(symbol+ "CREATE-" defstructname)
(id
- &optional
- (optional-test 2 optional-test-p)
+ &optional
+ (optional-test 2 optional-test-p)
&key
(home nil home-p)
(no-home-comment "Home package CL not provided.")
(refcount (if optional-test-p optional-test nil))
hash
weight)))))
-
+
;; some ordinary tagged slots
id
(home nil :type package :read-only t)
(format t "~&/done with DEFSTRUCT~%")
(let* ((cn (string+ ',defstructname "-")) ; conc-name
- (ctor (symbol-function ',(symbol+ (if boa-constructor-p
+ (ctor (symbol-function ',(symbol+ (if boa-constructor-p
"CREATE-"
"MAKE-")
defstructname)))
- (*instance* (funcall ctor
- ,@(unless boa-constructor-p
+ (*instance* (funcall ctor
+ ,@(unless boa-constructor-p
`(:id)) "some id"
- ,@(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)
- (read-slot cn "HASH" *instance*)))
+ (read-slot cn "HASH" *instance*)))
(assert (= 1 (read-slot cn "REFCOUNT" *instance*)))
;; There should be no writers for read-only slots.
;; (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 "~&/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))))))))
-
+ ;; 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)
;;;; some other raw slot).
(defstruct manyraw
- (a (expt 2 30) :type (unsigned-byte 32))
+ (a (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits))
(b 0.1 :type single-float)
(c 0.2d0 :type double-float)
(d #c(0.3 0.3) :type (complex single-float))
unraw-slot-just-for-variety
(e #c(0.4d0 0.4d0) :type (complex double-float))
- (aa (expt 2 30) :type (unsigned-byte 32))
+ (aa (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits))
(bb 0.1 :type single-float)
(cc 0.2d0 :type double-float)
(dd #c(0.3 0.3) :type (complex single-float))
(assert (eql (manyraw-cc copy) 0.22d0))
(assert (eql (manyraw-dd copy) #c(0.33 0.33)))
(assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0))))
+
+\f
+;;;; Since GC treats raw slots specially now, let's try this with more objects
+;;;; and random values as a stress test.
+
+(setf *manyraw* nil)
+
+(defconstant +n-manyraw+ 10)
+(defconstant +m-manyraw+ 1000)
+
+(defun check-manyraws (manyraws)
+ (assert (eql (length manyraws) (* +n-manyraw+ +m-manyraw+)))
+ (loop
+ for m in (reverse manyraws)
+ for i from 0
+ do
+ ;; 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)))))
+
+(defstruct (manyraw-subclass (:include manyraw))
+ (stolperstein 0 :type (unsigned-byte 32)))
+
+;;; create lots of manyraw objects, triggering GC every now and then
+(dotimes (y +n-manyraw+)
+ (dotimes (x +m-manyraw+)
+ (let ((a (random (expt 2 32)))
+ (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))))
+ (push (funcall (if (zerop (mod x 3))
+ #'make-manyraw-subclass
+ #'make-manyraw)
+ :unraw-slot-just-for-variety
+ (list (+ x (* y +m-manyraw+)) a b c d e)
+ :a a
+ :b b
+ :c c
+ :d d
+ :e e)
+ *manyraw*)))
+ (room)
+ (sb-ext:gc))
+(check-manyraws *manyraw*)
+
+;;; try a full GC, too
+(sb-ext:gc :full t)
+(check-manyraws *manyraw*)
+
+;;; fasl dumper and loader also have special handling of raw slots, so
+;;; dump all of them into a fasl
+(defmethod make-load-form ((self manyraw) &optional env)
+ self env
+ :sb-just-dump-it-normally)
+(with-open-file (s "tmp-defstruct.manyraw.lisp"
+ :direction :output
+ :if-exists :supersede)
+ (write-string "(defun dumped-manyraws () '#.*manyraw*)" s))
+(compile-file "tmp-defstruct.manyraw.lisp")
+(delete-file "tmp-defstruct.manyraw.lisp")
+
+;;; nuke the objects and try another GC just to be extra careful
+(setf *manyraw* nil)
+(sb-ext:gc :full t)
+
+;;; re-read the dumped structures and check them
+(load "tmp-defstruct.manyraw.fasl")
+(check-manyraws (dumped-manyraws))
+
\f
;;;; miscellaneous old bugs
;;; too fragile:
(defstruct (conc-name-syntax :conc-name) a-conc-name-slot)
(assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot 'y))
- 'y))
+ 'y))
;;; 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
- (make-conc-name-nil :conc-name-nil-slot 1)) 1))
+ (make-conc-name-nil :conc-name-nil-slot 1)) 1))
(assert (raises-error? (conc-name-nil-slot (make-conc-name-nil))
- undefined-function))
+ undefined-function))
\f
;;; The named/typed predicates were a little fragile, in that they
;;; could throw errors on innocuous input:
(assert (not (vector-struct-p nil)))
(assert (not (vector-struct-p #())))
\f
+
;;; bug 3d: type safety with redefined type constraints on slots
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
(macrolet
((test (type)
(let* ((base-name (intern (format nil "bug3d-~A" type)))
(assert (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332b)))
;;; Similar test for vectors, just for good measure.
-(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)))
(assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 premature-end))))
(assert (not (bug-332b-aux-p 873257)))
(assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332a-aux))))
(catch :ok
(handler-bind ((error (lambda (c)
;; Used to cause stack-exhaustion
- (unless (typep c 'storege-condition)
- (throw :ok)))))
+ (unless (typep c 'storage-condition)
+ (throw :ok t)))))
(eval '(progn
(defstruct foo a)
(setf (find-class 'foo) nil)
(defstruct foo slot-1)))))
+;;; bug 348, evaluation order of slot writer arguments. Fixed by Gabor
+;;; Melis.
+(defstruct bug-348 x)
+
+(assert (eql -1 (let ((i (eval '-2))
+ (x (make-bug-348)))
+ (funcall #'(setf bug-348-x)
+ (incf i)
+ (aref (vector x) (incf i)))
+ (bug-348-x x))))
+
;;; success
(format t "~&/returning success~%")
-(quit :unix-status 104)
projects / sbcl.git / blobdiff