Changeset 13955
- Timestamp:
- 06/03/12 22:19:18 (10 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/StandardObject.java
r13541 r13955 451 451 Fixnum.getInstance(instance.slots.length))); 452 452 } 453 if (value == UNBOUND_VALUE) 454 { 455 LispObject slotName = instance.layout.getSlotNames()[index]; 456 value = Symbol.SLOT_UNBOUND.execute(instance.getLispClass(), 457 instance, slotName); 458 LispThread.currentThread()._values = null; 459 } 453 // We let UNBOUND_VALUE escape here, since invoking 454 // standard-instance-access on an unbound slot has undefined 455 // consequences (AMOP pg. 239), and we use this behavior to 456 // implement slot-boundp-using-class. 460 457 return value; 461 458 } -
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r13947 r13955 100 100 ;; isn't true when I write the above, but it's definitely the target. 101 101 ;; 102 ;; 102 ;; A note about AMOP: the first chapters (and the sample Closette 103 ;; implementation) of the book sometimes deviate from the specification. 104 ;; For example, in the examples slot-value-using-class has the slot name 105 ;; as third argument where in the specification it is the effective slot 106 ;; definition. When in doubt, we aim to follow the specification, the 107 ;; MOP test suite at http://common-lisp.net/project/closer/features.html 108 ;; and the behavior of other CL implementations in preference to 109 ;; chapters 1-4 and appendix D. 103 110 104 111 (export '(class-precedence-list class-slots … … 257 264 (defsetf std-instance-layout %set-std-instance-layout) 258 265 (defsetf standard-instance-access %set-standard-instance-access) 266 (defun funcallable-standard-instance-access (instance location) 267 (standard-instance-access instance location)) 268 (defsetf funcallable-standard-instance-access %set-standard-instance-access) 259 269 260 270 (defun (setf find-class) (new-value symbol &optional errorp environment) … … 529 539 (let ((allocation-class (slot-definition-allocation-class slot))) 530 540 (setf (slot-definition-location slot) 531 532 533 541 (if (eq allocation-class class) 542 (cons (slot-definition-name slot) +slot-unbound+) 543 (slot-location allocation-class (slot-definition-name slot)))))) 534 544 (push (slot-definition-location slot) shared-slots)))) 535 545 (when old-layout … … 718 728 719 729 (defun slot-value (object slot-name) 720 (if (or (eq (class-of (class-of object)) +the-standard-class+) 721 (eq (class-of (class-of object)) +the-structure-class+)) 722 (std-slot-value object slot-name) 723 (slot-value-using-class (class-of object) object slot-name))) 730 (let* ((class (class-of object)) 731 (metaclass (class-of class))) 732 (if (or (eq metaclass +the-standard-class+) 733 (eq metaclass +the-structure-class+) 734 (eq metaclass +the-funcallable-standard-class+)) 735 (std-slot-value object slot-name) 736 (slot-value-using-class class object 737 (find-slot-definition class slot-name))))) 724 738 725 739 (defsetf std-slot-value set-std-slot-value) 726 740 727 741 (defun %set-slot-value (object slot-name new-value) 728 (if (or (eq (class-of (class-of object)) +the-standard-class+) 729 (eq (class-of (class-of object)) +the-structure-class+)) 730 (setf (std-slot-value object slot-name) new-value) 731 (setf (slot-value-using-class (class-of object) object slot-name) new-value))) 742 (let* ((class (class-of object)) 743 (metaclass (class-of class))) 744 (if (or (eq metaclass +the-standard-class+) 745 (eq metaclass +the-structure-class+) 746 (eq metaclass +the-funcallable-standard-class+)) 747 (setf (std-slot-value object slot-name) new-value) 748 (setf (slot-value-using-class class object 749 (find-slot-definition class slot-name)) 750 new-value)))) 732 751 733 752 (defsetf slot-value %set-slot-value) 734 753 735 754 (defun slot-boundp (object slot-name) 736 (if (eq (class-of (class-of object)) +the-standard-class+) 737 (std-slot-boundp object slot-name) 738 (slot-boundp-using-class (class-of object) object slot-name))) 755 (let* ((class (class-of object)) 756 (metaclass (class-of class))) 757 (if (or (eq metaclass +the-standard-class+) 758 (eq metaclass +the-funcallable-standard-class+)) 759 (std-slot-boundp object slot-name) 760 (slot-boundp-using-class class object 761 (find-slot-definition class slot-name))))) 739 762 740 763 (defun std-slot-makunbound (instance slot-name) … … 749 772 750 773 (defun slot-makunbound (object slot-name) 751 (if (eq (class-of (class-of object)) +the-standard-class+) 752 (std-slot-makunbound object slot-name) 753 (slot-makunbound-using-class (class-of object) object slot-name))) 774 (let* ((class (class-of object)) 775 (metaclass (class-of class))) 776 (if (or (eq metaclass +the-standard-class+) 777 (eq metaclass +the-funcallable-standard-class+)) 778 (std-slot-makunbound object slot-name) 779 (slot-makunbound-using-class class object 780 (find-slot-definition class slot-name))))) 754 781 755 782 (defun std-slot-exists-p (instance slot-name) … … 1976 2003 :expected-type class)) 1977 2004 (setf location (slow-reader-lookup gf layout slot-name))) 1978 (if (consp location) 1979 ;; Shared slot. 1980 (cdr location) 1981 (standard-instance-access arg location)))))) 2005 (let ((value (if (consp location) 2006 (cdr location) ; :allocation :class 2007 (funcallable-standard-instance-access arg location)))) 2008 (if (eq value +slot-unbound+) 2009 (slot-unbound class arg slot-name) 2010 value)))))) 1982 2011 1983 2012 (t … … 3059 3088 3060 3089 ;;; Slot access 3061 3062 (defgeneric slot-value-using-class (class instance slot-name)) 3063 3064 (defmethod slot-value-using-class ((class standard-class) instance slot-name) 3065 (std-slot-value instance slot-name)) 3090 ;;; 3091 ;;; See AMOP pg. 156ff. for an overview. 3092 ;;; 3093 ;;; AMOP specifies these generic functions to dispatch on slot objects 3094 ;;; (with the exception of slot-exists-p-using-class), although its 3095 ;;; sample implementation Closette dispatches on slot names. We let 3096 ;;; slot-value and friends call their gf counterparts with the effective 3097 ;;; slot definition, but leave the definitions dispatching on slot name 3098 ;;; in place for user convenience. 3099 3100 ;;; AMOP pg. 235 3101 (defgeneric slot-value-using-class (class instance slot)) 3102 3103 (defmethod slot-value-using-class ((class standard-class) instance (slot symbol)) 3104 (std-slot-value instance slot)) 3105 (defmethod slot-value-using-class ((class standard-class) instance 3106 (slot standard-effective-slot-definition)) 3107 (let* ((location (slot-definition-location slot)) 3108 (value (if (consp location) 3109 (cdr location) ; :allocation :class 3110 (standard-instance-access instance location)))) 3111 (if (eq value +slot-unbound+) 3112 (slot-unbound class instance (slot-definition-name slot)) 3113 value))) 3114 3066 3115 (defmethod slot-value-using-class ((class funcallable-standard-class) 3067 instance slot-name) 3068 (std-slot-value instance slot-name)) 3069 (defmethod slot-value-using-class ((class structure-class) instance slot-name) 3070 (std-slot-value instance slot-name)) 3071 3072 (defgeneric (setf slot-value-using-class) (new-value class instance slot-name)) 3116 instance (slot symbol)) 3117 (std-slot-value instance slot)) 3118 (defmethod slot-value-using-class ((class funcallable-standard-class) instance 3119 (slot standard-effective-slot-definition)) 3120 (let* ((location (slot-definition-location slot)) 3121 (value (if (consp location) 3122 (cdr location) ; :allocation :class 3123 (funcallable-standard-instance-access instance location)))) 3124 (if (eq value +slot-unbound+) 3125 (slot-unbound class instance (slot-definition-name slot)) 3126 value))) 3127 3128 (defmethod slot-value-using-class ((class structure-class) instance 3129 (slot symbol)) 3130 (std-slot-value instance slot)) 3131 (defmethod slot-value-using-class ((class structure-class) instance 3132 (slot standard-effective-slot-definition)) 3133 (std-slot-value instance (slot-definition-name slot))) 3134 3135 ;;; AMOP pg. 231 3136 (defgeneric (setf slot-value-using-class) (new-value class instance slot)) 3073 3137 3074 3138 (defmethod (setf slot-value-using-class) (new-value 3075 3139 (class standard-class) 3076 3140 instance 3077 slot-name) 3078 (setf (std-slot-value instance slot-name) new-value)) 3141 (slot symbol)) 3142 (setf (std-slot-value instance slot) new-value)) 3143 (defmethod (setf slot-value-using-class) (new-value 3144 (class standard-class) 3145 instance 3146 (slot standard-effective-slot-definition)) 3147 (let ((location (slot-definition-location slot))) 3148 (if (consp location) ; :allocation :class 3149 (setf (cdr location) new-value) 3150 (setf (standard-instance-access instance location) new-value)))) 3079 3151 3080 3152 (defmethod (setf slot-value-using-class) (new-value 3081 3153 (class funcallable-standard-class) 3082 3154 instance 3083 slot-name) 3084 (setf (std-slot-value instance slot-name) new-value)) 3155 (slot symbol)) 3156 (setf (std-slot-value instance slot) new-value)) 3157 (defmethod (setf slot-value-using-class) (new-value 3158 (class funcallable-standard-class) 3159 instance 3160 (slot standard-effective-slot-definition)) 3161 (let ((location (slot-definition-location slot))) 3162 (if (consp location) ; :allocation :class 3163 (setf (cdr location) new-value) 3164 (setf (funcallable-standard-instance-access instance location) 3165 new-value)))) 3085 3166 3086 3167 (defmethod (setf slot-value-using-class) (new-value 3087 3168 (class structure-class) 3088 3169 instance 3089 slot-name) 3090 (setf (std-slot-value instance slot-name) new-value)) 3091 3170 (slot symbol)) 3171 (setf (std-slot-value instance slot) new-value)) 3172 (defmethod (setf slot-value-using-class) (new-value 3173 (class structure-class) 3174 instance 3175 (slot standard-effective-slot-definition)) 3176 (setf (std-slot-value instance (slot-definition-name slot)) new-value)) 3177 3178 ;;; slot-exists-p-using-class is not specified by AMOP, and obviously 3179 ;;; cannot be specialized on the slot type. Hence, its implementation 3180 ;;; differs from slot-(boundp|makunbound|value)-using-class 3092 3181 (defgeneric slot-exists-p-using-class (class instance slot-name)) 3093 3182 … … 3106 3195 nil) 3107 3196 3108 (defgeneric slot-boundp-using-class (class instance slot-name)) 3109 (defmethod slot-boundp-using-class ((class standard-class) instance slot-name) 3110 (std-slot-boundp instance slot-name)) 3111 (defmethod slot-boundp-using-class ((class funcallable-standard-class) instance slot-name) 3112 (std-slot-boundp instance slot-name)) 3113 (defmethod slot-boundp-using-class ((class structure-class) instance slot-name) 3197 3198 (defgeneric slot-boundp-using-class (class instance slot)) 3199 (defmethod slot-boundp-using-class ((class standard-class) instance (slot symbol)) 3200 (std-slot-boundp instance slot)) 3201 (defmethod slot-boundp-using-class ((class standard-class) instance 3202 (slot standard-effective-slot-definition)) 3203 (let ((location (slot-definition-location slot))) 3204 (if (consp location) 3205 (eq (cdr location) +slot-unbound+) ; :allocation :class 3206 (eq (standard-instance-access instance location) +slot-unbound+)))) 3207 3208 (defmethod slot-boundp-using-class ((class funcallable-standard-class) instance 3209 (slot symbol)) 3210 (std-slot-boundp instance slot)) 3211 (defmethod slot-boundp-using-class ((class funcallable-standard-class) instance 3212 (slot standard-effective-slot-definition)) 3213 (let ((location (slot-definition-location slot))) 3214 (if (consp location) 3215 (eq (cdr location) +slot-unbound+) ; :allocation :class 3216 (eq (funcallable-standard-instance-access instance location) 3217 +slot-unbound+)))) 3218 3219 (defmethod slot-boundp-using-class ((class structure-class) instance slot) 3114 3220 "Structure slots can't be unbound, so this method always returns T." 3115 (declare (ignore class instance slot -name))3221 (declare (ignore class instance slot)) 3116 3222 t) 3117 3223 3118 (defgeneric slot-makunbound-using-class (class instance slot -name))3224 (defgeneric slot-makunbound-using-class (class instance slot)) 3119 3225 (defmethod slot-makunbound-using-class ((class standard-class) 3120 3226 instance 3121 slot-name) 3122 (std-slot-makunbound instance slot-name)) 3227 (slot symbol)) 3228 (std-slot-makunbound instance slot)) 3229 (defmethod slot-makunbound-using-class ((class standard-class) 3230 instance 3231 (slot standard-effective-slot-definition)) 3232 (let ((location (slot-definition-location slot))) 3233 (if (consp location) 3234 (setf (cdr location) +slot-unbound+) 3235 (setf (standard-instance-access instance location) +slot-unbound+)))) 3236 3123 3237 (defmethod slot-makunbound-using-class ((class funcallable-standard-class) 3124 3238 instance 3125 slot-name) 3126 (std-slot-makunbound instance slot-name)) 3239 (slot symbol)) 3240 (std-slot-makunbound instance slot)) 3241 (defmethod slot-makunbound-using-class ((class funcallable-standard-class) 3242 instance 3243 (slot symbol)) 3244 (let ((location (slot-definition-location slot))) 3245 (if (consp location) 3246 (setf (cdr location) +slot-unbound+) 3247 (setf (funcallable-standard-instance-access instance location) 3248 +slot-unbound+)))) 3249 3127 3250 (defmethod slot-makunbound-using-class ((class structure-class) 3128 3251 instance 3129 slot -name)3130 (declare (ignore class instance slot -name))3252 slot) 3253 (declare (ignore class instance slot)) 3131 3254 (error "Structure slots can't be unbound")) 3132 3255 -
trunk/abcl/src/org/armedbear/lisp/mop.lisp
r13929 r13955 100 100 slot-definition-location 101 101 standard-instance-access 102 funcallable-standard-instance-access 102 103 103 104 intern-eql-specializer
Note: See TracChangeset
for help on using the changeset viewer.