generalised-set.scm

#!r6rs
(library (generalized-set)
(export (rename (set!!! set!))
        define-getter/setter)
(import (rnrs)
        (rnrs mutable-pairs)
        (rnrs mutable-strings))

;; Usage:
;; > (import (generalized-set))
;; > (define-record-type cell
;;     (fields (mutable var)))
;; > (define-getter/setter cell-ref cell-var cell-var-set!)
;; > (define c (make-cell 3))
;; > (cell-ref c)
;; 3
;; > (set! (cell-ref c) 9)
;; > (cell-ref c)
;; 9
(define-syntax set!!
  (syntax-rules ()
    ((set!! (accessor arg ...) val)
     (set! accessor (arg ... val)))
    ((set!! . rest)
     (set! . rest))))

(define-syntax define-getter/setter
  (syntax-rules ()
    ((define-getter/setter name ?getter ?setter)
     (begin
       ;; No point evaluating ?getter and ?setter multiple times
       (define getter ?getter)
       (define setter ?setter)
       (define-syntax name
         (make-variable-transformer
          (lambda (stx)
            (syntax-case stx (set!)
              ((set! name (vars (... ...)))
               #'(setter vars (... ...)))
              ((name vals (... ...))
               #'(getter vals (... ...)))
              (name
               (identifier? #'name)
               #'getter)))))))))

;; We want to handle various primitives especially, so that we don't
;; have to use complicated imports every time we want to use
;; generalized `set!`. Basically, we make them literals so they
;; capture the appropriate lexical binding, and behave correctly if
;; they are rebound locally.
;; If you don't like this, you just don't have to use it, simply fix
;; the export list at the top to export set!! as set!, not set!!!
(define-syntax set!!!
  (syntax-rules
      (car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar
       cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
       cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr string-ref vector-ref)
    ((set!!! (car x) val)
     (set-car! x val))
    ((set!!! (cdr x) val)
     (set-cdr! x val))
    ((set!!! (caar x) val)
     (set-car! (car x) val))
    ((set!!! (cadr x) val)
     (set-car! (cdr x) val))
    ((set!!! (cdar x) val)
     (set-cdr! (car x) val))
    ((set!!! (cddr x) val)
     (set-cdr! (cdr x) val))
    ((set!!! (caaar x) val)
     (set-car! (caar x) val))
    ((set!!! (caadr x) val)
     (set-car! (cadr x) val))
    ((set!!! (cadar x) val)
     (set-car! (cdar x) val))
    ((set!!! (caddr x) val)
     (set-car! (cddr x) val))
    ((set!!! (cdaar x) val)
     (set-cdr! (caar x) val))
    ((set!!! (cdadr x) val)
     (set-cdr! (cadr x) val))
    ((set!!! (cddar x) val)
     (set-cdr! (cdar x) val))
    ((set!!! (cdddr x) val)
     (set-cdr! (cddr x) val))
    ((set!!! (caaaar x) val)
     (set-car! (caaar x) val))
    ((set!!! (caaadr x) val)
     (set-car! (caadr x) val))
    ((set!!! (caadar x) val)
     (set-car! (cadar x) val))
    ((set!!! (caaddr x) val)
     (set-car! (caddr x) val))
    ((set!!! (cadaar x) val)
     (set-car! (cdaar x) val))
    ((set!!! (cadadr x) val)
     (set-car! (cdadr x) val))
    ((set!!! (caddar x) val)
     (set-car! (cddar x) val))
    ((set!!! (cadddr x) val)
     (set-car! (cdddr x) val))
    ((set!!! (cdaaar x) val)
     (set-cdr! (caaar x) val))
    ((set!!! (cdaadr x) val)
     (set-cdr! (caadr x) val))
    ((set!!! (cdadar x) val)
     (set-cdr! (cadar x) val))
    ((set!!! (cdaddr x) val)
     (set-cdr! (caddr x) val))
    ((set!!! (cddaar x) val)
     (set-cdr! (cdaar x) val))
    ((set!!! (cddadr x) val)
     (set-cdr! (cdadr x) val))
    ((set!!! (cdddar x) val)
     (set-cdr! (cddar x) val))
    ((set!!! (cddddr x) val)
     (set-cdr! (cdddr x) val))
    ((set!!! (string-ref x index) val)
     (string-set! x index val))
    ((set!!! (vector-ref x index) val)
     (vector-set! x index val))
    ((set!!! x val)
     (set!! x val))))

)