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

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Mon Jun 11 04:47:06 2012
New Revision: 13958

Log:
Implement compute-default-initargs

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

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Mon Jun 11 03:44:13 2012	(r13957)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Mon Jun 11 04:47:06 2012	(r13958)
@@ -502,7 +502,11 @@
 
 ;;; finalize-inheritance
 
-(defun std-compute-class-default-initargs (class)
+(declaim (notinline compute-default-initargs))
+(defun compute-default-initargs (class)
+  (std-compute-default-initargs class))
+
+(defun std-compute-default-initargs (class)
   (delete-duplicates
    (mapcan #'(lambda (c)
                (copy-list
@@ -555,7 +559,7 @@
     (setf (class-layout class)
           (make-layout class (nreverse instance-slots) (nreverse shared-slots))))
   (setf (class-default-initargs class)
-        (std-compute-class-default-initargs class))
+        (compute-default-initargs class))
   (setf (class-finalized-p class) t))
 
 (declaim (notinline finalize-inheritance))
@@ -3629,6 +3633,15 @@
     (:method ((class funcallable-standard-class))
        (std-finalize-inheritance class)))
 
+;;; Default initargs
+
+;;; AMOP pg. 174
+(atomic-defgeneric compute-default-initargs (class)
+  (:method ((class standard-class))
+    (std-compute-default-initargs class))
+  (:method ((class funcallable-standard-class))
+    (std-compute-default-initargs class)))
+
 ;;; Class precedence lists
 
 (defgeneric compute-class-precedence-list (class))

Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/mop.lisp	Mon Jun 11 03:44:13 2012	(r13957)
+++ trunk/abcl/src/org/armedbear/lisp/mop.lisp	Mon Jun 11 04:47:06 2012	(r13958)
@@ -55,6 +55,7 @@
           
           compute-effective-slot-definition
           compute-class-precedence-list
+          compute-default-initargs
           compute-effective-slot-definition
           compute-slots
           finalize-inheritance