CHANGE-CLASS slot type workaround

gistfile1.lisp

(defun change-class-slot-workaround (old-class new-class)
  "Allow CHANGE-CLASS to convert instances of OLD-CLASS to NEW-CLASS
without invoking undefined behaviour if a slot in OLD-CLASS contains a
value incompatible with the type of that slot in NEW-CLASS. Due to the
way this function works, any slots common to OLD-CLASS and NEW-CLASS
will be unbound in the instance once its class has been changed, but
will still be present in the copy of the instance which is passed into
UPDATE-INSTANCE-FOR-DIFFERENT-CLASS.

This is done by defining two methods. The first is a primary method on
CHANGE-CLASS, with the INSTANCE argument specialized on OLD-CLASS and
the NEW-CLASS argument specialized on (eql NEW-CLASS), which will
unbind all slots in INSTANCE which are shared between OLD-CLASS and
NEW-CLASS, and then invoke CALL-NEXT-METHOD with an additional
DARKSKY::SAVED-SLOT-VALUES initialization argument, containing an
alist mapping the name of each shared slot to its value in INSTANCE
before being unbound. The second is an :around method on
UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, with the PREVIOUS argument
specialized on OLD-CLASS and the CURRENT argument specialized on
NEW-CLASS, which will set the slots of PREVIOUS to the values in the
DARKSKY::SAVED-SLOT-VALUES initialization argument and invoke the next
method without that argument.

Note that in any methods that are run after the one defined by this
function on CHANGE-CLASS and before the one defined on
UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, the shared slots will be unbound
in PREVIOUS or INSTANCE, and their values can instead be found in the
DARKSKY::SAVED-SLOT-VALUES initialization argument described above."
  (let* ((old-slots (mapcar #'c2mop:slot-definition-name (c2mop:class-slots old-class)))
         (new-slots (mapcar #'c2mop:slot-definition-name (c2mop:class-slots new-class)))
         (shared-slots (intersection old-slots new-slots)))
    (with-gensyms (prev curr new-class-sym slot-values initargs)
      (add-method
       #'change-class
       (make-instance
        'standard-method
        :specializers (list old-class (c2mop:intern-eql-specializer new-class))
        :lambda-list `(,prev ,new-class-sym &rest ,initargs)
        :function
        (compile
         nil
         (c2mop:make-method-lambda
          #'change-class
          (c2mop:class-prototype (find-class 'standard-method))
          `(lambda (,prev ,new-class-sym &rest ,initargs)
             (let ((,slot-values '()))
               ,@(mapcar
                  (lambda (slot-name)
                    `(progn
                       (push (cons ',slot-name (slot-value ,prev ',slot-name))
                             ,slot-values)
                       (slot-makunbound ,prev ',slot-name)))
                  shared-slots)
               (apply #'call-next-method ,prev ,new-class-sym
                      (list*
                       ;; ANAPHOR; allow accessing saved slot values
                       ;; in other methods
                       'saved-slot-values ,slot-values
                       ,initargs))))
          nil))))
      
      (add-method
       #'update-instance-for-different-class
       (make-instance
        'standard-method
        :qualifiers '(:around)
        :specializers (list old-class new-class)
        :lambda-list `(,prev ,curr &rest ,initargs &key ((saved-slot-values ,slot-values)))
        :function
        (compile
         nil
         (c2mop:make-method-lambda
          #'update-instance-for-different-class
          (c2mop:class-prototype (find-class 'standard-method))
          (with-gensyms (slot-value)
           `(lambda (,prev ,curr &rest ,initargs  &key ((saved-slot-values ,slot-values)))
              (dolist (,slot-value ,slot-values)
                (setf (slot-value ,prev (car ,slot-value)) (cdr ,slot-value)))
              (apply #'call-next-method ,prev ,curr
                     (remove-from-plist ,initargs 'saved-slot-values))))
          nil))))

      (values))))