drscheme test suites now run
svn: r498
This commit is contained in:
Robby Findler
parent
c9046e4e44
commit
de72d31f2b
|
|
@ -243,23 +243,7 @@ profile todo:
|
|||
(display #\space (current-error-port))))))
|
||||
|
||||
(let ([srcs-to-display (find-src-to-display exn cms)])
|
||||
(for-each (λ (src-to-display)
|
||||
(let ([src (srcloc-source src-to-display)])
|
||||
(when (and (path? src) file-note%)
|
||||
(let ([note (new file-note%)])
|
||||
(send note set-callback
|
||||
(λ () (open-and-highlight-in-file src-to-display)))
|
||||
(write-special note (current-error-port))
|
||||
(display #\space (current-error-port))
|
||||
(display (path->string (find-relative-path (current-directory) src))
|
||||
(current-error-port))
|
||||
(let ([line (srcloc-line src-to-display)]
|
||||
[col (srcloc-column src-to-display)])
|
||||
(when (and (number? line)
|
||||
(number? col))
|
||||
(fprintf (current-error-port) ":~a:~a" line col)))
|
||||
(display ": " (current-error-port))))))
|
||||
srcs-to-display)
|
||||
(for-each display-srcloc-in-error srcs-to-display)
|
||||
|
||||
(display msg (current-error-port))
|
||||
(when (exn:fail:syntax? exn)
|
||||
|
|
@ -281,6 +265,48 @@ profile todo:
|
|||
(number? (cddr x))))
|
||||
cms))))))
|
||||
|
||||
;; display-srcloc-in-error : src-loc -> void
|
||||
;; prints out the src location information for src-to-display
|
||||
;; as it would appear in an error message
|
||||
(define (display-srcloc-in-error src-to-display)
|
||||
(let ([src (srcloc-source src-to-display)])
|
||||
(when (and (path? src) file-note%)
|
||||
(let ([note (new file-note%)])
|
||||
(send note set-callback
|
||||
(λ () (open-and-highlight-in-file src-to-display)))
|
||||
(write-special note (current-error-port))
|
||||
(display #\space (current-error-port))
|
||||
(display (path->string (find-relative-path (current-directory) src))
|
||||
(current-error-port))
|
||||
(let ([line (srcloc-line src-to-display)]
|
||||
[col (srcloc-column src-to-display)]
|
||||
[pos (srcloc-position src-to-display)])
|
||||
(cond
|
||||
[(and (number? line) (number? col))
|
||||
(fprintf (current-error-port) ":~a:~a" line col)]
|
||||
[pos
|
||||
(fprintf (current-error-port) "::~a" pos)]))
|
||||
(display ": " (current-error-port))))))
|
||||
|
||||
;; find-src-to-display : exn (union #f (listof (list* <src> number number)))
|
||||
;; -> (listof srclocs)
|
||||
;; finds the source location to display, choosing between
|
||||
;; the stack trace and the exception record.
|
||||
;; returns #f if the source isn't a string.
|
||||
(define (find-src-to-display exn cms)
|
||||
(cond
|
||||
[(exn:srclocs? exn)
|
||||
((exn:srclocs-accessor exn) exn)]
|
||||
[(pair? cms)
|
||||
(let ([fst (car cms)])
|
||||
(list (make-srcloc (car fst)
|
||||
#f
|
||||
#f
|
||||
(cadr fst)
|
||||
(cddr fst))))]
|
||||
[else '()]))
|
||||
|
||||
|
||||
(define (show-syntax-error-context port exn)
|
||||
(let ([error-text-style-delta (make-object style-delta%)])
|
||||
(send error-text-style-delta set-delta-foreground (make-object color% 200 0 0))
|
||||
|
|
@ -308,23 +334,6 @@ profile todo:
|
|||
(λ (rep errs arrows) (send rep highlight-errors errs arrows))
|
||||
orig-error-display-handler))
|
||||
|
||||
;; find-src-to-display : exn (union #f (listof (list* <src> number number)))
|
||||
;; -> (listof srclocs)
|
||||
;; finds the source location to display, choosing between
|
||||
;; the stack trace and the exception record.
|
||||
;; returns #f if the source isn't a string.
|
||||
(define (find-src-to-display exn cms)
|
||||
(cond
|
||||
[(exn:srclocs? exn)
|
||||
((exn:srclocs-accessor exn) exn)]
|
||||
[(pair? cms)
|
||||
(let ([fst (car cms)])
|
||||
(list (make-srcloc (car fst)
|
||||
#f
|
||||
#f
|
||||
(cadr fst)
|
||||
(cddr fst))))]
|
||||
[else '()]))
|
||||
|
||||
;; insert/clickback : (instanceof text%) (union string (instanceof snip%)) (-> void)
|
||||
;; inserts `note' and a space at the end of `rep'
|
||||
|
|
|
|||
|
|
@ -62,7 +62,10 @@
|
|||
show-error-and-highlight
|
||||
open-and-highlight-in-file
|
||||
show-backtrace-window
|
||||
get-cm-key))
|
||||
get-cm-key
|
||||
|
||||
display-srcloc-in-error
|
||||
show-syntax-error-context))
|
||||
|
||||
(define-signature drscheme:module-language^
|
||||
(add-module-language
|
||||
|
|
|
|||
|
|
@ -316,62 +316,69 @@
|
|||
(if (eq? (simple-settings-printing-style settings) 'current-print)
|
||||
(parameterize ([current-output-port port])
|
||||
((current-print) value))
|
||||
(let ([converted-value
|
||||
(simple-module-based-language-convert-value value settings)]
|
||||
[use-number-snip?
|
||||
(let ([converted-value (simple-module-based-language-convert-value value settings)])
|
||||
(setup-printing-parameters
|
||||
(λ ()
|
||||
(cond
|
||||
[(simple-settings-insert-newlines settings)
|
||||
(if (number? width)
|
||||
(parameterize ([pretty-print-columns width])
|
||||
(pretty-print converted-value port))
|
||||
(pretty-print converted-value port))]
|
||||
[else
|
||||
(parameterize ([pretty-print-columns 'infinity])
|
||||
(pretty-print converted-value port))
|
||||
(newline port)]))
|
||||
settings
|
||||
width))))
|
||||
|
||||
;; setup-printing-parameters : (-> void) -> void
|
||||
(define (setup-printing-parameters thunk settings width)
|
||||
(let ([use-number-snip?
|
||||
(λ (x)
|
||||
(and (number? x)
|
||||
(exact? x)
|
||||
(real? x)
|
||||
(not (integer? x))))])
|
||||
(parameterize ([pretty-print-columns width]
|
||||
[pretty-print-size-hook
|
||||
(λ (value display? port)
|
||||
(cond
|
||||
[(is-a? value snip%) 1]
|
||||
[(use-number-snip? value) 1]
|
||||
[(syntax? value) 1]
|
||||
[(to-snip-value? value) 1]
|
||||
[else #f]))]
|
||||
[pretty-print-print-hook
|
||||
(λ (value display? port)
|
||||
(cond
|
||||
[(is-a? value snip%)
|
||||
(write-special value port)
|
||||
1]
|
||||
[(use-number-snip? value)
|
||||
(write-special
|
||||
(case (simple-settings-fraction-style settings)
|
||||
[(mixed-fraction)
|
||||
(number-snip:make-fraction-snip value #f)]
|
||||
[(mixed-fraction-e)
|
||||
(number-snip:make-fraction-snip value #t)]
|
||||
[(repeating-decimal)
|
||||
(number-snip:make-repeating-decimal-snip value #f)]
|
||||
[(repeating-decimal-e)
|
||||
(number-snip:make-repeating-decimal-snip value #t)])
|
||||
port)
|
||||
1]
|
||||
[(syntax? value)
|
||||
(write-special (render-syntax/snip value))]
|
||||
[else (write-special (value->snip value))]))]
|
||||
[print-graph
|
||||
;; only turn on print-graph when using `write' printing
|
||||
;; style because the sharing is being taken care of
|
||||
;; by the print-convert sexp construction when using
|
||||
;; other printing styles.
|
||||
(and (eq? (simple-settings-printing-style settings) 'write)
|
||||
(simple-settings-show-sharing settings))])
|
||||
(cond
|
||||
[(simple-settings-insert-newlines settings)
|
||||
(if (number? width)
|
||||
(parameterize ([pretty-print-columns width])
|
||||
(pretty-print converted-value port))
|
||||
(pretty-print converted-value port))]
|
||||
[else
|
||||
(parameterize ([pretty-print-columns 'infinity])
|
||||
(pretty-print converted-value port))
|
||||
(newline port)])))))
|
||||
(parameterize ([pretty-print-columns width]
|
||||
[pretty-print-size-hook
|
||||
(λ (value display? port)
|
||||
(cond
|
||||
[(is-a? value snip%) 1]
|
||||
[(use-number-snip? value) 1]
|
||||
[(syntax? value) 1]
|
||||
[(to-snip-value? value) 1]
|
||||
[else #f]))]
|
||||
[pretty-print-print-hook
|
||||
(λ (value display? port)
|
||||
(cond
|
||||
[(is-a? value snip%)
|
||||
(write-special value port)
|
||||
1]
|
||||
[(use-number-snip? value)
|
||||
(write-special
|
||||
(case (simple-settings-fraction-style settings)
|
||||
[(mixed-fraction)
|
||||
(number-snip:make-fraction-snip value #f)]
|
||||
[(mixed-fraction-e)
|
||||
(number-snip:make-fraction-snip value #t)]
|
||||
[(repeating-decimal)
|
||||
(number-snip:make-repeating-decimal-snip value #f)]
|
||||
[(repeating-decimal-e)
|
||||
(number-snip:make-repeating-decimal-snip value #t)])
|
||||
port)
|
||||
1]
|
||||
[(syntax? value)
|
||||
(write-special (render-syntax/snip value))]
|
||||
[else (write-special (value->snip value))]))]
|
||||
[print-graph
|
||||
;; only turn on print-graph when using `write' printing
|
||||
;; style because the sharing is being taken care of
|
||||
;; by the print-convert sexp construction when using
|
||||
;; other printing styles.
|
||||
(and (eq? (simple-settings-printing-style settings) 'write)
|
||||
(simple-settings-show-sharing settings))])
|
||||
(thunk))))
|
||||
|
||||
;; drscheme-inspector : inspector
|
||||
(define drscheme-inspector (current-inspector))
|
||||
|
|
@ -412,6 +419,15 @@
|
|||
(error-display-handler))))
|
||||
(drscheme:debug:profiling-enabled (eq? annotations 'debug/profile))
|
||||
(drscheme:debug:test-coverage-enabled (eq? annotations 'test-coverage)))
|
||||
(global-port-print-handler
|
||||
(λ (value port)
|
||||
(let ([converted-value (simple-module-based-language-convert-value value setting)])
|
||||
(setup-printing-parameters
|
||||
(λ ()
|
||||
(parameterize ([pretty-print-columns 'infinity])
|
||||
(pretty-print converted-value port)))
|
||||
setting
|
||||
'infinity))))
|
||||
(current-inspector (make-inspector))
|
||||
(read-case-sensitive (simple-settings-case-sensitive setting)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -172,16 +172,22 @@ TODO
|
|||
;; the highlight must be set after the error message, because inserting into the text resets
|
||||
;; the highlighting.
|
||||
(define (drscheme-error-display-handler msg exn)
|
||||
(display msg (current-error-port))
|
||||
(newline (current-error-port))
|
||||
(flush-output (current-error-port))
|
||||
(let ([rep (current-rep)])
|
||||
(when (and (is-a? rep -text<%>)
|
||||
(eq? (current-error-port) (send rep get-err-port)))
|
||||
(parameterize ([current-eventspace drscheme:init:system-eventspace])
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(send rep highlight-errors/exn exn)))))))
|
||||
(let ([src-locs (if (exn:srclocs? exn)
|
||||
((exn:srclocs-accessor exn) exn)
|
||||
'())])
|
||||
(for-each drscheme:debug:display-srcloc-in-error src-locs)
|
||||
(display msg (current-error-port))
|
||||
(when (exn:fail:syntax? exn)
|
||||
(drscheme:debug:show-syntax-error-context (current-error-port) exn))
|
||||
(newline (current-error-port))
|
||||
(flush-output (current-error-port))
|
||||
(let ([rep (current-rep)])
|
||||
(when (and (is-a? rep -text<%>)
|
||||
(eq? (current-error-port) (send rep get-err-port)))
|
||||
(parameterize ([current-eventspace drscheme:init:system-eventspace])
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(send rep highlight-errors/exn exn))))))))
|
||||
|
||||
;; drscheme-error-value->string-handler : TST number -> string
|
||||
(define (drscheme-error-value->string-handler x n)
|
||||
|
|
@ -1241,7 +1247,6 @@ TODO
|
|||
(current-error-port (get-err-port))
|
||||
(current-value-port (get-value-port))
|
||||
(current-input-port (get-in-box-port))
|
||||
;(current-input-port (make-input-port #f (λ (bytes) eof) #f void))
|
||||
(break-enabled #t)
|
||||
(let* ([primitive-dispatch-handler (event-dispatch-handler)])
|
||||
(event-dispatch-handler
|
||||
|
|
@ -1505,7 +1510,7 @@ TODO
|
|||
|
||||
(define input-delta (make-object style-delta%))
|
||||
(send input-delta set-delta-foreground (make-object color% 0 150 0))
|
||||
|
||||
|
||||
;; insert-error-in-text : (is-a?/c text%)
|
||||
;; (union #f (is-a?/c drscheme:rep:text<%>))
|
||||
;; string?
|
||||
|
|
@ -1533,13 +1538,13 @@ TODO
|
|||
[insert-file-name/icon
|
||||
;; insert-file-name/icon : string number number number number -> void
|
||||
(λ (source-name start span row col)
|
||||
(let* ([range-spec
|
||||
(cond
|
||||
[(and row col)
|
||||
(format ":~a:~a" row col)]
|
||||
[start
|
||||
(format "::~a" start)]
|
||||
[else ""])])
|
||||
(let ([range-spec
|
||||
(cond
|
||||
[(and row col)
|
||||
(format ":~a:~a" row col)]
|
||||
[start
|
||||
(format "::~a" start)]
|
||||
[else ""])])
|
||||
(cond
|
||||
[(file-exists? source-name)
|
||||
(let* ([normalized-name (normalize-path source-name)]
|
||||
|
|
|
|||
|
|
@ -1015,7 +1015,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
(drscheme:eval:expand-program
|
||||
(drscheme:language:make-text/pos definitions-text
|
||||
0
|
||||
(get-post-hash-bang-start definitions-text)
|
||||
(send definitions-text last-position))
|
||||
(send definitions-text get-next-settings)
|
||||
#t
|
||||
|
|
@ -1051,6 +1051,19 @@ If the namespace does not, they are colored the unbound color.
|
|||
(update-status-line 'drscheme:check-syntax status-expanding-expression)
|
||||
(loop)]))))))))))]))
|
||||
|
||||
(define/private (get-post-hash-bang-start definitions-text)
|
||||
(cond
|
||||
[(< (send definitions-text last-position) 2)
|
||||
0]
|
||||
[(equal? '(#\# #\!)
|
||||
(list (send definitions-text get-character 0)
|
||||
(send definitions-text get-character 1)))
|
||||
(let ([last-para (send definitions-text last-paragraph)])
|
||||
(if (zero? last-para)
|
||||
(send definitions-text last-position)
|
||||
(send definitions-text paragraph-start-position 1)))]
|
||||
[else 0]))
|
||||
|
||||
;; set-directory : text -> void
|
||||
;; sets the current-directory and current-load-relative-directory
|
||||
;; based on the file saved in the definitions-text
|
||||
|
|
|
|||
|
|
@ -118,7 +118,7 @@ the settings above should match r5rs
|
|||
(test-expression "(exact? 1.5)" "#f")
|
||||
|
||||
(test-expression "(list 1)" "(1)")
|
||||
(test-expression "(car (list))" "car: expects argument of type <pair>; given ()")
|
||||
(test-expression "(car (list))" "{bug09.gif} car: expects argument of type <pair>; given ()")
|
||||
|
||||
(test-expression "argv" "#0()")))
|
||||
|
||||
|
|
@ -213,7 +213,7 @@ the settings above should match r5rs
|
|||
(test-expression ",1" "unquote: not in quasiquote in: (unquote 1)")
|
||||
|
||||
(test-expression "(list 1)" "(1)")
|
||||
(test-expression "(car (list))" "car: expects argument of type <pair>; given ()")
|
||||
(test-expression "(car (list))" "{bug09.gif} car: expects argument of type <pair>; given ()")
|
||||
|
||||
(test-expression "argv" "#0()")))
|
||||
|
||||
|
|
@ -255,7 +255,8 @@ the settings above should match r5rs
|
|||
"#f")
|
||||
(test-expression "(define x 1)(define x 2)" "")
|
||||
|
||||
(test-expression "(define-struct spider (legs))(make-spider 4)" "#<struct:spider>")
|
||||
(test-expression "(define-struct spider (legs))(make-spider 4)"
|
||||
"{bug09.gif} reference to undefined identifier: define-struct")
|
||||
|
||||
(test-expression "(sqrt -1)" "0+1i")
|
||||
|
||||
|
|
@ -269,27 +270,27 @@ the settings above should match r5rs
|
|||
(test-expression "(define (f car) 1)" "")
|
||||
(test-expression "(define (f empty) 1)" "")
|
||||
|
||||
(test-expression "call/cc" "#<primitive:call-with-current-continuation>")
|
||||
(test-expression "call/cc" "{bug09.gif} reference to undefined identifier: call/cc")
|
||||
|
||||
(test-expression "(error 'a \"~a\" 1)" "{bug09.gif} a: 1")
|
||||
(test-expression "(error \"a\" \"a\")" "{bug09.gif} a \"a\"")
|
||||
(test-expression "(error 'a \"~a\" 1)" "{bug09.gif} reference to undefined identifier: error")
|
||||
(test-expression "(error \"a\" \"a\")" "{bug09.gif} reference to undefined identifier: error")
|
||||
|
||||
(test-expression "(time 1)"
|
||||
#rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
|
||||
"{bug09.gif} reference to undefined identifier: time")
|
||||
|
||||
(test-expression "true" "{bug09.gif} reference to undefined identifier: true")
|
||||
(test-expression "mred^" "{bug09.gif} reference to undefined identifier: mred^")
|
||||
(test-expression "(eq? 'a 'A)" "#t")
|
||||
(test-expression "(set! x 1)" "{bug09.gif} set!: cannot set undefined identifier: x")
|
||||
(test-expression "(cond [(= 1 2) 3])" "")
|
||||
(test-expression "(cond ((= 1 2) 3))" "")
|
||||
(test-expression "(cons 1 2)" "(1 . 2)")
|
||||
(test-expression "'(1)" "(1)")
|
||||
(test-expression "(define shrd (box 1)) (list shrd shrd)"
|
||||
"(#&1 #&1)")
|
||||
(test-expression "(define shrd (cons 1 1)) (list shrd shrd)"
|
||||
"((1 . 1) (1 . 1))")
|
||||
(test-expression
|
||||
"(local ((define x x)) 1)"
|
||||
#rx"define: not allowed in an expression context")
|
||||
(test-expression "(letrec ([x x]) 1)" "1")
|
||||
(test-expression "(letrec ((x x)) 1)" "1")
|
||||
(test-expression "(if 1 1 1)" "1")
|
||||
(test-expression "(+ 1)" "1")
|
||||
|
||||
|
|
@ -308,13 +309,14 @@ the settings above should match r5rs
|
|||
(test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}")
|
||||
(test-expression "(exact? 1.5)" "#f")
|
||||
|
||||
(test-expression "(let ([f (lambda (x) x)]) f)" "#<procedure:f>")
|
||||
(test-expression "(let ((f (lambda (x) x))) f)" "#<procedure:f>")
|
||||
(test-expression ",1" "unquote: not in quasiquote in: (unquote 1)")
|
||||
|
||||
(test-expression "(list 1)" "(1)")
|
||||
(test-expression "(car (list))" "car: expects argument of type <pair>; given ()")
|
||||
(test-expression "(car (list))"
|
||||
"{bug09.gif} car: expects argument of type <pair>; given ()")
|
||||
|
||||
(test-expression "argv" "#0()")))
|
||||
(test-expression "argv" "{bug09.gif} reference to undefined identifier: argv")))
|
||||
|
||||
;; ;
|
||||
;
|
||||
|
|
@ -1062,7 +1064,7 @@ the settings above should match r5rs
|
|||
(clear-definitions drs)
|
||||
(for-each fw:test:keystroke
|
||||
(string->list
|
||||
"(define (f n)\n(cond [(zero? n) null]\n[else (cons n (f (- n 1)))]))\n(f 200)"))
|
||||
"(define (f n)\n(cond ((zero? n) '())\n(else (cons n (f (- n 1))))))\n(f 200)"))
|
||||
(test "Constructor" #f #f
|
||||
(case-lambda
|
||||
[(x) (not (member #\newline (string->list x)))]
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
|
||||
(define-struct loc (line col offset))
|
||||
;; loc = (make-loc number number number)
|
||||
;; numbers in loc structs start at zero.
|
||||
;; all numbers in loc structs start at zero.
|
||||
|
||||
(define-struct test (program
|
||||
;; : (union
|
||||
|
|
@ -116,7 +116,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(make-test "("
|
||||
"~aread: expected a ')'"
|
||||
"~aread: expected a ')'"
|
||||
#t
|
||||
#f
|
||||
(cons (make-loc 0 0 0) (make-loc 0 1 1))
|
||||
'read
|
||||
#f
|
||||
|
|
@ -126,7 +126,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(make-test "."
|
||||
"~aread: illegal use of \".\""
|
||||
"~aread: illegal use of \".\""
|
||||
#t
|
||||
#f
|
||||
(cons (make-loc 0 0 0) (make-loc 0 1 1))
|
||||
'read
|
||||
#f
|
||||
|
|
@ -136,7 +136,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(make-test "(lambda ())"
|
||||
"~alambda: bad syntax in: (lambda ())"
|
||||
"~alambda: bad syntax in: (lambda ())"
|
||||
#t
|
||||
#f
|
||||
(cons (make-loc 0 0 0) (make-loc 0 11 11))
|
||||
'expand
|
||||
#t
|
||||
|
|
@ -512,7 +512,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
void)
|
||||
|
||||
(make-test "(current-namespace (make-namespace 'empty))\nif"
|
||||
"~acompile: bad syntax; reference to top-level identifiers is not allowed, because no #%top syntax transformer is bound in: if"
|
||||
"~acompile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: if"
|
||||
#f
|
||||
#f
|
||||
(cons (make-loc 1 0 44) (make-loc 1 0 46))
|
||||
|
|
@ -563,8 +563,8 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
|
||||
;; should produce a syntax object with a turn-down triangle.
|
||||
(make-test "(write (list (syntax x)))"
|
||||
"({syntax-snip})"
|
||||
"({syntax-snip})"
|
||||
"({embedded \".#<syntax:1:21>\"})"
|
||||
"({embedded \".#<syntax:/Users/robby/svn/plt/collects/tests/drscheme/repl-test-tmp.ss:1:21>\"})"
|
||||
#f
|
||||
'interactions
|
||||
#f
|
||||
|
|
@ -665,8 +665,8 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(make-test (list "(" '("Special" "Insert λ") "())")
|
||||
"~aλ: bad syntax in: (λ ())"
|
||||
"~aλ: bad syntax in: (λ ())"
|
||||
#t
|
||||
(cons (make-loc 0 0 0) (make-loc 0 11 11))
|
||||
#f
|
||||
(cons (make-loc 0 0 0) (make-loc 0 5 5))
|
||||
'expand
|
||||
#t
|
||||
#f
|
||||
|
|
@ -765,6 +765,8 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(number->string (+ 1 (loc-line (car source-location)))))]
|
||||
[start-col (and source-location-in-message
|
||||
(number->string (loc-col (car source-location))))]
|
||||
[start-pos (and (pair? source-location)
|
||||
(number->string (+ 1 (loc-offset (car source-location)))))]
|
||||
[formatted-execute-answer
|
||||
(let* ([w/backtrace
|
||||
(if (and (test-has-backtrace? in-vector)
|
||||
|
|
@ -782,29 +784,40 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
[load-answer (test-load-answer in-vector)]
|
||||
[formatted-load-answer
|
||||
(and load-answer
|
||||
(let* ([w/file-icon
|
||||
(if raw?
|
||||
(if source-location-in-message
|
||||
(string-append file-image-string " " load-answer)
|
||||
load-answer)
|
||||
(if (or (eq? source-location 'definitions)
|
||||
(pair? source-location))
|
||||
(string-append file-image-string " " load-answer)
|
||||
load-answer))]
|
||||
[w/backtrace
|
||||
(if raw?
|
||||
w/file-icon
|
||||
(if (or (eq? source-location 'definitions)
|
||||
(pair? source-location))
|
||||
(string-append backtrace-image-string " " w/file-icon)
|
||||
w/file-icon))])
|
||||
(if source-location-in-message
|
||||
(format w/file-icon
|
||||
(format "~a:~a:~a: "
|
||||
short-tmp-load-filename
|
||||
start-line
|
||||
start-col))
|
||||
w/file-icon)))]
|
||||
(let ([line-col-loc-str
|
||||
(and source-location-in-message
|
||||
(format "~a:~a:~a: "
|
||||
short-tmp-load-filename
|
||||
start-line
|
||||
start-col))]
|
||||
[pos-col-str
|
||||
(if (pair? source-location)
|
||||
(format "~a::~a:"
|
||||
short-tmp-load-filename
|
||||
start-pos)
|
||||
"")])
|
||||
(if raw?
|
||||
(if source-location-in-message
|
||||
(string-append file-image-string
|
||||
" "
|
||||
(format load-answer line-col-loc-str))
|
||||
load-answer)
|
||||
(cond
|
||||
[source-location-in-message
|
||||
;; syntax error or read time error, so has a back trace
|
||||
;; (the call to load) and line/col info
|
||||
(string-append backtrace-image-string " "
|
||||
file-image-string " "
|
||||
(format load-answer line-col-loc-str))]
|
||||
[(or (eq? source-location 'definitions)
|
||||
(pair? source-location))
|
||||
;; run-time error, so has a backtrace (the call to to load)
|
||||
;; but only offset info
|
||||
(string-append backtrace-image-string " "
|
||||
file-image-string " "
|
||||
pos-col-str " "
|
||||
load-answer)]
|
||||
[else load-answer]))))]
|
||||
[breaking-test? (test-breaking-test? in-vector)])
|
||||
|
||||
(setup)
|
||||
|
|
@ -984,5 +997,6 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
|
||||
;(set-language-level! (list "PLT" "Graphical (MrEd)")) (kill-tests)
|
||||
|
||||
(run-test-in-language-level #t)
|
||||
(run-test-in-language-level #f)
|
||||
(run-test-in-language-level #t)))
|
||||
))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user