0.6.12.22:

[sbcl.git] / src / pcl / defclass.lisp

diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index 022f979..f4d934a 100644 (file)
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -88,26 +88,37 @@
            (defstruct-p (and (eq *boot-state* 'complete)
                              (let ((mclass (find-class metaclass nil)))
                                (and mclass
-                                    (*subtypep mclass
-                                               *the-class-structure-class*))))))
+                                    (*subtypep
+                                     mclass
+                                     *the-class-structure-class*))))))
        (let ((defclass-form
-                (eval-when (:load-toplevel :execute)
-                  `(progn
-                    ,@(mapcar #'(lambda (x)
-                                  `(declaim (ftype (function (t) t) ,x)))
-                              *readers*)
-                    ,@(mapcar #'(lambda (x)
-                                  `(declaim (ftype (function (t t) t) ,x)))
-                              *writers*)
-                    (let ,(mapcar #'cdr *initfunctions*)
-                      (load-defclass ',name
-                                     ',metaclass
-                                     ',supers
-                                     (list ,@canonical-slots)
-                                     (list ,@(apply #'append
-                                                    (when defstruct-p
-                                                      '(:from-defclass-p t))
-                                                    other-initargs))))))))
+               `(progn
+                  ,@(mapcar (lambda (x)
+                              `(declaim (ftype (function (t) t) ,x)))
+                            *readers*)
+                  ,@(mapcar (lambda (x)
+                              `(declaim (ftype (function (t t) t) ,x)))
+                            *writers*)
+                  (let ,(mapcar #'cdr *initfunctions*)
+                    (load-defclass ',name
+                                   ',metaclass
+                                   ',supers
+                                   (list ,@canonical-slots)
+                                   (list ,@(apply #'append
+                                                  (when defstruct-p
+                                                    '(:from-defclass-p t))
+                                                  other-initargs)))))))
+         ;; FIXME: The way that we do things like (EVAL DEFCLASS-FORM)
+         ;; here is un-ANSI-Common-Lisp-y and leads to problems
+         ;; (like DEFUN for the type predicate being called more than
+         ;; once when we do DEFCLASS at the interpreter prompt),
+         ;; causing bogus style warnings. It would be better to
+         ;; rewrite this so that the macroexpansion looks like e.g.
+         ;; (PROGN
+         ;;   (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
+         ;;     (FROB1 ..))
+         ;;   (EVAL-WHEN (:LOAD-TOPLEVEL :EXECUTE)
+         ;;     (FROB2 ..)))
          (if defstruct-p
              (progn
                (eval defclass-form) ; Define the class now, so that..
@@ -121,13 +132,13 @@
 
 (defun make-initfunction (initform)
   (declare (special *initfunctions*))
-  (cond ((or (eq initform 't)
+  (cond ((or (eq initform t)
             (equal initform ''t))
         '(function constantly-t))
-       ((or (eq initform 'nil)
+       ((or (eq initform nil)
             (equal initform ''nil))
         '(function constantly-nil))
-       ((or (eql initform '0)
+       ((or (eql initform 0)
             (equal initform ''0))
         '(function constantly-0))
        (t
@@ -281,8 +292,8 @@
        (loop (when (null others) (return nil))
              (let ((initarg (pop others)))
                (unless (eq initarg :direct-default-initargs)
-                (error "The defclass option ~S is not supported by the bootstrap~%~
-                       object system."
+                (error "~@<The defclass option ~S is not supported by ~
+                       the bootstrap object system.~:@>"
                        initarg)))
              (setq default-initargs
                    (nconc default-initargs (reverse (pop others)))))))
@@ -308,7 +319,8 @@
 ;;; standard slots must be computed the same way in this file as it is
 ;;; by the full object system later.
 (defmacro !bootstrap-get-slot (type object slot-name)
-  `(instance-ref (get-slots ,object) (!bootstrap-slot-index ,type ,slot-name)))
+  `(clos-slots-ref (get-slots ,object)
+                  (!bootstrap-slot-index ,type ,slot-name)))
 (defun !bootstrap-set-slot (type object slot-name new-value)
   (setf (!bootstrap-get-slot type object slot-name) new-value))