From: William Harold Newman Date: Wed, 17 Oct 2001 22:15:17 +0000 (+0000) Subject: 0.pre7.73: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a939d36e25af582c08d937776735a67ca95dcab8;p=sbcl.git 0.pre7.73: added more tests for DEFSTRUCT Don't proclaim/declaim instance types in DEFSTRUCT :TYPE LIST or DEFSTRUCT :TYPE VECTOR (because they're not known to the type system in those cases). --- diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index dfd7be2..6b4afc1 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -114,9 +114,22 @@ (print-unreadable-object (x stream :type t) (prin1 (dd-name x) stream))) -;;; Is DD a structure with a class? -(defun dd-class-p (defstruct) - (member (dd-type defstruct) '(structure funcallable-structure))) +;;; Does DD describe a structure with a class? +(defun dd-class-p (dd) + (member (dd-type dd) + '(structure funcallable-structure))) + +;;; a type name which can be used when declaring things which operate +;;; on structure instances +(defun dd-declarable-type (dd) + (if (dd-class-p dd) + ;; Native classes are known to the type system, and we can + ;; declare them as types. + (dd-name dd) + ;; Structures layered on :TYPE LIST or :TYPE VECTOR aren't part + ;; of the type system, so all we can declare is the underlying + ;; LIST or VECTOR type. + (dd-type dd))) (defun dd-layout-or-lose (dd) (compiler-layout-or-lose (dd-name dd))) @@ -579,7 +592,8 @@ ;;; Return forms to define readers and writers for raw slots as inline ;;; functions. (defun raw-accessor-definitions (dd) - (let* ((name (dd-name dd))) + (let* ((name (dd-name dd)) + (dtype (dd-declarable-type dd))) (collect ((res)) (dolist (slot (dd-slots dd)) (let ((slot-type (dsd-type slot)) @@ -592,7 +606,7 @@ (when (and accessor-name (not (eq accessor-name '%instance-ref))) (res `(declaim (inline ,accessor-name))) - (res `(declaim (ftype (function (,name) ,slot-type) + (res `(declaim (ftype (function (,dtype) ,slot-type) ,accessor-name))) (res `(defun ,accessor-name (,argname) ;; Note: The DECLARE here might seem redundant @@ -600,17 +614,17 @@ ;; If we're not at toplevel, the PROCLAIM inside ;; the DECLAIM doesn't get executed until after ;; this function is compiled. - (declare (type ,name ,argname)) + (declare (type ,dtype ,argname)) (truly-the ,slot-type (,accessor ,data ,offset)))) (unless (dsd-read-only slot) (res `(declaim (inline (setf ,accessor-name)))) - (res `(declaim (ftype (function (,slot-type ,name) ,slot-type) + (res `(declaim (ftype (function (,slot-type ,dtype) ,slot-type) (setf ,accessor-name)))) ;; FIXME: I rewrote this somewhat from the CMU CL definition. ;; Do some basic tests to make sure that reading and writing ;; raw slots still works correctly. (res `(defun (setf ,accessor-name) (,nvname ,argname) - (declare (type ,name ,argname)) + (declare (type ,dtype ,argname)) (setf (,accessor ,data ,offset) ,nvname) ,nvname))))))) (res)))) @@ -675,10 +689,10 @@ `((setf (fdefinition ',(dd-copier-name defstruct)) #'copy-seq) (declaim (ftype function ,(dd-copier-name defstruct)))))) -;;; Return a list of function definitions for accessing and setting the -;;; slots of a typed DEFSTRUCT. The functions are proclaimed to be inline, -;;; and the types of their arguments and results are declared as well. We -;;; count on the compiler to do clever things with ELT. +;;; Return a list of function definitions for accessing and setting +;;; the slots of a typed DEFSTRUCT. The functions are proclaimed to be +;;; inline, and the types of their arguments and results are declared +;;; as well. We count on the compiler to do clever things with ELT. (defun typed-accessor-definitions (defstruct) (collect ((stuff)) (let ((ltype (dd-lisp-type defstruct))) @@ -1180,11 +1194,12 @@ (setf (info :type :compiler-layout (dd-name dd)) layout)) (let* ((dd-name (dd-name dd)) + (dtype (dd-declarable-type dd)) (class (sb!xc:find-class dd-name))) (let ((copier-name (dd-copier-name dd))) (when copier-name - (sb!xc:proclaim `(ftype (function (,dd-name) ,dd-name) ,copier-name)))) + (sb!xc:proclaim `(ftype (function (,dtype) ,dtype) ,copier-name)))) (let ((predicate-name (dd-predicate-name dd))) (when predicate-name @@ -1196,7 +1211,7 @@ (when accessor-name (multiple-value-bind (reader-designator writer-designator) (accessor-inline-expansion-designators dd dsd) - (sb!xc:proclaim `(ftype (function (,dd-name) ,dsd-type) + (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type) ,accessor-name)) (setf (info :function :inline-expansion-designator @@ -1207,7 +1222,7 @@ (unless (dsd-read-only dsd) (let ((setf-accessor-name `(setf ,accessor-name))) (sb!xc:proclaim - `(ftype (function (,dsd-type ,dd-name) ,dsd-type) + `(ftype (function (,dsd-type ,dtype) ,dsd-type) ,setf-accessor-name)) (setf (info :function :inline-expansion-designator diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index 68e1df7..0a72dbd 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -109,6 +109,171 @@ 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 (concname slotname) + (symbol+ concname slotname)) + +;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions) +;;; to read and write a structure slot. +(defun read-slot-notinline (concname slotname instance) + (funcall (accessor-name concname slotname) instance)) +(defun write-slot-notinline (new-value concname slotname instance) + (funcall (fdefinition `(setf ,(accessor-name concname slotname))) + new-value instance)) + +;;; Use inline expansions of slot accessors, if possible, to read and +;;; write a structure slot. +(defun read-slot-inline (concname slotname instance) + (funcall (compile nil + `(lambda (instance) + (,(accessor-name concname slotname) instance))) + instance)) +(defun write-slot-inline (new-value concname slotname instance) + (funcall (compile nil + `(lambda (new-value instance) + (setf (,(accessor-name concname slotname) 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 (concname slotname instance) + (let ((inline-value (read-slot-inline concname slotname instance)) + (notinline-value (read-slot-notinline concname slotname 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 concname slotname instance inlinep) + (if inlinep + (write-slot-inline new-value concname slotname instance) + (write-slot-notinline new-value concname slotname 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) + ;;; success +(format t "~&/returning success~%") (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 58842c1..3a3ad19 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.72" +"0.pre7.73"