From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Tue, 27 May 2003 13:32:11 +0000 (+0000)
Subject: 0.8.0.8:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=2ef330d818799fe54587bdcb4c626b397ca15266;p=sbcl.git

0.8.0.8:
	Some slight MAKE-LOAD-FORM-related fixes
	... in general, slots can be named by any symbols; DEFCLASS is
		more stringent in its requirements, so move the extra
		checks into the DEFCLASS macro.
	... now structure slots can be named by keywords again.
	... make MAKE-LOAD-FORM-SAVING-SLOTS results on structures
		cause the compiler to be less verbose, by using a
		lower-level setter (SB!KERNEL:SLOT-SETTER-LAMBDA-FORM).
---

diff --git a/NEWS b/NEWS
index de94c74..90b4e1d 100644
--- a/NEWS
+++ b/NEWS
@@ -1775,6 +1775,8 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0:
     ** type checking in branches (194bc).
   * VALUES declaration is disabled.
   * a short form of VALUES type specifier has ANSI meaning.
+  * fixed bug in DEFSTRUCT: once again, naming structure slots with
+    keywords or constants is permissible.
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 1f7fc50..63ba1ba 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1312,9 +1312,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "CLASSOID-LAYOUT" "CLASSOID-NAME"
              "DD-RAW-LENGTH" "NOTE-NAME-DEFINED"
              "%CODE-CODE-SIZE" "DD-SLOTS"
-	     "DD-INCLUDE"
+	     "DD-INCLUDE" "SLOT-SETTER-LAMBDA-FORM"
              "%IMAGPART" "DSD-ACCESSOR-NAME"
-             "%CODE-DEBUG-INFO" "DSD-%NAME"
+             "%CODE-DEBUG-INFO"
              "LAYOUT-CLASSOID" "LAYOUT-INVALID"
              "%SIMPLE-FUN-NAME" "DSD-TYPE" "%INSTANCEP"
              "DEFSTRUCT-SLOT-DESCRIPTION" "%SIMPLE-FUN-ARGLIST"
diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index 2c1dfed..4226df5 100644
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -59,7 +59,7 @@
 ;;; After the metabraid has been setup, and the protocol for defining
 ;;; classes has been defined, the real definition of LOAD-DEFCLASS is
 ;;; installed by the file std-class.lisp
-(defmacro defclass (name %direct-superclasses %direct-slots &rest %options)
+(defmacro defclass (&environment env name %direct-superclasses %direct-slots &rest %options)
   (let ((supers  (copy-tree %direct-superclasses))
 	(slots   (copy-tree %direct-slots))
 	(options (copy-tree %options)))
@@ -82,7 +82,7 @@
             (*slot-names-for-this-defclass* ()))
         (let ((canonical-slots
                 (mapcar (lambda (spec)
-			  (canonicalize-slot-specification name spec))
+			  (canonicalize-slot-specification name spec env))
                         slots))
               (other-initargs
                 (mapcar (lambda (option)
@@ -181,52 +181,72 @@
 	     (push entry *initfunctions-for-this-defclass*))
 	   (cadr entry)))))
 
-(defun canonicalize-slot-specification (class-name spec)
-  (cond ((and (symbolp spec)
-	      (not (keywordp spec))
-	      (not (memq spec '(t nil))))
-         (push spec *slot-names-for-this-defclass*)
-	 `'(:name ,spec))
-	((not (consp spec))
-	 (error "~S is not a legal slot specification." spec))
-	((null (cdr spec))
-         (push (car spec) *slot-names-for-this-defclass*)
+(defun canonicalize-slot-specification (class-name spec env)
+  (labels ((slot-name-illegal (reason)
+	     (error 'simple-program-error
+		    :format-control
+		    (format nil "~~@<in DEFCLASS ~~S, the slot name in the ~
+                                 specification ~~S is ~A.~~@:>" reason)
+		    :format-arguments (list class-name spec)))
+	   (check-slot-name-legality (name)
+	     (cond
+	       ((not (symbolp name))
+		(slot-name-illegal "not a symbol"))
+	       ((keywordp name)
+		(slot-name-illegal "a keyword"))
+	       ((constantp name env)
+		(slot-name-illegal "a constant")))))
+    (cond ((atom spec)
+	   (check-slot-name-legality spec)
+	   (push spec *slot-names-for-this-defclass*)
+	   `'(:name ,spec))
+	  ((null (cdr spec))
+	   (check-slot-name-legality (car spec))
+	   (push (car spec) *slot-names-for-this-defclass*)
 	 `'(:name ,(car spec)))
-	((null (cddr spec))
-	 (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
-		 Convert it to ~S"
-		class-name spec (list (car spec) :initform (cadr spec))))
-	(t
-	 (let* ((name (pop spec))
-		(readers ())
-		(writers ())
-		(initargs ())
-		(unsupplied (list nil))
-		(initform (getf spec :initform unsupplied)))
-           (push name *slot-names-for-this-defclass*)
-	   (doplist (key val) spec
-	     (case key
-	       (:accessor (push val readers)
-			  (push `(setf ,val) writers))
-	       (:reader   (push val readers))
-	       (:writer   (push val writers))
-	       (:initarg  (push val initargs))))
-	   (loop (unless (remf spec :accessor) (return)))
-	   (loop (unless (remf spec :reader)   (return)))
-	   (loop (unless (remf spec :writer)   (return)))
-	   (loop (unless (remf spec :initarg)  (return)))
-	   (setq *writers-for-this-defclass*
-		 (append writers *writers-for-this-defclass*))
-	   (setq *readers-for-this-defclass*
-		 (append readers *readers-for-this-defclass*))
-	   (setq spec `(:name     ',name
-			:readers  ',readers
-			:writers  ',writers
-			:initargs ',initargs
-			',spec))
-	   (if (eq initform unsupplied)
-	       `(list* ,@spec)
-	       `(list* :initfunction ,(make-initfunction initform) ,@spec))))))
+	  ((null (cddr spec))
+	   (error 'simple-program-error
+		  :format-control
+		  "~@<in DEFCLASS ~S, the slot specification ~S is invalid; ~
+                   the probable intended meaning may be achieved by ~
+                   specifiying ~S instead."
+		  :format-arguments
+		  (list class-name spec
+			`(,(car spec) :initform ,(cadr spec)))))
+	  (t
+	   (let* ((name (car spec))
+		  (spec (cdr spec))
+		  (readers ())
+		  (writers ())
+		  (initargs ())
+		  (unsupplied (list nil))
+		  (initform (getf spec :initform unsupplied)))
+	     (check-slot-name-legality name)
+	     (push name *slot-names-for-this-defclass*)
+	     (doplist (key val) spec
+	       (case key
+		 (:accessor (push val readers)
+			    (push `(setf ,val) writers))
+		 (:reader   (push val readers))
+		 (:writer   (push val writers))
+		 (:initarg  (push val initargs))))
+	     (loop (unless (remf spec :accessor) (return)))
+	     (loop (unless (remf spec :reader)   (return)))
+	     (loop (unless (remf spec :writer)   (return)))
+	     (loop (unless (remf spec :initarg)  (return)))
+	     (setq *writers-for-this-defclass*
+		   (append writers *writers-for-this-defclass*))
+	     (setq *readers-for-this-defclass*
+		   (append readers *readers-for-this-defclass*))
+	     (setq spec `(:name     ',name
+			  :readers  ',readers
+			  :writers  ',writers
+			  :initargs ',initargs
+			  ',spec))
+	     (if (eq initform unsupplied)
+		 `(list* ,@spec)
+		 `(list* :initfunction ,(make-initfunction initform)
+		         ,@spec)))))))
 
 (defun canonicalize-defclass-option (class-name option)
   (declare (ignore class-name))
diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp
index d793f9a..d074eb6 100644
--- a/src/pcl/env.lisp
+++ b/src/pcl/env.lisp
@@ -158,7 +158,14 @@
                          (eq :instance (slot-definition-allocation slot))))
             (if (slot-boundp-using-class class object slot)
                 (let ((value (slot-value-using-class class object slot)))
-                  (inits `(setf (slot-value ,object ',slot-name) ',value)))
+		  (if (typep object 'structure-object)
+		      ;; low-level but less noisy initializer form
+		      (let* ((dd (get-structure-dd (class-name class)))
+			     (dsd (find slot-name (dd-slots dd)
+					:key #'dsd-name)))
+			(inits `(,(slot-setter-lambda-form dd dsd)
+				 ',value ,object)))
+		      (inits `(setf (slot-value ,object ',slot-name) ',value))))
                 (inits `(slot-makunbound ,object ',slot-name))))))
       (values `(allocate-instance (find-class ',(class-name class)))
               `(progn ,@(inits))))))
diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index eeeeec4..1f9a12c 100644
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -354,7 +354,7 @@
 (defun structure-slotd-writer-function (type slotd)
   (if (dsd-read-only slotd)
       (let ((dd (get-structure-dd type)))
-	(coerce (sb-kernel::slot-setter-lambda-form dd slotd) 'function))
+	(coerce (slot-setter-lambda-form dd slotd) 'function))
       (fdefinition `(setf ,(dsd-accessor-name slotd)))))
 
 (defun structure-slotd-type (slotd)
diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 5a57f24..63b1bcd 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -89,10 +89,7 @@
       "is not a non-null atom"))
 
 (defmethod legal-slot-name-p ((object standard-method) x)
-  (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")
-	((keywordp x)      "is a keyword and so cannot be bound")
-	((memq x '(t nil)) "cannot be bound")
-	((constantp x)     "is a constant and so cannot be bound")
+  (cond ((not (symbolp x)) "is not a symbol")
 	(t t)))
 
 (defmethod legal-specializers-p ((object standard-method) x)
diff --git a/version.lisp-expr b/version.lisp-expr
index 738c035..5db49d0 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.8.0.7"
+"0.8.0.8"