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
;;;; -*- 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
@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
(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)
())
(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 <sqd5hrclb2.fsf@cam.ac.uk> and
+ ;; responses in comp.lang.lisp). -- CSR, 2006-02-27
+ ((%type :initform nil :reader specializer-type)))
(defclass specializer-with-object (specializer) ())
(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)
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))))))
(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)))
(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))))
;;; 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"
projects / sbcl.git / commitdiff