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

scopes

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-14 17:07:13 -07:00
parent cdda2224da
commit e3b7495a7a
2 changed files with 54 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
beautiful-racket-lib/br/syntax-scopes-test.rkt
View File

@ -8,36 +8,54 @@
(define-scope green (blue yellow))
(define-scope purple (blue red)))
(define #'(define-blue _id _val)
(with-blue-binding-form ([x '_id])
#'(define x _val)))
#;(define-blue x (+ 42 42))
(define #'(def-x)
(with-blue-binding-form ([x 'x])
#'(define x (+ 42 42))))
(define #'(def-x-2)
(with-yellow-binding-form ([x 'x])
#'(define x (+ 42))))
(define #'(print-x)
(with-yellow-syntax ([x 'x])
#'(println (+ x x))))
(define #'(print-x-2)
(with-purple-syntax ([x 'x])
#'(println (+ x x x))))
(define #'(def-blue-x)
(with-blue-binding-form (x)
#'(define x (+ 42 42))))
(scopes (syntax-find (expand-once #'(def-x)) 'x))
(def-x)
(def-x-2)
(define #'(print-blue-x)
(with-purple-identifiers (x)
#'x))
(define #'(define-blue _id _expr)
(with-syntax ([_id (blue-binding-form #'_id)])
#'(define _id _expr)))
(define #'(print-blue-y)
(with-blue-identifiers (y)
#'y))
(scopes (syntax-find (expand-once #'(def-blue-x)) 'x))
(def-blue-x)
(scopes (syntax-find (expand-once #'(print-blue-x)) 'x))
(print-blue-x)
(let ()
(scopes (syntax-find (expand-once #'(print-blue-x)) 'x))
#;(print-blue-x)) ;; error why?
(define-blue y (+ 42 42))
(print-blue-y)
#|
(define #'(def-y)
(with-yellow-binding-form (y)
#'(define y (+ 42))))
#;(scopes (syntax-find (expand-once #'(def-x)) 'x))
#;(def-x)
(def-y)
(scopes (syntax-find (expand-once #'(print-x)) 'x))
(print-x)
(scopes (syntax-find (expand-once #'(print-x-2)) 'x))
(print-x-2)
(scopes (syntax-find (expand-once #'(print-y)) 'y))
(print-y)
#;(let-syntax ([x (λ(stx) (syntax-case stx () [_ #'42]))])
(* x 4))
(* x 4))
|#

17
beautiful-racket-lib/br/syntax.rkt
View File

@ -67,9 +67,9 @@
[else (raise-argument-error 'syntax-find "not given syntax or datum as second argument" stx-or-datum)]))
(let/ec exit
(let loop ([so stx])
(cond
[(eq? (syntax->datum so) datum) (exit so)]
[(syntax->list so) => (curry map loop)]))))
(cond
[(eq? (syntax->datum so) datum) (exit so)]
[(syntax->list so) => (curry map loop)]))))
(define (->syntax x)
@ -85,7 +85,8 @@
[add-id (format-id #'id "add-~a" #'id)]
[flip-id (format-id #'id "flip-~a" #'id)]
[id-binding-form (format-id #'id "~a-binding-form" #'id)]
[with-id-syntax (format-id #'id "with-~a-syntax" #'id)]
[define-id (format-id #'id "define-~a" #'id)]
[with-id-identifiers (format-id #'id "with-~a-identifiers" #'id)]
[let-id-syntax (format-id #'id "let-~a-syntax" #'id)]
[with-id-binding-form (format-id #'id "with-~a-binding-form" #'id)]
[remove-id (format-id #'id "remove-~a" #'id)]
@ -113,10 +114,10 @@
(member (car (context (add-id (datum->syntax #f '_))))
(context (->syntax x)))
#t))
(define-syntax-rule (with-id-syntax ([pat val] (... ...)) . body)
(with-syntax ([pat (id* val)] (... ...)) . body))
(define-syntax-rule (with-id-binding-form ([pat val] (... ...)) . body)
(with-syntax ([pat (id-binding-form val)] (... ...)) . body))
(define-syntax-rule (with-id-identifiers (name (... ...)) . body)
(with-syntax ([name (id* 'name)] (... ...)) . body))
(define-syntax-rule (with-id-binding-form (name (... ...)) . body)
(with-syntax ([name (id-binding-form 'name)] (... ...)) . body))
(define-syntax-rule (let-id-syntax ([pat val] (... ...)) . body)
(let-syntax ([pat (id* val)] (... ...)) . body))))]))