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

54
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!)
;; if the getter is a set!-transformer, make it do its thing
[(setf! getter . xs)
(and (identifier? #'getter)
(set!-transformer? (syntax-local-value #'getter (lambda () #f))))
((set!-transformer-procedure (syntax-local-value #'getter)) stx)]
[(setf! place val)
;; need to expand place first, in case it is itself a macro
(with-syntax ([place (local-expand
#'place 'expression
(append '(#%app #%top #%datum) (append '(#%app #%top #%datum)
(map (lambda (s) (datum->syntax-object #'var s #f)) (map (lambda (s)
'(#%app #%top #%datum)))) (datum->syntax-object #'place s #f))
val))] '(#%app #%top #%datum))))])
[else stx])) (syntax-case #'place ()
(syntax-case (expand-place stx) () [(getter args ...)
[(_ (getter args ...) val)
(if (identifier? #'getter) (if (identifier? #'getter)
(quasisyntax/loc stx (with-syntax ([setter (set!-prefix #'getter)])
(#,(datum->syntax-object (syntax/loc stx (setter args ... val)))
#'getter
(string->symbol
(string-append "set-" (symbol->string (syntax-e #'getter)) "!"))
#'getter #'getter)
args ... val))
(raise-syntax-error #f "not an identifier" stx #'getter))] (raise-syntax-error #f "not an identifier" stx #'getter))]
[(_ var val) [_ (syntax/loc stx (set! place val))]))]
(syntax/loc stx (set! var val))] [(setf! place val . more)
[(_ var val more ...) (let loop ([pvs #'(place val . more)] [r '()])
(let loop ([vas #'(var val more ...)] [r '()]) (syntax-case pvs ()
(syntax-case vas () [(p v . more)
[(v a more ...) (loop #'more (cons (syntax/loc stx (setf! p v)) r))]
(loop #'(more ...) (cons (syntax/loc stx (_ v a)) 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)]))]))