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

[Mark Evenson]

Author: mevenson
Date: Mon Feb  8 03:13:42 2010
New Revision: 12432

Log:
Revert to r12425 for clos.lisp (which is broken under ANSI tests).

Undo inadvertent fix in last commit.



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	Mon Feb  8 03:13:42 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)))))