conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

implement by using (picrin attribute)

This commit is contained in:
stibear 2014-08-30 14:42:35 +09:00
parent 688c41a402
commit a85de7ff73
1 changed files with 20 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
piclib/srfi/17.scm
View File

@ -1,30 +1,11 @@
(define-library (srfi 17)
(define-library (rename set!)
(import (scheme base))
(export (rename set! %set!)
define
quasiquote
letrec
let
error
apply
define-syntax
syntax-rules
lambda
if
quote
begin
vector-ref
string-ref
bytevector-u8-ref
vector-set!
string-set!
bytevector-u8-set!
list-set!))
(import (rename set!)
(srfi 1))
(import (except (scheme base) set!)
(rename (prefix (only (scheme base) set!) %))
(picrin dictionary)
(picrin attribute)
(srfi 1)
(srfi 8))
(define-syntax set!
(syntax-rules ()
@ -33,30 +14,18 @@
((_ var val)
(%set! var val))))
(define setter-alist '())
(define setter
(letrec ((setter
(lambda (proc)
(let ((probe (assv proc setter-alist)))
(if probe
(cdr probe)
(error "No setter for " proc)))))
(receive (setter exists) (dictionary-ref (attribute proc)
'setter)
(if exists
setter
(error "No setter found")))))
(set-setter!
(lambda (proc setter)
(set! setter-alist
(alist-cons proc setter setter-alist)))))
(dictionary-set! (attribute proc) 'setter setter))))
(set-setter! setter set-setter!)
(set-setter! car set-car!)
(set-setter! cdr set-cdr!)
(set-setter! caar (lambda (p v) (set-car! (car p) v)))
(set-setter! cadr (lambda (p v) (set-car! (cdr p) v)))
(set-setter! cdar (lambda (p v) (set-cdr! (car p) v)))
(set-setter! cddr (lambda (p v) (set-cdr! (cdr p) v)))
(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!)
setter))
(define (getter-with-setter get set)
@ -64,7 +33,13 @@
(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
setter-alist))
getter-with-setter))