From 99df968112602d07a4b91492ab45367df27ee8ac Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 27 Feb 2006 11:02:11 +0000 Subject: [PATCH] 0.9.10.2: Fix remaining slot name publicness in standardized classes. ... be cowardly and just rename TYPE to %TYPE, but write a comment about why this isn't really good enough. ... now we can test for our interpretation. ... document it, too --- NEWS | 7 ++++++ doc/manual/beyond-ansi.texinfo | 14 ++++++++++++ src/pcl/braid.lisp | 16 ++++++------- src/pcl/defs.lisp | 10 +++++++- src/pcl/dfun.lisp | 4 ++-- src/pcl/std-class.lisp | 6 ++--- tests/mop.pure.lisp | 49 ++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 8 files changed, 93 insertions(+), 15 deletions(-) diff --git a/NEWS b/NEWS index efe729c..fcc512e 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,11 @@ ;;;; -*- coding: utf-8; -*- +changes in sbcl-0.9.11 relative to sbcl-0.9.10: + * new feature: Unicode character names are now known to the system + (through CHAR-NAME and NAME-CHAR). + * bug fix: as implied by AMOP, standardized classes no longer have + slots named by external symbols of public packages. (reported by + Pascal Costanza) + changes in sbcl-0.9.10 relative to sbcl-0.9.9: * new feature: new SAVE-LISP-AND-DIE keyword argument :EXECUTABLE can be used for bundling the runtime and the core file into one diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index c79ee95..b947bf8 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -118,6 +118,20 @@ The following definition is acceptable: @end lisp and leads to a class whose instances are funcallable and have one slot. +@item +the requirement that ``No portable class @math{C_p} may inherit, by +virtue of being a direct or indirect subclass of a specified class, any +slot for which the name is a symbol accessible in the +@code{common-lisp-user} package or exported by any package defined in +the ANSI Common Lisp standard.'' is interpreted to mean that the +standardized classes themselves should not have slots named by external +symbols of public packages. + +The rationale behind the restriction is likely to be similar to the ANSI +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. + @end itemize @node Support For Unix diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 6bed8f4..2c761aa 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -266,16 +266,16 @@ (set-slot 'name name) (set-slot 'finalized-p t) (set-slot 'source source) - (set-slot 'type (if (eq class (find-class t)) - t - ;; FIXME: Could this just be CLASS instead - ;; of `(CLASS ,CLASS)? If not, why not? - ;; (See also similar expression in - ;; SHARED-INITIALIZE :BEFORE (CLASS).) - `(class ,class))) + (set-slot '%type (if (eq class (find-class t)) + t + ;; FIXME: Could this just be CLASS instead + ;; of `(CLASS ,CLASS)? If not, why not? + ;; (See also similar expression in + ;; SHARED-INITIALIZE :BEFORE (CLASS).) + `(class ,class))) (set-slot 'class-eq-specializer (let ((spec (allocate-standard-instance class-eq-wrapper))) - (!bootstrap-set-slot 'class-eq-specializer spec 'type + (!bootstrap-set-slot 'class-eq-specializer spec '%type `(class-eq ,class)) (!bootstrap-set-slot 'class-eq-specializer spec 'object class) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 7a2e36b..b866b62 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -537,7 +537,15 @@ ()) (defclass specializer (metaobject) - ((type :initform nil :reader specializer-type))) + ;; KLUDGE: in sbcl-0.9.10.2 this was renamed from TYPE, which was an + ;; external symbol of the CL package and hence potentially collides + ;; with user code. Renaming this to %TYPE, however, is the coward's + ;; way out, because the objects that PCL puts in this slot aren't + ;; (quite) types: they are closer to kinds of specializer. However, + ;; the wholesale renaming and disentangling of specializers didn't + ;; appeal. (See also message and + ;; responses in comp.lang.lisp). -- CSR, 2006-02-27 + ((%type :initform nil :reader specializer-type))) (defclass specializer-with-object (specializer) ()) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 251a5fa..7c3ed05 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -1426,10 +1426,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun order-specializers (specl1 specl2 index compare-classes-function) (let ((type1 (if (eq *boot-state* 'complete) (specializer-type specl1) - (!bootstrap-get-slot 'specializer specl1 'type))) + (!bootstrap-get-slot 'specializer specl1 '%type))) (type2 (if (eq *boot-state* 'complete) (specializer-type specl2) - (!bootstrap-get-slot 'specializer specl2 'type)))) + (!bootstrap-get-slot 'specializer specl2 '%type)))) (cond ((eq specl1 specl2) nil) ((atom type1) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index d003364..83e16de 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -280,11 +280,11 @@ slot-names &key) (declare (ignore slot-names)) - (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl)))) + (setf (slot-value specl '%type) `(class-eq ,(specializer-class specl)))) (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key) (declare (ignore slot-names)) - (setf (slot-value specl 'type) + (setf (slot-value specl '%type) `(eql ,(specializer-object specl))) (setf (info :type :translator specl) (constantly (make-member-type :members (list (specializer-object specl)))))) @@ -484,7 +484,7 @@ (declare (ignore slot-names name)) ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not, ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.) - (setf (slot-value class 'type) `(class ,class)) + (setf (slot-value class '%type) `(class ,class)) (setf (slot-value class 'class-eq-specializer) (make-instance 'class-eq-specializer :class class))) diff --git a/tests/mop.pure.lisp b/tests/mop.pure.lisp index f7a5e33..c443cef 100644 --- a/tests/mop.pure.lisp +++ b/tests/mop.pure.lisp @@ -30,3 +30,52 @@ (assert (find (find-class 'sb-mop:metaobject) (sb-mop:class-direct-superclasses (find-class name)))) (assert (subtypep name 'sb-mop:metaobject))) + +;;; No portable class Cp may inherit, by virtue of being a direct or +;;; indirect subclass of a specified class, any slot for which the +;;; name is a symbol accessible in the common-lisp-user package or +;;; exported by any package defined in the ANSI Common Lisp standard. +(let ((specified-class-names + '(sb-mop:built-in-class + sb-mop:class + sb-mop:direct-slot-definition + sb-mop:effective-slot-definition + sb-mop:eql-specializer + sb-mop:forward-referenced-class + sb-mop:funcallable-standard-class + sb-mop:funcallable-standard-object + sb-mop:generic-function + sb-mop:metaobject + sb-mop:method + sb-mop:method-combination + sb-mop:slot-definition + sb-mop:specializer + sb-mop:standard-accessor-method + sb-mop:standard-class + sb-mop:standard-direct-slot-definition + sb-mop:standard-effective-slot-definition + sb-mop:standard-generic-function + sb-mop:standard-method + sb-mop:standard-object + sb-mop:standard-reader-method + sb-mop:standard-slot-definition + sb-mop:standard-writer-method))) + (labels ((slot-name-ok (name) + (dolist (package (mapcar #'find-package + '("CL" "CL-USER" "KEYWORD" "SB-MOP")) + t) + (when (multiple-value-bind (symbol status) + (find-symbol (symbol-name name) package) + (and (eq symbol name) + (or (eq package (find-package "CL-USER")) + (eq status :external)))) + (return nil)))) + (test-class-slots (class) + (loop for slot in (sb-mop:class-slots class) + for slot-name = (sb-mop:slot-definition-name slot) + unless (slot-name-ok slot-name) + collect (cons class slot-name)))) + (loop for class-name in specified-class-names + for class = (find-class class-name) + for results = (test-class-slots class) + when results do (cerror "continue" "~A" results)))) diff --git a/version.lisp-expr b/version.lisp-expr index 1c09ad3..cfd0f5e 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.10.1" +"0.9.10.2" -- 1.7.10.4