Changeset 13956

Timestamp:

06/10/12 21:34:15 (9 years ago)

Author:

rschlatte

Message:

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.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• SlotClass.java (modified) (1 diff)
• StandardClass.java (modified) (1 diff)
• clos.lisp (modified) (3 diffs)

trunk/abcl/src/org/armedbear/lisp/SlotClass.java

@@ -123 +123 @@
     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();

trunk/abcl/src/org/armedbear/lisp/StandardClass.java

@@ -682 +682 @@
                                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);

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

@@ -370 +370 @@
      (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)))
@@ -506 +504 @@
 
 (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)
@@ -3381 +3381 @@
 (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)