;; By Christopher Allan Webber, LGPLv3+; adapted from shallow-clone in GOOPS

(use-modules (oop goops))

(define-method (slot-fset (self <object>) slot-name value)
  "Return a new copy of SELF, with all slots preserved except SLOT-NAME
set to VALUE."
  (let* ((class (class-of self))
         (clone (allocate-instance class '()))
         (slots (map slot-definition-name
                     (class-slots class))))
    (for-each (lambda (slot)
                (if (and (slot-bound? self slot) (not (eq? slot slot-name)))
                    (slot-set! clone slot (slot-ref self slot))))
              slots)
    ;; Set the particular slot we're overriding
    (slot-set! clone slot-name value)
    clone))

;; By Christopher Allan Webber, LGPLv3+; adapted from shallow-clone in GOOPS
(use-modules (oop goops))

(define-method (slot-fset (self <object>) slot-name value)
  "Return a new copy of SELF, with all slots preserved except SLOT-NAME
set to VALUE."
  (let* ((class (class-of self))
         (clone (allocate-instance class '())))
    (for-each (lambda (slot)
                (define slot-n
                  (slot-definition-name slot))
                (if (and (slot-bound? self slot-n) (not (eq? slot-n slot-name)))
                    (slot-set! clone slot-n (slot-ref self slot-n))))
              (class-slots class))
    ;; Set the particular slot we're overriding
    (slot-set! clone slot-name value)
    clone))

;; By Christopher Allan Webber, LGPLv3+; adapted from shallow-clone in GOOPS
(use-modules (oop goops))

(define-method (slot-fset (self <object>) slot-name value)
  "Return a new copy of SELF, with all slots preserved except SLOT-NAME
set to VALUE."
  (let* ((class (class-of self))
         (clone (allocate-instance class '())))
    (for-each (lambda (slot)
                (define slot-n
                  (slot-definition-name slot))
                (if (and (not (eq? slot-n slot-name)) (slot-bound? self slot-n))
                    (slot-set! clone slot-n (slot-ref self slot-n))))
              (class-slots class))
    ;; Set the particular slot we're overriding
    (slot-set! clone slot-name value)
    clone))