0.7.13.pcl-class.1

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

diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index dfba214..2c1dfed 100644 (file)
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -48,6 +48,7 @@
 (defvar *initfunctions-for-this-defclass*)
 (defvar *readers-for-this-defclass*)
 (defvar *writers-for-this-defclass*)
+(defvar *slot-names-for-this-defclass*)
 
 ;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is
 ;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until
@@ -71,17 +72,14 @@
              (error "The value of the :metaclass option (~S) is not a~%~
                      legal class name."
                     (cadr option)))
-           (setq metaclass
-                    (case (cadr option)
-                      (cl:standard-class 'standard-class)
-                      (cl:structure-class 'structure-class)
-                      (t (cadr option))))
+           (setq metaclass (cadr option))
            (setf options (remove option options))
            (return t))))
 
       (let ((*initfunctions-for-this-defclass* ())
             (*readers-for-this-defclass* ()) ;Truly a crock, but we got
-            (*writers-for-this-defclass* ())) ;to have it to live nicely.
+            (*writers-for-this-defclass* ()) ;to have it to live nicely.
+            (*slot-names-for-this-defclass* ()))
         (let ((canonical-slots
                 (mapcar (lambda (spec)
                          (canonicalize-slot-specification name spec))
@@ -107,6 +105,13 @@
                     ,@(mapcar (lambda (x)
                                 `(declaim (ftype (function (t t) t) ,x)))
                               *writers-for-this-defclass*)
+                     ,@(mapcar (lambda (x)
+                                 `(declaim (ftype (function (t) t)
+                                                  ,(slot-reader-name x)
+                                                  ,(slot-boundp-name x))
+                                           (ftype (function (t t) t)
+                                                  ,(slot-writer-name x))))
+                               *slot-names-for-this-defclass*)
                     (let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
                       (load-defclass ',name
                                      ',metaclass
@@ -180,10 +185,12 @@
   (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*)
         `'(:name ,(car spec)))
        ((null (cddr spec))
         (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
@@ -196,6 +203,7 @@
                (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)
@@ -219,7 +227,7 @@
           (if (eq initform unsupplied)
               `(list* ,@spec)
               `(list* :initfunction ,(make-initfunction initform) ,@spec))))))
-                                               
+
 (defun canonicalize-defclass-option (class-name option)
   (declare (ignore class-name))
   (case (car option)
@@ -388,7 +396,7 @@
        canonical-options (copy-tree canonical-options))
   (let ((ecd
          (make-early-class-definition name
-                                      *load-truename*
+                                      *load-pathname*
                                       metaclass
                                       supers
                                       canonical-slots