suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

respect set!-transformers in setf!

Browse Source 
svn: r5436
This commit is contained in:
Eli Barzilay 2007-01-23 08:54:16 +00:00
parent 975ffcc227
commit a5d01f9c3a
1 changed files with 31 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
collects/swindle/setf.ss
View File

@ -29,35 +29,37 @@
;; Original idea thanks to Eric Kidd who stole it from Dylan ;; Original idea thanks to Eric Kidd who stole it from Dylan
(provide setf!) (provide setf!)
(define-syntax (setf! stx) (define-syntax (setf! stx)
(define (expand-place stx) (define (set!-prefix id)
(syntax-case stx () (datum->syntax-object
[(_ var val) id
(quasisyntax/loc stx (string->symbol (string-append "set-" (symbol->string (syntax-e id)) "!"))
(_ #,(local-expand id id))
#'var 'expression (syntax-case stx (setf!)
(append '(#%app #%top #%datum) ;; if the getter is a set!-transformer, make it do its thing
(map (lambda (s) (datum->syntax-object #'var s #f)) [(setf! getter . xs)
'(#%app #%top #%datum)))) (and (identifier? #'getter)
val))] (set!-transformer? (syntax-local-value #'getter (lambda () #f))))
[else stx])) ((set!-transformer-procedure (syntax-local-value #'getter)) stx)]
(syntax-case (expand-place stx) () [(setf! place val)
[(_ (getter args ...) val) ;; need to expand place first, in case it is itself a macro
(if (identifier? #'getter) (with-syntax ([place (local-expand
(quasisyntax/loc stx #'place 'expression
(#,(datum->syntax-object (append '(#%app #%top #%datum)
#'getter (map (lambda (s)
(string->symbol (datum->syntax-object #'place s #f))
(string-append "set-" (symbol->string (syntax-e #'getter)) "!")) '(#%app #%top #%datum))))])
#'getter #'getter) (syntax-case #'place ()
args ... val)) [(getter args ...)
(raise-syntax-error #f "not an identifier" stx #'getter))] (if (identifier? #'getter)
[(_ var val) (with-syntax ([setter (set!-prefix #'getter)])
(syntax/loc stx (set! var val))] (syntax/loc stx (setter args ... val)))
[(_ var val more ...) (raise-syntax-error #f "not an identifier" stx #'getter))]
(let loop ([vas #'(var val more ...)] [r '()]) [_ (syntax/loc stx (set! place val))]))]
(syntax-case vas () [(setf! place val . more)
[(v a more ...) (let loop ([pvs #'(place val . more)] [r '()])
(loop #'(more ...) (cons (syntax/loc stx (_ v a)) r))] (syntax-case pvs ()
[(p v . more)
(loop #'more (cons (syntax/loc stx (setf! p v)) r))]
[() (quasisyntax/loc stx (begin #,@(reverse! r)))] [() (quasisyntax/loc stx (begin #,@(reverse! r)))]
[_ (raise-syntax-error #f "uneven number of forms" stx)]))])) [_ (raise-syntax-error #f "uneven number of forms" stx)]))]))