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

Removed naming of use-site scope, as it is handled specially by definition contexts.

Browse Source
This commit is contained in:
Georges Dupéron 2016-12-14 18:08:42 +01:00
parent 2c8423ac16
commit 61d4a48d38
2 changed files with 8 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
named-scopes/exptime.rkt
View File

@ -10,11 +10,6 @@
named-transformer named-transformer
(rename-out [-syntax-local-introduce syntax-local-introduce])) (rename-out [-syntax-local-introduce syntax-local-introduce]))
(define (use-site-context?)
(not (bound-identifier=? (syntax-local-introduce #'here)
(syntax-local-identifier-as-binding
(syntax-local-introduce #'here)))))
(define (make-named-scope nm) (define (make-named-scope nm)
(define name (if (symbol? nm) nm (string->symbol nm))) (define name (if (symbol? nm) nm (string->symbol nm)))
(define E1 (define E1
@ -82,52 +77,24 @@
(datum->syntax #f 'zero))) (datum->syntax #f 'zero)))
(datum->syntax #f 'zero))) (datum->syntax #f 'zero)))
(define (old-use-site-scope)
(make-syntax-delta-introducer
((old-macro-scope) (syntax-local-introduce (datum->syntax #f 'zero)) 'remove)
(datum->syntax #f 'zero)))
(define (convert-macro-scopes stx) (define (convert-macro-scopes stx)
(if (sli-scopes) (if (sli-scopes)
(let* ([macro (car (sli-scopes))] (let* ([macro (sli-scopes)]
[use-site (cdr (sli-scopes))] [old-macro (old-macro-scope)])
[old-macro (old-macro-scope)] ((replace-scope old-macro macro) stx))
[old-use (old-use-site-scope)])
((compose (if (use-site-context?)
(replace-scope old-use use-site)
(λ (x) x))
(replace-scope old-macro macro))
stx))
;; Otherwise leave unchanged. ;; Otherwise leave unchanged.
stx)) stx))
(define ((named-transformer-wrap name f) stx) (define ((named-transformer-wrap name f) stx)
(parameterize ([sli-scopes (parameterize ([sli-scopes (make-named-scope (format "macro: ~a" name))])
(cons (make-named-scope (format "macro: ~a" name))
(if (use-site-context?)
(make-named-scope (format "use-site: ~a" name))
(make-syntax-delta-introducer
(datum->syntax #f 'zero)
(datum->syntax #f 'zero))))])
;;; TODO: we should detect the presence of old-* here instead, and 'add them ;;; TODO: we should detect the presence of old-* here instead, and 'add them
(displayln (+scopes stx))
(displayln (use-site-context?))
(displayln (+scopes (convert-macro-scopes stx)))
(let ([res (f (convert-macro-scopes stx))]) (let ([res (f (convert-macro-scopes stx))])
(when ((deep-has-scope (old-macro-scope)) res) (when ((deep-has-scope (old-macro-scope)) res)
(error (format "original macro scope appeared within the result of a named transformer: ~a\n~a\n~a" (error (format "original macro scope appeared within the result of a named transformer: ~a\n~a\n~a"
res res
(+scopes res) (+scopes res)
(with-output-to-string (λ () (print-full-scopes)))))) (with-output-to-string (λ () (print-full-scopes))))))
(when (and (use-site-context?) ((old-macro-scope) ((sli-scopes) res 'flip) 'add))))
((deep-has-scope (old-use-site-scope)) res))
(error "original use-site scope appeared within the result of a named transformer"))
(let* ([/mm ((car (sli-scopes)) res 'flip)]
[/mm/uu (if (use-site-context?) ((cdr (sli-scopes)) /mm 'flip) /mm)]
[/mm/uu+m ((old-macro-scope) /mm/uu 'add)])
(if (use-site-context?)
((old-use-site-scope) /mm/uu+m 'add)
/mm/uu+m)))))
(define-syntax-rule (named-transformer (name stx) . body) (define-syntax-rule (named-transformer (name stx) . body)
(named-transformer-wrap 'name (λ (stx) . body))) (named-transformer-wrap 'name (λ (stx) . body)))
@ -136,11 +103,5 @@
(define (-syntax-local-introduce stx) (define (-syntax-local-introduce stx)
(if (sli-scopes) (if (sli-scopes)
((cdr (sli-scopes)) ((car (sli-scopes)) stx 'flip) ((sli-scopes) stx 'flip)
'flip)
(syntax-local-introduce stx)))
(define (-syntax-local-identifier-as-binding stx)
(if (and (sli-scopes) (use-site-context?))
((cdr (sli-scopes)) stx 'flip)
(syntax-local-introduce stx))) (syntax-local-introduce stx)))

19
test/named-scopes-test-use.rkt
View File

@ -1,12 +1,8 @@
#lang racket #lang racket
(require ;"named-scopes-test-def.rkt" (require "named-scopes-test-def.rkt"
rackunit rackunit)
(for-syntax type-expander/debug-scopes
;debug-scopes/named-scopes
))
#|
(define r1 (foo-macro +)) (define r1 (foo-macro +))
(define r2 (let ([x 2]) (define r2 (let ([x 2])
(bar-macro x))) (bar-macro x)))
@ -19,14 +15,3 @@
(quux))) (quux)))
(check-equal? (list r1 r2 r3 r4) (list + 2 3 +)) (check-equal? (list r1 r2 r3 r4) (list + 2 3 +))
|#
(define-syntax (quux stx)
(syntax-case stx ()
[(_ m)
(let ()
(displayln (+scopes #'m))
(displayln (+scopes (syntax-local-introduce #'+)))
(print-full-scopes)
(syntax-local-introduce #'+))]))
(quux -)