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

Allow clients of recover-source-syntax to ask for early traversal.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2013-11-11 14:14:05 -05:00 committed by Vincent St-Amour
parent 1e7eb34ba1
commit d1abf632b1
2 changed files with 13 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/errortrace-pkgs/errortrace-lib/errortrace/stacktrace.rkt
View File

@ -82,7 +82,8 @@
;; expanded-stx ;; expanded-stx
(define recover (hash-ref! recover-table (cons (original-stx) (expanded-stx)) (define recover (hash-ref! recover-table (cons (original-stx) (expanded-stx))
(lambda () (lambda ()
(recover-source-syntax (original-stx) (expanded-stx))))) (recover-source-syntax (original-stx) (expanded-stx)
#:traverse-now? #t))))
(define better-stx (and stx (recover stx))) (define better-stx (and stx (recover stx)))
(with-syntax ([quote (syntax-shift-phase-level #'quote phase)]) (with-syntax ([quote (syntax-shift-phase-level #'quote phase)])
#`(quote (#,(short-version better-stx 10) #`(quote (#,(short-version better-stx 10)

36
pkgs/typed-racket-pkgs/source-syntax/source-syntax.rkt
View File

@ -11,31 +11,10 @@
;; -------------------- the real stuff ;; -------------------- the real stuff
;; Look for `lookfor' in `enclosing', return chain of syntaxes from
;; the innermost out of only syntaxes with the given src, returns #f
;; if it can't find it.
(define (enclosing-syntaxes-with-source enclosing lookfor src)
(let loop ([r '()] [stx enclosing])
;(printf "stx is ~a\n" (syntax->datum stx))
;(printf "source is ~a\n" (syntax-source stx))
(let* ([r* (if (and (syntax? stx) (eq? src (syntax-source stx)))
(cons stx r)
r)])
(if (eq? stx lookfor)
r*
(let ([stx (if (syntax? stx) (syntax-e stx) stx)])
(and (pair? stx)
(or (loop r* (car stx)) (loop r* (cdr stx)))))))))
;; Look for (the outermost) syntax in `orig' that has the same ;; Look for (the outermost) syntax in `orig' that has the same
;; location as `lookfor' which is coming from the expanded `orig', ;; location as `lookfor' which is coming from the expanded `orig',
;; given in `expanded'. ;; given in `expanded'.
(define (recover-source-syntax orig expanded) (define (recover-source-syntax orig expanded #:traverse-now? [now? #f])
(define src (syntax-source orig)) (define src (syntax-source orig))
;; this maps source locations that are from orig to their syntax ;; this maps source locations that are from orig to their syntax
@ -55,6 +34,8 @@
(hash-ref syntax-locs (syntax-loc expanded) #f)) (hash-ref syntax-locs (syntax-loc expanded) #f))
;; this searches for lookfor in orig, building up the table as we go ;; this searches for lookfor in orig, building up the table as we go
;; add-to-table: stx or #f -> stx or #f
;; #f as `lookfor` indicates "traverse all of `expanded`
(define (add-to-table lookfor) (define (add-to-table lookfor)
(let loop ([stx expanded] [target initial-target]) (let loop ([stx expanded] [target initial-target])
(cond (cond
@ -68,7 +49,7 @@
(hash-ref! parent-table stx new-target) (hash-ref! parent-table stx new-target)
(cond (cond
;; if we got what we came for, stop ;; if we got what we came for, stop
[(eq? stx lookfor) new-target] [(and lookfor (eq? stx lookfor)) new-target]
;; take apart stx and loop on the components ;; take apart stx and loop on the components
[else [else
@ -77,11 +58,16 @@
(or (loop (car stxe) stx) (loop (cdr stxe) stx)))])] (or (loop (car stxe) stx) (loop (cdr stxe) stx)))])]
[else #f]))) [else #f])))
;; if now?, add everything to the table
(when now?
(add-to-table #f))
(lambda (lookfor) (lambda (lookfor)
(or (or
;; we just might get a lookfor that is already in the original ;; we just might get a lookfor that is already in the original
(and (eq? src (syntax-source lookfor)) (and (eq? src (syntax-source lookfor))
(hash-ref syntax-locs (syntax-loc lookfor) #f)) (hash-ref syntax-locs (syntax-loc lookfor) #f))
(hash-ref parent-table lookfor (λ () (hash-ref parent-table lookfor (λ ()
(add-to-table lookfor) (cond [now? #f]
(hash-ref parent-table lookfor #f)))))) [else (add-to-table lookfor)
(hash-ref parent-table lookfor #f)]))))))