Comment 2 for bug 520366

Revision history for this message
Nikodemus Siivola (nikodemus) wrote :

The undefined function warning is a separate issue from the type derivation lossage, being only due to a missing muffling in ACCESSOR-SET-SLOT-VALUE.

The derived type on the other hand: it is not lost, but the transform fires before the type has propagated. Redefining the deftransforms as follows gets the propagated type:

(deftransform slot-value ((object slot-name) (t (constant-arg symbol)) *
                          :node node)
  (let ((c-slot-name (lvar-value slot-name)))
    (if (sb-pcl::interned-symbol-p c-slot-name)
        (let* ((type (lvar-type object))
               (dd (when (structure-classoid-p type)
                     (find-defstruct-description
                      (sb-kernel::structure-classoid-name type))))
               (dsd (when dd
                      (find c-slot-name (dd-slots dd) :key #'dsd-name))))
          (cond (dsd
                 `(,(dsd-accessor-name dsd) object))
                (t
                 (delay-ir1-transform node :constraint)
                 `(sb-pcl::accessor-slot-value object ',c-slot-name))))
        (give-up-ir1-transform "slot name is not an interned symbol"))))

(deftransform sb-pcl::set-slot-value ((object slot-name new-value)
                                      (t (constant-arg symbol) t)
                                      * :node node)
  (let ((c-slot-name (lvar-value slot-name)))
    (if (sb-pcl::interned-symbol-p c-slot-name)
        (let* ((type (lvar-type object))
               (dd (when (structure-classoid-p type)
                     (find-defstruct-description
                      (sb-kernel::structure-classoid-name type))))
               (dsd (when dd
                      (find c-slot-name (dd-slots dd) :key #'dsd-name))))
          (cond (dsd
                 `(setf (,(dsd-accessor-name dsd) object) new-value))
                ((policy node (= safety 3))
                 ;; Safe code wants to check the type, and the global
                 ;; accessor won't do that. Also see the comment in the
                 ;; compiler-macro.
                 (give-up-ir1-transform "cannot use optimized accessor in safe code"))
                (t
                 (delay-ir1-transform node :constraint)
                 `(sb-pcl::accessor-set-slot-value object ',c-slot-name new-value))))
        (give-up-ir1-transform "slot name is not an interned symbol"))))