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

syntax-debug-info: restore all-bindings support

Browse Source 
Relevant to #2099
This commit is contained in:
Matthew Flatt 2018-05-26 10:31:36 -06:00
parent 87a5ee4cc1
commit ec2387fa16
4 changed files with 7927 additions and 7675 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/racket-test-core/tests/racket/stx.rktl
View File

@ -2006,6 +2006,12 @@
(eval '(require (prefix-in foo: racket/base)))
(check (lambda (stx) (syntax-debug-info (namespace-syntax-introduce stx))))))
(test #t
'syntax-debug-info-all-binding
(let ([y 10])
(for/or ([e (in-list (hash-ref (syntax-debug-info (quote-syntax x #:local) 0 #t) 'bindings null))])
(eq? 'y (hash-ref e 'name #f)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that attacks are thwarted via `syntax-local-get-shadower'
;; or `make-syntax-delta-introducer':

54
racket/src/expander/syntax/binding-table.rkt
View File

@ -25,6 +25,7 @@
binding-table-empty?
in-binding-table
in-full-non-bulk-binding-table
binding-table-symbols
@ -191,7 +192,7 @@
;; the syntax object and extra shifts expressions may be used for
;; loading bulk bindings.
(define-sequence-syntax in-binding-table
(lambda () #'do-not-use-in-binding-as-an-expression)
(lambda () #'do-not-use-in-binding-table-as-an-expression)
(lambda (stx)
(syntax-case stx ()
[[(scopes-id binding-id) (_ sym table-expr s-expr extra-shifts-expr)]
@ -239,6 +240,57 @@
;; ----------------------------------------
;; Iterate through all non-bulk symbol+scope+binding combinations.
;; This iterator allocates; its intended for use in situations
;; that don't need a tight loop, which should generally be the
;; case for somethign that's inspecting all bindings.
(define-sequence-syntax in-full-non-bulk-binding-table
(lambda () #'do-not-use-in-full-non-bulk-binding-table-as-an-expression)
(lambda (stx)
(syntax-case stx ()
[[(sym-id scopes-id binding-id) (_ table-expr)]
#'[(scopes-id binding-id)
(:do-in
([(sym-ht)
(let ([table table-expr])
(if (hash? table)
table
(table-with-bulk-bindings-syms table)))])
#t
([state (let loop ([sym-i (hash-iterate-first sym-ht)])
(if sym-i
(next-state-in-full-binding-table sym-ht sym-i)
'(#f . #f)))])
(car state)
;; At each step, extract the current scope set and binding;
;; either can be #f, in which case the consumer of the
;; sequence should move on the the next result
([(sym-id) (vector-ref (car state) 1)]
[(scopes-id) (hash-iterate-key (vector-ref (car state) 2) (cdr state))]
[(binding-id) (hash-iterate-value (vector-ref (car state) 2) (cdr state))])
#t
#t
[(let* ([ht (vector-ref (car state) 2)]
[i (hash-iterate-next ht (cdr state))])
(if i
(cons (car state) i)
(next-state-in-full-binding-table sym-ht
(hash-iterate-next sym-ht (vector-ref (car state) 0)))))])]])))
(define (next-state-in-full-binding-table sym-ht sym-i)
(if sym-i
(let* ([ht (hash-iterate-value sym-ht sym-i)]
[i (hash-iterate-first ht)])
(if i
(cons (vector sym-i
(hash-iterate-key sym-ht sym-i) ; symbol
ht)
i)
(next-state-in-full-binding-table (hash-iterate-next sym-ht sym-i))))
'(#f . #f)))
;; ----------------------------------------
;; Return a set of symbols that have bindings for a given scope set
(define (binding-table-symbols table scs s extra-shifts)
(define-values (ht bulk-bindings)

70
racket/src/expander/syntax/debug.rkt
View File

@ -20,35 +20,51 @@
(define context (scope-set->context s-scs))
(define context-ht (hash-set init-ht 'context context))
(define sym (syntax-e s))
(define (classify-binding b)
(if (local-binding? b)
'local
'module))
(define (extract-binding b)
(if (local-binding? b)
(local-binding-key b)
(vector (module-binding-sym b)
(module-binding-module b)
(module-binding-phase b))))
(define bindings
(cond
[(identifier? s)
(define-values (bindings covered-scopess)
(for*/fold ([bindings null] [covered-scope-sets (set)])
([sc (in-set s-scs)]
[(scs b) (in-binding-table sym (scope-binding-table sc) s null)]
#:when (and scs b
(or all-bindings?
(subset? scs s-scs))
;; Skip overidden:
(not (set-member? covered-scope-sets scs))))
(values
(cons
(hash 'name (syntax-e s)
(append
;; Bindings based on the identifier `s`
(cond
[(identifier? s)
(define-values (bindings covered-scopess)
(for*/fold ([bindings null] [covered-scope-sets (set)])
([sc (in-set s-scs)]
[(scs b) (in-binding-table sym (scope-binding-table sc) s null)]
#:when (and scs b
(or all-bindings?
(subset? scs s-scs))
;; Skip overidden:
(not (set-member? covered-scope-sets scs))))
(values
(cons
(hasheq 'name (syntax-e s)
'context (scope-set->context scs)
'match? (subset? scs s-scs)
(classify-binding b) (extract-binding b))
bindings)
(set-add covered-scope-sets scs))))
bindings]
[else null])
;; All other bindings (but not other bulk bindings, currently)
(cond
[all-bindings?
(for*/list ([sc (in-set s-scs)]
[(o-sym scs b) (in-full-non-bulk-binding-table (scope-binding-table sc))]
#:unless (eq? o-sym sym))
(hasheq 'name o-sym
'context (scope-set->context scs)
'match? (subset? scs s-scs)
(if (local-binding? b)
'local
'module)
(if (local-binding? b)
(local-binding-key b)
(vector (module-binding-sym b)
(module-binding-module b)
(module-binding-phase b))))
bindings)
(set-add covered-scope-sets scs))))
bindings]
[else null]))
'match? #f
(classify-binding b) (extract-binding b)))]
[else null])))
(if (null? bindings)
context-ht
(hash-set context-ht 'bindings bindings))))

15472
racket/src/racket/src/startup.inc
View File

File diff suppressed because it is too large Load Diff