From: Christophe Rhodes Date: Wed, 2 Nov 2005 22:19:47 +0000 (+0000) Subject: 0.9.6.13: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=45e89c1430d86a7a8a8d7afc133400c7a70e1080;p=sbcl.git 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 --- 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 --- 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 --- 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 --- 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)))))) -(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)) (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 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 --- 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"