X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdefstruct.impure.lisp;h=10152576ab55faee8be0e08fb94d14909540b3ab;hb=8b89077f2d8c3aec140ded650d95d7869f6a7f28;hp=68e1df7c238e9e7aa72dff3fd29544c3dd949e75;hpb=9514c25e89aad10784c6d04fea4595d8c8ae68cc;p=sbcl.git diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index 68e1df7..1015257 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -109,6 +109,226 @@ frizzy-hair-p polkadots) (assert (is-a-bozo-p (make-up-klown))) + +;;;; systematically testing variants of DEFSTRUCT: +;;;; * native, :TYPE LIST, and :TYPE VECTOR + +;;; FIXME: things to test: +;;; * Slot readers work. +;;; * Slot writers work. +;;; * Predicates work. + +;;; FIXME: things that would be nice to test systematically someday: +;;; * constructors (default, boa..) +;;; * copiers +;;; * no type checks when (> SPEED SAFETY) +;;; * Tests of inclusion would be good. (It's tested very lightly +;;; above, and then tested a fair amount by the system compiling +;;; itself.) + +(defun string+ (&rest rest) + (apply #'concatenate 'string + (mapcar #'string rest))) +(defun symbol+ (&rest rest) + (values (intern (apply #'string+ rest)))) + +(defun accessor-name (conc-name slot-name) + (symbol+ conc-name slot-name)) + +;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions) +;;; to read and write a structure slot. +(defun read-slot-notinline (conc-name slot-name instance) + (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)) + +;;; 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)) +(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)) + +;;; 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))) + (assert (eql inline-value notinline-value)) + inline-value)) + +;;; Write a structure slot, using INLINEP argument to decide +;;; on inlineness of accessor used. +(defun write-slot (new-value conc-name slot-name instance inlinep) + (if inlinep + (write-slot-inline new-value conc-name slot-name instance) + (write-slot-notinline new-value conc-name slot-name instance))) + +;;; 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) + +;;;; 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)))) + ;;; success +(format t "~&/returning success~%") (quit :unix-status 104)