46 lines
1.3 KiB
Scheme
46 lines
1.3 KiB
Scheme
(define-library (srfi 17)
|
|
|
|
(import (except (scheme base) set!)
|
|
(prefix (only (scheme base) set!) %)
|
|
(picrin dictionary)
|
|
(picrin attribute)
|
|
(srfi 1)
|
|
(srfi 8))
|
|
|
|
(define-syntax set!
|
|
(syntax-rules ()
|
|
((_ (proc args ...) val)
|
|
((setter proc) args ... val))
|
|
((_ var val)
|
|
(%set! var val))))
|
|
|
|
(define setter
|
|
(letrec ((setter
|
|
(lambda (proc)
|
|
(receive (setter exists) (dictionary-ref (attribute proc)
|
|
'@@setter)
|
|
(if exists
|
|
setter
|
|
(error "No setter found")))))
|
|
(set-setter!
|
|
(lambda (proc setter)
|
|
(dictionary-set! (attribute proc) 'setter setter))))
|
|
(set-setter! setter set-setter!)
|
|
setter))
|
|
|
|
(define (getter-with-setter get set)
|
|
(let ((proc (lambda args (apply get args))))
|
|
(set! (setter proc) set)
|
|
proc))
|
|
|
|
(set! (setter car) set-car!)
|
|
(set! (setter cdr) set-cdr!)
|
|
(set! (setter vector-ref) vector-set!)
|
|
(set! (setter string-ref) string-set!)
|
|
(set! (setter bytevector-u8-ref) bytevector-u8-set!)
|
|
(set! (setter list-ref) list-set!)
|
|
|
|
(export set!
|
|
setter
|
|
getter-with-setter))
|