(library (srfi n17)
  (export set!)
  (import (except (rnrs base) set!)
          (rename (rnrs base) (set! prim:set!))
          (rnrs mutable-pairs)
          (rnrs mutable-strings)
          (only (rnrs lists) assv))

  (define (unspecified) (if #f #f))

;; SRFI 17 Reference Implementation
;; http://srfi.schemers.org/srfi-17/srfi-17-twobit.scm

;; See *R6RS* for change.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; SRFI 17 reference implementation for Twobit, contributed
; by Lars Thomas Hansen <lth@ccs.neu.edu>

; Use the LET* syntax scope extension in Twobit to let this SET! macro
; reference the old definition of SET! in the second clause.

; (define-syntax set! let*
;   (syntax-rules ()
;     ((set! (?e0 ?e1 ...) ?v)
;      ((setter ?e0) ?e1 ... ?v))
;     ((set! ?i ?v)
;      (set! ?i ?v))))

; *R6RS*: Replaced Twobit-specific definition of set! (above) with the
; following portable code.
(define-syntax set!
  (syntax-rules ()
    ((set! (?e0 ?e1 ...) ?v)
     ((setter ?e0) ?e1 ... ?v))
    ((set! ?i ?v)
     (prim:set! ?i ?v))))

(define setter 
  (let ((setters (list (cons car  set-car!)
                       (cons cdr  set-cdr!)
                       (cons caar (lambda (p v) (set-car! (car p) v)))
                       (cons cadr (lambda (p v) (set-car! (cdr p) v)))
                       (cons cdar (lambda (p v) (set-cdr! (car p) v)))
                       (cons cddr (lambda (p v) (set-cdr! (cdr p) v)))
                       (cons vector-ref vector-set!)
                       (cons string-ref string-set!))))
    (letrec ((setter
              (lambda (proc)
                (let ((probe (assv proc setters)))
                  (if probe
                      (cdr probe)
                      (error "No setter for " proc)))))
             (set-setter!
              (lambda (proc setter)
                (set! setters (cons (cons proc setter) setters))
                (unspecified))))
      (set-setter! setter set-setter!)
      setter)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
) ; end library