(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)))
;;; 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))
(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
;; 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))))
`((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)))
(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
(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
(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
frizzy-hair-p
polkadots)
(assert (is-a-bozo-p (make-up-klown)))
+\f
+;;;; 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)
+\f
;;; success
+(format t "~&/returning success~%")
(quit :unix-status 104)
projects / sbcl.git / commitdiff