0.9.6.13:

	Implement (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) as
	required by AMOP
	... call REINITIALIZE-INSTANCE;
	... no longer generic functions;
	... rewrite the classoid-finding code in (SETF CLASS-NAME), which
		previously broke on the second rename :-/

diff --git a/NEWS b/NEWS
index da04493..1b7ab15 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,11 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-0.9.7 relative to sbcl-0.9.6:
+  * minor incompatible change: (SETF CLASS-NAME) and (SETF
+    GENERIC-FUNCTION-NAME) are no longer generic functions, and
+    therefore are not customizeable by user code (as seems to be at
+    least permitted and maybe required by AMOP).  As a consolation,
+    however, the SBCL implementation of these functions now calls
+    REINITIALIZE-INSTANCE as specified by AMOP.
   * bug fix: it is now possible to have more than one subclass of
     STANDARD-GENERIC-FUNCTION without causing stack overflow.
     (reported by Bruno Haible, Pascal Costanza and others)

diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index e2240a1..5f943e4 100644 (file)
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -342,7 +342,7 @@
   ((name
     :initform nil
     :initarg :name
-    :accessor generic-function-name)
+    :reader generic-function-name)
    (methods
     :initform ()
     :accessor generic-function-methods
@@ -580,8 +580,8 @@
                  specializer)
   ((name
     :initform nil
-    :initarg  :name
-    :accessor class-name)
+    :initarg :name
+    :reader class-name)
    (class-eq-specializer
     :initform nil
     :reader class-eq-specializer)

diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp
index 34f3981..6db290a 100644 (file)
--- a/src/pcl/generic-functions.lisp
+++ b/src/pcl/generic-functions.lisp
@@ -166,8 +166,6 @@
 
 (defgeneric (setf class-incompatible-superclass-list) (new-value pcl-class))
 
-(defgeneric (setf class-name) (new-value class))
-
 (defgeneric (setf class-slots) (new-value slot-class))
 
 (defgeneric (setf generic-function-method-class) (new-value
@@ -182,8 +180,6 @@
 (defgeneric (setf generic-function-methods) (new-value
                                              standard-generic-function))
 
-(defgeneric (setf generic-function-name) (new-value standard-generic-function))
-
 (defgeneric (setf gf-dfun-state) (new-value standard-generic-function))
 
 (defgeneric (setf generic-function-initial-methods)

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 0ac414e..f721a4b 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -1543,9 +1543,13 @@
              (set-dfun gf dfun cache info) ; lest the cache be freed twice
              (update-dfun gf dfun cache info))))))
 \f
-(defmethod (setf class-name) :before (new-value (class class))
-  (let ((classoid (find-classoid (class-name class))))
-    (setf (classoid-name classoid) new-value)))
+(defun (setf class-name) (new-value class)
+  (let ((classoid (%wrapper-classoid (class-wrapper class))))
+    (setf (classoid-name classoid) new-value))
+  (reinitialize-instance class :name new-value))
+
+(defun (setf generic-function-name) (new-value generic-function)
+  (reinitialize-instance generic-function :name new-value))
 \f
 (defmethod function-keywords ((method standard-method))
   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)

diff --git a/tests/mop-9.impure-cload.lisp b/tests/mop-9.impure-cload.lisp
new file mode 100644 (file)
index 0000000..751b1b4
--- /dev/null
+++ b/tests/mop-9.impure-cload.lisp
@@ -0,0 +1,83 @@
+;;;; 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 contains tests of (SETF CLASS-NAME) and (SETF
+;;; GENERIC-FUNCTION-NAME)
+
+(defpackage "MOP-9"
+  (:use "CL" "SB-MOP" "TEST-UTIL"))
+
+(in-package "MOP-9")
+
+(defclass metaclass/ri (standard-class)
+  ())
+(defmethod validate-superclass ((c metaclass/ri) (s standard-class))
+  t)
+(defclass class/ri ()
+  ()
+  (:metaclass metaclass/ri))
+(defvar *class/ri-args* nil)
+(defmethod reinitialize-instance :after ((o metaclass/ri) &rest initargs)
+  (setf *class/ri-args* initargs))
+(with-test (:name ((setf class-name) reinitialize-instance))
+  (let ((class (find-class 'class/ri)))
+    (setf (class-name class) 'name)
+    (assert (equal *class/ri-args* '(:name name)))
+    (setf (class-name class) 'class/ri)
+    (assert (equal *class/ri-args* '(:name class/ri)))))
+
+(defclass dependent ()
+  ((slot :initform nil :accessor dependent-slot)))
+(defclass class/dependent ()
+  ())
+(defvar *dependent* (make-instance 'dependent))
+(defmethod update-dependent ((object standard-class) (dependent dependent)
+                             &rest args)
+  (setf (dependent-slot dependent) args))
+(with-test (:name ((setf class-name) update-dependent))
+  (let ((class (find-class 'class/dependent)))
+    (add-dependent class *dependent*)
+    (setf (class-name class) 'name)
+    (assert (equal (dependent-slot *dependent*) '(:name name)))
+    (remove-dependent class *dependent*)
+    (setf (class-name class) 'name)
+    (assert (equal (dependent-slot *dependent*) '(:name name)))))
+
+(defclass gfc/ri (standard-generic-function)
+  ()
+  (:metaclass funcallable-standard-class))
+(defgeneric gf/ri ()
+  (:generic-function-class gfc/ri))
+(defvar *gf/ri-args* nil)
+(defmethod reinitialize-instance :after ((o gfc/ri) &rest initargs)
+  (setf *gf/ri-args* initargs))
+(with-test (:name ((setf generic-function-name) reinitialize-instance))
+  (let ((gf #'gf/ri))
+    (setf (generic-function-name gf) 'name)
+    (assert (equal *gf/ri-args* '(:name name)))
+    (setf (generic-function-name gf) 'gf/ri)
+    (assert (equal *gf/ri-args* '(:name gf/ri)))))
+
+(defgeneric gf/dependent ())
+(defmethod update-dependent ((object standard-generic-function)
+                             (dependent dependent)
+                             &rest args)
+  (setf (dependent-slot dependent) args))
+(with-test (:name ((setf generic-function-name) update-dependent))
+  (let ((gf (find-class 'class/dependent)))
+    (add-dependent gf *dependent*)
+    (setf (generic-function-name gf) 'gf/name)
+    (assert (equal (dependent-slot *dependent*) '(:name gf/name)))
+    (remove-dependent gf *dependent*)
+    (setf (generic-function-name gf) 'gf/dependent)
+    (assert (equal (dependent-slot *dependent*) '(:name gf/name)))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 6f11c54..19b7386 100644 (file)
--- 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.6.12"
+"0.9.6.13"