backwards-compatible-class.lisp

(defclass backwards-compatible-class (standard-class)
  ())

(defmethod sb-mop:validate-superclass ((class backwards-compatible-class)
                                       (superclass standard-class))
  t)

(defmethod initialize-instance :before ((instance backwards-compatible-class)
                                        &key (direct-slots))
  (:printv :initialize direct-slots))
(defmethod reinitialize-instance :before ((instance backwards-compatible-class)
                                          &key ((:direct-slots new-slots)))
  (let* ((old-slots (c2mop:class-direct-slots instance)))
    (loop for old-slot in old-slots
          for old-slot-name = (c2mop:slot-definition-name old-slot)
          for new-slot-plist = (find old-slot-name new-slots :key (data-lens:key :name))
          do (ensure-compatibility instance
                                   old-slot
                                   new-slot-plist) )))

(defgeneric ensure-compatibility (backwards-compatible-class old-slot new-slot-plist)
  (:method ((cls backwards-compatible-class) old-slot new-slot-plist)
    (let ((old-slot-name (c2cl:slot-definition-name old-slot)))
      (unless new-slot-plist
        (with-simple-restart (force "Force deletion of removed slot")
          (error "removed slot: ~a" old-slot-name)))
      (let ((old-readers (c2mop:slot-definition-readers old-slot))
            (new-readers (getf new-slot-plist :readers)))
        (alexandria:when-let ((missing-readers (set-difference old-readers new-readers)))
          (restart-case (error "missing readers for slot ~a: ~{~a~^, ~}" old-slot-name missing-readers)
            (force ()
              :report "Force deletion of readers"
              (loop for reader in missing-readers
                    for gf = (symbol-function reader)
                    for method = (find-method gf
                                              '()
                                              (list cls))
                    do (remove-method gf method)))))))
    t))