Changeset 13200 for trunk/abcl/src/org


Ignore:
Timestamp:
01/31/11 21:17:21 (11 years ago)
Author:
ehuelsmann
Message:

Atomically swap generic functions into place of temporary
DEFUNs for all standard-class slot accessors.

Note: This addresses the recursive requirement to be able
to allocate objects and classes while changing the functions
used to create them.

File:
1 edited

Legend:

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

    r13185 r13200  
    21992199                   )))
    22002200
    2201 (defmacro redefine-class-forwarder (name slot &optional alternative-name)
     2201(defmacro redefine-class-forwarder (name slot)
     2202  "Define a generic function on a temporary symbol as an accessor
     2203for the slot `slot'. Then, when definition is complete (including
     2204allocation of methods), swap the definition in place.
     2205
     2206Without this approach, we can't depend the old forwarders to be
     2207in place, while we still need them to "
    22022208  (let* (($name (if (consp name) (cadr name) name))
    22032209         (%name (intern (concatenate 'string
     
    22062212                                         (symbol-name 'set-) "")
    22072213                                     (symbol-name $name))
    2208                         (find-package "SYS"))))
    2209     (unless alternative-name
    2210       (setf alternative-name name))
     2214                        (find-package "SYS")))
     2215         (alternative-name (gensym)))
    22112216    (if (consp name)
    22122217        `(progn ;; setter
     
    22202225           (defmethod ,alternative-name (new-value (class standard-class))
    22212226             (setf (slot-value class ',slot) new-value))
    2222            ,@(unless (eq name alternative-name)
    2223                      `((setf (get ',$name 'SETF-FUNCTION)
    2224                              (symbol-function ',alternative-name))))
    2225            )
     2227           (let ((gf (symbol-function ',alternative-name)))
     2228             (setf (get ',$name 'SETF-FUNCTION) gf)
     2229             (%set-generic-function-name gf ',name)))
    22262230        `(progn ;; getter
    22272231           (defgeneric ,alternative-name (class))
     
    22342238           (defmethod ,alternative-name ((class standard-class))
    22352239             (slot-value class ',slot))
    2236            ,@(unless (eq name alternative-name)
    2237                      `((setf (symbol-function ',$name)
    2238                              (symbol-function ',alternative-name))))
    2239            ) )))
     2240           (let ((gf (symbol-function ',alternative-name)))
     2241             (setf (symbol-function ',$name) gf)
     2242             (%set-generic-function-name gf ',name))))))
    22402243
    22412244(redefine-class-forwarder class-name name)
     
    22512254(redefine-class-forwarder class-direct-subclasses direct-subclasses)
    22522255(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses)
    2253 (redefine-class-forwarder class-direct-methods direct-methods !class-direct-methods)
    2254 (redefine-class-forwarder (setf class-direct-methods) direct-methods !!class-direct-methods)
     2256(redefine-class-forwarder class-direct-methods direct-methods)
     2257(redefine-class-forwarder (setf class-direct-methods) direct-methods)
    22552258(redefine-class-forwarder class-precedence-list precedence-list)
    22562259(redefine-class-forwarder (setf class-precedence-list) precedence-list)
Note: See TracChangeset for help on using the changeset viewer.