From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Sun, 28 May 2006 11:02:02 +0000 (+0000)
Subject: 0.9.13.4:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e404d36bb823d93ad20ccd6c653244cf443f2633;p=sbcl.git

0.9.13.4:
	Explicitly disallow specializations on new-value for (setf
	slot-value-using-class), as suggested by Levente Mezaros
	sbcl-devel 2006-05-09.
	... documentation
	... internals documentation
	... also one or two other small cleanups: don't keep dfun
		information in special-case generic functions; make
		metaobject-protocol-violation an error, not just a
		condition.
---

diff --git a/NEWS b/NEWS
index f97afdb..7994058 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,11 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-0.9.14 relative to sbcl-0.9.13:
+  * minor incompatible change: prevent the user from specializing the
+    new-value argument to SB-MOP:SLOT-VALUE-USING-CLASS.  It's
+    somewhat counter to the intent of the protocol, I (CSR) think, and
+    additionally it just doesn't work in SBCL as currently
+    implemented, thanks to optimizations (that are always valid for
+    the other three SLOT-VALUEish functions, but not for the setter).
   * bug fix: unparsing logical pathnames with :NAME :WILD :TYPE NIL
     failed with a type error.  (reported by Pascal Bourguignon)
   * fixed some bugs revealed by Paul Dietz' test suite:
diff --git a/doc/internals/slot-value.texinfo b/doc/internals/slot-value.texinfo
index 0a00d8f..ec0312f 100644
--- a/doc/internals/slot-value.texinfo
+++ b/doc/internals/slot-value.texinfo
@@ -189,3 +189,7 @@ computed lazily rather than eagerly.  The default image has 8589
 closures implementing this optimization: 3 (@code{slot-value},
 @code{set-slot-value} and @code{slot-boundp}) for each of 2863 effective
 slots.)
+
+(Also note that this optimization depends on not being able to
+specialize the @code{new-value} argument to @{(setf
+slot-value-using-class)}.)
diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo
index 7a79357..93929ec 100644
--- a/doc/manual/beyond-ansi.texinfo
+++ b/doc/manual/beyond-ansi.texinfo
@@ -132,6 +132,30 @@ Common Lisp restriction on defining functions, variables and types named
 by symbols in the Common Lisp package: preventing two independent pieces
 of software from colliding with each other.
 
+@item
+@findex slot-value-using-class
+@findex sb-mop:slot-value-using-class
+@findex (setf slot-value-using-class)
+@findex (setf sb-mop:slot-value-using-class)
+@findex slot-boundp-using-class
+@findex sb-mop:slot-boundp-using-class
+specializations of the @code{new-value} argument to @code{(setf
+sb-mop:slot-value-using-class)} are not allowed: all user-defined
+methods must have a specializer of the class @code{t}.
+
+This prohibition is motivated by a separation of layers: the
+@code{slot-value-using-class} family of functions is intended for use in
+implementing different and new slot allocation strategies, rather than
+in performing application-level dispatching.  Additionally, with this
+requirement, there is a one-to-one mapping between metaclass, class and
+slot-definition-class tuples and effective methods of @code{(setf
+slot-value-using-class)}, which permits optimization of @code{(setf
+slot-value-using-class)}'s discriminating function in the same manner as
+for @code{slot-value-using-class} and @code{slot-boundp-using-class}.
+
+Note that application code may specialize on the @code{new-value}
+argument of slot accessors.
+
 @end itemize
 
 @node  Support For Unix
diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 9f43c63..f61386e 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -54,7 +54,7 @@
 ;;; Methods are not reinitializable.
 
 (define-condition metaobject-initialization-violation
-    (reference-condition simple-condition)
+    (reference-condition simple-error)
   ())
 
 (macrolet ((def (name args control)
@@ -486,6 +486,18 @@
   (loop (when (null methods) (return gf))
         (real-add-method gf (pop methods) methods)))
 
+(define-condition new-value-specialization (reference-condition error)
+  ((%method :initarg :method :reader new-value-specialization-method))
+  (:report
+   (lambda (c s)
+     (format s "~@<Cannot add method ~S to ~S, as it specializes the ~
+                new-value argument.~@:>"
+             (new-value-specialization-method c)
+             #'(setf slot-value-using-class))))
+  (:default-initargs :references
+      (list '(:sbcl :node "Metaobject Protocol")
+            '(:amop :generic-function (setf slot-value-using-class)))))
+
 (defun real-add-method (generic-function method &optional skip-dfun-update-p)
   (when (method-generic-function method)
     (error "~@<The method ~S is already part of the generic ~
@@ -516,6 +528,17 @@
         (when (and existing (similar-lambda-lists-p existing method))
           (remove-method generic-function existing))
 
+        ;; KLUDGE: We have a special case here, as we disallow
+        ;; specializations of the NEW-VALUE argument to (SETF
+        ;; SLOT-VALUE-USING-CLASS).  GET-ACCESSOR-METHOD-FUNCTION is
+        ;; the optimizing function here: it precomputes the effective
+        ;; method, assuming that there is no dispatch to be done on
+        ;; the new-value argument.
+        (when (and (eq generic-function #'(setf slot-value-using-class))
+                   (not (eq *the-class-t* (first specializers))))
+          (error 'new-value-specialization
+                 :method method))
+
         (setf (method-generic-function method) generic-function)
         (pushnew method (generic-function-methods generic-function))
         (dolist (specializer specializers)
@@ -1520,45 +1543,50 @@
   (declare (ignore class))
   (function-funcall (slot-definition-boundp-function slotd) object))
 
+(defun special-case-for-compute-discriminating-function-p (gf)
+  (or (eq gf #'slot-value-using-class)
+      (eq gf #'(setf slot-value-using-class))
+      (eq gf #'slot-boundp-using-class)))
+
 (defmethod compute-discriminating-function ((gf standard-generic-function))
   (with-slots (dfun-state arg-info) gf
+    (when (special-case-for-compute-discriminating-function-p gf)
+      ;; if we have a special case for
+      ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the
+      ;; special cases implemented as of 2006-05-09) any information
+      ;; in the cache is misplaced.
+      (aver (null dfun-state)))
     (typecase dfun-state
-      (null (let ((name (generic-function-name gf)))
-              (when (eq name 'compute-applicable-methods)
-                (update-all-c-a-m-gf-info gf))
-              (cond ((eq name 'slot-value-using-class)
-                     (update-slot-value-gf-info gf 'reader)
-                     #'slot-value-using-class-dfun)
-                    ((equal name '(setf slot-value-using-class))
-                     (update-slot-value-gf-info gf 'writer)
-                     #'setf-slot-value-using-class-dfun)
-                    ((eq name 'slot-boundp-using-class)
-                     (update-slot-value-gf-info gf 'boundp)
-                     #'slot-boundp-using-class-dfun)
-                    ((gf-precompute-dfun-and-emf-p arg-info)
-                     (make-final-dfun gf))
-                    (t
-                     (make-initial-dfun gf)))))
+      (null
+       (when (eq gf #'compute-applicable-methods)
+         (update-all-c-a-m-gf-info gf))
+       (cond
+         ((eq gf #'slot-value-using-class)
+          (update-slot-value-gf-info gf 'reader)
+          #'slot-value-using-class-dfun)
+         ((eq gf #'(setf slot-value-using-class))
+          (update-slot-value-gf-info gf 'writer)
+          #'setf-slot-value-using-class-dfun)
+         ((eq gf #'slot-boundp-using-class)
+          (update-slot-value-gf-info gf 'boundp)
+          #'slot-boundp-using-class-dfun)
+         ((gf-precompute-dfun-and-emf-p arg-info)
+          (make-final-dfun gf))
+         (t
+          (make-initial-dfun gf))))
       (function dfun-state)
       (cons (car dfun-state)))))
 
 (defmethod update-gf-dfun ((class std-class) gf)
   (let ((*new-class* class)
-        #|| (name (generic-function-name gf)) ||#
         (arg-info (gf-arg-info gf)))
-    (cond #||
-          ((eq name 'slot-value-using-class)
-           (update-slot-value-gf-info gf 'reader))
-          ((equal name '(setf slot-value-using-class))
-           (update-slot-value-gf-info gf 'writer))
-          ((eq name 'slot-boundp-using-class)
-           (update-slot-value-gf-info gf 'boundp))
-          ||#
-          ((gf-precompute-dfun-and-emf-p arg-info)
-           (multiple-value-bind (dfun cache info)
-               (make-final-dfun-internal gf)
-             (set-dfun gf dfun cache info) ; lest the cache be freed twice
-             (update-dfun gf dfun cache info))))))
+    (cond
+      ((special-case-for-compute-discriminating-function-p gf))
+      ((gf-precompute-dfun-and-emf-p arg-info)
+       (multiple-value-bind (dfun cache info)
+           (make-final-dfun-internal gf)
+         (set-dfun gf dfun cache info) ; lest the cache be freed twice
+         (update-dfun gf dfun cache info))))))
 
 (defmethod (setf class-name) (new-value class)
   (let ((classoid (%wrapper-classoid (class-wrapper class))))
diff --git a/tests/mop-16.impure-cload.lisp b/tests/mop-16.impure-cload.lisp
new file mode 100644
index 0000000..86257be
--- /dev/null
+++ b/tests/mop-16.impure-cload.lisp
@@ -0,0 +1,37 @@
+;;;; 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.
+
+;;; this file tests that it is not possible to add an
+;;; optimization-invalidating method to #'(SETF
+;;; SLOT-VALUE-USING-CLASS).  If a way is found to preserve the
+;;; optimization, or if the optimization is deemed to be invalid, then
+;;; this test can go away.
+
+(defpackage "MOP-16"
+  (:use "CL" "SB-MOP"))
+
+(in-package "MOP-16")
+
+(defclass foo-class (standard-class) ())
+
+(defclass foo-effective-slot-definition (standard-effective-slot-definition)
+  ())
+
+(multiple-value-bind (value condition)
+    (ignore-errors
+      (defmethod (setf slot-value-using-class)
+          ((new-value integer) (class foo-class)
+           (object standard-object) (slotd foo-effective-slot-definition))
+        "Haha"))
+  (assert (null value))
+  (assert (typep condition 'error)))
diff --git a/version.lisp-expr b/version.lisp-expr
index 73d397e..7e8523a 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.9.13.3"
+"0.9.13.4"