0.9.1.4: ENSURE-CLASS-USING-CLASS patch by Gerd Moellman, from cmucl-imp

  * accept a class as :METACLASS as per AMOP.

diff --git a/NEWS b/NEWS
index a144a6f..78b7f55 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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))
 \f
 ;;;; success
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 225e0e6..f8bcf07 100644 (file)
--- 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"