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