From 3bbc7259c2e01f38fe93edfa6f95e07590b07ac2 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Wed, 28 May 2003 08:50:41 +0000 Subject: [PATCH] Structure slot names can be any symbol. Found by Paul Dietz. * src/pcl/std-class.lisp (*allow-funny-slot-names*): Renamed from *allow-keyword-slot-names*. * src/pcl/methods.lisp (legal-slot-name-p): Allow any symbol if *allow-funny-slot-names* is true. (shared-initialize): Print the value of the :slot-name initarg. * src/code/defstruct.lisp (parse-1-dsd): Treat nil as symbol when used as a slot name. --- code/defstruct.lisp | 4 ++-- pcl/methods.lisp | 12 +++++++----- pcl/std-class.lisp | 6 +++--- 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/code/defstruct.lisp b/code/defstruct.lisp index 4971320ae..a9fd30100 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.87 2003/05/20 18:39:36 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.88 2003/05/28 08:50:41 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -669,7 +669,7 @@ (islot (make-defstruct-slot-description :name nil :index 0 :type t))) (multiple-value-bind (name default default-p type type-p read-only ro-p) - (cond ((listp spec) + (cond ((consp spec) (destructuring-bind (name &optional (default nil default-p) &key (type nil type-p) (read-only nil ro-p)) diff --git a/pcl/methods.lisp b/pcl/methods.lisp index 98bda92c3..c11ea0102 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.34 2003/05/25 17:01:51 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.35 2003/05/28 08:50:39 gerd Exp $") (in-package :pcl) @@ -227,10 +227,11 @@ (defmethod legal-slot-name-p ((object standard-method) x) (cond ((not (symbolp x)) "is not a symbol and so cannot be bound") + ;; + ;; Structure slots names can be any symbol. + (*allow-funny-slot-names*) ((keywordp x) - (if *allow-keyword-slot-names* - t - "is a keyword and so cannot be bound")) + "is a keyword and so cannot be bound") ((memq x '(t nil)) "cannot be bound") ((constantp x) @@ -259,7 +260,8 @@ (unless slot-definition (let ((legalp (legal-slot-name-p method slot-name))) (unless (eq legalp t) - (error "The value of the ~s initarg ~A." :slot-name legalp))))) + (error "The value of the ~s initarg, ~s, ~A." + :slot-name slot-name legalp))))) (defmethod shared-initialize :after ((method standard-method) slot-names &rest initargs diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 4befefe88..5cdd720a1 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.67 2003/05/25 14:33:49 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.68 2003/05/28 08:50:39 gerd Exp $") (in-package :pcl) @@ -1064,11 +1064,11 @@ (mapc #'initialize-internal-slot-functions eslotds) eslotds)) -(defvar *allow-keyword-slot-names* nil) +(defvar *allow-funny-slot-names* nil) (defmethod initialize-internal-slot-functions :around ((slotd structure-effective-slot-definition)) - (let ((*allow-keyword-slot-names* t)) + (let ((*allow-funny-slot-names* t)) (call-next-method))) (defmethod compute-effective-slot-definition -- GitLab