Skip to content
Snippets Groups Projects
Commit 18bfa853 authored by pmai's avatar pmai
Browse files

Fixed AMOP conformance bug of ensure-class-using-class reported by

Hannu Koivisto:  ensure-class-using-class shouldn't default unsupplied
:direct-superclasses or :direct-slots arguments in its calls to
make-instance and reinitialize-instance.

Code audit showed that only coerce-to-class relied on the old
behaviour.  This was necessary because the initialization code for
std-class didn't default an unsupplied value for :direct-superclasses
correctly, producing a class with no direct superclasses, contrary to
the AMOP.  Fixed this as well.
parent a9ee852b
No related branches found
No related tags found
No related merge requests found
...@@ -26,7 +26,7 @@ ...@@ -26,7 +26,7 @@
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.27 2001/04/10 22:37:23 pw Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.28 2001/11/29 03:50:35 pmai Exp $")
;;; ;;;
(in-package :pcl) (in-package :pcl)
...@@ -363,7 +363,6 @@ ...@@ -363,7 +363,6 @@
(unsupplied (list 1)) (unsupplied (list 1))
(supplied-meta (getf initargs :metaclass unsupplied)) (supplied-meta (getf initargs :metaclass unsupplied))
(supplied-supers (getf initargs :direct-superclasses unsupplied)) (supplied-supers (getf initargs :direct-superclasses unsupplied))
(supplied-slots (getf initargs :direct-slots unsupplied))
(meta (meta
(cond ((neq supplied-meta unsupplied) (cond ((neq supplied-meta unsupplied)
(find-class supplied-meta)) (find-class supplied-meta))
...@@ -383,14 +382,13 @@ ...@@ -383,14 +382,13 @@
:name s))))))) :name s)))))))
(loop (unless (remf initargs :metaclass) (return))) (loop (unless (remf initargs :metaclass) (return)))
(loop (unless (remf initargs :direct-superclasses) (return))) (loop (unless (remf initargs :direct-superclasses) (return)))
(loop (unless (remf initargs :direct-slots) (return)))
(values meta (values meta
(list* :direct-superclasses (nconc
(and (neq supplied-supers unsupplied) (when (neq supplied-supers unsupplied)
(mapcar #'fix-super supplied-supers)) (list
:direct-slots :direct-superclasses
(and (neq supplied-slots unsupplied) supplied-slots) (mapcar #'fix-super supplied-supers)))
initargs))))) initargs)))))
;;; ;;;
...@@ -413,7 +411,8 @@ ...@@ -413,7 +411,8 @@
(direct-default-initargs nil direct-default-initargs-p) (direct-default-initargs nil direct-default-initargs-p)
(predicate-name nil predicate-name-p)) (predicate-name nil predicate-name-p))
(declare (ignore slot-names)) (declare (ignore slot-names))
(cond (direct-superclasses-p (cond ((or direct-superclasses-p
(null (slot-value class 'direct-superclasses)))
(setq direct-superclasses (setq direct-superclasses
(or direct-superclasses (or direct-superclasses
(list (if (funcallable-standard-class-p class) (list (if (funcallable-standard-class-p class)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment