X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdefstruct.impure.lisp;h=e1952867fd02118dd86b37529ea290084304f18d;hb=d76c81b0ca4dcfc99f0cd805f5c20493fa80b2b6;hp=6c264665b3b93078346038ab69010b9096738571;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index 6c26466..e195286 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -9,9 +9,8 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. -(cl:in-package :cl-user) - (load "assertoid.lisp") +(use-package "ASSERTOID") ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec @@ -21,8 +20,38 @@ (defstruct person age (name 007 :type string)) ; not an error until 007 used (make-person :name "James") ; not an error, 007 not used (assert (raises-error? (make-person) type-error)) -;;; FIXME: broken structure slot type checking in sbcl-0.pre7.62 -#+nil (assert (raises-error? (setf (person-name (make-person "Q")) 1) type-error)) +(assert (raises-error? (setf (person-name (make-person :name "Q")) 1) + type-error)) + +;;; An &AUX variable in a boa-constructor without a default value +;;; means "do not initialize slot" and does not cause type error +(defstruct (boa-saux (:constructor make-boa-saux (&aux a (b 3) (c)))) + (a #\! :type (integer 1 2)) + (b #\? :type (integer 3 4)) + (c #\# :type (integer 5 6))) +(let ((s (make-boa-saux))) + (declare (notinline identity)) + #+nil ; bug 235a + (locally (declare (optimize (safety 3)) + (inline boa-saux-a)) + (assert (raises-error? (identity (boa-saux-a s)) type-error))) + (setf (boa-saux-a s) 1) + (setf (boa-saux-c s) 5) + (assert (eql (boa-saux-a s) 1)) + (assert (eql (boa-saux-b s) 3)) + (assert (eql (boa-saux-c s) 5))) + ; these two checks should be + ; kept separated +(let ((s (make-boa-saux))) + (declare (notinline identity)) + (locally (declare (optimize (safety 0)) + (inline boa-saux-a)) + (assert (eql (identity (boa-saux-a s)) 0))) + (setf (boa-saux-a s) 1) + (setf (boa-saux-c s) 5) + (assert (eql (boa-saux-a s) 1)) + (assert (eql (boa-saux-b s) 3)) + (assert (eql (boa-saux-c s) 5))) ;;; basic inheritance (defstruct (astronaut (:include person) @@ -41,7 +70,7 @@ ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET (defstruct (binop (:type list) :named (:initial-offset 2)) - (operator '? :type symbol) + (operator '? :type symbol) operand-1 operand-2) (defstruct (annotated-binop (:type list) @@ -177,13 +206,26 @@ ;;; debugger is having a bad day (defvar *instance*) -(defmacro test-variant (defstructname &key colontype) +(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) + &key + (home nil home-p) + (no-home-comment "Home package CL not provided.") + (comment (if home-p "" no-home-comment)) + (refcount (if optional-test-p optional-test nil)) + hash + weight))))) + ;; some ordinary tagged slots id (home nil :type package :read-only t) @@ -197,12 +239,19 @@ (format t "~&/done with DEFSTRUCT~%") (let* ((cn (string+ ',defstructname "-")) ; conc-name - (ctor (symbol-function (symbol+ "MAKE-" ',defstructname))) + (ctor (symbol-function ',(symbol+ (if boa-constructor-p + "CREATE-" + "MAKE-") + defstructname))) (*instance* (funcall ctor - :id "some id" + ,@(unless boa-constructor-p + `(:id)) "some id" + ,@(when boa-constructor-p + '(1)) :home (find-package :cl) :hash (+ 14 most-positive-fixnum) - :refcount 1))) + ,@(unless boa-constructor-p + `(:refcount 1))))) ;; Check that ctor set up slot values correctly. (format t "~&/checking constructed structure~%") @@ -273,7 +322,160 @@ (test-variant vanilla-struct) (test-variant vector-struct :colontype vector) (test-variant list-struct :colontype list) +(test-variant vanilla-struct :boa-constructor-p t) +(test-variant vector-struct :colontype vector :boa-constructor-p t) +(test-variant list-struct :colontype list :boa-constructor-p t) + + +;;;; testing raw slots harder +;;;; +;;;; The offsets of raw slots need to be rescaled during the punning +;;;; process which is used to access them. That seems like a good +;;;; place for errors to lurk, so we'll try hunting for them by +;;;; verifying that all the raw slot data gets written successfully +;;;; into the object, can be copied with the object, and can then be +;;;; read back out (with none of it ending up bogusly outside the +;;;; object, so that it couldn't be copied, or bogusly overwriting +;;;; some other raw slot). + +(defstruct manyraw + (a (expt 2 30) :type (unsigned-byte 32)) + (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)) + (bb 0.1 :type single-float) + (cc 0.2d0 :type double-float) + (dd #c(0.3 0.3) :type (complex single-float)) + (ee #c(0.4d0 0.4d0) :type (complex double-float))) + +(defvar *manyraw* (make-manyraw)) + +(assert (eql (manyraw-a *manyraw*) (expt 2 30))) +(assert (eql (manyraw-b *manyraw*) 0.1)) +(assert (eql (manyraw-c *manyraw*) 0.2d0)) +(assert (eql (manyraw-d *manyraw*) #c(0.3 0.3))) +(assert (eql (manyraw-e *manyraw*) #c(0.4d0 0.4d0))) +(assert (eql (manyraw-aa *manyraw*) (expt 2 30))) +(assert (eql (manyraw-bb *manyraw*) 0.1)) +(assert (eql (manyraw-cc *manyraw*) 0.2d0)) +(assert (eql (manyraw-dd *manyraw*) #c(0.3 0.3))) +(assert (eql (manyraw-ee *manyraw*) #c(0.4d0 0.4d0))) + +(setf (manyraw-aa *manyraw*) (expt 2 31) + (manyraw-bb *manyraw*) 0.11 + (manyraw-cc *manyraw*) 0.22d0 + (manyraw-dd *manyraw*) #c(0.33 0.33) + (manyraw-ee *manyraw*) #c(0.44d0 0.44d0)) + +(let ((copy (copy-manyraw *manyraw*))) + (assert (eql (manyraw-a copy) (expt 2 30))) + (assert (eql (manyraw-b copy) 0.1)) + (assert (eql (manyraw-c copy) 0.2d0)) + (assert (eql (manyraw-d copy) #c(0.3 0.3))) + (assert (eql (manyraw-e copy) #c(0.4d0 0.4d0))) + (assert (eql (manyraw-aa copy) (expt 2 31))) + (assert (eql (manyraw-bb copy) 0.11)) + (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)))) +;;;; miscellaneous old bugs + +(defstruct ya-struct) +(when (ignore-errors (or (ya-struct-p) 12)) + (error "YA-STRUCT-P of no arguments should signal an error.")) +(when (ignore-errors (or (ya-struct-p 'too 'many 'arguments) 12)) + (error "YA-STRUCT-P of three arguments should signal an error.")) + +;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0 +;;; declared inside on the theory that slot types were already +;;; checked, which bogusly suppressed unbound-variable and other +;;; checks within the evaluation of initforms. +(defvar *bug210*) +(defstruct (bug210a (:constructor bug210a ())) + (slot *bug210*)) +(defstruct bug210b + (slot *bug210*)) +;;; Because of bug 210, this assertion used to fail. +(assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable)) +;;; Even with bug 210, these assertions succeeded. +(assert (typep (nth-value 1 (ignore-errors *bug210*)) 'unbound-variable)) +(assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable)) + +;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts +;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff +;;; setting up compiler-layout information would run before the +;;; constructor function installing the layout was compiled. Make sure +;;; that doesn't happen again. +(defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x (y :not))) +(assert (not (find-class 'foo-0-7-8-53 nil))) +(foo-0-7-8-53) +(assert (find-class 'foo-0-7-8-53 nil)) +(let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x :s))) + (assert (eq (foo-0-7-8-53-x foo-0-7-8-53) :s)) + (assert (eq (foo-0-7-8-53-y foo-0-7-8-53) :not))) + +;;; tests of behaviour of colliding accessors. +(defstruct (bug127-foo (:conc-name bug127-baz-)) a) +(assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1)) +(defstruct (bug127-bar (:conc-name bug127-baz-) (:include bug127-foo)) b) +(assert (= (bug127-baz-a (make-bug127-bar :a 1 :b 2)) 1)) +(assert (= (bug127-baz-b (make-bug127-bar :a 1 :b 2)) 2)) +(assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1)) + +(defun bug127-flurble (x) + x) +(defstruct bug127 flurble) +(assert (= (bug127-flurble (make-bug127 :flurble 7)) 7)) + +(defstruct bug127-a b-c) +(assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9)) +(defstruct (bug127-a-b (:include bug127-a)) c) +(assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9)) +(assert (= (bug127-a-b-c (make-bug127-a-b :b-c 11 :c 13)) 11)) + +(defstruct (bug127-e (:conc-name bug127--)) foo) +(assert (= (bug127--foo (make-bug127-e :foo 3)) 3)) +(defstruct (bug127-f (:conc-name bug127--)) foo) +(assert (= (bug127--foo (make-bug127-f :foo 3)) 3)) +(assert (raises-error? (bug127--foo (make-bug127-e :foo 3)) type-error)) + +;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE + +;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little +;;; 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)) +;;; 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)) +(assert (raises-error? (conc-name-nil-slot (make-conc-name-nil)) + undefined-function)) + +;;; The named/typed predicates were a little fragile, in that they +;;; could throw errors on innocuous input: +(defstruct (list-struct (:type list) :named) a-slot) +(assert (list-struct-p (make-list-struct))) +(assert (not (list-struct-p nil))) +(assert (not (list-struct-p 1))) +(defstruct (offset-list-struct (:type list) :named (:initial-offset 1)) a-slot) +(assert (offset-list-struct-p (make-offset-list-struct))) +(assert (not (offset-list-struct-p nil))) +(assert (not (offset-list-struct-p 1))) +(assert (not (offset-list-struct-p '(offset-list-struct)))) +(assert (not (offset-list-struct-p '(offset-list-struct . 3)))) +(defstruct (vector-struct (:type vector) :named) a-slot) +(assert (vector-struct-p (make-vector-struct))) +(assert (not (vector-struct-p nil))) +(assert (not (vector-struct-p #()))) + ;;; success (format t "~&/returning success~%") (quit :unix-status 104)