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

Added uses of internal-definition-context-apply from unstable/syntax

Browse Source
This commit is contained in:
Ryan Culpepper 2010-07-01 21:29:42 -06:00
parent 07f57aac9b
commit 79a06deb79
4 changed files with 10 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/mzlib/private/sigutil.rkt
View File

@ -602,6 +602,7 @@
(syntax-e (stx-car (stx-cdr p))))) (syntax-e (stx-car (stx-cdr p)))))
(cdr (stx->list (cdr (stx->list
(let ([rn (car body)]) (let ([rn (car body)])
;; Use internal-definition-context-apply ??
(local-expand rn (local-expand rn
'expression 'expression
(list (stx-car rn)) (list (stx-car rn))

8
collects/mzlib/unit200.rkt
View File

@ -6,6 +6,7 @@
syntax/stx syntax/stx
syntax/name syntax/name
syntax/context syntax/context
unstable/syntax
"list.rkt" "list.rkt"
"private/unitidmap.rkt") "private/unitidmap.rkt")
@ -73,11 +74,8 @@
(begin (begin
;; Treat imports as internal-defn names: ;; Treat imports as internal-defn names:
(syntax-local-bind-syntaxes ids #f def-ctx) (syntax-local-bind-syntaxes ids #f def-ctx)
(cdr (syntax->list (syntax->list
(local-expand #`(stop #,@ids) (internal-definition-context-apply def-ctx ids)))
'expression
(list #'stop)
def-ctx))))
ids) ids)
;; Let later checking report an error: ;; Let later checking report an error:
ids))]) ids))])

11
collects/racket/contract/regions.rkt
View File

@ -562,9 +562,7 @@
(values (syntax->list #'(fv.var ...)) (values (syntax->list #'(fv.var ...))
(syntax->list #'(fv.ctc ...)))]) (syntax->list #'(fv.ctc ...)))])
(define (add-context stx) (define (add-context stx)
(let ([ctx-added-stx (local-expand #`(quote #,stx) ctx (list #'quote) intdef)]) (internal-definition-context-apply intdef stx))
(syntax-case ctx-added-stx ()
[(_ expr) #'expr])))
(syntax-local-bind-syntaxes free-vars #f intdef) (syntax-local-bind-syntaxes free-vars #f intdef)
(internal-definition-context-seal intdef) (internal-definition-context-seal intdef)
(with-syntax ([blame-stx #''(region blame)] (with-syntax ([blame-stx #''(region blame)]
@ -621,12 +619,7 @@
(values (syntax->list #'(ec.var ...)) (values (syntax->list #'(ec.var ...))
(syntax->list #'(ec.ctc ...)))]) (syntax->list #'(ec.ctc ...)))])
(define (add-context stx) (define (add-context stx)
(let ([ctx-added-stx (local-expand #`(quote #,stx) (internal-definition-context-apply intdef stx))
ctx
(list #'quote)
intdef)])
(syntax-case ctx-added-stx ()
[(_ expr) #'expr])))
(syntax-local-bind-syntaxes protected #f intdef) (syntax-local-bind-syntaxes protected #f intdef)
(syntax-local-bind-syntaxes free-vars #f intdef) (syntax-local-bind-syntaxes free-vars #f intdef)
(internal-definition-context-seal intdef) (internal-definition-context-seal intdef)

17
collects/racket/splicing.rkt
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require (for-syntax scheme/base (require (for-syntax scheme/base
syntax/kerncase) syntax/kerncase
unstable/syntax)
"stxparam.rkt" "stxparam.rkt"
"private/stxparam.rkt" "private/stxparam.rkt"
"private/local.rkt") "private/local.rkt")
@ -56,12 +57,7 @@
(internal-definition-context-seal def-ctx) (internal-definition-context-seal def-ctx)
(let* ([add-context (let* ([add-context
(lambda (expr) (lambda (expr)
(let ([q (local-expand #`(quote #,expr) (internal-definition-context-apply def-ctx expr))])
ctx
(list #'quote)
def-ctx)])
(syntax-case q ()
[(_ expr) #'expr])))])
(with-syntax ([((id ...) ...) (with-syntax ([((id ...) ...)
(map (lambda (ids) (map (lambda (ids)
(map add-context ids)) (map add-context ids))
@ -129,12 +125,7 @@
(internal-definition-context-seal def-ctx) (internal-definition-context-seal def-ctx)
(let* ([add-context (let* ([add-context
(lambda (expr) (lambda (expr)
(let ([q (local-expand #`(quote #,expr) (internal-definition-context-apply def-ctx expr))]
ctx
(list #'quote)
def-ctx)])
(syntax-case q ()
[(_ expr) #'expr])))]
[add-context-to-idss [add-context-to-idss
(lambda (idss) (lambda (idss)
(map add-context idss))]) (map add-context idss))])