0.8.16.43: Fixes for various CLOS/MOP bugs
authorNikodemus Siivola <nikodemus@random-state.net>
Fri, 19 Nov 2004 15:13:51 +0000 (15:13 +0000)
committerNikodemus Siivola <nikodemus@random-state.net>
Fri, 19 Nov 2004 15:13:51 +0000 (15:13 +0000)
            * Correct canonization of DEFCLASS slot options (also move
               checking to macroexpansion time of DEFCLASS, and do
               some trivial reorganization of the defclass.lisp to
               make the diff bigger then it really is.) (reported
               by Bruno Haible)
            * (SETF FIND-CLASS) with new-value that is a
               FORWARD-REFERENCED-CLASS. (reported by Bruno Haible)
            * CLASS-PROTOTYPE signals an error if the class is not yet
               finalized; also clean up some of the class-prototype
               machinery a bit. (reported by Bruno Haible)
            * ALLOCATE-INSTANCE for BUILT-IN-CLASS now a) exists b)
               signals an error.
            * Add tests & record an as-of-yet-unfixed bug.

BUGS
NEWS
src/pcl/defclass.lisp
src/pcl/macros.lisp
src/pcl/slots.lisp
src/pcl/std-class.lisp
tests/clos.impure.lisp
tests/mop.impure.lisp
tests/run-tests.sh
version.lisp-expr

diff --git a/BUGS b/BUGS
index b9e6f93..48ca825 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1579,5 +1579,15 @@ WORKAROUND:
   pprinter and only truncated at output?  (So that indenting by 1/2
   then 3/2 would indent by two spaces, not one?)
 
-351: suboptimal error handling/reporting when compiling (PUSH (LET ...)) 
-  (fixed in 0.8.16.37)
+352: forward-referenced-class trouble
+ reported by Bruno Haible on sbcl-devel
+   (defclass c (a) ())
+   (setf (class-name (find-class 'a)) 'b)
+   (defclass a () (x))
+   (defclass b () (y))
+   (make-instance 'c)
+ Expected: an instance of c, with a slot named x
+ Got: debugger invoked on a SIMPLE-ERROR in thread 78906:
+        While computing the class precedence list of the class named C.
+        The class named B is a forward referenced class.
+        The class named B is a direct superclass of the class named C.
diff --git a/NEWS b/NEWS
index 4ff5f42..a583d35 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -25,6 +25,14 @@ changes in sbcl-0.8.17 relative to sbcl-0.8.16:
     types.
   * fixed bug #308: non-graphic characters now all have names, as
     required.  (reported by Bruno Haible)
+  * bug fix: (SETF FIND-CLASS) using a FORWARD-REFERENCED-CLASS as the
+    new value now works. (reported by Bruno Haible)
+  * bug fix: correct canonicalization of multiple non-standard slot
+    options in DEFCLASS as per AMOP 5.4.2. (reported by Bruno Haible)
+  * bug fix: SB-MOP:CLASS-PROTOTYPE now signals an error if the class
+    is not yet finalized, as required by AMOP. (reported by Bruno Haible)
+  * bug fix: SB-MOP:ALLOCATE-INSTANCE method for instances of BUILT-IN-CLASS
+    now exists, an signals an error.
   * bug fix: duplicate LOOP variable bindings now signal PROGRAM-ERROR
     during macroexpansion for non-iteration variables as well. (reported 
     by Bruno Haible for CMUCL)
index 363c960..8dc0529 100644 (file)
 \f
 ;;;; DEFCLASS macro and close personal friends
 
-;;; ANSI says (Macro DEFCLASS, section 7.7) that DEFCLASS, if it
-;;; "appears as a top level form, the compiler must make the class
-;;; name be recognized as a valid type name in subsequent declarations
-;;; (as for deftype) and be recognized as a valid class name for
-;;; defmethod parameter specializers and for use as the :metaclass
-;;; option of a subsequent defclass."
-(defun preinform-compiler-about-class-type (name)
-  ;; Unless the type system already has an actual type attached to
-  ;; NAME (in which case (1) writing a placeholder value over that
-  ;; actual type as a compile-time side-effect would probably be a bad
-  ;; idea and (2) anyway we don't need to modify it in order to make
-  ;; NAME be recognized as a valid type name)
-  (unless (info :type :kind name)
-    ;; Tell the compiler to expect a class with the given NAME, by
-    ;; writing a kind of minimal placeholder type information. This
-    ;; placeholder will be overwritten later when the class is defined.
-    (setf (info :type :kind name) :forthcoming-defclass-type))
-  (values))
-
-(defun preinform-compiler-about-accessors (readers writers slots)
-  (flet ((inform (name type)
-           ;; FIXME: This matches what PROCLAIM FTYPE does, except
-           ;; that :WHERE-FROM is :DEFINED, not :DECLARED, and should
-           ;; probably be factored into a common function -- eg.
-           ;; (%proclaim-ftype name declared-or-defined).
-           (when (eq (info :function :where-from name) :assumed)
-             (proclaim-as-fun-name name)
-             (note-name-defined name :function)
-             (setf (info :function :where-from name) :defined
-                   (info :function :type name) type))))
-    (let ((rtype (specifier-type '(function (t) t)))
-          (wtype (specifier-type '(function (t t) t))))
-      (dolist (reader readers)
-        (inform reader rtype))
-      (dolist (writer writers)
-        (inform writer wtype))
-      (dolist (slot slots)
-        (inform (slot-reader-name slot) rtype)
-        (inform (slot-boundp-name slot) rtype)
-        (inform (slot-writer-name slot) wtype)))))
-
 ;;; state for the current DEFCLASS expansion
 (defvar *initfunctions-for-this-defclass*)
 (defvar *readers-for-this-defclass*)
 ;;; 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 (&environment env name %direct-superclasses %direct-slots &rest %options)
-  (let ((supers  (copy-tree %direct-superclasses))
-       (slots   (copy-tree %direct-slots))
-       (options (copy-tree %options)))
-    (let ((metaclass 'standard-class))
+(defmacro defclass (&environment env name direct-superclasses direct-slots &rest options)
+  (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.
+        *slot-names-for-this-defclass*)
+    ;; FIXME: It would be nice to collect all errors from the
+    ;; expansion of a defclass and signal them in a single go.
+    (multiple-value-bind (metaclass canonical-options)
+        (canonize-defclass-options name options)
+    (let ((canonical-slots (canonize-defclass-slots name direct-slots env))
+          ;; DEFSTRUCT-P should be true if the class is defined
+          ;; with a metaclass STRUCTURE-CLASS, so that a DEFSTRUCT
+          ;; is compiled for the class.
+          (defstruct-p (and (eq *boot-state* 'complete)
+                            (let ((mclass (find-class metaclass nil)))
+                              (and mclass
+                                   (*subtypep
+                                    mclass
+                                    *the-class-structure-class*))))))
+      (let* ((defclass-form
+              `(let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
+                 (load-defclass ',name
+                                ',metaclass
+                                ',direct-superclasses
+                                (list ,@canonical-slots)
+                                (list ,@(apply #'append
+                                               (when defstruct-p
+                                                 '(:from-defclass-p t))
+                                                canonical-options))
+                                ',*readers-for-this-defclass*
+                                ',*writers-for-this-defclass*
+                                ',*slot-names-for-this-defclass*))))
+        (if defstruct-p
+            (progn
+              ;; FIXME: (YUK!) Why do we do this? Because in order
+              ;; to make the defstruct form, we need to know what
+              ;; the accessors for the slots are, so we need already
+              ;; to have hooked into the CLOS machinery.
+              ;;
+              ;; There may be a better way to do this: it would
+              ;; involve knowing enough about PCL to ask "what will
+              ;; my slot names and accessors be"; failing this, we
+              ;; currently just evaluate the whole kaboodle, and
+              ;; then use CLASS-DIRECT-SLOTS. -- CSR, 2002-06-07
+              (eval defclass-form)
+              (let* ((include (or (and direct-superclasses
+                                       (fix-super (car direct-superclasses)))
+                                  (and (not (eq name 'structure-object))
+                                       *the-class-structure-object*)))
+                     (defstruct-form (make-structure-class-defstruct-form
+                                      name (class-direct-slots (find-class name))
+                                      include)))
+                `(progn
+                   (eval-when (:compile-toplevel :load-toplevel :execute)
+                     ,defstruct-form) ; really compile the defstruct-form
+                   (eval-when (:compile-toplevel :load-toplevel :execute)
+                     ,defclass-form))))
+            `(progn
+               ;; By telling the type system at compile time about
+               ;; the existence of a class named NAME, we can avoid
+               ;; various bogus warnings about "type isn't defined yet"
+               ;; for code elsewhere in the same file which uses
+               ;; the name of the type.
+               ;;
+               ;; We only need to do this at compile time, because
+               ;; at load and execute time we write the actual
+               ;; full-blown class, so the "a class of this name is
+               ;; coming" note we write here would be irrelevant.
+               (eval-when (:compile-toplevel)
+                 (%compiler-defclass ',name 
+                                     ',*readers-for-this-defclass*
+                                     ',*writers-for-this-defclass*
+                                     ',*slot-names-for-this-defclass*))
+               (eval-when (:load-toplevel :execute)
+                 ,defclass-form))))))))
+
+(defun canonize-defclass-options (class-name options)
+  (macrolet ((assert-single (option)
+               `(when ,option
+                  (error "Multiple ~A options in DEFCLASS ~S."
+                         ,(intern (string option) :keyword)
+                         class-name))))
+    (let (metaclass 
+          default-initargs
+          documentation
+          canonized-options)
       (dolist (option options)
-        (if (not (listp option))
-         (error "~S is not a legal defclass option." option)
-         (when (eq (car option) :metaclass)
-           (unless (legal-class-name-p (cadr option))
-             (error "The value of the :metaclass option (~S) is not a~%~
-                     legal class name."
-                    (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.
-            (*slot-names-for-this-defclass* ()))
-        (let ((canonical-slots
-                (mapcar (lambda (spec)
-                         (canonicalize-slot-specification name spec env))
-                        slots))
-              (other-initargs
-                (mapcar (lambda (option)
-                         (canonicalize-defclass-option name option))
-                        options))
-              ;; DEFSTRUCT-P should be true if the class is defined
-              ;; with a metaclass STRUCTURE-CLASS, so that a DEFSTRUCT
-              ;; is compiled for the class.
-              (defstruct-p (and (eq *boot-state* 'complete)
-                                (let ((mclass (find-class metaclass nil)))
-                                  (and mclass
-                                       (*subtypep
-                                        mclass
-                                        *the-class-structure-class*))))))
-          (let* ((defclass-form
-                     `(let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
-                         (load-defclass ',name
-                                        ',metaclass
-                                        ',supers
-                                        (list ,@canonical-slots)
-                                        (list ,@(apply #'append
-                                                       (when defstruct-p
-                                                         '(:from-defclass-p t))
-                                                       other-initargs))
-                                        ',*readers-for-this-defclass*
-                                        ',*writers-for-this-defclass*
-                                        ',*slot-names-for-this-defclass*))))
-            (if defstruct-p
-               (progn
-                 ;; FIXME: (YUK!) Why do we do this? Because in order
-                 ;; to make the defstruct form, we need to know what
-                 ;; the accessors for the slots are, so we need
-                 ;; already to have hooked into the CLOS machinery.
-                 ;;
-                 ;; There may be a better way to do this: it would
-                 ;; involve knowing enough about PCL to ask "what
-                 ;; will my slot names and accessors be"; failing
-                 ;; this, we currently just evaluate the whole
-                 ;; kaboodle, and then use CLASS-DIRECT-SLOTS. --
-                 ;; CSR, 2002-06-07
-                 (eval defclass-form)
-                 (let* ((include (or (and supers
-                                          (fix-super (car supers)))
-                                     (and (not (eq name 'structure-object))
-                                          *the-class-structure-object*)))
-                        (defstruct-form (make-structure-class-defstruct-form
-                                         name (class-direct-slots (find-class name))
-                                         include)))
-                   `(progn
-                     (eval-when (:compile-toplevel :load-toplevel :execute)
-                       ,defstruct-form) ; really compile the defstruct-form
-                     (eval-when (:compile-toplevel :load-toplevel :execute)
-                       ,defclass-form))))
-               `(progn
-                  ;; By telling the type system at compile time about
-                  ;; the existence of a class named NAME, we can avoid
-                  ;; various bogus warnings about "type isn't defined yet"
-                  ;; for code elsewhere in the same file which uses
-                  ;; the name of the type.
-                  ;;
-                  ;; We only need to do this at compile time, because
-                  ;; at load and execute time we write the actual
-                  ;; full-blown class, so the "a class of this name is
-                  ;; coming" note we write here would be irrelevant.
-                  (eval-when (:compile-toplevel)
-                    (%compiler-defclass ',name 
-                                         ',*readers-for-this-defclass*
-                                         ',*writers-for-this-defclass*
-                                         ',*slot-names-for-this-defclass*))
-                  (eval-when (:load-toplevel :execute)
-                    ,defclass-form)))))))))
-
-(defun %compiler-defclass (name readers writers slots)
-  (preinform-compiler-about-class-type name)
-  (preinform-compiler-about-accessors readers writers slots))
+        (unless (listp option)
+          (error "~S is not a legal defclass option." option))
+        (case (first option)
+          (:metaclass 
+           (assert-single metaclass)
+           (let ((maybe-metaclass (second option)))
+             (unless (and maybe-metaclass (legal-class-name-p maybe-metaclass))
+               (error "~@<The value of the :metaclass option (~S) ~
+                         is not a legal class name.~:@>"
+                      maybe-metaclass))
+             (setf metaclass maybe-metaclass)))
+          (:default-initargs
+           (assert-single default-initargs)
+           (let (initargs arg-names)
+             (doplist (key val) (cdr option)
+               (when (member key arg-names)
+                 (error 'simple-program-error 
+                        :format-control "~@<Duplicate initialization argument ~
+                                         name ~S in :DEFAULT-INITARGS of ~
+                                         DEFCLASS ~S.~:>" 
+                        :format-arguments (list key class-name)))
+               (push key arg-names)
+               (push ``(,',key ,,(make-initfunction val) ,',val) initargs))
+             (setf default-initargs t)
+             (push `(:direct-default-initargs (list ,@(nreverse initargs))) 
+                   canonized-options)))
+          (:documentation
+           (assert-single documentation)
+           (unless (stringp (second option))
+             (error "~S is not a legal :documentation value" (second option)))
+           (setf documentation t)
+           (push `(:documentation ,(second option)) canonized-options))
+          (otherwise
+           (push `(',(car option) ',(cdr option)) canonized-options))))
+      (values (or metaclass 'standard-class) (nreverse canonized-options)))))
+
+(defun canonize-defclass-slots (class-name slots env)
+  (let (canonized-specs)
+    (dolist (spec slots)
+      (when (atom spec)
+        (setf spec (list spec)))
+      (when (and (cdr 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)))))
+      (let* ((name (car spec))
+             (plist (cdr spec))
+             (readers ())
+             (writers ())
+             (initargs ())
+             (others ())
+             (unsupplied (list nil))
+             (initform unsupplied))
+        (check-slot-name-for-defclass name class-name env)
+        (push name *slot-names-for-this-defclass*)
+        (flet ((note-reader (x)
+                 (unless (symbolp x)
+                   (error 'simple-program-error 
+                          :format-control "Slot reader name ~S for slot ~S in ~
+                                           DEFCLASS ~S is not a symbol." 
+                          :format-arguments (list x name class-name)))
+                 (push x readers)
+                 (push x *readers-for-this-defclass*))
+               (note-writer (x)
+                 (push x writers)
+                 (push x *writers-for-this-defclass*)))
+          (doplist (key val) plist
+            (case key
+              (:accessor (note-reader val) (note-writer `(setf ,val)))
+              (:reader   (note-reader val))
+              (:writer   (note-writer val))
+              (:initarg
+               (unless (symbolp val)
+                 (error 'simple-program-error 
+                        :format-control "Slot initarg name ~S for slot ~S in ~
+                                         DEFCLASS ~S is not a symbol."
+                        :format-arguments (list val name class-name)))
+               (push val initargs))
+              (otherwise
+               (when (member key '(:initform :allocation :type :documentation))
+                 (when (eq key :initform)
+                   (setf initform val))
+                 (when (get-properties others (list key))
+                   (error 'simple-program-error 
+                          :format-control "Duplicate slot option ~S for slot ~
+                                           ~S in DEFCLASS ~S." 
+                          :format-arguments (list key name class-name))))
+               ;; For non-standard options multiple entries go in a list
+               (push val (getf others key))))))
+        ;; Unwrap singleton lists (AMOP 5.4.2)
+        (do ((head others (cddr head)))
+            ((null head))
+          (unless (cdr (second head))
+            (setf (second head) (car (second head)))))
+        (let ((canon `(:name ',name :readers ',readers :writers ',writers
+                             :initargs ',initargs ',others)))
+          (push (if (eq initform unsupplied)
+                    `(list* ,@canon)
+                    `(list* :initfunction ,(make-initfunction initform)
+                            ,@canon))
+                canonized-specs))))
+    (nreverse canonized-specs)))
+
+
+(defun check-slot-name-for-defclass (name class-name env)
+  (flet ((slot-name-illegal (reason)
+           (error 'simple-program-error
+                  :format-control
+                  (format nil "~~@<In DEFCLASS ~~S, the slot name ~~S ~
+                               is ~A.~~@:>" reason)
+                  :format-arguments (list class-name 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"))
+          ((member name *slot-names-for-this-defclass*)
+           (error 'simple-program-error 
+                  :format-control "Multiple slots named ~S in DEFCLASS ~S."
+                  :format-arguments (list name class-name))))))
 
 (defun make-initfunction (initform)
   (cond ((or (eq initform t)
             (push entry *initfunctions-for-this-defclass*))
           (cadr entry)))))
 
-(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 '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))
-  (case (car option)
-    (:default-initargs
-      (let ((canonical ()))
-       (let (key val (tail (cdr option)))
-         (loop (when (null tail) (return nil))
-               (setq key (pop tail)
-                     val (pop tail))
-               (push ``(,',key ,,(make-initfunction val) ,',val) canonical))
-         `(:direct-default-initargs (list ,@(nreverse canonical))))))
-    (:documentation
-      `(',(car option) ',(cadr option)))
-    (otherwise
-     `(',(car option) ',(cdr option)))))
+(defun %compiler-defclass (name readers writers slots)
+  ;; ANSI says (Macro DEFCLASS, section 7.7) that DEFCLASS, if it
+  ;; "appears as a top level form, the compiler must make the class
+  ;; name be recognized as a valid type name in subsequent
+  ;; declarations (as for deftype) and be recognized as a valid class
+  ;; name for defmethod parameter specializers and for use as the
+  ;; :metaclass option of a subsequent defclass."
+  (preinform-compiler-about-class-type name)
+  (preinform-compiler-about-accessors readers writers slots))
+
+(defun preinform-compiler-about-class-type (name)
+  ;; Unless the type system already has an actual type attached to
+  ;; NAME (in which case (1) writing a placeholder value over that
+  ;; actual type as a compile-time side-effect would probably be a bad
+  ;; idea and (2) anyway we don't need to modify it in order to make
+  ;; NAME be recognized as a valid type name)
+  (unless (info :type :kind name)
+    ;; Tell the compiler to expect a class with the given NAME, by
+    ;; writing a kind of minimal placeholder type information. This
+    ;; placeholder will be overwritten later when the class is defined.
+    (setf (info :type :kind name) :forthcoming-defclass-type))
+  (values))
+
+(defun preinform-compiler-about-accessors (readers writers slots)
+  (flet ((inform (name type)
+           ;; FIXME: This matches what PROCLAIM FTYPE does, except
+           ;; that :WHERE-FROM is :DEFINED, not :DECLARED, and should
+           ;; probably be factored into a common function -- eg.
+           ;; (%proclaim-ftype name declared-or-defined).
+           (when (eq (info :function :where-from name) :assumed)
+             (proclaim-as-fun-name name)
+             (note-name-defined name :function)
+             (setf (info :function :where-from name) :defined
+                   (info :function :type name) type))))
+    (let ((rtype (specifier-type '(function (t) t)))
+          (wtype (specifier-type '(function (t t) t))))
+      (dolist (reader readers)
+        (inform reader rtype))
+      (dolist (writer writers)
+        (inform writer wtype))
+      (dolist (slot slots)
+        (inform (slot-reader-name slot) rtype)
+        (inform (slot-boundp-name slot) rtype)
+        (inform (slot-writer-name slot) wtype)))))
 \f
 ;;; This is the early definition of LOAD-DEFCLASS. It just collects up
 ;;; all the class definitions in a list. Later, in braid1.lisp, these
 (defun load-defclass (name metaclass supers canonical-slots canonical-options
                       readers writers slot-names)
   (%compiler-defclass name readers writers slot-names)
-  (preinform-compiler-about-accessors readers writers slot-names)
   (setq supers  (copy-tree supers)
        canonical-slots   (copy-tree canonical-slots)
        canonical-options (copy-tree canonical-options))
     (setq *early-class-definitions*
          (cons ecd (remove existing *early-class-definitions*)))
     ecd))
-
index 156d1e4..296aeb4 100644 (file)
             (setf (find-classoid name) nil))
           (when (or (eq *boot-state* 'complete)
                     (eq *boot-state* 'braid))
-            (when (and new-value (class-wrapper new-value))
+            (when (and new-value (class-wrapper new-value)
+                        (class-predicate-name new-value))
               (setf (find-class-cell-predicate cell)
                     (fdefinition (class-predicate-name new-value))))
             (update-ctors 'setf-find-class :class new-value :name name))
index 7cae742..24de706 100644 (file)
       (cons
        (car position))))))
 \f
+;;; FIXME: AMOP says that allocate-instance imples finalize-inheritance
+;;; if the class is not yet finalized, but we don't seem to be taking
+;;; care of this for non-standard-classes.x
 (defmethod allocate-instance ((class standard-class) &rest initargs)
   (declare (ignore initargs))
-  (unless (class-finalized-p class) (finalize-inheritance class))
+  (unless (class-finalized-p class) 
+    (finalize-inheritance class))
   (allocate-standard-instance (class-wrapper class)))
 
 (defmethod allocate-instance ((class structure-class) &rest initargs)
   (let ((constructor (class-defstruct-constructor class)))
     (if constructor
        (funcall constructor)
-       (error "can't allocate an instance of class ~S" (class-name class)))))
+        (allocate-standard-instance (class-wrapper class)))))
 
+;;; FIXME: It would be nicer to have allocate-instance return
+;;; uninitialized objects for conditions as well.
 (defmethod allocate-instance ((class condition-class) &rest initargs)
   (declare (ignore initargs))
   (make-condition (class-name class)))
+
+(defmethod allocate-instance ((class built-in-class) &rest initargs)
+  (declare (ignore initargs))
+  (error "Cannot allocate an instance of ~S." class)) ; So sayeth AMOP
index cec50b1..d60c04c 100644 (file)
 ;;;; various class accessors that are a little more complicated than can be
 ;;;; done with automatically generated reader methods
 
-(defmethod class-prototype ((class std-class))
-  (with-slots (prototype) class
-    (or prototype (setq prototype (allocate-instance class)))))
-
-(defmethod class-prototype ((class structure-class))
-  (with-slots (prototype wrapper defstruct-constructor) class
-    (or prototype
-       (setq prototype
-             (if defstruct-constructor
-                 (allocate-instance class)
-                 (allocate-standard-instance wrapper))))))
-
-(defmethod class-prototype ((class condition-class))
-  (with-slots (prototype) class
-    (or prototype (setf prototype (allocate-instance class)))))
+(defmethod class-prototype :before (class)
+  (unless (class-finalized-p class)
+    (error "~S not yet finalized, cannot allocate a prototype." class)))
+
+;;; KLUDGE: For some reason factoring the common body into a function
+;;; breaks PCL bootstrapping, so just generate it with a macrolet for
+;;; all.
+(macrolet ((def (class)
+             `(defmethod class-prototype ((class ,class))
+                (with-slots (prototype) class
+                  (or prototype 
+                      (setf prototype (allocate-instance class)))))))
+  (def std-class)
+  (def condition-class)
+  (def structure-class))
 
 (defmethod class-direct-default-initargs ((class slot-class))
   (plist-value class 'direct-default-initargs))
   (setf (info :type :translator specl)
         (constantly (make-member-type :members (list (specializer-object specl))))))
 
-\f
 (defun real-load-defclass (name metaclass-name supers slots other
                            readers writers slot-names)
   (with-single-package-locked-error (:symbol name "defining ~S as a class")
             (make-instance 'forward-referenced-class
                            :name s)))))
 
-(defun ensure-class-values (class args)
-  (let* ((initargs (copy-list args))
-        (unsupplied (list 1))
-        (supplied-meta   (getf initargs :metaclass unsupplied))
-        (supplied-supers (getf initargs :direct-superclasses unsupplied))
-        (supplied-slots  (getf initargs :direct-slots unsupplied))
-        (meta
-          (cond ((neq supplied-meta unsupplied)
-                 (find-class supplied-meta))
-                ((or (null class)
-                     (forward-referenced-class-p class))
-                 *the-class-standard-class*)
-                (t
-                 (class-of class)))))
-    ;; KLUDGE: It seemed to me initially that there ought to be a way
-    ;; of collecting all the erroneous problems in one go, rather than
-    ;; this way of solving the problem of signalling the errors that
-    ;; we are required to, which stops at the first bogus input.
-    ;; However, after playing around a little, I couldn't find that
-    ;; way, so I've left it as is, but if someone does come up with a
-    ;; better way... -- CSR, 2002-09-08
-    (do ((direct-slots (getf initargs :direct-slots) (cdr direct-slots)))
-       ((endp direct-slots) nil)
-      (destructuring-bind (slot &rest more) direct-slots
-       (let ((slot-name (getf slot :name)))
-         (when (some (lambda (s) (eq slot-name (getf s :name))) more)
-           ;; FIXME: It's quite possible that we ought to define an
-           ;; SB-INT:PROGRAM-ERROR function to signal these and other
-           ;; errors throughout the codebase that are required to be
-           ;; of type PROGRAM-ERROR.
-           (error 'simple-program-error
-                  :format-control "~@<There is more than one direct slot ~
-                                   with name ~S.~:>"
-                  :format-arguments (list slot-name)))
-         (do ((stuff slot (cddr stuff)))
-             ((endp stuff) nil)
-           (destructuring-bind (option value &rest more) stuff
-             (cond
-               ((and (member option '(:allocation :type
-                                      :initform :documentation))
-                     (not (eq unsupplied
-                              (getf more option unsupplied))))
-                (error 'simple-program-error
-                       :format-control "~@<Duplicate slot option ~S for ~
-                                        slot named ~S.~:>"
-                       :format-arguments (list option slot-name)))
-               ((and (eq option :readers)
-                     (notevery #'symbolp value))
-                (error 'simple-program-error
-                       :format-control "~@<Slot reader names for slot ~
-                                        named ~S must be symbols.~:>"
-                       :format-arguments (list slot-name)))
-               ((and (eq option :initargs)
-                     (notevery #'symbolp value))
-                (error 'simple-program-error
-                       :format-control "~@<Slot initarg names for slot ~
-                                        named ~S must be symbols.~:>"
-                       :format-arguments (list slot-name)))))))))
-    (loop for (initarg . more) on (getf initargs :direct-default-initargs)
-         for name = (car initarg) 
-         when (some (lambda (a) (eq (car a) name)) more) 
-         do (error 'simple-program-error 
-                   :format-control "~@<Duplicate initialization argument ~
-                                    name ~S in :DEFAULT-INITARGS.~:>"
-                   :format-arguments (list name class)))
-    (let ((metaclass 0)
-         (default-initargs 0))
-      (do ((args initargs (cddr args)))
-         ((endp args) nil)
-       (case (car args)
-         (:metaclass
-          (when (> (incf metaclass) 1)
-            (error 'simple-program-error
-                   :format-control "~@<More than one :METACLASS ~
-                                    option specified.~:>")))
-         (:direct-default-initargs
-          (when (> (incf default-initargs) 1)
-            (error 'simple-program-error
-                   :format-control "~@<More than one :DEFAULT-INITARGS ~
-                                    option specified.~:>"))))))
-    (remf initargs :metaclass)
-    (loop (unless (remf initargs :direct-superclasses) (return)))
-    (loop (unless (remf initargs :direct-slots) (return)))
-    (values
-     meta
-     (nconc
-      (when (neq supplied-supers unsupplied)
-       (list :direct-superclasses (mapcar #'fix-super supplied-supers)))
-      (when (neq supplied-slots unsupplied)
-       (list :direct-slots supplied-slots))
-      initargs))))
+(defun ensure-class-values (class initargs)
+  (let (metaclass metaclassp reversed-plist)
+    (doplist (key val) initargs
+        (cond ((eq key :metaclass)
+               (setf metaclass val
+                     metaclassp key))
+              (t
+               (when (eq key :direct-superclasses)
+                 (setf val (mapcar #'fix-super val)))
+               (setf reversed-plist (list* val key reversed-plist)))))
+    (values (cond (metaclassp
+                   (find-class metaclass))
+                  ((or (null class) (forward-referenced-class-p class))
+                   *the-class-standard-class*)
+                  (t
+                   (class-of class)))
+            (nreverse reversed-plist))))
+
 \f
 (defmethod shared-initialize :after
           ((class std-class)
index a857c29..873e8cf 100644 (file)
   ((a-slot :initarg :a-slot :accessor a-slot)
    (b-slot :initarg :b-slot :accessor b-slot)
    (c-slot :initarg :c-slot :accessor c-slot)))
+
 (let ((foo (make-instance 'class-with-slots
                          :a-slot 1
                          :b-slot 2
 (macrolet ((assert-program-error (form)
             `(multiple-value-bind (value error)
                  (ignore-errors ,form)
-               (assert (null value))
-               (assert (typep error 'program-error)))))
+               (unless (and (null value) (typep error 'program-error))
+                  (error "~S failed: ~S, ~S" ',form value error)))))
   (assert-program-error (defclass foo001 () (a b a)))
   (assert-program-error (defclass foo002 () 
                          (a b) 
                                           (:method () t))))))
         'generic-function))
 
-
+;;; bug reported by Bruno Haible: (setf find-class) using a
+;;; forward-referenced class
+(defclass fr-sub (fr-super) ())
+(setf (find-class 'fr-alt) (find-class 'fr-super))
+(assert (eq (find-class 'fr-alt) (find-class 'fr-super)))
 
 ;;;; success
 (sb-ext:quit :unix-status 104)
index 648b43b..ddc2e9b 100644 (file)
 (let ((inst (make-instance 'testclass15 :x 12)))
   (assert (equal (list (testclass15-x inst) (setf (testclass15-y inst) 13))
                 '(12 13))))
+
+;;; bug reported by Bruno Haible on sbcl-devel 2004-11-17: incorrect
+;;; handling of multiple values for non-standard slot-options
+(progn
+  (defclass option-slot-definition (sb-mop:standard-direct-slot-definition)
+    ((option :accessor sl-option :initarg :my-option)))
+  (defclass option-slot-class (standard-class)
+    ())
+  (defmethod sb-mop:direct-slot-definition-class 
+      ((c option-slot-class) &rest args)
+    (declare (ignore args))
+    (find-class 'option-slot-definition))
+  (defmethod sb-mop:validate-superclass 
+      ((c1 option-slot-class) (c2 standard-class))
+    t)
+  (eval '(defclass test-multiple-slot-option-bug ()
+          ((x :my-option bar :my-option baz))
+          (:metaclass option-slot-class)))
+  (assert (null (set-difference 
+                 '(bar baz)
+                 (sl-option (first (sb-mop:class-direct-slots 
+                                    (find-class 'test-multiple-slot-option-bug))))))))
+
+;;; bug reported by Bruno Haibel on sbcl-devel 2004-11-19: AMOP requires
+;;; that CLASS-PROTOYPE signals an error if the class is not yet finalized
+(defclass prototype-not-finalized-sub (prototype-not-finalized-super) ())
+(multiple-value-bind (val err)
+    (ignore-errors (sb-mop:class-prototype (find-class 'prototype-not-finalized-super)))
+  (assert (null val))
+  (assert (typep err 'error)))
+
+;;; AMOP says so
+(find-method (fdefinition 'sb-mop:allocate-instance) () '(built-in-class))
+(dolist (class-name '(fixnum bignum symbol))
+  (let ((class (find-class class-name)))
+    (multiple-value-bind (value error) (ignore-errors (allocate-instance class))
+      (assert (null value))
+      (assert (typep error 'error)))))
+
 \f
 ;;;; success
 (sb-ext:quit :unix-status 104)
index 487537e..674b965 100644 (file)
@@ -20,7 +20,7 @@
 # generated relative to `pwd` in the tests/ directory) so that tests
 # can chdir before invoking SBCL and still work.
 sbclstem=`pwd`/../src/runtime/sbcl
-SBCL="${1:-$sbclstem --core `pwd`/../output/sbcl.core --noinform --sysinit /dev/null --userinit /dev/null --noprint --disable-debugger}"
+SBCL="${1:-$sbclstem --core `pwd`/../output/sbcl.core --noinform --sysinit /dev/null --userinit /dev/null --noprint}"
 export SBCL
 echo /running tests on SBCL=\'$SBCL\'
 # more or less like SBCL, but without enough grot removed that appending
index 5ea4bd9..b592228 100644 (file)
@@ -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.16.42"
+"0.8.16.43"