Changeset 13964
- Timestamp:
- 06/14/12 12:46:25 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r13960 r13964 2723 2723 gf)))) 2724 2724 2725 (defmacro redefine-class-forwarder (name slot )2725 (defmacro redefine-class-forwarder (name slot &optional body-alist) 2726 2726 "Define a generic function on a temporary symbol as an accessor 2727 2727 for the slot `slot'. Then, when definition is complete (including 2728 2728 allocation of methods), swap the definition in place. 2729 2729 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 2731 metaclasses. In substitute method bodies, `class' names the class 2732 instance 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))))) 2757 2762 2758 2763 2759 2764 (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)))) 2761 2769 (redefine-class-forwarder class-slots slots) 2762 2770 (redefine-class-forwarder (setf class-slots) slots)
Note: See TracChangeset
for help on using the changeset viewer.