From 5d0643d3b70aade43037e8b7cdf39b7e12f5d3fd Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 24 Apr 2003 15:22:49 +0000 Subject: [PATCH] 0.pre8.100: As suggested by Fufie (Stig Sandoe) on #lisp IRC, emit a STYLE-WARNING for slots with names that are STRING= but not EQ. ... test that we can nonetheless still make them, given the insecurity I feel about my format string wizardry. --- src/pcl/std-class.lisp | 20 ++++++++++++++++++++ tests/clos.impure.lisp | 10 ++++++++++ version.lisp-expr | 2 +- 3 files changed, 31 insertions(+), 1 deletion(-) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 34a1d5a..76b3343 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -505,6 +505,26 @@ (add-direct-subclasses class direct-superclasses) (make-class-predicate class predicate-name) (update-class class nil) + (do* ((slots (slot-value class 'slots) (cdr slots)) + (dupes nil)) + ((null slots) (when dupes + (style-warn + ;; FIXME: the indentation request ("~4I") + ;; below appears not to do anything. Finding + ;; out why would be nice. -- CSR, 2003-04-24 + "~@~@:>" + class + dupes))) + (let* ((slot (car slots)) + (oslots (remove (slot-definition-name slot) (cdr slots) + :test-not #'string= :key #'slot-definition-name))) + (when oslots + (pushnew (cons (slot-definition-name slot) + (mapcar #'slot-definition-name oslots)) + dupes + :test #'string= :key #'car)))) (add-slot-accessors class direct-slots) (make-preliminary-layout class)) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index b437d76..14787f5 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -598,5 +598,15 @@ (defclass frc-3 () ()) (assert (typep (make-instance 'frc-1 :a 2) (find-class 'frc-1))) (assert (typep (make-instance 'frc-2 :a 3) (find-class 'frc-2))) + +;;; check that we can define classes with two slots of different names +;;; (even if it STYLE-WARNs). +(defclass odd-name-class () + ((name :initarg :name) + (cl-user::name :initarg :name2))) +(let ((x (make-instance 'odd-name-class :name 1 :name2 2))) + (assert (= (slot-value x 'name) 1)) + (assert (= (slot-value x 'cl-user::name) 2))) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 95102c4..e46bf66 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.pre8.99" +"0.pre8.100" -- 1.7.10.4