test-suite/vm/t-proc-with-setter.scm

   1 (define the-struct (vector 1 2))
   2
   3 (define get/set
   4   (make-procedure-with-setter
   5    (lambda (struct name)
   6      (case name
   7        ((first)  (vector-ref struct 0))
   8        ((second) (vector-ref struct 1))
   9        (else     #f)))
  10    (lambda (struct name val)
  11      (case name
  12        ((first)  (vector-set! struct 0 val))
  13        ((second) (vector-set! struct 1 val))
  14        (else     #f)))))
  15
  16 (and (eq? (vector-ref the-struct 0) (get/set the-struct 'first))
  17      (eq? (vector-ref the-struct 1) (get/set the-struct 'second))
  18      (begin
  19        (set! (get/set the-struct 'second) 77)
  20        (eq? (vector-ref the-struct 1) (get/set the-struct 'second))))