From 3a10f894e7867fa2c27a3af05380abc3247f728d Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 20 May 2003 10:36:02 +0000 Subject: [PATCH] 0.8alpha.0.40: Firefighting the build, part I ... make SLOT-VALUE work on :READ-ONLY T structure slots Notes: * This version may have a subtle breakage that may or may not bite. The forthcoming 0.8alpha.0.41 commit will fix that subtle breakage, but it was fixed chronologically before in my tree, so I haven't taken out that fix to test this one in isolation. I hope that makes sense...) * The new implementation of MAKE-LOAD-FORM-SAVING-SLOTS seems very slow; this may be a perceptual problem. What is incontrovertible is that it is very noisy; it chatters about compiling many top-level forms, caused by PCL generating LOAD-TIME-VALUE forms for ENSURE-ACCESSOR to optimize SLOT-VALUE. A fix for this, at least for structure objects, will probably be forthcoming in 0.8alpha.0.4x. --- src/pcl/braid.lisp | 2 +- src/pcl/low.lisp | 8 +++++--- tests/dump.impure-cload.lisp | 20 +++++++++++++++++++- version.lisp-expr | 2 +- 4 files changed, 26 insertions(+), 6 deletions(-) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index e236279..ca1b434 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -564,7 +564,7 @@ `(:internal-reader-function ,(structure-slotd-reader-function slotd) :internal-writer-function - ,(structure-slotd-writer-function slotd))) + ,(structure-slotd-writer-function name slotd))) :type ,(or (structure-slotd-type slotd) t) :initform ,(structure-slotd-init-form slotd) :initfunction ,(eval-form (structure-slotd-init-form slotd))))) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 34537ac..eeeeec4 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -351,9 +351,11 @@ (defun structure-slotd-reader-function (slotd) (fdefinition (dsd-accessor-name slotd))) -(defun structure-slotd-writer-function (slotd) - (unless (dsd-read-only slotd) - (fdefinition `(setf ,(dsd-accessor-name slotd))))) +(defun structure-slotd-writer-function (type slotd) + (if (dsd-read-only slotd) + (let ((dd (get-structure-dd type))) + (coerce (sb-kernel::slot-setter-lambda-form dd slotd) 'function)) + (fdefinition `(setf ,(dsd-accessor-name slotd))))) (defun structure-slotd-type (slotd) (dsd-type slotd)) diff --git a/tests/dump.impure-cload.lisp b/tests/dump.impure-cload.lisp index a9d77e7..2b1ad11 100644 --- a/tests/dump.impure-cload.lisp +++ b/tests/dump.impure-cload.lisp @@ -71,5 +71,23 @@ (defparameter *numbers* '(-1s0 -1f0 -1d0 -1l0 #c(-1s0 -1s0) #c(-1f0 -1f0) #c(-1d0 -1d0) #c(-1l0 -1l0))) - + +;;; tests for MAKE-LOAD-FORM-SAVING-SLOTS +(eval-when (:compile-toplevel :load-toplevel :execute) + (defstruct savable-structure + (a nil :type symbol) + (b nil :type symbol :read-only t) + (c nil :read-only t) + (d 0 :type fixnum) + (e 17 :type (unsigned-byte 32) :read-only t)) + (defmethod make-load-form ((s savable-structure) &optional env) + (make-load-form-saving-slots s :environment env))) +(defparameter *savable-structure* + #.(make-savable-structure :a t :b 'frob :c 1 :d 39 :e 19)) +(assert (eql (savable-structure-a *savable-structure*) t)) +(assert (eql (savable-structure-b *savable-structure*) 'frob)) +(assert (eql (savable-structure-c *savable-structure*) 1)) +(assert (eql (savable-structure-d *savable-structure*) 39)) +(assert (eql (savable-structure-e *savable-structure*) 19)) + (sb-ext:quit :unix-status 104) ; success diff --git a/version.lisp-expr b/version.lisp-expr index 077543b..c86943d 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8alpha.0.39" +"0.8alpha.0.40" -- 1.7.10.4