syntax-debug-info: restore all-bindings support

Relevant to #2099

pkgs/racket-test-core/tests/racket/stx.rktl

@@ -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':

racket/src/expander/syntax/binding-table.rkt

@@ -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)

racket/src/expander/syntax/debug.rkt

@@ -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
+        (append
-         [(identifier? s)
+         ;; Bindings based on the identifier `s`
-          (define-values (bindings covered-scopess)
+         (cond
-            (for*/fold ([bindings null] [covered-scope-sets (set)])
+           [(identifier? s)
-                       ([sc (in-set s-scs)]
+            (define-values (bindings covered-scopess)
-                        [(scs b) (in-binding-table sym (scope-binding-table sc) s null)]
+              (for*/fold ([bindings null] [covered-scope-sets (set)])
-                        #:when (and scs b
+                         ([sc (in-set s-scs)]
-                                    (or all-bindings?
+                          [(scs b) (in-binding-table sym (scope-binding-table sc) s null)]
-                                        (subset? scs s-scs))
+                          #:when (and scs b
-                                    ;; Skip overidden:
+                                      (or all-bindings?
-                                    (not (set-member? covered-scope-sets scs))))
+                                          (subset? scs s-scs))
-              (values
+                                      ;; Skip overidden:
-               (cons
+                                      (not (set-member? covered-scope-sets scs))))
-                (hash 'name (syntax-e s)
+                (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)
+                      'match? #f
-                      (if (local-binding? b)
+                      (classify-binding b) (extract-binding b)))]
-                          'local
+           [else null])))
-                          '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]))
       (if (null? bindings)
           context-ht
           (hash-set context-ht 'bindings bindings))))