Changeset 13956


Ignore:
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:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/SlotClass.java

    r13541 r13956  
    123123    LispObject computeDefaultInitargs()
    124124    {
     125      // KLUDGE (rudi 2012-06-02): duplicate initargs are not removed
     126      // here, but this does not hurt us since no Lisp class we define
     127      // Java-side has non-nil direct default initargs.
    125128        LispObject result = NIL;
    126129        LispObject cpl = getCPL();
  • trunk/abcl/src/org/armedbear/lisp/StandardClass.java

    r13947 r13956  
    682682                               list(Symbol.SIMPLE_CONDITION_FORMAT_ARGUMENTS),
    683683                               NIL)));
    684     CONDITION.setDirectDefaultInitargs(list(Keyword.FORMAT_ARGUMENTS,
    685                                              // FIXME
    686                                              new Closure(list(Symbol.LAMBDA, NIL, NIL),
    687                                                          new Environment())));
     684    CONDITION.setDirectDefaultInitargs(list(list(Keyword.FORMAT_ARGUMENTS,
     685                                                 NIL,
     686                                                 constantlyNil)));
    688687    CONTROL_ERROR.setCPL(CONTROL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION,
    689688                         STANDARD_OBJECT, BuiltInClass.CLASS_T);
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13955 r13956  
    370370     (list
    371371      ':direct-default-initargs
    372       `(list ,@(mapappend
    373                 #'(lambda (x) x)
    374                 (mapplist
    375                  #'(lambda (key value)
    376                     `(',key ,(make-initfunction value)))
    377                  (cdr option))))))
     372      `(list ,@(mapplist
     373                #'(lambda (key value)
     374                    `(list ',key ',value ,(make-initfunction value)))
     375                (cdr option)))))
    378376    ((:documentation :report)
    379377     (list (car option) `',(cadr option)))
     
    506504
    507505(defun std-compute-class-default-initargs (class)
    508   (mapcan #'(lambda (c)
    509               (copy-list
    510                (class-direct-default-initargs c)))
    511           (class-precedence-list class)))
     506  (delete-duplicates
     507   (mapcan #'(lambda (c)
     508               (copy-list
     509                (class-direct-default-initargs c)))
     510           (class-precedence-list class))
     511   :key #'car :from-end t))
    512512
    513513(defun std-finalize-inheritance (class)
     
    33813381(defun augment-initargs-with-defaults (class initargs)
    33823382  (let ((default-initargs '()))
    3383     (do* ((list (class-default-initargs class) (cddr list))
    3384           (key (car list) (car list))
    3385           (fn (cadr list) (cadr list)))
    3386          ((null list))
    3387       (when (eq (getf initargs key 'not-found) 'not-found)
    3388         (setf default-initargs (append default-initargs (list key (funcall fn))))))
    3389     (append initargs default-initargs)))
     3383    (dolist (initarg (class-default-initargs class))
     3384      (let ((key (first initarg))
     3385            (fn (third initarg)))
     3386        (when (eq (getf initargs key +slot-unbound+) +slot-unbound+)
     3387          (push key default-initargs)
     3388          (push (funcall fn) default-initargs))))
     3389    (append initargs (nreverse default-initargs))))
    33903390
    33913391(defmethod make-instance ((class standard-class) &rest initargs)
Note: See TracChangeset for help on using the changeset viewer.