picrin/contrib/10.srfi/srfi/17.scm

46 lines
1.3 KiB
Scheme
Raw Normal View History

2014-07-14 00:16:07 -04:00
(define-library (srfi 17)
2014-08-30 01:42:35 -04:00
(import (except (scheme base) set!)
2014-08-30 02:26:21 -04:00
(prefix (only (scheme base) set!) %)
2014-08-30 01:42:35 -04:00
(picrin dictionary)
2014-09-08 07:44:16 -04:00
(except (picrin base) set!)
2014-08-30 01:42:35 -04:00
(srfi 1)
(srfi 8))
2014-09-08 07:44:16 -04:00
2014-07-14 00:16:07 -04:00
(define-syntax set!
(syntax-rules ()
((_ (proc args ...) val)
((setter proc) args ... val))
((_ var val)
(%set! var val))))
(define setter
(letrec ((setter
(lambda (proc)
2014-08-30 01:42:35 -04:00
(receive (setter exists) (dictionary-ref (attribute proc)
2014-08-30 02:26:21 -04:00
'@@setter)
2014-08-30 01:42:35 -04:00
(if exists
setter
(error "No setter found")))))
2014-07-14 00:16:07 -04:00
(set-setter!
(lambda (proc setter)
2014-08-30 02:31:26 -04:00
(dictionary-set! (attribute proc) '@@setter setter))))
2014-07-14 00:16:07 -04:00
(set-setter! setter set-setter!)
setter))
(define (getter-with-setter get set)
(let ((proc (lambda args (apply get args))))
(set! (setter proc) set)
proc))
2014-08-30 01:42:35 -04:00
(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!)
2014-07-14 00:16:07 -04:00
(export set!
setter
2014-08-30 01:42:35 -04:00
getter-with-setter))