Changeset 13964


Ignore:
Timestamp:
06/14/12 12:46:25 (9 years ago)
Author:
rschlatte
Message:

make (setf class-name) call reinitialize-instance

File:
1 edited

Legend:

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

    r13960 r13964  
    27232723         gf))))
    27242724
    2725 (defmacro redefine-class-forwarder (name slot)
     2725(defmacro redefine-class-forwarder (name slot &optional body-alist)
    27262726  "Define a generic function on a temporary symbol as an accessor
    27272727for the slot `slot'. Then, when definition is complete (including
    27282728allocation of methods), swap the definition in place.
    27292729
    2730 Without this approach, we can't depend the old forwarders to be
    2731 in place, while we still need them to "
    2732   (let* (($name (if (consp name) (cadr name) name))
    2733          (%name (intern (concatenate 'string
    2734                                      "%"
    2735                                      (if (consp name)
    2736                                          (symbol-name 'set-) "")
    2737                                      (symbol-name $name))
    2738                         (find-package "SYS"))))
    2739     `(atomic-defgeneric ,name (;; splice a new-value parameter for setters
    2740                                ,@(when (consp name) (list 'new-value))
    2741                                class)
    2742          ,@(mapcar (if (consp name)
    2743                        #'(lambda (class-name)
    2744                            `(:method (new-value (class ,class-name))
    2745                               (,%name new-value class)))
    2746                        #'(lambda (class-name)
    2747                            `(:method ((class ,class-name))
    2748                               (,%name class))))
    2749                    '(built-in-class forward-referenced-class structure-class))
    2750          ,@(mapcar #'(lambda (class-name)
    2751                        `(:method (,@(when (consp name) (list 'new-value))
    2752                                   (class ,class-name))
    2753                           ,(if (consp name)
    2754                                `(setf (slot-value class ',slot) new-value)
    2755                                `(slot-value class ',slot))))
    2756                    '(standard-class funcallable-standard-class)))))
     2730`body-alist' can be used to override the default method bodies for given
     2731metaclasses.  In substitute method bodies, `class' names the class
     2732instance and, for setters, `new-value' the new value."
     2733  (let* ((setterp (consp name))
     2734         (%name
     2735          (intern (concatenate 'string
     2736                               "%"
     2737                               (if setterp (symbol-name 'set-) "")
     2738                               (symbol-name (if setterp (cadr name) name)))
     2739                  (find-package "SYS")))
     2740         (bodies
     2741          (append body-alist
     2742                  (if setterp
     2743                      `((built-in-class . (,%name new-value class))
     2744                        (forward-referenced-class . (,%name new-value class))
     2745                        (structure-class . (,%name new-value class))
     2746                        (standard-class . (setf (slot-value class ',slot)
     2747                                                new-value))
     2748                        (funcallable-standard-class . (setf (slot-value class ',slot)
     2749                                                            new-value)))
     2750                      `((built-in-class . (,%name class))
     2751                        (forward-referenced-class . (,%name class))
     2752                        (structure-class . (,%name class))
     2753                        (standard-class . (slot-value class ',slot))
     2754                        (funcallable-standard-class . (slot-value class ',slot)))))))
     2755    `(atomic-defgeneric ,name (,@(when setterp (list 'new-value)) class)
     2756        ,@(mapcar #'(lambda (class-name)
     2757                      `(:method (,@(when setterp (list 'new-value))
     2758                                 (class ,class-name))
     2759                         ,(cdr (assoc class-name bodies))))
     2760                  '(built-in-class forward-referenced-class structure-class
     2761                    standard-class funcallable-standard-class)))))
    27572762
    27582763
    27592764(redefine-class-forwarder class-name name)
    2760 (redefine-class-forwarder (setf class-name) name)
     2765;;; AMOP pg. 230
     2766(redefine-class-forwarder (setf class-name) name
     2767   ((standard-class . (reinitialize-instance class :name new-value))
     2768    (funcallable-standard-class . (reinitialize-instance class :name new-value))))
    27612769(redefine-class-forwarder class-slots slots)
    27622770(redefine-class-forwarder (setf class-slots) slots)
Note: See TracChangeset for help on using the changeset viewer.