From 79389fecc0308d1a582424b198ebfc402ce161e1 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 29 May 2005 10:37:20 +0000 Subject: [PATCH] 0.9.1.4: ENSURE-CLASS-USING-CLASS patch by Gerd Moellman, from cmucl-imp * accept a class as :METACLASS as per AMOP. --- NEWS | 3 +++ src/code/class.lisp | 6 +++--- src/pcl/std-class.lisp | 18 ++++++++++-------- tests/mop.impure.lisp | 10 +++++++++- version.lisp-expr | 2 +- 5 files changed, 26 insertions(+), 13 deletions(-) diff --git a/NEWS b/NEWS index a144a6f..78b7f55 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,7 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1: + * SB-MOP:ENSURE-CLASS-USING-CLASS now accepts a class as the + :METACLASS argument in addition to a class name. (reported by + Bruno Haible for CMUCL, patch for CMUCL by Gerd Moellman) * fixed some bugs revealed by Paul Dietz' test suite: ** Invalid dotted lists no longer raise a read error when *READ-SUPPRESS* is T diff --git a/src/code/class.lisp b/src/code/class.lisp index c41894e..515f3b4 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -173,9 +173,9 @@ ;; and PCL has made it invalid and made a note to itself about it (invalid :uninitialized :type (or cons (member nil t :uninitialized))) ;; the layouts for all classes we inherit. If hierarchical, i.e. if - ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS, - ;; so that each inherited layout appears at its expected depth, - ;; i.e. at its LAYOUT-DEPTHOID value. + ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS + ;; (least to most specific), so that each inherited layout appears + ;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value. ;; ;; Remaining elements are filled by the non-hierarchical layouts or, ;; if they would otherwise be empty, by copies of succeeding layouts. diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 89815b9..eaa7ad0 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -349,15 +349,17 @@ (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))))) + (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)) + (if (classp metaclass) + metaclass + (find-class metaclass))) ((or (null class) (forward-referenced-class-p class)) *the-class-standard-class*) (t diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 28fccf3..f58ff98 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -396,7 +396,15 @@ (:metaclass option-class)))) (assert (not result)) (assert error)) - + +;;; class as :metaclass +(assert (typep + (sb-mop:ensure-class-using-class + nil 'class-as-metaclass-test + :metaclass (find-class 'standard-class) + :name 'class-as-metaclass-test + :direct-superclasses (list (find-class 'standard-object))) + 'class)) ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 225e0e6..f8bcf07 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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.9.1.3" +"0.9.1.4" -- 1.7.10.4