[armedbear-cvs] r12425 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Feb  6 12:00:32 2010
New Revision: 12425

Log:
No longer ignore the METACLASS defclass option;
  instead act on it upon class creation.

Modified:
   trunk/abcl/src/org/armedbear/lisp/clos.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sat Feb  6 12:00:32 2010
@@ -537,7 +537,14 @@
 (defun canonical-slot-name (canonical-slot)
   (getf canonical-slot :name))
 
-(defun ensure-class (name &rest all-keys &allow-other-keys)
+(defun ensure-class (name &rest all-keys
+                     &key (metaclass 'standard-class) &allow-other-keys)
+
+  ;; Don't pass METACLASS on to the initialization routines
+  ;; This only works because we *know* ABCL conses up new &rest lists
+  ;; every time; otherwise, modifying the argument list is discouraged by the spec
+  (remf all-keys :metaclass)
+
   ;; Check for duplicate slots.
   (let ((slots (getf all-keys :direct-slots)))
     (dolist (s1 slots)
@@ -582,8 +589,12 @@
                   (apply #'std-after-initialization-for-classes old-class all-keys)
                   old-class)))
           (t
-           (let ((class (apply #'make-instance-standard-class
-                               (find-class 'standard-class)
+           (let ((class (apply (if (eq metaclass 'standard-class)
+                                   #'make-instance-standard-class
+                                   #'make-instance)
+                               (or (when (symbolp metaclass)
+                                     (find-class metaclass))
+                                   metaclass)
                                :name name all-keys)))
              (%set-find-class name class)
              class)))))