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

match: avoid recording full paths

Browse Source 
Use a syntax object to store a source location, letting the
marshal process for syntax objects deal with non-relative
paths.
This commit is contained in:
Matthew Flatt 2015-12-09 16:44:00 -07:00
parent 2743ea06bb
commit 1d7429f1d7
2 changed files with 12 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
racket/collects/racket/match/gen-match.rkt
View File

@ -2,7 +2,7 @@
(require "patterns.rkt" "compiler.rkt" (require "patterns.rkt" "compiler.rkt"
syntax/stx syntax/parse racket/syntax syntax/stx syntax/parse racket/syntax
(for-template racket/base (only-in "runtime.rkt" match:error fail))) (for-template racket/base (only-in "runtime.rkt" match:error fail syntax-srclocs)))
(provide go go/one) (provide go go/one)
@ -33,17 +33,13 @@
(syntax-e #'fname)] (syntax-e #'fname)]
[_ 'match])) [_ 'match]))
(define len (length (syntax->list es))) (define len (length (syntax->list es)))
(define srcloc-list (list #`(quote #,(syntax-source stx)) (define srcloc-stx (datum->syntax #f 'srcloc stx))
#`(quote #,(syntax-line stx))
#`(quote #,(syntax-column stx))
#`(quote #,(syntax-position stx))
#`(quote #,(syntax-span stx))))
(define/with-syntax (xs ...) (generate-temporaries es)) (define/with-syntax (xs ...) (generate-temporaries es))
(define/with-syntax (exprs ...) es) (define/with-syntax (exprs ...) es)
(define/with-syntax outer-fail (generate-temporary #'fail)) (define/with-syntax outer-fail (generate-temporary #'fail))
(define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...))) (define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...)))
(define/with-syntax raise-error (define/with-syntax raise-error
(quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)) 'form-name))) (quasisyntax/loc stx (match:error orig-expr (syntax-srclocs (quote-syntax #,srcloc-stx)) 'form-name)))
(define parsed-clauses (define parsed-clauses
(for/list ([clause (syntax->list clauses)] (for/list ([clause (syntax->list clauses)]
[pats (syntax->list #'(pats ...))] [pats (syntax->list #'(pats ...))]

10
racket/collects/racket/match/runtime.rkt
View File

@ -9,7 +9,8 @@
fail fail
matchable? matchable?
match-prompt-tag match-prompt-tag
mlist? mlist->list) mlist? mlist->list
syntax-srclocs)
(define match-prompt-tag (make-continuation-prompt-tag 'match)) (define match-prompt-tag (make-continuation-prompt-tag 'match))
@ -58,3 +59,10 @@
(cond (cond
[(null? l) null] [(null? l) null]
[else (cons (mcar l) (mlist->list (mcdr l)))])) [else (cons (mcar l) (mlist->list (mcdr l)))]))
(define (syntax-srclocs stx)
(list (srcloc (syntax-source stx)
(syntax-line stx)
(syntax-column stx)
(syntax-position stx)
(syntax-span stx))))