Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs1:/tmp/cvs-serv23309/src/pcl
Modified Files:
defclass.lisp env.lisp low.lisp methods.lisp
Log Message:
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).
Index: defclass.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defclass.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- defclass.lisp 24 Mar 2003 18:39:08 -0000 1.26
+++ defclass.lisp 27 May 2003 13:32:13 -0000 1.27
@@ -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))
Index: env.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/env.lisp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- env.lisp 19 May 2003 14:05:18 -0000 1.10
+++ env.lisp 27 May 2003 13:32:13 -0000 1.11
@@ -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))))))
Index: low.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/low.lisp,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -d -r1.30 -r1.31
--- low.lisp 20 May 2003 10:36:02 -0000 1.30
+++ low.lisp 27 May 2003 13:32:13 -0000 1.31
@@ -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)
Index: methods.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- methods.lisp 19 May 2003 10:51:33 -0000 1.26
+++ methods.lisp 27 May 2003 13:32:13 -0000 1.27
@@ -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)
|