0.9.1.4: ENSURE-CLASS-USING-CLASS patch by Gerd Moellman, from cmucl-imp
authorNikodemus Siivola <nikodemus@random-state.net>
Sun, 29 May 2005 10:37:20 +0000 (10:37 +0000)
committerNikodemus Siivola <nikodemus@random-state.net>
Sun, 29 May 2005 10:37:20 +0000 (10:37 +0000)
  * accept a class as :METACLASS as per AMOP.

NEWS
src/code/class.lisp
src/pcl/std-class.lisp
tests/mop.impure.lisp
version.lisp-expr

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
index c41894e..515f3b4 100644 (file)
   ;;     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.
index 89815b9..eaa7ad0 100644 (file)
 (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
index 28fccf3..f58ff98 100644 (file)
                            (: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)
index 225e0e6..f8bcf07 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.9.1.3"
+"0.9.1.4"