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

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Sun Jun 10 14:34:15 2012
New Revision: 13956

Log:
Properly canonicalize class-direct-default-initargs

- AMOP pg. 149: "A canonicalized default initarg is a list of three
  elements" -- namely, the initarg name, form, and closure.  Make it so.

Modified:
   trunk/abcl/src/org/armedbear/lisp/SlotClass.java
   trunk/abcl/src/org/armedbear/lisp/StandardClass.java
   trunk/abcl/src/org/armedbear/lisp/clos.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/SlotClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SlotClass.java	Sun Jun  3 15:19:18 2012	(r13955)
+++ trunk/abcl/src/org/armedbear/lisp/SlotClass.java	Sun Jun 10 14:34:15 2012	(r13956)
@@ -122,6 +122,9 @@
 
     LispObject computeDefaultInitargs()
     {
+      // KLUDGE (rudi 2012-06-02): duplicate initargs are not removed
+      // here, but this does not hurt us since no Lisp class we define
+      // Java-side has non-nil direct default initargs.
         LispObject result = NIL;
         LispObject cpl = getCPL();
         while (cpl != NIL) {

Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java	Sun Jun  3 15:19:18 2012	(r13955)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java	Sun Jun 10 14:34:15 2012	(r13956)
@@ -681,10 +681,9 @@
             new SlotDefinition(Symbol.FORMAT_ARGUMENTS,
                                list(Symbol.SIMPLE_CONDITION_FORMAT_ARGUMENTS),
                                NIL)));
-    CONDITION.setDirectDefaultInitargs(list(Keyword.FORMAT_ARGUMENTS,
-                                             // FIXME
-                                             new Closure(list(Symbol.LAMBDA, NIL, NIL),
-                                                         new Environment())));
+    CONDITION.setDirectDefaultInitargs(list(list(Keyword.FORMAT_ARGUMENTS,
+                                                 NIL,
+                                                 constantlyNil)));
     CONTROL_ERROR.setCPL(CONTROL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION,
                          STANDARD_OBJECT, BuiltInClass.CLASS_T);
     DIVISION_BY_ZERO.setCPL(DIVISION_BY_ZERO, ARITHMETIC_ERROR, ERROR,

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Jun  3 15:19:18 2012	(r13955)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Jun 10 14:34:15 2012	(r13956)
@@ -369,12 +369,10 @@
     (:default-initargs
      (list
       ':direct-default-initargs
-      `(list ,@(mapappend
-                #'(lambda (x) x)
-                (mapplist
-                 #'(lambda (key value)
-                    `(',key ,(make-initfunction value)))
-                 (cdr option))))))
+      `(list ,@(mapplist
+                #'(lambda (key value)
+                    `(list ',key ',value ,(make-initfunction value)))
+                (cdr option)))))
     ((:documentation :report)
      (list (car option) `',(cadr option)))
     (t (list `(quote ,(car option)) `(quote ,(cdr option))))))
@@ -505,10 +503,12 @@
 ;;; finalize-inheritance
 
 (defun std-compute-class-default-initargs (class)
-  (mapcan #'(lambda (c)
-              (copy-list
-               (class-direct-default-initargs c)))
-          (class-precedence-list class)))
+  (delete-duplicates
+   (mapcan #'(lambda (c)
+               (copy-list
+                (class-direct-default-initargs c)))
+           (class-precedence-list class))
+   :key #'car :from-end t))
 
 (defun std-finalize-inheritance (class)
   ;; In case the class is already finalized, return
@@ -3380,13 +3380,13 @@
 
 (defun augment-initargs-with-defaults (class initargs)
   (let ((default-initargs '()))
-    (do* ((list (class-default-initargs class) (cddr list))
-          (key (car list) (car list))
-          (fn (cadr list) (cadr list)))
-         ((null list))
-      (when (eq (getf initargs key 'not-found) 'not-found)
-        (setf default-initargs (append default-initargs (list key (funcall fn))))))
-    (append initargs default-initargs)))
+    (dolist (initarg (class-default-initargs class))
+      (let ((key (first initarg))
+            (fn (third initarg)))
+        (when (eq (getf initargs key +slot-unbound+) +slot-unbound+)
+          (push key default-initargs)
+          (push (funcall fn) default-initargs))))
+    (append initargs (nreverse default-initargs))))
 
 (defmethod make-instance ((class standard-class) &rest initargs)
   (setf initargs (augment-initargs-with-defaults class initargs))