;;;; -*- coding: utf-8; fill-column: 78 -*-
changes relative to sbcl-1.0.32:
* improvement: support O_LARGEFILE access to files larger than 2GB on
- x86-64/linux. (thanks to Daniel Janus)
+ x86-64/linux. (thanks to Daniel Janus; launchpad bug #453080)
* new feature: SB-INTROSPECT:WHO-SPECIALIZES-DIRECTLY to get a list of
definitions for methods specializing on the passed class itself.
* new feature: SB-INTROSPECT:WHO-SPECIALIZES-GENERALLY to get a list of
subclasses of it.
* fixes and improvements related to external formats:
** fix a typo preventing conversion of strings into octet vectors
- in the latin-2 encoding. (reported by Attila Lendvai)
+ in the latin-2 encoding. (reported by Attila Lendvai; launchpad bug
+ #471689)
+ * bug fix: uses of slot accessors on specialized method parameters within
+ the bodies of SLOT-VALUE-USING-CLASS methods no longer triggers a type
+ error while finalizing the class. This fix may cause classes with slot
+ accessors to be finalized later than previously. (reported by Lars Rune
+ Nøstdal; launchpad bug #473699)
* bug fix: restore buildability on the MIPS platform. (regression from
1.0.30.38, reported by Samium Gromoff)
* bug fix: inspecting closures is less likely to fail with a type error.
- * bug fix: no timer starvation when setting the system clock back
+ * bug fix: no timer starvation when setting the system clock back.
+ (launchpad bug #460283)
changes in sbcl-1.0.32 relative to sbcl-1.0.31:
* optimization: faster FIND and POSITION on strings of unknown element type
(the fixnum (logand (the fixnum (lognot mask)) flags)))))
value)
-(defmethod initialize-internal-slot-functions ((slotd
- effective-slot-definition))
+(defmethod initialize-internal-slot-functions
+ ((slotd effective-slot-definition))
(let* ((name (slot-value slotd 'name))
(class (slot-value slotd '%class)))
(dolist (type '(reader writer boundp))
(writer '(setf slot-value-using-class))
(boundp 'slot-boundp-using-class)))
(gf (gdefinition gf-name)))
+ ;; KLUDGE: this logic is cut'n'pasted from
+ ;; GET-ACCESSOR-METHOD-FUNCTION, which (for STD-CLASSes) is
+ ;; only called later, because it does things that can't be
+ ;; computed this early in class finalization; however, we need
+ ;; this bit as early as possible. -- CSR, 2009-11-05
+ (setf (slot-accessor-std-p slotd type)
+ (let* ((std-method (standard-svuc-method type))
+ (str-method (structure-svuc-method type))
+ (types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
+ (types (if (eq type 'writer) `(t ,@types1) types1))
+ (methods (compute-applicable-methods-using-types gf types)))
+ (null (cdr methods))))
+ (setf (slot-accessor-function slotd type)
+ (lambda (&rest args)
+ ;; FIXME: a tiny amount of wasted SLOT-ACCESSOR-STD-P
+ ;; work here (see KLUDGE comment above).
+ (let ((fun (compute-slot-accessor-info slotd type gf)))
+ (apply fun args))))))))
+
+(defmethod finalize-internal-slot-functions ((slotd effective-slot-definition))
+ (let* ((name (slot-value slotd 'name)))
+ (dolist (type '(reader writer boundp))
+ (let* ((gf-name (ecase type
+ (reader 'slot-value-using-class)
+ (writer '(setf slot-value-using-class))
+ (boundp 'slot-boundp-using-class)))
+ (gf (gdefinition gf-name)))
(compute-slot-accessor-info slotd type gf)))))
;;; CMUCL (Gerd PCL 2003-04-25) comment:
(defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
type gf)
(let* ((name (slot-value slotd 'name))
- (class (slot-value slotd '%class))
- (old-slotd (when (class-finalized-p class)
- (find-slot-definition class name)))
- (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
+ (class (slot-value slotd '%class)))
(multiple-value-bind (function std-p)
(if (eq **boot-state** 'complete)
(get-accessor-method-function gf type class slotd)
(defmethod compute-slots :around ((class condition-class))
(let ((eslotds (call-next-method)))
- (mapc #'initialize-internal-slot-functions eslotds)
+ (mapc #'finalize-internal-slot-functions eslotds)
eslotds))
(defmethod shared-initialize :after
(defmethod compute-slots :around ((class structure-class))
(let ((eslotds (call-next-method)))
- (mapc #'initialize-internal-slot-functions eslotds)
+ (mapc #'finalize-internal-slot-functions eslotds)
eslotds))
(defmethod compute-effective-slot-definition ((class slot-class) name dslotds)
--- /dev/null
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; a test that metaclasses can be instantiated even if there are
+;;; applicable methods for SLOT-VALUE-USING-CLASS with specialized
+;;; arguments that invoke slot readers. (Previously the PV
+;;; optimization for slot readers caused the new class's wrapper and
+;;; effective slot definitions to be available during class
+;;; finalization)
+
+(load "assertoid.lisp")
+
+(defpackage "MOP-29"
+ (:use "CL" "SB-MOP"))
+
+(in-package "MOP-29")
+
+(defclass my-class (standard-class)
+ ())
+(defmethod validate-superclass ((class my-class) (super-class standard-class))
+ t)
+(defvar *foo*)
+;;; the specialization of OBJECT here triggers the PV optimization;
+;;; with an unspecialized argument, the SLOT-VALUE is not optimized.
+(defmethod slot-value-using-class
+ ((class my-class) (object standard-object) eslotd)
+ (if *foo*
+ (setf (slot-value object 'id) 42)
+ (call-next-method)))
+(defclass my-object ()
+ ((id :type integer :reader id-of))
+ (:metaclass my-class))
+
+;;; the first patch failed on code like this, because the STD-P field
+;;; of the accessor information was also computed lazily, but it is
+;;; needed in order to real with accessor cache misses.
+(defun test-global-accessors ()
+ (let ((object (make-instance 'my-object)))
+ (setf (slot-value object 'id) 13)
+ (let ((*foo* nil))
+ (assert (= (id-of object) 13))
+ (assert (= (slot-value object 'id) 13)))
+ (let ((*foo* t))
+ (assert (= (id-of object) 42))
+ (assert (= (slot-value object 'id) 42)))
+ (let ((*foo* nil))
+ (assert (= (id-of object) 42))
+ (assert (= (slot-value object 'id) 42)))))
+(compile 'test-global-accessors)
+(test-global-accessors)
;;; 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".)
-"1.0.32.11"
+"1.0.32.12"
projects / sbcl.git / commitdiff