Merge pull request #163 from stibear/srfi17

implements srfi-17(generalized-set!)

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

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))