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

implement caller-stx parameter

Browse Source
This commit is contained in:
Matthew Butterick 2016-04-22 18:48:43 -07:00
parent e8a3ffae8a
commit dfab2a25bf
2 changed files with 18 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
beautiful-racket-lib/br/define.rkt
View File

@ -14,6 +14,12 @@
(regexp-match #rx"^_" str))))) (regexp-match #rx"^_" str)))))
pat-arg)) pat-arg))
;; expose the caller context within br:define macros with syntax parameter
(begin-for-syntax
(require (for-syntax racket/base) racket/stxparam)
(provide caller-stx)
(define-syntax-parameter caller-stx (λ(stx) (error 'not-parameterized))))
;; todo: support `else` case ;; todo: support `else` case
(define-syntax (br:define-cases stx) (define-syntax (br:define-cases stx)
(define-syntax-class syntaxed-id (define-syntax-class syntaxed-id
@ -43,7 +49,8 @@
#'(define-syntax top-id.name (λ (stx) #'(define-syntax top-id.name (λ (stx)
(define result (define result
(syntax-case stx (LITERAL ...) (syntax-case stx (LITERAL ...)
[pat body ...] ... [pat (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
body ...)] ...
[else (raise-syntax-error 'define-cases (format "no matching case for syntax pattern `~a`" (syntax->datum stx)) (syntax->datum #'top-id.name))])) [else (raise-syntax-error 'define-cases (format "no matching case for syntax pattern `~a`" (syntax->datum stx)) (syntax->datum #'top-id.name))]))
(if (not (syntax? result)) (if (not (syntax? result))
(datum->syntax stx result) (datum->syntax stx result)
@ -144,7 +151,15 @@
(begin (begin
(br:define #'(redefine _id) #'(define _id 42)) (br:define #'(redefine _id) #'(define _id 42))
(redefine zoombar) (redefine zoombar)
(check-equal? zoombar 42))) (check-equal? zoombar 42))
;; use caller-stx parameter to introduce identifier unhygienically
(br:define #'(zam _arg1 _arg2 _arg3)
(with-syntax ([dz (datum->syntax caller-stx 'dirty-zam)])
#`(define dz 'got-dirty-zam)))
(zam 'this 'that 42)
(check-equal? dirty-zam 'got-dirty-zam))
(define-syntax-rule (br:debug-define (syntax (id pat-arg ... . rest-arg)) body-exp) (define-syntax-rule (br:debug-define (syntax (id pat-arg ... . rest-arg)) body-exp)

1
beautiful-racket-lib/br/main.rkt
View File

@ -6,6 +6,7 @@
(all-from-out racket/list racket/string racket/format racket/match racket/port (all-from-out racket/list racket/string racket/format racket/match racket/port
br/syntax br/datum br/debug br/conditional) br/syntax br/datum br/debug br/conditional)
(for-syntax (all-from-out racket/base racket/syntax br/syntax)) (for-syntax (all-from-out racket/base racket/syntax br/syntax))
(for-syntax caller-stx) ; from br/define
(filtered-out (filtered-out
(λ (name) (λ (name)
(let ([pat (regexp "^br:")]) (let ([pat (regexp "^br:")])