[plt-scheme] Detecting cycles when traversing through shared graph syntax objects?
Hi everyone,
I've been recently trying to understand how people deal with graphs in
syntax objects. One example of this is:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module test-evil mzscheme
(require (lib "stx.ss" "syntax")
(lib "list.ss"))
(define nice-syntax-object (syntax (hello (world))))
;; The syntax object representing an infinite series of ones.
(define evil-syntax-object
(read-syntax
#f
(open-input-string "#0=(1 . #0#)")))
;; Go through syntax, return list of all identifiers we see, free or
;; bound.
(define (find-identifiers-broken stx)
(let ([seen-stxs (make-hash-table)])
(let loop ([stx stx])
(cond [(hash-table-get seen-stxs stx (lambda () #f))
empty]
[else
(hash-table-put! seen-stxs stx #t)
(syntax-case stx ()
[_ (identifier? stx)
(list stx)]
[(x y ...)
(append (loop #'x)
(loop #'(y ...)))]
[else empty])])))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Trying to evaluate find-identifiers-broken on evil-syntax-object is an
infinite loop. I naively thought that keeping some hash-table to traverse
the structure would allow me to avoid cycles, but unfortunately, nope.
My question is: how do people handle this?
(This actually seems like a problem for other things like the DrScheme
repl, which doesn't appear to capture the cycles either when it tries to
display the evil-syntax-object.)
I see that Help Desk's documentation on syntax-graph? recommends using
syntax-object->datum to detect cycles, so I suppose I could do some kind
of parallel traversal of the syntax object and its datum partner.
Ah. This appears to do the trick:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (find-identifiers stx)
(let ([seen-data (make-hash-table)])
;; subtle: we can't reliably do eq? on syntax to detect sharing,
;; but we CAN do it on the syntax-object->datum-ed value. So
;; we keep both, and do a parallel traversal.
(let loop ([stx stx]
[datum (syntax-object->datum stx)])
(cond [(hash-table-get seen-data datum (lambda () #f))
empty]
[else
(hash-table-put! seen-data datum #t)
(cond
[(identifier? stx)
(list stx)]
[(stx-pair? stx)
(append (loop (stx-car stx)
(car datum))
(loop (stx-cdr stx)
(cdr datum)))]
[else empty])]))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Am I understanding the situation properly?
Thanks in advance!