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

use syntax objects to represent source locations

Browse Source 
To avoid the possibility of absolute paths in bytecode form,
rely on syntax objects to encode source locations (so that the
marshaling of syntax object can avoid absolute paths).
This commit is contained in:
Matthew Flatt 2015-12-09 17:22:42 -07:00
parent a3a22d191f
commit 644a4c550f
2 changed files with 14 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
rackunit-lib/rackunit/private/check.rkt
View File

@ -1,8 +1,7 @@
#lang racket/base #lang racket/base
(require racket/match (require racket/match
(for-syntax racket/base (for-syntax racket/base)
"location.rkt")
rackunit/log rackunit/log
"base.rkt" "base.rkt"
"check-info.rkt" "check-info.rkt"
@ -145,19 +144,18 @@
(define check-secret-name check-fn) (define check-secret-name check-fn)
(define-syntax (name stx) (define-syntax (name stx)
(with-syntax (with-syntax ([loc (datum->syntax #f 'loc stx)])
([loc (syntax->location stx)])
(syntax-case stx () (syntax-case stx ()
((name actual ...) ((name actual ...)
(syntax/loc stx (syntax/loc stx
(check-secret-name actual ... (check-secret-name actual ...
#:location (quote loc) #:location (syntax->location (quote-syntax loc))
#:expression (quote (name actual ...))))) #:expression (quote (name actual ...)))))
((name actual ... msg) ((name actual ... msg)
(syntax/loc stx (syntax/loc stx
(check-secret-name actual ... msg (check-secret-name actual ... msg
#:location (quote loc) #:location (syntax->location (quote-syntax loc))
#:expression (quote (name actual ...))))) #:expression (quote (name actual ...)))))
(name (name
@ -166,11 +164,11 @@
(case-lambda (case-lambda
[(formal ...) [(formal ...)
(check-secret-name formal ... (check-secret-name formal ...
#:location (quote loc) #:location (syntax->location (quote-syntax loc))
#:expression (quote (name actual ...)))] #:expression (quote (name actual ...)))]
[(formal ... msg) [(formal ... msg)
(check-secret-name formal ... msg (check-secret-name formal ... msg
#:location (quote loc) #:location (syntax->location (quote-syntax loc))
#:expression (quote (name actual ...)))])))))) #:expression (quote (name actual ...)))]))))))
)))))) ))))))
@ -307,11 +305,7 @@
(with-check-info* (with-check-info*
(list (make-check-name 'check-match) (list (make-check-name 'check-match)
(make-check-location (make-check-location
(list '(unsyntax (syntax-source stx)) (syntax->location (quote-syntax #,(datum->syntax #f 'loc stx))))
'(unsyntax (syntax-line stx))
'(unsyntax (syntax-column stx))
'(unsyntax (syntax-position stx))
'(unsyntax (syntax-span stx))))
(make-check-expression '#,(syntax->datum stx)) (make-check-expression '#,(syntax->datum stx))
(make-check-actual actual-val) (make-check-actual actual-val)
(make-check-expected 'expected)) (make-check-expected 'expected))

11
rackunit-lib/rackunit/private/test-case.rkt
View File

@ -64,12 +64,15 @@
[(_ name expr ...) [(_ name expr ...)
(quasisyntax/loc stx (quasisyntax/loc stx
(parameterize (parameterize
([current-test-name ([current-test-name
(contract string? name (ensure-string name (quote-syntax #,(datum->syntax #f 'loc #'name)))])
'#,(syntax-source-module #'name #t)
'#,(syntax-source-module #'test-case #t))])
(test-begin expr ...)))])) (test-begin expr ...)))]))
(define (ensure-string name src-stx)
(contract string? name
(syntax-source name)
(syntax-source-module #'test-case #t)))
(define-syntax before (define-syntax before
(syntax-rules () (syntax-rules ()
((_ before-e expr1 expr2 ...) ((_ before-e expr1 expr2 ...)