diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index 43d5ab4a..21712355 100644 --- a/piclib/CMakeLists.txt +++ b/piclib/CMakeLists.txt @@ -22,6 +22,7 @@ list(APPEND PICLIB_SCHEME_LIBS ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm + ${PROJECT_SOURCE_DIR}/piclib/srfi/17.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/26.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/43.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/60.scm diff --git a/piclib/srfi/17.scm b/piclib/srfi/17.scm new file mode 100644 index 00000000..eb02e66e --- /dev/null +++ b/piclib/srfi/17.scm @@ -0,0 +1,45 @@ +(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))