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

(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))


;; By Christopher Allan Webber, LGPLv3+
;; Inspired by a conversation with Jan Nieuwenhuizen... thanks for the
;; help, Jan!
;; This one does an "immutable" interface cloned-with-adjustments
;; version of things that can change multiple fields at the same time.
;; It uses, and requires, accessors to work on the adjusted fields.

(use-modules (oop goops)
             (ice-9 match))

(define (do-clone obj adjust-fields)
  (define new (shallow-clone obj))
  (for-each
   (match-lambda
     ;; Apply just this one field
     (((accessor) val)
      (set! (accessor new) val))
     ;; Recursively apply fields
     (((accessor recur-fields ...) val)
      (set! (accessor new)
            (do-clone (accessor new)
                      (list (list recur-fields val))))))
   adjust-fields)
  new)

(define-syntax-rule (clone obj ((fields ...) val) ...)
  (do-clone obj
            (list (list (list fields ...) val) ...)))

;; That's all the code.
;; Now here's an example adapted from the (srfi srfi-9 gnu)
;; documentation.

(define-class <address> ()
  (street #:init-keyword #:street
          #:accessor .street)
  (city #:init-keyword #:city
        #:accessor .city)
  (country #:init-keyword #:country
           #:accessor .country))

(define-class <person> ()
  (age #:init-keyword #:age
       #:accessor .age)
  (email #:init-keyword #:email
         #:accessor .email)
  (address #:init-keyword #:address
           #:accessor .address))


(define fsf-address
  (make <address> 
    #:street "Franklin Street"
    #:city "Boston"
    #:country "USA"))

(define rms
  (make <person>
    #:age 30
    #:email "rms@gnu.org"
    #:address fsf-address))

(define new-rms
  (clone rms 
         ((.age) 60)
         ((.address .street) "Temple Place")))

;; scheme@(guile-user)> (.age rms)
;; $12 = 30
;; scheme@(guile-user)> (.age new-rms)
;; $13 = 60
;; scheme@(guile-user)> (.street (.address rms))
;; $14 = "Franklin Street"
;; scheme@(guile-user)> (.street (.address new-rms))
;; $15 = "Temple Place"