improved handling of source locations
svn: r15132
This commit is contained in:
Robby Findler
parent
3b401288f7
commit
1450b89b75
|
|
@ -92,6 +92,7 @@
|
|||
(render-metafunction Name))
|
||||
"metafunction-Name-vertical.png")
|
||||
|
||||
|
||||
;; makes sure that there is no overlap inside or across metafunction calls
|
||||
;; or when there are unquotes involved
|
||||
(define-metafunction lang
|
||||
|
|
|
|||
|
|
@ -457,7 +457,12 @@
|
|||
(set! current-line line)
|
||||
(set! current-column col))]
|
||||
[else
|
||||
(error 'eject "lines going backwards")])
|
||||
(error 'eject
|
||||
"lines going backwards (current-line ~s line ~s atom ~s tokens ~s)"
|
||||
current-line
|
||||
line
|
||||
atom
|
||||
tokens)])
|
||||
(when (< current-column col)
|
||||
(let ([space-span (- col current-column)])
|
||||
(set! tokens (cons (make-blank-space-token unquoted?
|
||||
|
|
|
|||
96
collects/redex/private/loc-wrapper-ct.ss
Normal file
96
collects/redex/private/loc-wrapper-ct.ss
Normal file
|
|
@ -0,0 +1,96 @@
|
|||
#lang scheme/base
|
||||
(require (for-template scheme/base)
|
||||
(for-template "loc-wrapper-rt.ss")
|
||||
"term-fn.ss")
|
||||
(provide to-lw/proc to-lw/uq/proc)
|
||||
|
||||
(define (process-arg stx quote-depth)
|
||||
(define quoted? (quote-depth . > . 0))
|
||||
(define-values (op cl)
|
||||
(if (syntax? stx)
|
||||
(case (syntax-property stx 'paren-shape)
|
||||
[(#\{) (values "{" "}")]
|
||||
[(#\[) (values "[" "]")]
|
||||
[else (values "(" ")")])
|
||||
(values #f #f)))
|
||||
(define (reader-shorthand arg qd-delta mrk)
|
||||
#`(init-loc-wrapper
|
||||
(list (init-loc-wrapper #,mrk
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)
|
||||
'spring
|
||||
#,(process-arg arg (+ quote-depth qd-delta)))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?))
|
||||
(define (handle-sequence qd-delta)
|
||||
#`(init-loc-wrapper
|
||||
(list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
|
||||
#,@(map (λ (x) (process-arg x (+ qd-delta quote-depth))) (syntax->list stx))
|
||||
(init-loc-wrapper #,cl #f #f #,quoted?))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?))
|
||||
(syntax-case* stx (name unquote quote unquote-splicing term) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
['a (reader-shorthand #'a +1 (if (= quote-depth 0) "" "'"))]
|
||||
[,a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ","))]
|
||||
[,@a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ",@"))]
|
||||
[(term a)
|
||||
(if (= quote-depth 0)
|
||||
#`(init-loc-wrapper
|
||||
(list (init-loc-wrapper "" #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
|
||||
'spring
|
||||
#,(process-arg (cadr (syntax->list stx)) (+ quote-depth 1)))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)
|
||||
(handle-sequence +1))]
|
||||
[(a ...)
|
||||
(handle-sequence 0)]
|
||||
[(a b ... . c)
|
||||
#`(init-loc-wrapper
|
||||
(list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
|
||||
#,@(map (λ (x) (process-arg x quote-depth)) (syntax->list (syntax (a b ...))))
|
||||
(init-loc-wrapper #," . " #f #f #,quoted?)
|
||||
#,(process-arg #'c quote-depth)
|
||||
(init-loc-wrapper #,cl #f #f #,quoted?))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)]
|
||||
[x
|
||||
(and (identifier? #'x)
|
||||
(term-fn? (syntax-local-value #'x (λ () #f))))
|
||||
#`(make-lw
|
||||
'#,(syntax-e #'x)
|
||||
#,(syntax-line stx)
|
||||
#f
|
||||
#,(syntax-column stx)
|
||||
#f
|
||||
#f
|
||||
#t)]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
#`(init-loc-wrapper
|
||||
'#,(syntax-e #'x)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)]
|
||||
[x
|
||||
#`(init-loc-wrapper
|
||||
#,(let ([base (syntax-e #'x)])
|
||||
(if (string? base)
|
||||
#`(rewrite-quotes #,(format "~s" base))
|
||||
(format "~s" (syntax-e #'x))))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)]))
|
||||
|
||||
(define (to-lw/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stx)
|
||||
#`(add-spans #,(process-arg #'stx 1))]))
|
||||
(define (to-lw/uq/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stx)
|
||||
#`(add-spans #,(process-arg #'stx 0))]))
|
||||
96
collects/redex/private/loc-wrapper-rt.ss
Normal file
96
collects/redex/private/loc-wrapper-rt.ss
Normal file
|
|
@ -0,0 +1,96 @@
|
|||
#lang scheme/base
|
||||
|
||||
;; this is the runtime code for loc-wrapper-ct.ss.
|
||||
;; it isn't really its own module, but separated
|
||||
;; out in order to get the phases right.
|
||||
(provide (all-defined-out))
|
||||
|
||||
(require (lib "etc.ss")
|
||||
"term.ss")
|
||||
|
||||
(define (init-loc-wrapper e line column quoted?)
|
||||
(make-lw e line #f column #f (not quoted?) #f))
|
||||
|
||||
;; lw = (union 'spring loc-wrapper)
|
||||
|
||||
;; e : (union string symbol #f (listof lw))
|
||||
;; line, line-span, column, column-span : number
|
||||
(define-struct lw (e line line-span column column-span unq? metafunction?)
|
||||
#:mutable
|
||||
#:inspector (make-inspector))
|
||||
|
||||
;; build-lw is designed for external consumption
|
||||
(define (build-lw e line line-span column column-span)
|
||||
(make-lw e line line-span column column-span #f #f))
|
||||
|
||||
(define curly-quotes-for-strings (make-parameter #t))
|
||||
|
||||
(define (rewrite-quotes s)
|
||||
(if (curly-quotes-for-strings)
|
||||
(string-append "“"
|
||||
(substring s 1 (- (string-length s) 1))
|
||||
"”")
|
||||
s))
|
||||
|
||||
|
||||
(define (add-spans lw)
|
||||
(define line-seen-so-far 0)
|
||||
|
||||
(define (add-spans/lw lw line col)
|
||||
(cond
|
||||
[(eq? lw 'spring) (values line col col)]
|
||||
[else
|
||||
(let ([start-line (or (lw-line lw) line line-seen-so-far)]
|
||||
[start-column (or (lw-column lw) col 0)])
|
||||
(set! line-seen-so-far (max line-seen-so-far start-line))
|
||||
(unless (lw-line lw) (set-lw-line! lw line-seen-so-far))
|
||||
(unless (lw-column lw) (set-lw-column! lw start-column))
|
||||
(let-values ([(last-line first-column last-column)
|
||||
(add-spans/obj (lw-e lw) start-line start-column)])
|
||||
(set-lw-line-span! lw (- last-line start-line))
|
||||
(let ([new-col (min/f (lw-column lw)
|
||||
first-column)])
|
||||
(set-lw-column! lw new-col)
|
||||
(set-lw-column-span! lw (- last-column new-col)))
|
||||
(values last-line first-column last-column)))]))
|
||||
(define (add-spans/obj e line col)
|
||||
(cond
|
||||
[(string? e)
|
||||
(values line col (+ col (string-length e)))]
|
||||
[(symbol? e)
|
||||
(values line col (+ col (string-length (symbol->string e))))]
|
||||
[(not e) (values line col col)]
|
||||
[else
|
||||
(let loop ([lws e]
|
||||
[line line]
|
||||
[first-column col]
|
||||
[last-column col]
|
||||
[current-col col])
|
||||
(cond
|
||||
[(null? lws) (values line first-column last-column)]
|
||||
[else
|
||||
(let-values ([(last-line inner-first-column inner-last-column)
|
||||
(add-spans/lw (car lws) line current-col)])
|
||||
(if (= last-line line)
|
||||
(loop (cdr lws)
|
||||
last-line
|
||||
(min inner-first-column first-column)
|
||||
(max inner-last-column last-column)
|
||||
inner-last-column)
|
||||
(loop (cdr lws)
|
||||
last-line
|
||||
(min inner-first-column first-column)
|
||||
inner-last-column
|
||||
inner-last-column)))]))]))
|
||||
|
||||
(add-spans/lw lw #f #f)
|
||||
lw)
|
||||
|
||||
(define (min/f a b)
|
||||
(cond
|
||||
[(and a b) (min a b)]
|
||||
[a a]
|
||||
[b b]
|
||||
[else 0]))
|
||||
|
||||
|
||||
|
|
@ -1,181 +1,12 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (lib "etc.ss")
|
||||
"term.ss"
|
||||
scheme/contract)
|
||||
(require (for-syntax "term-fn.ss" scheme/base))
|
||||
(require scheme/contract
|
||||
(for-syntax scheme/base)
|
||||
(for-syntax "loc-wrapper-ct.ss")
|
||||
"loc-wrapper-rt.ss")
|
||||
|
||||
(define (init-loc-wrapper e line column quoted?)
|
||||
(make-lw e line #f column #f (not quoted?) #f))
|
||||
|
||||
;; lw = (union 'spring loc-wrapper)
|
||||
|
||||
;; e : (union string symbol #f (listof lw))
|
||||
;; line, line-span, column, column-span : number
|
||||
(define-struct lw (e line line-span column column-span unq? metafunction?)
|
||||
#:mutable
|
||||
#:inspector (make-inspector))
|
||||
|
||||
;; build-lw is designed for external consumption
|
||||
(define (build-lw e line line-span column column-span)
|
||||
(make-lw e line line-span column column-span #f #f))
|
||||
|
||||
(define curly-quotes-for-strings (make-parameter #t))
|
||||
|
||||
(define (rewrite-quotes s)
|
||||
(if (curly-quotes-for-strings)
|
||||
(string-append "“"
|
||||
(substring s 1 (- (string-length s) 1))
|
||||
"”")
|
||||
s))
|
||||
|
||||
(define-syntax-set (to-lw to-lw/uq)
|
||||
(define (process-arg stx quote-depth)
|
||||
(define quoted? (quote-depth . > . 0))
|
||||
(define-values (op cl)
|
||||
(if (syntax? stx)
|
||||
(case (syntax-property stx 'paren-shape)
|
||||
[(#\{) (values "{" "}")]
|
||||
[(#\[) (values "[" "]")]
|
||||
[else (values "(" ")")])
|
||||
(values #f #f)))
|
||||
(define (reader-shorthand arg qd-delta mrk)
|
||||
#`(init-loc-wrapper
|
||||
(list (init-loc-wrapper #,mrk
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)
|
||||
'spring
|
||||
#,(process-arg arg (+ quote-depth qd-delta)))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?))
|
||||
(define (handle-sequence qd-delta)
|
||||
#`(init-loc-wrapper
|
||||
(list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
|
||||
#,@(map (λ (x) (process-arg x (+ qd-delta quote-depth))) (syntax->list stx))
|
||||
(init-loc-wrapper #,cl #f #f #,quoted?))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?))
|
||||
(syntax-case* stx (name unquote quote unquote-splicing term) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
['a (reader-shorthand #'a +1 (if (= quote-depth 0) "" "'"))]
|
||||
[,a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ","))]
|
||||
[,@a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ",@"))]
|
||||
[(term a)
|
||||
(if (= quote-depth 0)
|
||||
#`(init-loc-wrapper
|
||||
(list (init-loc-wrapper "" #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
|
||||
'spring
|
||||
#,(process-arg (cadr (syntax->list stx)) (+ quote-depth 1)))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)
|
||||
(handle-sequence +1))]
|
||||
[(a ...)
|
||||
(handle-sequence 0)]
|
||||
[(a b ... . c)
|
||||
#`(init-loc-wrapper
|
||||
(list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
|
||||
#,@(map (λ (x) (process-arg x quote-depth)) (syntax->list (syntax (a b ...))))
|
||||
(init-loc-wrapper #," . " #f #f #,quoted?)
|
||||
#,(process-arg #'c quote-depth)
|
||||
(init-loc-wrapper #,cl #f #f #,quoted?))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)]
|
||||
[x
|
||||
(and (identifier? #'x)
|
||||
(term-fn? (syntax-local-value #'x (λ () #f))))
|
||||
#`(make-lw
|
||||
'#,(syntax-e #'x)
|
||||
#,(syntax-line stx)
|
||||
#f
|
||||
#,(syntax-column stx)
|
||||
#f
|
||||
#f
|
||||
#t)]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
#`(init-loc-wrapper
|
||||
'#,(syntax-e #'x)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)]
|
||||
[x
|
||||
#`(init-loc-wrapper
|
||||
#,(let ([base (syntax-e #'x)])
|
||||
(if (string? base)
|
||||
#`(rewrite-quotes #,(format "~s" base))
|
||||
(format "~s" (syntax-e #'x))))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)]))
|
||||
|
||||
(define (to-lw/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stx)
|
||||
#`(add-spans #,(process-arg #'stx 1))]))
|
||||
(define (to-lw/uq/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stx)
|
||||
#`(add-spans #,(process-arg #'stx 0))])))
|
||||
|
||||
(define (add-spans lw)
|
||||
(define (add-spans/lw lw line col)
|
||||
(cond
|
||||
[(eq? lw 'spring) (values line col col)]
|
||||
[else
|
||||
(let ([start-line (or (lw-line lw) line)]
|
||||
[start-column (or (lw-column lw) col)])
|
||||
(when (and start-line ;; if we don't have src loc info, just give up.
|
||||
start-column)
|
||||
(let-values ([(last-line first-column last-column)
|
||||
(add-spans/obj (lw-e lw) start-line start-column)])
|
||||
(unless (lw-line lw)
|
||||
(set-lw-line! lw line))
|
||||
(set-lw-line-span! lw (- last-line start-line))
|
||||
|
||||
(unless (lw-column lw)
|
||||
(set-lw-column! lw col))
|
||||
(let ([new-col (min (lw-column lw)
|
||||
first-column)])
|
||||
(set-lw-column! lw new-col)
|
||||
(set-lw-column-span! lw (- last-column new-col)))
|
||||
|
||||
(values last-line first-column last-column))))]))
|
||||
(define (add-spans/obj e line col)
|
||||
(cond
|
||||
[(string? e)
|
||||
(values line col (+ col (string-length e)))]
|
||||
[(symbol? e)
|
||||
(values line col (+ col (string-length (symbol->string e))))]
|
||||
[(not e) (values line col col)]
|
||||
[else
|
||||
(let loop ([lws e]
|
||||
[line line]
|
||||
[first-column col]
|
||||
[last-column col]
|
||||
[current-col col])
|
||||
(cond
|
||||
[(null? lws) (values line first-column last-column)]
|
||||
[else
|
||||
(let-values ([(last-line inner-first-column inner-last-column)
|
||||
(add-spans/lw (car lws) line current-col)])
|
||||
(if (= last-line line)
|
||||
(loop (cdr lws)
|
||||
last-line
|
||||
(min inner-first-column first-column)
|
||||
(max inner-last-column last-column)
|
||||
inner-last-column)
|
||||
(loop (cdr lws)
|
||||
last-line
|
||||
(min inner-first-column first-column)
|
||||
inner-last-column
|
||||
inner-last-column)))]))]))
|
||||
|
||||
(add-spans/lw lw #f #f)
|
||||
lw)
|
||||
(define-syntax (to-lw stx) (to-lw/proc stx))
|
||||
(define-syntax (to-lw/uq stx) (to-lw/uq/proc stx))
|
||||
|
||||
(define pnum (and/c number? (or/c zero? positive?)))
|
||||
|
||||
|
|
|
|||
|
|
@ -580,9 +580,10 @@
|
|||
[column (+ (lw-column fst)
|
||||
(lw-column-span fst))]
|
||||
[column-span
|
||||
(- (lw-column snd)
|
||||
(max (- (lw-column snd)
|
||||
(+ (lw-column fst)
|
||||
(lw-column-span fst)))])
|
||||
(lw-column-span fst)))
|
||||
0)])
|
||||
(build-lw (make-bar) line line-span column column-span))]
|
||||
[else
|
||||
(build-lw
|
||||
|
|
|
|||
|
|
@ -20,6 +20,46 @@
|
|||
(define (language-nts lang)
|
||||
(hash-map (compiled-lang-ht lang) (λ (x y) x)))
|
||||
|
||||
#;
|
||||
(define-for-syntax (prune-syntax stx)
|
||||
(datum->syntax
|
||||
(identifier-prune-lexical-context #'whatever '())
|
||||
(let loop ([stx stx])
|
||||
(syntax-case stx (quote)
|
||||
[(quote x) (list (quote-syntax/prune quote)
|
||||
(syntax->datum #'x))]
|
||||
[x
|
||||
(cond
|
||||
[(identifier? stx) (identifier-prune-lexical-context stx)]
|
||||
[(syntax? stx)
|
||||
(datum->syntax (identifier-prune-lexical-context
|
||||
#'whatever
|
||||
'(#%app))
|
||||
(syntax-e stx)
|
||||
stx)]
|
||||
[(pair? stx)
|
||||
(cons (loop (car stx))
|
||||
(loop (cdr stx)))]
|
||||
[else stx])]))))
|
||||
|
||||
(define-for-syntax (prune-syntax stx)
|
||||
stx
|
||||
|
||||
#;
|
||||
(datum->syntax
|
||||
(identifier-prune-lexical-context #'whatever '(#%app #%datum))
|
||||
(let loop ([stx stx])
|
||||
(syntax-case stx (quote)
|
||||
[(quote x) (list (quote-syntax/prune quote)
|
||||
(syntax->datum #'x))]
|
||||
[(a . b) (cons (loop #'a) (loop #'b))]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
(datum->syntax (identifier-prune-lexical-context #'x)
|
||||
(syntax-e #'x))]
|
||||
[() '()]
|
||||
[_ (syntax->datum stx)]))))
|
||||
|
||||
(define-syntax (term-match/single stx)
|
||||
(syntax-case stx ()
|
||||
[(_ lang [pattern rhs] ...)
|
||||
|
|
@ -243,6 +283,7 @@
|
|||
(syntax-case stx ()
|
||||
[(_ id orig-reduction-relation allow-zero-rules? lang . w/domain-args)
|
||||
(identifier? #'lang)
|
||||
(prune-syntax
|
||||
(let-values ([(domain-pattern main-arrow args)
|
||||
(parse-keywords stx #'id #'w/domain-args)])
|
||||
(with-syntax ([(rules ...) (before-with args)]
|
||||
|
|
@ -258,7 +299,7 @@
|
|||
#'(list lws ...)
|
||||
(syntax-e #'allow-zero-rules?)
|
||||
domain-pattern
|
||||
main-arrow))))]
|
||||
main-arrow)))))]
|
||||
[(_ id orig-reduction-relation allow-zero-rules? lang args ...)
|
||||
(raise-syntax-error (syntax-e #'id)
|
||||
"expected an identifier for the language name"
|
||||
|
|
@ -983,6 +1024,7 @@
|
|||
(raise-syntax-error syn-error-name "expected an identifier in the language position" orig-stx #'lang))
|
||||
(when (null? (syntax-e #'rest))
|
||||
(raise-syntax-error syn-error-name "no clauses" orig-stx))
|
||||
(prune-syntax
|
||||
(let-values ([(contract-name dom-ctcs codom-contract pats)
|
||||
(split-out-contract orig-stx syn-error-name #'rest)])
|
||||
(with-syntax ([(((original-names lhs-clauses ...) rhs stuff ...) ...) pats]
|
||||
|
|
@ -1122,7 +1164,7 @@
|
|||
'name)))
|
||||
(term-define-fn name name2))
|
||||
'disappeared-use
|
||||
(map syntax-local-introduce (syntax->list #'(original-names ...))))))))))))]
|
||||
(map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))))]
|
||||
[(_ prev-metafunction name lang clauses ...)
|
||||
(begin
|
||||
(unless (identifier? #'name)
|
||||
|
|
@ -1361,6 +1403,7 @@
|
|||
(identifier? (syntax name))
|
||||
(begin
|
||||
(check-rhss-not-empty stx (cddr (syntax->list stx)))
|
||||
(prune-syntax
|
||||
(with-syntax ([((nt-names orig) ...) (pull-out-names 'define-language stx #'(names ...))])
|
||||
(with-syntax ([(subst-names ...) (generate-temporaries (syntax->list #'(nt-names ...)))])
|
||||
(syntax/loc stx
|
||||
|
|
@ -1377,7 +1420,7 @@
|
|||
(identifier? #'x)
|
||||
#'define-language-name])])
|
||||
'(nt-names ...))))
|
||||
(define define-language-name (language name (names rhs ...) ...)))))))]))
|
||||
(define define-language-name (language name (names rhs ...) ...))))))))]))
|
||||
|
||||
(define-struct binds (source binds))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user