Changeset 13955


Ignore:
Timestamp:
06/03/12 22:19:18 (9 years ago)
Author:
rschlatte
Message:

Make slot-value-using-class &c dispatch on slot definition object

  • Keeping the old methods dispatching on slot name around for existing users, but slot-value &c now use the new code paths.
  • The new behavior is following the AMOP spec (although chapters 1-4 and the Closette implementation of AMOP show method dispatch on slot names instead).
  • Minor incompatible change: standard-instance-access now does not complain about unbound slots, returning +slot-unbound+ instead. We handle unbound slots Lisp-side now both for :allocation :instance and :allocation :class in one code path.
  • Removes 5 failures from the AMOP test suite.
Location:
trunk/abcl/src/org/armedbear/lisp
Files:
3 edited

Legend:

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

    r13541 r13955  
    451451                                 Fixnum.getInstance(instance.slots.length)));
    452452        }
    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.
    460457      return value;
    461458    }
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13947 r13955  
    100100;; isn't true when I write the above, but it's definitely the target.
    101101;;
    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.
    103110
    104111(export '(class-precedence-list class-slots
     
    257264(defsetf std-instance-layout %set-std-instance-layout)
    258265(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)
    259269
    260270(defun (setf find-class) (new-value symbol &optional errorp environment)
     
    529539           (let ((allocation-class (slot-definition-allocation-class slot)))
    530540             (setf (slot-definition-location slot)
    531        (if (eq allocation-class class)
    532            (cons (slot-definition-name slot) +slot-unbound+)
    533            (slot-location allocation-class (slot-definition-name slot))))))
     541                   (if (eq allocation-class class)
     542                       (cons (slot-definition-name slot) +slot-unbound+)
     543                       (slot-location allocation-class (slot-definition-name slot))))))
    534544         (push (slot-definition-location slot) shared-slots))))
    535545    (when old-layout
     
    718728
    719729(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)))))
    724738
    725739(defsetf std-slot-value set-std-slot-value)
    726740
    727741(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))))
    732751
    733752(defsetf slot-value %set-slot-value)
    734753
    735754(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)))))
    739762
    740763(defun std-slot-makunbound (instance slot-name)
     
    749772
    750773(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)))))
    754781
    755782(defun std-slot-exists-p (instance slot-name)
     
    19762003                        :expected-type class))
    19772004               (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))))))
    19822011
    19832012    (t
     
    30593088
    30603089;;; 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
    30663115(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))
    30733137
    30743138(defmethod (setf slot-value-using-class) (new-value
    30753139                                          (class standard-class)
    30763140                                          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))))
    30793151
    30803152(defmethod (setf slot-value-using-class) (new-value
    30813153                                          (class funcallable-standard-class)
    30823154                                          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))))
    30853166
    30863167(defmethod (setf slot-value-using-class) (new-value
    30873168                                          (class structure-class)
    30883169                                          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
    30923181(defgeneric slot-exists-p-using-class (class instance slot-name))
    30933182
     
    31063195  nil)
    31073196
    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)
    31143220  "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))
    31163222  t)
    31173223
    3118 (defgeneric slot-makunbound-using-class (class instance slot-name))
     3224(defgeneric slot-makunbound-using-class (class instance slot))
    31193225(defmethod slot-makunbound-using-class ((class standard-class)
    31203226                                        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
    31233237(defmethod slot-makunbound-using-class ((class funcallable-standard-class)
    31243238                                        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
    31273250(defmethod slot-makunbound-using-class ((class structure-class)
    31283251                                        instance
    3129                                         slot-name)
    3130   (declare (ignore class instance slot-name))
     3252                                        slot)
     3253  (declare (ignore class instance slot))
    31313254  (error "Structure slots can't be unbound"))
    31323255
  • trunk/abcl/src/org/armedbear/lisp/mop.lisp

    r13929 r13955  
    100100          slot-definition-location
    101101          standard-instance-access
     102          funcallable-standard-instance-access
    102103
    103104          intern-eql-specializer
Note: See TracChangeset for help on using the changeset viewer.