unstable module for source location manipulation
svn: r17065
This commit is contained in:
Carl Eastlund
parent
3492522501
commit
edae542b58
305
collects/tests/unstable/srcloc.ss
Normal file
305
collects/tests/unstable/srcloc.ss
Normal file
|
|
@ -0,0 +1,305 @@
|
|||
|
||||
(load-relative "../mzscheme/loadtest.ss")
|
||||
|
||||
(Section 'srcloc)
|
||||
(require unstable/srcloc)
|
||||
(require scheme/shared)
|
||||
|
||||
(test #t source-location? #f)
|
||||
(test #f source-location? #t)
|
||||
(test #t source-location? (list #f #f #f #f #f))
|
||||
(test #t source-location? (list 'here 1 0 1 0))
|
||||
(test #t source-location? (list #f 1 0 1 0))
|
||||
(test #f source-location? (list 'here #f 0 1 0))
|
||||
(test #f source-location? (list 'here 1 #f 1 0))
|
||||
(test #t source-location? (list 'here 1 0 #f 0))
|
||||
(test #t source-location? (list 'here 1 0 1 #f))
|
||||
(test #f source-location? (list 'here 1 -1 1 0))
|
||||
(test #f source-location? (list 'here 1 0 0 0))
|
||||
(test #f source-location? (list 'here 1 0 1 -1))
|
||||
(test #f source-location? (shared ([x (list* 'here 1 0 1 0 x)]) x))
|
||||
(test #t source-location? (vector #f #f #f #f #f))
|
||||
(test #t source-location? (vector 'here 1 0 1 0))
|
||||
(test #t source-location? (vector #f 1 0 1 0))
|
||||
(test #f source-location? (vector 'here #f 0 1 0))
|
||||
(test #f source-location? (vector 'here 1 #f 1 0))
|
||||
(test #t source-location? (vector 'here 1 0 #f 0))
|
||||
(test #t source-location? (vector 'here 1 0 1 #f))
|
||||
(test #f source-location? (vector 'here 0 0 1 0))
|
||||
(test #f source-location? (vector 'here 1 -1 1 0))
|
||||
(test #f source-location? (vector 'here 1 0 0 0))
|
||||
(test #f source-location? (vector 'here 1 0 1 -1))
|
||||
(test #t source-location? (make-srcloc #f #f #f #f #f))
|
||||
(test #t source-location? (make-srcloc 'here 1 0 1 0))
|
||||
(test #t source-location? (make-srcloc #f 1 0 1 0))
|
||||
(test #f source-location? (make-srcloc 'here #f 0 1 0))
|
||||
(test #f source-location? (make-srcloc 'here 1 #f 1 0))
|
||||
(test #t source-location? (make-srcloc 'here 1 0 #f 0))
|
||||
(test #t source-location? (make-srcloc 'here 1 0 1 #f))
|
||||
(test #t source-location? (datum->syntax #f null #f))
|
||||
(test #t source-location? (datum->syntax #f null (list 'here 1 0 1 0)))
|
||||
(test #t source-location? (datum->syntax #f null (list #f 1 0 1 0)))
|
||||
;;(test #f source-location? (datum->syntax #f null (list 'here #f 0 1 0))) ;; won't run
|
||||
;;(test #f source-location? (datum->syntax #f null (list 'here 1 #f 1 0))) ;; won't run
|
||||
(test #t source-location? (datum->syntax #f null (list 'here 1 0 #f 0)))
|
||||
(test #t source-location? (datum->syntax #f null (list 'here 1 0 1 #f)))
|
||||
|
||||
(test #f source-location-list? #f)
|
||||
(test #t source-location-list? (list #f #f #f #f #f))
|
||||
(test #t source-location-list? (list 'here 1 0 1 0))
|
||||
(test #t source-location-list? (list #f 1 0 1 0))
|
||||
(test #f source-location-list? (list 'here #f 0 1 0))
|
||||
(test #f source-location-list? (list 'here 1 #f 1 0))
|
||||
(test #t source-location-list? (list 'here 1 0 #f 0))
|
||||
(test #t source-location-list? (list 'here 1 0 1 #f))
|
||||
(test #f source-location-list? (list 'here 0 0 1 0))
|
||||
(test #f source-location-list? (list 'here 1 -1 1 0))
|
||||
(test #f source-location-list? (list 'here 1 0 0 0))
|
||||
(test #f source-location-list? (list 'here 1 0 1 -1))
|
||||
(test #f source-location-list? (shared ([x (list* 'here 1 0 1 0 x)]) x))
|
||||
(test #f source-location-list? (vector 'here 1 0 1 0))
|
||||
(test #f source-location-list? (make-srcloc 'here 1 0 1 0))
|
||||
(test #f source-location-list? (datum->syntax #f null #f))
|
||||
(test #f source-location-list? (datum->syntax #f null (list 'here 1 0 1 0)))
|
||||
|
||||
(test #f source-location-vector? #f)
|
||||
(test #f source-location-vector? (list 'here 1 0 1 0))
|
||||
(test #t source-location-vector? (vector #f 1 0 1 0))
|
||||
(test #f source-location-vector? (vector 'here #f 0 1 0))
|
||||
(test #f source-location-vector? (vector 'here 1 #f 1 0))
|
||||
(test #t source-location-vector? (vector 'here 1 0 #f 0))
|
||||
(test #t source-location-vector? (vector 'here 1 0 1 #f))
|
||||
(test #t source-location-vector? (vector #f #f #f #f #f))
|
||||
(test #t source-location-vector? (vector 'here 1 0 1 0))
|
||||
(test #f source-location-vector? (vector 'here 0 0 1 0))
|
||||
(test #f source-location-vector? (vector 'here 1 -1 1 0))
|
||||
(test #f source-location-vector? (vector 'here 1 0 0 0))
|
||||
(test #f source-location-vector? (vector 'here 1 0 1 -1))
|
||||
(test #f source-location-vector? (make-srcloc 'here 1 0 1 0))
|
||||
(test #f source-location-vector? (datum->syntax #f null #f))
|
||||
(test #f source-location-vector? (datum->syntax #f null (list 'here 1 0 1 0)))
|
||||
|
||||
(test (void) check-source-location! 'test-srcloc #f)
|
||||
(err/rt-test (check-source-location! 'test-srcloc #t) exn:fail:contract?)
|
||||
(test (void) check-source-location! 'test-srcloc (list #f #f #f #f #f))
|
||||
(test (void) check-source-location! 'test-srcloc (list 'here 1 0 1 0))
|
||||
(test (void) check-source-location! 'test-srcloc (list #f 1 0 1 0))
|
||||
(err/rt-test (check-source-location! 'test-srcloc (list 'here #f 0 1 0)) exn:fail:contract?)
|
||||
(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 #f 1 0)) exn:fail:contract?)
|
||||
(test (void) check-source-location! 'test-srcloc (list 'here 1 0 #f 0))
|
||||
(test (void) check-source-location! 'test-srcloc (list 'here 1 0 1 #f))
|
||||
(err/rt-test (check-source-location! 'test-srcloc (list 'here 0 0 1 0)) exn:fail:contract?)
|
||||
(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 -1 1 0)) exn:fail:contract?)
|
||||
(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 0 0 0)) exn:fail:contract?)
|
||||
(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 0 1 -1)) exn:fail:contract?)
|
||||
(err/rt-test (check-source-location! 'test-srcloc (shared ([x (list* 'here 1 0 1 0 x)]) x)) exn:fail:contract?)
|
||||
(test (void) check-source-location! 'test-srcloc (vector #f #f #f #f #f))
|
||||
(test (void) check-source-location! 'test-srcloc (vector 'here 1 0 1 0))
|
||||
(test (void) check-source-location! 'test-srcloc (vector #f 1 0 1 0))
|
||||
(err/rt-test (check-source-location! 'test-srcloc (vector 'here #f 0 1 0)) exn:fail:contract?)
|
||||
(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 #f 1 0)) exn:fail:contract?)
|
||||
(test (void) check-source-location! 'test-srcloc (vector 'here 1 0 #f 0))
|
||||
(test (void) check-source-location! 'test-srcloc (vector 'here 1 0 1 #f))
|
||||
(err/rt-test (check-source-location! 'test-srcloc (vector 'here 0 0 1 0)) exn:fail:contract?)
|
||||
(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 -1 1 0)) exn:fail:contract?)
|
||||
(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 0 0 0)) exn:fail:contract?)
|
||||
(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 0 1 -1)) exn:fail:contract?)
|
||||
(test (void) check-source-location! 'test-srcloc (make-srcloc #f #f #f #f #f))
|
||||
(test (void) check-source-location! 'test-srcloc (make-srcloc 'here 1 0 1 0))
|
||||
(test (void) check-source-location! 'test-srcloc (make-srcloc #f 1 0 1 0))
|
||||
(err/rt-test (check-source-location! 'test-srcloc (make-srcloc 'here #f 0 1 0)) exn:fail:contract?)
|
||||
(err/rt-test (check-source-location! 'test-srcloc (make-srcloc 'here 1 #f 1 0)) exn:fail:contract?)
|
||||
(test (void) check-source-location! 'test-srcloc (make-srcloc 'here 1 0 #f 0))
|
||||
(test (void) check-source-location! 'test-srcloc (make-srcloc 'here 1 0 1 #f))
|
||||
(test (void) check-source-location! 'test-srcloc (datum->syntax #f null #f))
|
||||
(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 0 1 0)))
|
||||
(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list #f 1 0 1 0)))
|
||||
;;(err/rt-test (check-source-location! 'test-srcloc (datum->syntax #f null (list 'here #f 0 1 0))) exn:fail:contract?) ;; won't run
|
||||
;;(err/rt-test (check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 #f 1 0))) exn:fail:contract?) ;; won't run
|
||||
(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 0 #f 0)))
|
||||
(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 0 1 #f)))
|
||||
|
||||
(test (make-srcloc #f #f #f #f #f) build-source-location)
|
||||
(test (make-srcloc #f #f #f #f #f) build-source-location #f)
|
||||
(test (make-srcloc 'here 1 0 1 0) build-source-location (make-srcloc 'here 1 0 1 0))
|
||||
(test (make-srcloc 'here 1 0 1 0) build-source-location (vector 'here 1 0 1 0))
|
||||
(test (make-srcloc 'here 1 0 1 0) build-source-location (list 'here 1 0 1 0))
|
||||
(test (make-srcloc 'here 1 0 1 0) build-source-location (datum->syntax #f null (list 'here 1 0 1 0)))
|
||||
(test (make-srcloc 'here 1 0 1 3) build-source-location (list 'here 1 0 1 0) (vector 'here 2 1 3 1))
|
||||
(test (make-srcloc 'here 1 0 1 3) build-source-location (vector 'here 2 1 3 1) (list 'here 1 0 1 0))
|
||||
(test (make-srcloc #f #f #f #f #f) build-source-location (vector 'here 2 1 3 1) (list 'there 1 0 1 0))
|
||||
(err/rt-test (build-source-location (list 'bad 0 0 0 0)) exn:fail:contract?)
|
||||
|
||||
(test (list #f #f #f #f #f) build-source-location-list)
|
||||
(test (list #f #f #f #f #f) build-source-location-list #f)
|
||||
(test (list 'here 1 0 1 0) build-source-location-list (make-srcloc 'here 1 0 1 0))
|
||||
(test (list 'here 1 0 1 0) build-source-location-list (vector 'here 1 0 1 0))
|
||||
(test (list 'here 1 0 1 0) build-source-location-list (list 'here 1 0 1 0))
|
||||
(test (list 'here 1 0 1 0) build-source-location-list (datum->syntax #f null (list 'here 1 0 1 0)))
|
||||
(test (list 'here 1 0 1 3) build-source-location-list (list 'here 1 0 1 0) (vector 'here 2 1 3 1))
|
||||
(test (list 'here 1 0 1 3) build-source-location-list (vector 'here 2 1 3 1) (list 'here 1 0 1 0))
|
||||
(test (list #f #f #f #f #f) build-source-location-list (vector 'here 2 1 3 1) (list 'there 1 0 1 0))
|
||||
(err/rt-test (build-source-location-list (list 'bad 0 0 0 0)) exn:fail:contract?)
|
||||
|
||||
(test (vector #f #f #f #f #f) build-source-location-vector)
|
||||
(test (vector #f #f #f #f #f) build-source-location-vector #f)
|
||||
(test (vector 'here 1 0 1 0) build-source-location-vector (make-srcloc 'here 1 0 1 0))
|
||||
(test (vector 'here 1 0 1 0) build-source-location-vector (vector 'here 1 0 1 0))
|
||||
(test (vector 'here 1 0 1 0) build-source-location-vector (list 'here 1 0 1 0))
|
||||
(test (vector 'here 1 0 1 0) build-source-location-vector (datum->syntax #f null (list 'here 1 0 1 0)))
|
||||
(test (vector 'here 1 0 1 3) build-source-location-vector (list 'here 1 0 1 0) (vector 'here 2 1 3 1))
|
||||
(test (vector 'here 1 0 1 3) build-source-location-vector (vector 'here 2 1 3 1) (list 'here 1 0 1 0))
|
||||
(test (vector #f #f #f #f #f) build-source-location-vector (vector 'here 2 1 3 1) (list 'there 1 0 1 0))
|
||||
(err/rt-test (build-source-location-vector (list 'bad 0 0 0 0)) exn:fail:contract?)
|
||||
|
||||
(define-syntax-rule (test-stx-srcloc (list src line col pos span) fn arg ...)
|
||||
(begin
|
||||
(test #t syntax? (fn arg ...))
|
||||
(test src syntax-source (fn arg ...))
|
||||
(test line syntax-line (fn arg ...))
|
||||
(test col syntax-column (fn arg ...))
|
||||
(test pos syntax-position (fn arg ...))
|
||||
(test span syntax-span (fn arg ...))))
|
||||
|
||||
(test-stx-srcloc (list #f #f #f #f #f) build-source-location-syntax)
|
||||
(test-stx-srcloc (list #f #f #f #f #f) build-source-location-syntax #f)
|
||||
(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (make-srcloc 'here 1 0 1 0))
|
||||
(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (vector 'here 1 0 1 0))
|
||||
(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (list 'here 1 0 1 0))
|
||||
(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (datum->syntax #f null (list 'here 1 0 1 0)))
|
||||
(test-stx-srcloc (list 'here 1 0 1 3) build-source-location-syntax (list 'here 1 0 1 0) (vector 'here 2 1 3 1))
|
||||
(test-stx-srcloc (list 'here 1 0 1 3) build-source-location-syntax (vector 'here 2 1 3 1) (list 'here 1 0 1 0))
|
||||
(test-stx-srcloc (list #f #f #f #f #f) build-source-location-syntax (vector 'here 2 1 3 1) (list 'there 1 0 1 0))
|
||||
(err/rt-test (build-source-location-syntax (list 'bad 0 0 0 0)) exn:fail:contract?)
|
||||
|
||||
(test #f source-location-known? #f)
|
||||
(test #t source-location-known? (list 'here 1 0 1 0))
|
||||
(test #f source-location-known? (list #f #f #f #f #f))
|
||||
(test #t source-location-known? (vector 'here 1 0 1 0))
|
||||
(test #f source-location-known? (vector #f #f #f #f #f))
|
||||
(test #t source-location-known? (make-srcloc 'here 1 0 1 0))
|
||||
(test #f source-location-known? (make-srcloc #f #f #f #f #f))
|
||||
(test #t source-location-known? (datum->syntax #f null (list 'here 1 0 1 0)))
|
||||
(test #f source-location-known? (datum->syntax #f null (list #f #f #f #f #f)))
|
||||
|
||||
(test #f source-location-source #f)
|
||||
(test 'here source-location-source (list 'here 1 2 3 4))
|
||||
(test 'here source-location-source (vector 'here 1 2 3 4))
|
||||
(test 'here source-location-source (make-srcloc 'here 1 2 3 4))
|
||||
(test 'here source-location-source (datum->syntax #f null (list 'here 1 2 3 4)))
|
||||
|
||||
(test #f source-location-line #f)
|
||||
(test 1 source-location-line (list 'here 1 2 3 4))
|
||||
(test 1 source-location-line (vector 'here 1 2 3 4))
|
||||
(test 1 source-location-line (make-srcloc 'here 1 2 3 4))
|
||||
(test 1 source-location-line (datum->syntax #f null (list 'here 1 2 3 4)))
|
||||
|
||||
(test #f source-location-column #f)
|
||||
(test 2 source-location-column (list 'here 1 2 3 4))
|
||||
(test 2 source-location-column (vector 'here 1 2 3 4))
|
||||
(test 2 source-location-column (make-srcloc 'here 1 2 3 4))
|
||||
(test 2 source-location-column (datum->syntax #f null (list 'here 1 2 3 4)))
|
||||
|
||||
(test #f source-location-position #f)
|
||||
(test 3 source-location-position (list 'here 1 2 3 4))
|
||||
(test 3 source-location-position (vector 'here 1 2 3 4))
|
||||
(test 3 source-location-position (make-srcloc 'here 1 2 3 4))
|
||||
(test 3 source-location-position (datum->syntax #f null (list 'here 1 2 3 4)))
|
||||
|
||||
(test #f source-location-span #f)
|
||||
(test 4 source-location-span (list 'here 1 2 3 4))
|
||||
(test 4 source-location-span (vector 'here 1 2 3 4))
|
||||
(test 4 source-location-span (make-srcloc 'here 1 2 3 4))
|
||||
(test 4 source-location-span (datum->syntax #f null (list 'here 1 2 3 4)))
|
||||
|
||||
(test #f source-location-end #f)
|
||||
(test 7 source-location-end (list 'here 1 2 3 4))
|
||||
(test #f source-location-end (list 'here 1 2 #f 4))
|
||||
(test #f source-location-end (list 'here 1 2 3 #f))
|
||||
(test 7 source-location-end (vector 'here 1 2 3 4))
|
||||
(test #f source-location-end (vector 'here 1 2 #f 4))
|
||||
(test #f source-location-end (vector 'here 1 2 3 #f))
|
||||
(test 7 source-location-end (make-srcloc 'here 1 2 3 4))
|
||||
(test #f source-location-end (make-srcloc 'here 1 2 #f 4))
|
||||
(test #f source-location-end (make-srcloc 'here 1 2 3 #f))
|
||||
(test 7 source-location-end (datum->syntax #f null (list 'here 1 2 3 4)))
|
||||
(test #f source-location-end (datum->syntax #f null (list 'here 1 2 #f 4)))
|
||||
(test #f source-location-end (datum->syntax #f null (list 'here 1 2 3 #f)))
|
||||
|
||||
(test "" source-location->string #f)
|
||||
|
||||
(test "" source-location->string (list #f #f #f #f #f))
|
||||
(test "here" source-location->string (list 'here #f #f #f #f))
|
||||
(test "here:1.2" source-location->string (list 'here 1 2 3 #f))
|
||||
(test "here::3" source-location->string (list 'here #f #f 3 #f))
|
||||
(test "::3-7" source-location->string (list #f #f #f 3 4))
|
||||
(test ":1.2" source-location->string (list #f 1 2 3 #f))
|
||||
(test "::3" source-location->string (list #f #f #f 3 #f))
|
||||
(test "::3-7" source-location->string (list #f #f #f 3 4))
|
||||
|
||||
(test "" source-location->string (vector #f #f #f #f #f))
|
||||
(test "here" source-location->string (vector 'here #f #f #f #f))
|
||||
(test "here:1.2" source-location->string (vector 'here 1 2 3 #f))
|
||||
(test "here::3" source-location->string (vector 'here #f #f 3 #f))
|
||||
(test "::3-7" source-location->string (vector #f #f #f 3 4))
|
||||
(test ":1.2" source-location->string (vector #f 1 2 3 #f))
|
||||
(test "::3" source-location->string (vector #f #f #f 3 #f))
|
||||
(test "::3-7" source-location->string (vector #f #f #f 3 4))
|
||||
|
||||
(test "" source-location->string (make-srcloc #f #f #f #f #f))
|
||||
(test "here" source-location->string (make-srcloc 'here #f #f #f #f))
|
||||
(test "here:1.2" source-location->string (make-srcloc 'here 1 2 3 #f))
|
||||
(test "here::3" source-location->string (make-srcloc 'here #f #f 3 #f))
|
||||
(test "::3-7" source-location->string (make-srcloc #f #f #f 3 4))
|
||||
(test ":1.2" source-location->string (make-srcloc #f 1 2 3 #f))
|
||||
(test "::3" source-location->string (make-srcloc #f #f #f 3 #f))
|
||||
(test "::3-7" source-location->string (make-srcloc #f #f #f 3 4))
|
||||
|
||||
(test "" source-location->string (datum->syntax #f null (list #f #f #f #f #f)))
|
||||
(test "here" source-location->string (datum->syntax #f null (list 'here #f #f #f #f)))
|
||||
(test "here:1.2" source-location->string (datum->syntax #f null (list 'here 1 2 3 #f)))
|
||||
(test "here::3" source-location->string (datum->syntax #f null (list 'here #f #f 3 #f)))
|
||||
(test "::3-7" source-location->string (datum->syntax #f null (list #f #f #f 3 4)))
|
||||
(test ":1.2" source-location->string (datum->syntax #f null (list #f 1 2 3 #f)))
|
||||
(test "::3" source-location->string (datum->syntax #f null (list #f #f #f 3 #f)))
|
||||
(test "::3-7" source-location->string (datum->syntax #f null (list #f #f #f 3 4)))
|
||||
|
||||
(test "" source-location->prefix #f)
|
||||
|
||||
(test "" source-location->prefix (list #f #f #f #f #f))
|
||||
(test "here: " source-location->prefix (list 'here #f #f #f #f))
|
||||
(test "here:1.2: " source-location->prefix (list 'here 1 2 3 #f))
|
||||
(test "here::3: " source-location->prefix (list 'here #f #f 3 #f))
|
||||
(test "::3-7: " source-location->prefix (list #f #f #f 3 4))
|
||||
(test ":1.2: " source-location->prefix (list #f 1 2 3 #f))
|
||||
(test "::3: " source-location->prefix (list #f #f #f 3 #f))
|
||||
(test "::3-7: " source-location->prefix (list #f #f #f 3 4))
|
||||
|
||||
(test "" source-location->prefix (vector #f #f #f #f #f))
|
||||
(test "here: " source-location->prefix (vector 'here #f #f #f #f))
|
||||
(test "here:1.2: " source-location->prefix (vector 'here 1 2 3 #f))
|
||||
(test "here::3: " source-location->prefix (vector 'here #f #f 3 #f))
|
||||
(test "::3-7: " source-location->prefix (vector #f #f #f 3 4))
|
||||
(test ":1.2: " source-location->prefix (vector #f 1 2 3 #f))
|
||||
(test "::3: " source-location->prefix (vector #f #f #f 3 #f))
|
||||
(test "::3-7: " source-location->prefix (vector #f #f #f 3 4))
|
||||
|
||||
(test "" source-location->prefix (make-srcloc #f #f #f #f #f))
|
||||
(test "here: " source-location->prefix (make-srcloc 'here #f #f #f #f))
|
||||
(test "here:1.2: " source-location->prefix (make-srcloc 'here 1 2 3 #f))
|
||||
(test "here::3: " source-location->prefix (make-srcloc 'here #f #f 3 #f))
|
||||
(test "::3-7: " source-location->prefix (make-srcloc #f #f #f 3 4))
|
||||
(test ":1.2: " source-location->prefix (make-srcloc #f 1 2 3 #f))
|
||||
(test "::3: " source-location->prefix (make-srcloc #f #f #f 3 #f))
|
||||
(test "::3-7: " source-location->prefix (make-srcloc #f #f #f 3 4))
|
||||
|
||||
(test "" source-location->prefix (datum->syntax #f null (list #f #f #f #f #f)))
|
||||
(test "here: " source-location->prefix (datum->syntax #f null (list 'here #f #f #f #f)))
|
||||
(test "here:1.2: " source-location->prefix (datum->syntax #f null (list 'here 1 2 3 #f)))
|
||||
(test "here::3: " source-location->prefix (datum->syntax #f null (list 'here #f #f 3 #f)))
|
||||
(test "::3-7: " source-location->prefix (datum->syntax #f null (list #f #f #f 3 4)))
|
||||
(test ":1.2: " source-location->prefix (datum->syntax #f null (list #f 1 2 3 #f)))
|
||||
(test "::3: " source-location->prefix (datum->syntax #f null (list #f #f #f 3 #f)))
|
||||
(test "::3-7: " source-location->prefix (datum->syntax #f null (list #f #f #f 3 4)))
|
||||
|
||||
(report-errs)
|
||||
123
collects/unstable/scribblings/srcloc.scrbl
Normal file
123
collects/unstable/scribblings/srcloc.scrbl
Normal file
|
|
@ -0,0 +1,123 @@
|
|||
#lang scribble/manual
|
||||
@(require scribble/eval "utils.ss" (for-label scheme/base unstable/srcloc))
|
||||
|
||||
@(define evaluator (make-base-eval))
|
||||
@(evaluator '(require unstable/srcloc))
|
||||
|
||||
@title[#:tag "srcloc"]{Source Locations}
|
||||
|
||||
@defmodule[unstable/srcloc]
|
||||
|
||||
@unstable[@author+email["Carl Eastlund" "cce@ccs.neu.edu"]]
|
||||
|
||||
This module defines utilities for manipulating representations of source
|
||||
locations, including both @scheme[srcloc] structures and all the values accepted
|
||||
by @scheme[datum->syntax]'s third argument: syntax objects, lists, vectors, and
|
||||
@scheme[#f].
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(source-location? [x any/c]) boolean?]{}
|
||||
@defproc[(source-location-list? [x any/c]) boolean?]{}
|
||||
@defproc[(source-location-vector? [x any/c]) boolean?]{}
|
||||
)]{
|
||||
|
||||
These functions recognize valid source location representations. The first,
|
||||
@scheme[source-location?], recognizes @scheme[srcloc] structures, syntax
|
||||
objects, lists, and vectors with appropriate structure, as well as @scheme[#f].
|
||||
The latter predicates recognize only valid lists and vectors, respectively.
|
||||
|
||||
@examples[#:eval evaluator
|
||||
(source-location? #f)
|
||||
(source-location? #'here)
|
||||
(source-location? (make-srcloc 'here 1 0 1 0))
|
||||
(source-location? (make-srcloc 'bad 1 #f 1 0))
|
||||
(source-location? (list 'here 1 0 1 0))
|
||||
(source-location? (list* 'bad 1 0 1 0 'tail))
|
||||
(source-location? (vector 'here 1 0 1 0))
|
||||
(source-location? (vector 'bad 0 0 0 0))
|
||||
]
|
||||
|
||||
}
|
||||
|
||||
@defproc[(check-source-location! [name symbol?] [x any/c]) void?]{
|
||||
|
||||
This procedure checks that its input is a valid source location. If it is, the
|
||||
procedure returns @scheme[(void)]. If it is not,
|
||||
@scheme[check-source-location!] raises a detailed error message in terms of
|
||||
@scheme[name] and the problem with @scheme[x].
|
||||
|
||||
@examples[#:eval evaluator
|
||||
(check-source-location! 'this-example #f)
|
||||
(check-source-location! 'this-example #'here)
|
||||
(check-source-location! 'this-example (make-srcloc 'here 1 0 1 0))
|
||||
(check-source-location! 'this-example (make-srcloc 'bad 1 #f 1 0))
|
||||
(check-source-location! 'this-example (list 'here 1 0 1 0))
|
||||
(check-source-location! 'this-example (list* 'bad 1 0 1 0 'tail))
|
||||
(check-source-location! 'this-example (vector 'here 1 0 1 0))
|
||||
(check-source-location! 'this-example (vector 'bad 0 0 0 0))
|
||||
]
|
||||
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(build-source-location [loc source-location?] ...) srcloc?]{}
|
||||
@defproc[(build-source-location-list [loc source-location?] ...) source-location-list?]{}
|
||||
@defproc[(build-source-location-vector [loc source-location?] ...) source-location-vector?]{}
|
||||
@defproc[(build-source-location-syntax [loc source-location?] ...) syntax?]{}
|
||||
)]{
|
||||
|
||||
These procedures combine multiple (zero or more) source locations, merging
|
||||
locations within the same source and reporting @scheme[#f] for locations that
|
||||
span sources. They also convert the result to the desired representation:
|
||||
@scheme[srcloc], list, vector, or syntax object, respectively.
|
||||
|
||||
@examples[#:eval evaluator
|
||||
(build-source-location)
|
||||
(build-source-location-list)
|
||||
(build-source-location-vector)
|
||||
(build-source-location-syntax)
|
||||
(build-source-location #f)
|
||||
(build-source-location-list #f)
|
||||
(build-source-location-vector #f)
|
||||
(build-source-location-syntax #f)
|
||||
(build-source-location (list 'here 1 2 3 4))
|
||||
(build-source-location-list (make-srcloc 'here 1 2 3 4))
|
||||
(build-source-location-vector (make-srcloc 'here 1 2 3 4))
|
||||
(build-source-location-syntax (make-srcloc 'here 1 2 3 4))
|
||||
(build-source-location (list 'here 1 2 3 4) (vector 'here 5 6 7 8))
|
||||
(build-source-location-list (make-srcloc 'here 1 2 3 4) (vector 'here 5 6 7 8))
|
||||
(build-source-location-vector (make-srcloc 'here 1 2 3 4) (vector 'here 5 6 7 8))
|
||||
(build-source-location-syntax (make-srcloc 'here 1 2 3 4) (vector 'here 5 6 7 8))
|
||||
(build-source-location (list 'here 1 2 3 4) (vector 'there 5 6 7 8))
|
||||
(build-source-location-list (make-srcloc 'here 1 2 3 4) (vector 'there 5 6 7 8))
|
||||
(build-source-location-vector (make-srcloc 'here 1 2 3 4) (vector 'there 5 6 7 8))
|
||||
(build-source-location-syntax (make-srcloc 'here 1 2 3 4) (vector 'there 5 6 7 8))
|
||||
]
|
||||
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(source-location->string [loc source-location?]) string?]{}
|
||||
@defproc[(source-location->prefix [loc source-location?]) string?]{}
|
||||
)]{
|
||||
|
||||
These procedures convert source locations to strings for use in error messages.
|
||||
The first produces a string describing the source location; the second appends
|
||||
@scheme[": "] to the string if it is non-empty.
|
||||
|
||||
@examples[#:eval evaluator
|
||||
(source-location->string (make-srcloc 'here 1 2 3 4))
|
||||
(source-location->string (make-srcloc 'here #f #f 3 4))
|
||||
(source-location->string (make-srcloc 'here #f #f #f #f))
|
||||
(source-location->string (make-srcloc #f 1 2 3 4))
|
||||
(source-location->string (make-srcloc #f #f #f 3 4))
|
||||
(source-location->string (make-srcloc #f #f #f #f #f))
|
||||
(source-location->prefix (make-srcloc 'here 1 2 3 4))
|
||||
(source-location->prefix (make-srcloc 'here #f #f 3 4))
|
||||
(source-location->prefix (make-srcloc 'here #f #f #f #f))
|
||||
(source-location->prefix (make-srcloc #f 1 2 3 4))
|
||||
(source-location->prefix (make-srcloc #f #f #f 3 4))
|
||||
(source-location->prefix (make-srcloc #f #f #f #f #f))
|
||||
]
|
||||
|
||||
}
|
||||
|
|
@ -77,6 +77,7 @@ Keep documentation and tests up to date.
|
|||
@include-section["list.scrbl"]
|
||||
@include-section["net.scrbl"]
|
||||
@include-section["path.scrbl"]
|
||||
@include-section["srcloc.scrbl"]
|
||||
@include-section["string.scrbl"]
|
||||
@include-section["struct.scrbl"]
|
||||
@include-section["syntax.scrbl"]
|
||||
|
|
|
|||
321
collects/unstable/srcloc.ss
Normal file
321
collects/unstable/srcloc.ss
Normal file
|
|
@ -0,0 +1,321 @@
|
|||
#lang scheme/base
|
||||
|
||||
;; Unstable library by: Carl Eastlund <cce@ccs.neu.edu>
|
||||
;; intended for use in scheme/contract, so don't try to add contracts!
|
||||
|
||||
(provide
|
||||
|
||||
;; type predicates
|
||||
source-location?
|
||||
source-location-list?
|
||||
source-location-vector?
|
||||
|
||||
;; error checks
|
||||
check-source-location!
|
||||
|
||||
;; conversion and combination
|
||||
build-source-location
|
||||
build-source-location-list
|
||||
build-source-location-vector
|
||||
build-source-location-syntax
|
||||
|
||||
;; accessors
|
||||
source-location-known?
|
||||
source-location-source
|
||||
source-location-line
|
||||
source-location-column
|
||||
source-location-position
|
||||
source-location-span
|
||||
source-location-end
|
||||
|
||||
;; rendering
|
||||
source-location->string
|
||||
source-location->prefix
|
||||
|
||||
)
|
||||
|
||||
(define (source-location? x)
|
||||
(process-source-location x good? bad? 'source-location?))
|
||||
|
||||
(define (source-location-list? x)
|
||||
(process-list x good? bad? 'source-location-list?))
|
||||
|
||||
(define (source-location-vector? x)
|
||||
(process-vector x good? bad? 'source-location-vector?))
|
||||
|
||||
(define (check-source-location! name x)
|
||||
(process-source-location x good! bad! name))
|
||||
|
||||
(define (source-location-known? x)
|
||||
(process-source-location x good-known? bad! 'source-location-known?))
|
||||
|
||||
(define (source-location-source x)
|
||||
(process-source-location x good-source bad! 'source-location-source))
|
||||
|
||||
(define (source-location-line x)
|
||||
(process-source-location x good-line bad! 'source-location-line))
|
||||
|
||||
(define (source-location-position x)
|
||||
(process-source-location x good-position bad! 'source-location-position))
|
||||
|
||||
(define (source-location-column x)
|
||||
(process-source-location x good-column bad! 'source-location-column))
|
||||
|
||||
(define (source-location-span x)
|
||||
(process-source-location x good-span bad! 'source-location-span))
|
||||
|
||||
(define (source-location-end x)
|
||||
(process-source-location x good-end bad! 'source-location-end))
|
||||
|
||||
(define (source-location->string x)
|
||||
(process-source-location x good-string bad! 'source-location->string))
|
||||
|
||||
(define (source-location->prefix x)
|
||||
(process-source-location x good-prefix bad! 'source-location->prefix))
|
||||
|
||||
(define (build-source-location . locs)
|
||||
(combine-source-locations locs good-srcloc bad!
|
||||
'build-source-location))
|
||||
|
||||
(define (build-source-location-list . locs)
|
||||
(combine-source-locations locs good-list bad!
|
||||
'build-source-location-list))
|
||||
|
||||
(define (build-source-location-vector . locs)
|
||||
(combine-source-locations locs good-vector bad!
|
||||
'build-source-location-vector))
|
||||
|
||||
(define (build-source-location-syntax . locs)
|
||||
(combine-source-locations locs good-syntax bad!
|
||||
'build-source-location-syntax))
|
||||
|
||||
(define (good? x src line col pos span) #t)
|
||||
(define (bad? fmt . args) #f)
|
||||
|
||||
(define (good! x src line col pos span) (void))
|
||||
(define (bad! fmt . args)
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(apply format fmt args)
|
||||
(current-continuation-marks))))
|
||||
|
||||
(define (good-known? x src line col pos span)
|
||||
(and (or src line col pos span) #t))
|
||||
|
||||
(define (good-source x src line col pos span) src)
|
||||
(define (good-line x src line col pos span) line)
|
||||
(define (good-column x src line col pos span) col)
|
||||
(define (good-position x src line col pos span) pos)
|
||||
(define (good-span x src line col pos span) span)
|
||||
(define (good-end x src line col pos span) (and pos span (+ pos span)))
|
||||
|
||||
(define (good-srcloc x src line col pos span)
|
||||
(if (srcloc? x) x (make-srcloc src line col pos span)))
|
||||
|
||||
(define (good-list x src line col pos span)
|
||||
(if (list? x) x (list src line col pos span)))
|
||||
|
||||
(define (good-vector x src line col pos span)
|
||||
(if (vector? x) x (vector src line col pos span)))
|
||||
|
||||
(define (good-syntax x src line col pos span)
|
||||
(cond
|
||||
[(syntax? x) x]
|
||||
[(or (list? x) (vector? x)) (datum->syntax #f null x)]
|
||||
[else (datum->syntax #f null (vector src line col pos span))]))
|
||||
|
||||
(define (good-string x src line col pos span)
|
||||
(format "~a~a"
|
||||
(or src "")
|
||||
(if line
|
||||
(if col
|
||||
(format ":~a.~a" line col)
|
||||
(format ":~a" line))
|
||||
(if pos
|
||||
(if span
|
||||
(format "::~a-~a" pos (+ pos span))
|
||||
(format "::~a" pos))
|
||||
""))))
|
||||
|
||||
(define (good-prefix x src line col pos span)
|
||||
(let ([str (good-string x src line col pos span)])
|
||||
(if (string=? str "") "" (string-append str ": "))))
|
||||
|
||||
(define (combine-source-locations locs good bad name)
|
||||
|
||||
(define (loop loc1 src1 line1 col1 pos1 span1 locs)
|
||||
(if (null? locs)
|
||||
(good loc1 src1 line1 col1 pos1 span1)
|
||||
(process-source-location
|
||||
(car locs)
|
||||
(lambda (loc2 src2 line2 col2 pos2 span2)
|
||||
(combine-two
|
||||
src1 line1 col1 pos1 span1
|
||||
src2 line2 col2 pos2 span2
|
||||
(lambda (loc src line col pos span)
|
||||
(loop loc src line col pos span (cdr locs)))))
|
||||
bad
|
||||
name)))
|
||||
|
||||
(if (null? locs)
|
||||
(process-source-location #f good bad name)
|
||||
(process-source-location
|
||||
(car locs)
|
||||
(lambda (loc src line col pos span)
|
||||
(loop loc src line col pos span (cdr locs)))
|
||||
bad
|
||||
name)))
|
||||
|
||||
(define (combine-two src1 line1 col1 pos1 span1
|
||||
src2 line2 col2 pos2 span2
|
||||
good)
|
||||
(if (and src1 src2 (equal? src1 src2))
|
||||
(let-values
|
||||
([(src) src1]
|
||||
[(line col)
|
||||
(cond
|
||||
[(and line1 line2)
|
||||
(cond
|
||||
[(< line1 line2) (values line1 col1)]
|
||||
[(> line1 line2) (values line2 col2)]
|
||||
[else (values line1
|
||||
(if (and col1 col2)
|
||||
(min col1 col2)
|
||||
(or col1 col2)))])]
|
||||
[line1 (values line1 col1)]
|
||||
[line2 (values line2 col2)]
|
||||
[else (values #f #f)])]
|
||||
[(pos span)
|
||||
(cond
|
||||
[(and pos1 pos2)
|
||||
(let ([pos (min pos1 pos2)])
|
||||
(cond
|
||||
[(and span1 span2)
|
||||
(let ([end (max (+ pos1 span1) (+ pos2 span2))])
|
||||
(values pos (- end pos)))]
|
||||
[span1 (values pos (- (+ pos1 span1) pos))]
|
||||
[span2 (values pos (- (+ pos2 span2) pos))]
|
||||
[else (values pos #f)]))])])
|
||||
(good #f src line col pos span))
|
||||
(good #f #f #f #f #f #f)))
|
||||
|
||||
(define (process-source-location x good bad name)
|
||||
(cond
|
||||
;; #f
|
||||
[(not x) (process-false x good bad name)]
|
||||
;; srcloc
|
||||
[(srcloc? x) (process-srcloc x good bad name)]
|
||||
;; list
|
||||
[(or (null? x) (pair? x)) (process-list x good bad name)]
|
||||
;; vector
|
||||
[(vector? x) (process-vector x good bad name)]
|
||||
;; syntax
|
||||
[(syntax? x) (process-syntax x good bad name)]
|
||||
;; other
|
||||
[else
|
||||
(bad
|
||||
"~a: expected a source location (srcloc struct, syntax object, list, vector, or #f); got: ~e"
|
||||
name
|
||||
x)]))
|
||||
|
||||
(define (process-false x good bad name)
|
||||
(process-elements #f good bad name #f #f #f #f #f))
|
||||
|
||||
(define (process-srcloc x good bad name)
|
||||
(process-elements x good bad name
|
||||
(srcloc-source x)
|
||||
(srcloc-line x)
|
||||
(srcloc-column x)
|
||||
(srcloc-position x)
|
||||
(srcloc-span x)))
|
||||
|
||||
(define (process-syntax x good bad name)
|
||||
(process-elements x good bad name
|
||||
(syntax-source x)
|
||||
(syntax-line x)
|
||||
(syntax-column x)
|
||||
(syntax-position x)
|
||||
(syntax-span x)))
|
||||
|
||||
(define (process-list x good bad name)
|
||||
(cond
|
||||
[(null? x)
|
||||
(bad
|
||||
"~a: expected a source location (a list of 5 elements); got an empty list: ~e"
|
||||
name
|
||||
x)]
|
||||
[(list? x)
|
||||
(let ([n (length x)])
|
||||
(if (= n 5)
|
||||
(apply process-elements x good bad name x)
|
||||
(bad
|
||||
"~a: expected a source location (a list of 5 elements); got a list of ~a elements: ~e"
|
||||
name
|
||||
n
|
||||
x)))]
|
||||
[(pair? x)
|
||||
(bad
|
||||
"~a: expected a source location (a list of 5 elements); got an improper list: ~e"
|
||||
name
|
||||
x)]
|
||||
[else
|
||||
(bad
|
||||
"~a: expected a source location list; got: ~e"
|
||||
name
|
||||
x)]))
|
||||
|
||||
(define (process-vector x good bad name)
|
||||
(if (vector? x)
|
||||
(let ([n (vector-length x)])
|
||||
(if (= n 5)
|
||||
(process-elements x good bad name
|
||||
(vector-ref x 0)
|
||||
(vector-ref x 1)
|
||||
(vector-ref x 2)
|
||||
(vector-ref x 3)
|
||||
(vector-ref x 4))
|
||||
(bad
|
||||
"~a: expected a source location (a vector of 5 elements); got a vector of ~a elements: ~e"
|
||||
name
|
||||
n
|
||||
x)))
|
||||
(bad
|
||||
"~a: expected a source location vector; got: ~e"
|
||||
name
|
||||
x)))
|
||||
|
||||
(define (process-elements x good bad name src line col pos span)
|
||||
(cond
|
||||
[(and line (not (exact-positive-integer? line)))
|
||||
(bad
|
||||
"~a: expected a source location with a positive line number or #f (second element); got line number ~e: ~e"
|
||||
name
|
||||
line
|
||||
x)]
|
||||
[(and col (not (exact-nonnegative-integer? col)))
|
||||
(bad
|
||||
"~a: expected a source location with a non-negative column number or #f (third element); got column number ~e: ~e"
|
||||
name
|
||||
col
|
||||
x)]
|
||||
[(or (and col (not line)) (and (not col) line))
|
||||
(bad
|
||||
"~a: expected a source location with line number and column number both numeric or both #f; got ~a and ~a respectively: ~e"
|
||||
name
|
||||
line
|
||||
col
|
||||
x)]
|
||||
[(and pos (not (exact-positive-integer? pos)))
|
||||
(bad
|
||||
"~a: expected a source location with a positive position or #f (fourth element); got line number ~e: ~e"
|
||||
name
|
||||
pos
|
||||
x)]
|
||||
[(and span (not (exact-nonnegative-integer? span)))
|
||||
(bad
|
||||
"~a: expected a source location with a non-negative span or #f (fifth element); got column number ~e: ~e"
|
||||
name
|
||||
span
|
||||
x)]
|
||||
[else (good x src line col pos span)]))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user