trims the top of the stack, removing drscheme-specific frames, plus fixes to the test suites
svn: r3792
This commit is contained in:
Robby Findler
parent
7fdf03bffd
commit
61254b02e7
|
|
@ -172,10 +172,11 @@ 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)
|
||||
(let* ([srclocs-stack
|
||||
(if (exn? exn)
|
||||
(filter values (map cdr (continuation-mark-set->context (exn-continuation-marks exn))))
|
||||
(let* ([cut-stack (if (and (exn? exn)
|
||||
(main-user-eventspace-thread?))
|
||||
(cut-out-top-of-stack exn)
|
||||
'())]
|
||||
[srclocs-stack (filter values (map cdr cut-stack))]
|
||||
[stack
|
||||
(filter
|
||||
values
|
||||
|
|
@ -191,6 +192,16 @@ TODO
|
|||
(if (null? stack)
|
||||
'()
|
||||
(list (car srclocs-stack))))])
|
||||
|
||||
;; for use in debugging the stack trace stuff
|
||||
#;
|
||||
(when (exn? exn)
|
||||
(print-struct #t)
|
||||
(for-each
|
||||
(λ (frame) (printf " ~s\n" frame))
|
||||
(continuation-mark-set->context (exn-continuation-marks exn)))
|
||||
(printf "\n"))
|
||||
|
||||
(unless (null? stack)
|
||||
(drscheme:debug:print-bug-to-stderr msg stack))
|
||||
(for-each drscheme:debug:display-srcloc-in-error src-locs)
|
||||
|
|
@ -209,6 +220,58 @@ TODO
|
|||
src-locs
|
||||
(filter (λ (x) (is-a? (car x) text%)) stack)))))))))
|
||||
|
||||
(define (main-user-eventspace-thread?)
|
||||
(let ([rep (current-rep)])
|
||||
(and rep
|
||||
(eq? (eventspace-handler-thread (send rep get-user-eventspace))
|
||||
(current-thread)))))
|
||||
|
||||
(define (cut-out-top-of-stack exn)
|
||||
(let ([initial-stack (continuation-mark-set->context (exn-continuation-marks exn))])
|
||||
(let loop ([stack (reverse initial-stack)]
|
||||
[hit-2? #f])
|
||||
(cond
|
||||
[(null? stack)
|
||||
(unless (exn:break? exn)
|
||||
;; give break exn's a free pass on this one.
|
||||
;; sometimes they get raised in a funny place.
|
||||
;; (see call-with-break-parameterization below)
|
||||
(fprintf (current-error-port) "ACK! didn't find drscheme's stackframe when filtering\n"))
|
||||
initial-stack]
|
||||
[else
|
||||
(let ([top (car stack)])
|
||||
(cond
|
||||
[(is-cut? top 'cut-stacktrace-above-here1)
|
||||
(if hit-2?
|
||||
(reverse (cdr stack))
|
||||
(begin
|
||||
(fprintf (current-error-port) "ACK! found 1 without 2\n")
|
||||
initial-stack))]
|
||||
[(is-cut? top 'cut-stacktrace-above-here2)
|
||||
(if hit-2?
|
||||
(reverse (cdr stack))
|
||||
(loop (cdr stack) #t))]
|
||||
[else
|
||||
(loop (cdr stack) hit-2?)]))]))))
|
||||
|
||||
;; is-cut? : any symbol -> boolean
|
||||
;; determines if this stack entry is really
|
||||
(define (is-cut? top sym)
|
||||
(and (pair? top)
|
||||
(let* ([fn-name (car top)]
|
||||
[srcloc (cdr top)]
|
||||
[source (and srcloc (srcloc-source srcloc))])
|
||||
(and (eq? fn-name sym)
|
||||
(path? source)
|
||||
(let loop ([path source]
|
||||
[pieces '(#"rep.ss" #"private" #"drscheme" #"collects")])
|
||||
(cond
|
||||
[(null? pieces) #t]
|
||||
[else
|
||||
(let-values ([(base name dir?) (split-path path)])
|
||||
(and (equal? (path->bytes name) (car pieces))
|
||||
(loop base (cdr pieces))))]))))))
|
||||
|
||||
;; drscheme-error-value->string-handler : TST number -> string
|
||||
(define (drscheme-error-value->string-handler x n)
|
||||
(let ([port (open-output-string)])
|
||||
|
|
@ -960,7 +1023,8 @@ TODO
|
|||
(λ () ; =User=, =Handler=, =No-Breaks=
|
||||
(let* ([settings (current-language-settings)]
|
||||
[lang (drscheme:language-configuration:language-settings-language settings)]
|
||||
[settings (drscheme:language-configuration:language-settings-settings settings)])
|
||||
[settings (drscheme:language-configuration:language-settings-settings settings)]
|
||||
[dummy-value (box #f)])
|
||||
(set! get-sexp/syntax/eof
|
||||
(if complete-program?
|
||||
(send lang front-end/complete-program port settings user-teachpack-cache)
|
||||
|
|
@ -981,19 +1045,33 @@ TODO
|
|||
(current-error-escape-k (λ ()
|
||||
(set! cleanup? #t)
|
||||
(k (void)))))
|
||||
|
||||
(λ ()
|
||||
(let loop ()
|
||||
(let ([sexp/syntax/eof (get-sexp/syntax/eof)])
|
||||
(let ([sexp/syntax/eof
|
||||
;; this named thunk & application helps drscheme know to cut
|
||||
;; off part of the stack trace. (too bad not all of it ...)
|
||||
((rec cut-stacktrace-above-here1
|
||||
(λ ()
|
||||
(begin0 (get-sexp/syntax/eof)
|
||||
(void)))))])
|
||||
(unless (eof-object? sexp/syntax/eof)
|
||||
(call-with-break-parameterization
|
||||
(get-user-break-parameterization)
|
||||
;; a break exn may be raised right at this point,
|
||||
;; in which case the stack won't be in a trimmable state
|
||||
;; so we don't complain (above) when we find an untrimmable
|
||||
;; break exn.
|
||||
(λ ()
|
||||
(call-with-values
|
||||
(rec cut-stacktrace-above-here1
|
||||
(λ ()
|
||||
(eval-syntax sexp/syntax/eof))
|
||||
(begin0 (eval-syntax sexp/syntax/eof)
|
||||
(void))))
|
||||
(λ x (display-results x)))))
|
||||
(loop))))
|
||||
(set! cleanup? #t))
|
||||
|
||||
(λ ()
|
||||
(current-error-escape-k saved-error-escape-k)
|
||||
(when cleanup?
|
||||
|
|
@ -1074,10 +1152,11 @@ TODO
|
|||
(current-error-escape-k (λ ()
|
||||
(set! cleanup? #t)
|
||||
(k (void)))))
|
||||
(rec cut-stacktrace-above-here2
|
||||
(λ ()
|
||||
(thunk)
|
||||
; Breaks must be off!
|
||||
(set! cleanup? #t))
|
||||
(set! cleanup? #t)))
|
||||
(λ ()
|
||||
(current-error-escape-k saved-error-escape-k)
|
||||
(when cleanup?
|
||||
|
|
|
|||
|
|
@ -1081,7 +1081,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) (list))\n(else (cons n (f (- n 1))))))\n(f 200)"))
|
||||
(test "Constructor" #f #f
|
||||
(case-lambda
|
||||
[(x) (not (member #\newline (string->list x)))]
|
||||
|
|
|
|||
|
|
@ -31,12 +31,10 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
;; 'left // left arrow key
|
||||
;; (list string? string?)))) // menu item select
|
||||
|
||||
execute-answer ;; : string
|
||||
load-answer ;; : (union #f string)
|
||||
|
||||
has-backtrace? ;; : boolean
|
||||
;; indicates if the backtrace icon should appear for this test
|
||||
;; only applies to the debug tests
|
||||
raw-execute-answer ;; answer when executing without debugging
|
||||
raw-load-answer ;; answer when loading after executing (w/out debugging)
|
||||
err-execute-answer ;; answer when executing with debugging
|
||||
err-load-answer ;; answer when loading after executing (with debugging)
|
||||
|
||||
source-location ;; : (union 'definitions
|
||||
;; 'interactions
|
||||
|
|
@ -47,15 +45,6 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
;; if 'definitions, no source location and
|
||||
;; the focus must be in the definitions window
|
||||
|
||||
source-location-in-message ;; : (union #f 'read 'expand)
|
||||
;; 'read indicates that the error message is a read error, so
|
||||
;; the source location is the port info, and 'expand indicates
|
||||
;; that the error messsage is an expansion time error, so the
|
||||
;; the source location is the repl.
|
||||
;; #f indicates no source location error message
|
||||
;; if this field is not #f, the execute-answer and load-answer fields
|
||||
;; are expected to be `format'able strings with one ~a in them.
|
||||
|
||||
breaking-test? ;; : boolean
|
||||
|
||||
;; setup is called before the test case is run.
|
||||
|
|
@ -66,128 +55,130 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
|
||||
(define test-data
|
||||
(list
|
||||
|
||||
;; basic tests
|
||||
(make-test "1"
|
||||
"1"
|
||||
"1"
|
||||
#f
|
||||
"1"
|
||||
"1"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "\"a\""
|
||||
"\"a\""
|
||||
"\"a\""
|
||||
#f
|
||||
"\"a\""
|
||||
"\"a\""
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "1 2"
|
||||
"1\n2"
|
||||
"2"
|
||||
#f
|
||||
"1\n2"
|
||||
"2"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "\"a\" \"b\""
|
||||
"\"a\"\n\"b\""
|
||||
"\"b\""
|
||||
#f
|
||||
"\"a\"\n\"b\""
|
||||
"\"b\""
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "("
|
||||
"~aread: expected a ')'"
|
||||
"~aread: expected a ')'"
|
||||
#f
|
||||
"{bug09.gif} read: expected a ')'"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: read: expected a ')'"
|
||||
"read: expected a ')'"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: read: expected a ')'"
|
||||
(cons (make-loc 0 0 0) (make-loc 0 1 1))
|
||||
'read
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "."
|
||||
"~aread: illegal use of \".\""
|
||||
"~aread: illegal use of \".\""
|
||||
#f
|
||||
"{bug09.gif} read: illegal use of \".\""
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: read: illegal use of \".\""
|
||||
"read: illegal use of \".\""
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: read: illegal use of \".\""
|
||||
(cons (make-loc 0 0 0) (make-loc 0 1 1))
|
||||
'read
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "(lambda ())"
|
||||
"~alambda: bad syntax in: (lambda ())"
|
||||
"~alambda: bad syntax in: (lambda ())"
|
||||
#f
|
||||
"lambda: bad syntax in: (lambda ())"
|
||||
"{file.gif} repl-test-tmp.ss:1:0: lambda: bad syntax in: (lambda ())"
|
||||
"lambda: bad syntax in: (lambda ())"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: lambda: bad syntax in: (lambda ())"
|
||||
(cons (make-loc 0 0 0) (make-loc 0 11 11))
|
||||
'expand
|
||||
#f
|
||||
void
|
||||
void)
|
||||
(make-test "xx"
|
||||
"reference to undefined identifier: xx"
|
||||
"reference to undefined identifier: xx"
|
||||
#t
|
||||
"{bug09.gif} reference to undefined identifier: xx"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss::1: reference to undefined identifier: xx"
|
||||
(cons (make-loc 0 0 0) (make-loc 0 2 2))
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
(make-test "(raise 1)"
|
||||
"uncaught exception: 1"
|
||||
"uncaught exception: 1"
|
||||
#f
|
||||
"uncaught exception: 1"
|
||||
"uncaught exception: 1"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
(make-test "(raise #f)"
|
||||
"uncaught exception: #f"
|
||||
"uncaught exception: #f"
|
||||
#f
|
||||
"uncaught exception: #f"
|
||||
"uncaught exception: #f"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "(values 1 2)"
|
||||
"1\n2"
|
||||
"1\n2"
|
||||
#f
|
||||
"1\n2"
|
||||
"1\n2"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
(make-test "(list 1 2)"
|
||||
"(1 2)"
|
||||
"(1 2)"
|
||||
#f
|
||||
"(1 2)"
|
||||
"(1 2)"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "(parameterize ([print-struct #t])(define-struct s (x) (make-inspector))(printf \"~s\\n\" (make-s 1)))"
|
||||
"#(struct:s 1)"
|
||||
"#(struct:s 1)"
|
||||
#f
|
||||
"#(struct:s 1)"
|
||||
"#(struct:s 1)"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
|
|
@ -195,81 +186,90 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(make-test "(define (f) (+ 1 1)) (define + -) (f)"
|
||||
"0"
|
||||
"0"
|
||||
#f
|
||||
"0"
|
||||
"0"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "(begin (define-struct a ()) (define-struct (b a) ()))"
|
||||
""
|
||||
""
|
||||
#f
|
||||
""
|
||||
""
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "(begin (values) 1)"
|
||||
"1"
|
||||
"1"
|
||||
#f
|
||||
"1"
|
||||
"1"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
#|
|
||||
;; syntax error template
|
||||
"{bug09.gif} "
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: "
|
||||
""
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: "
|
||||
|#
|
||||
|
||||
(make-test (string-append
|
||||
"(module m mzscheme (provide e) (define e #'1))\n"
|
||||
"(module n mzscheme (require-for-syntax m) (provide s) (define-syntax (s stx) e))\n"
|
||||
"(require n)\n"
|
||||
"s")
|
||||
"~acompile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
||||
"~acompile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
||||
#f
|
||||
"compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
||||
"{file.gif} repl-test-tmp.ss:1:43: compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
||||
"compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:43: compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
||||
(cons (make-loc 0 43 43) (make-loc 0 44 44))
|
||||
'expand
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
|
||||
;; leading comment test
|
||||
(make-test "#!\n1"
|
||||
"1"
|
||||
"1"
|
||||
#f
|
||||
"1"
|
||||
"1"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "#!/bin/sh\nxx"
|
||||
"reference to undefined identifier: xx"
|
||||
"reference to undefined identifier: xx"
|
||||
#t
|
||||
"{bug09.gif} reference to undefined identifier: xx"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss::11: reference to undefined identifier: xx"
|
||||
(cons (make-loc 1 0 10) (make-loc 1 2 12))
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
#|
|
||||
(make-test (list "#!\n"
|
||||
'("Special" "Insert XML Box")
|
||||
"<a>")
|
||||
"(a ())"
|
||||
"(a ())"
|
||||
#f
|
||||
"(a ())"
|
||||
"(a ())"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
#|
|
||||
;; XML tests
|
||||
(make-test
|
||||
'(("Special" "Insert XML Box")
|
||||
|
|
@ -324,171 +324,169 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
#f
|
||||
void
|
||||
void)
|
||||
|#
|
||||
|
||||
|#
|
||||
;; eval tests
|
||||
|
||||
(make-test " (eval '(values 1 2))"
|
||||
"1\n2"
|
||||
"1\n2"
|
||||
#f
|
||||
"1\n2"
|
||||
"1\n2"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test " (eval '(list 1 2))"
|
||||
"(1 2)"
|
||||
"(1 2)"
|
||||
#f
|
||||
"(1 2)"
|
||||
"(1 2)"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test " (eval '(lambda ()))"
|
||||
"lambda: bad syntax in: (lambda ())"
|
||||
"lambda: bad syntax in: (lambda ())"
|
||||
2
|
||||
"{bug09.gif} lambda: bad syntax in: (lambda ())"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss::5: lambda: bad syntax in: (lambda ())"
|
||||
(cons (make-loc 0 4 4) (make-loc 0 23 23))
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
(make-test " (eval 'x)"
|
||||
"reference to undefined identifier: x"
|
||||
"reference to undefined identifier: x"
|
||||
2
|
||||
"{bug09.gif} reference to undefined identifier: x"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss::5: reference to undefined identifier: x"
|
||||
(cons (make-loc 0 4 4) (make-loc 0 13 13))
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "(eval (box 1))"
|
||||
"#&1"
|
||||
"#&1"
|
||||
#f
|
||||
"#&1"
|
||||
"#&1"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "(eval '(box 1))"
|
||||
"#&1"
|
||||
"#&1"
|
||||
#f
|
||||
"#&1"
|
||||
"#&1"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
; printer setup test
|
||||
(make-test "(car (void))"
|
||||
"car: expects argument of type <pair>; given #<void>"
|
||||
"car: expects argument of type <pair>; given #<void>"
|
||||
2
|
||||
"{bug09.gif} car: expects argument of type <pair>; given #<void>"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss::1: car: expects argument of type <pair>; given #<void>"
|
||||
(cons (make-loc 0 0 0) (make-loc 0 12 12))
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
;; error in the middle
|
||||
(make-test "1 2 ( 3 4"
|
||||
"1\n2\n~aread: expected a ')'"
|
||||
"~aread: expected a ')'"
|
||||
#f
|
||||
"1\n2\n{bug09.gif} read: expected a ')'"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:4: read: expected a ')'"
|
||||
"1\n2\nread: expected a ')'"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:4: read: expected a ')'"
|
||||
(cons (make-loc 0 4 4) (make-loc 0 9 9))
|
||||
'read
|
||||
#f
|
||||
void
|
||||
void)
|
||||
(make-test "1 2 . 3 4"
|
||||
"1\n2\n~aread: illegal use of \".\""
|
||||
"~aread: illegal use of \".\""
|
||||
#f
|
||||
"1\n2\n{bug09.gif} read: illegal use of \".\""
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:4: read: illegal use of \".\""
|
||||
"1\n2\nread: illegal use of \".\""
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:4: read: illegal use of \".\""
|
||||
(cons (make-loc 0 4 4) (make-loc 0 5 5))
|
||||
'read
|
||||
#f
|
||||
void
|
||||
void)
|
||||
(make-test "1 2 (lambda ()) 3 4"
|
||||
"1\n2\n~alambda: bad syntax in: (lambda ())"
|
||||
"~alambda: bad syntax in: (lambda ())"
|
||||
#f
|
||||
"1\n2\nlambda: bad syntax in: (lambda ())"
|
||||
"{file.gif} repl-test-tmp.ss:1:4: lambda: bad syntax in: (lambda ())"
|
||||
"1\n2\nlambda: bad syntax in: (lambda ())"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:4: lambda: bad syntax in: (lambda ())"
|
||||
(cons (make-loc 0 4 4) (make-loc 0 15 15))
|
||||
'expand
|
||||
#f
|
||||
void
|
||||
void)
|
||||
(make-test "1 2 x 3 4"
|
||||
"1\n2\nreference to undefined identifier: x"
|
||||
"reference to undefined identifier: x"
|
||||
#t
|
||||
"1\n2\n{bug09.gif} reference to undefined identifier: x"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss::5: reference to undefined identifier: x"
|
||||
(cons (make-loc 0 4 4) (make-loc 0 5 5))
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
(make-test "1 2 (raise 1) 3 4"
|
||||
"1\n2\nuncaught exception: 1"
|
||||
"uncaught exception: 1"
|
||||
#f
|
||||
"1\n2\nuncaught exception: 1"
|
||||
"uncaught exception: 1"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
(make-test "1 2 (raise #f) 3 4"
|
||||
"1\n2\nuncaught exception: #f"
|
||||
"uncaught exception: #f"
|
||||
#f
|
||||
"1\n2\nuncaught exception: #f"
|
||||
"uncaught exception: #f"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
;; error across separate files
|
||||
(let ([tmp-filename (make-temporary-file "dr-repl-test~a.ss")])
|
||||
(make-test
|
||||
(format "(load ~s) (f (lambda () (+ 1 (car 1))))" (path->string tmp-filename))
|
||||
"car: expects argument of type <pair>; given 1"
|
||||
"car: expects argument of type <pair>; given 1"
|
||||
#t
|
||||
(cons (make-loc -1 -1 (+ (string-length (path->string tmp-filename)) 29))
|
||||
(make-loc -1 -1 (+ (string-length (path->string tmp-filename)) 36)))
|
||||
"(load \"repl-test-tmp2.ss\") (define (g) (+ 1 (car 1))) (f g)"
|
||||
"{bug09.gif} car: expects argument of type <pair>; given 1"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:27: car: expects argument of type <pair>; given 1"
|
||||
"{bug09.gif} car: expects argument of type <pair>; given 1"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss::45: car: expects argument of type <pair>; given 1"
|
||||
(cons (make-loc -1 -1 44)
|
||||
(make-loc -1 -1 51))
|
||||
#f
|
||||
#f
|
||||
(lambda ()
|
||||
(call-with-output-file tmp-filename
|
||||
(λ ()
|
||||
(call-with-output-file (build-path tmp-load-directory "repl-test-tmp2.ss")
|
||||
(lambda (port)
|
||||
(write '(define (f t) (+ 1 (t)))
|
||||
port))
|
||||
'truncate))
|
||||
(lambda ()
|
||||
(delete-file tmp-filename))))
|
||||
(λ () (delete-file (build-path tmp-load-directory "repl-test-tmp2.ss"))))
|
||||
|
||||
;; new namespace test
|
||||
(make-test "(current-namespace (make-namespace))\nif"
|
||||
"~aif: bad syntax in: if"
|
||||
"~aif: bad syntax in: if"
|
||||
#f
|
||||
"if: bad syntax in: if"
|
||||
"{file.gif} repl-test-tmp.ss:2:0: if: bad syntax in: if"
|
||||
"if: bad syntax in: if"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:2:0: if: bad syntax in: if"
|
||||
(cons (make-loc 1 0 37) (make-loc 1 2 39))
|
||||
'expand
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "(current-namespace (make-namespace 'empty))\nif"
|
||||
"~acompile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: if"
|
||||
#f
|
||||
#f
|
||||
"compile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: if"
|
||||
"{file.gif} repl-test-tmp.ss:2:0: compile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: if"
|
||||
"compile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: if"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:2:0: compile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: if"
|
||||
(cons (make-loc 1 0 44) (make-loc 1 0 46))
|
||||
'expand
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
|
@ -497,10 +495,10 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(make-test "(define-syntax (c stx) (syntax-case stx () [(_ p q r) (syntax (+ p q r))]))"
|
||||
""
|
||||
""
|
||||
#f
|
||||
""
|
||||
""
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
|
|
@ -509,10 +507,10 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
"(let ([old (error-escape-handler)])\n(+ (let/ec k\n(dynamic-wind\n(lambda () (error-escape-handler (lambda () (k 5))))\n(lambda () (car))\n(lambda () (error-escape-handler old))))\n10))"
|
||||
"car: expects 1 argument, given 0\n15"
|
||||
"car: expects 1 argument, given 0\n15"
|
||||
#t
|
||||
"{bug09.gif} car: expects 1 argument, given 0\n15"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss::153: car: expects 1 argument, given 0\n15"
|
||||
'definitions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
|
|
@ -522,10 +520,10 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(make-test 'fraction-sum
|
||||
"{number 5/6 \"5/6\" improper}"
|
||||
"{number 5/6 \"5/6\" improper}"
|
||||
#f
|
||||
"{number 5/6 \"5/6\" improper}"
|
||||
"{number 5/6 \"5/6\" improper}"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
|
|
@ -533,10 +531,10 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(make-test "(write (list (syntax x)))"
|
||||
"({embedded \".#<syntax:1:21>\"})"
|
||||
"({embedded \".#<syntax:/Users/robby/svn/plt/collects/tests/drscheme/repl-test-tmp.ss:1:21>\"})"
|
||||
#f
|
||||
"({embedded \".#<syntax:1:21>\"})"
|
||||
"({embedded \".#<syntax:/Users/robby/svn/plt/collects/tests/drscheme/repl-test-tmp.ss:1:21>\"})"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
|
|
@ -544,10 +542,10 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(make-test "(define-syntax (foo stx) (with-handlers ([exn:fail? (lambda (x) #'10)]) (syntax-local-value #'foot))) (foo)"
|
||||
"10"
|
||||
"10"
|
||||
#f
|
||||
"10"
|
||||
"10"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
|
|
@ -555,30 +553,30 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(make-test "(parameterize ([current-output-port (open-output-string)]) (write #'1))"
|
||||
""
|
||||
""
|
||||
#f
|
||||
""
|
||||
""
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "(parameterize ([current-output-port (open-output-string)]) (fprintf (current-error-port) \"~e\" #'foot))"
|
||||
"#<syntax:1:96>"
|
||||
"#<syntax:/Users/robby/svn/plt/collects/tests/drscheme/repl-test-tmp.ss:1:96>"
|
||||
#f
|
||||
"#<syntax:1:96>"
|
||||
"#<syntax:/Users/robby/svn/plt/collects/tests/drscheme/repl-test-tmp.ss:1:96>"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "(write-special 1)"
|
||||
"1#t"
|
||||
"1#t"
|
||||
#f
|
||||
"1#t"
|
||||
"1#t"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
|
|
@ -588,67 +586,71 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
"(define s (make-semaphore 0))\n(queue-callback\n(lambda ()\n(dynamic-wind\nvoid\n(lambda () (car))\n(lambda () (semaphore-post s)))))\n(begin (yield s) (void))"
|
||||
"car: expects 1 argument, given 0"
|
||||
"car: expects 1 argument, given 0"
|
||||
2
|
||||
"{bug09.gif} car: expects 1 argument, given 0"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss::100: car: expects 1 argument, given 0"
|
||||
(cons (make-loc 0 99 99) (make-loc 0 104 104))
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
|
||||
;; breaking tests
|
||||
(make-test "(semaphore-wait (make-semaphore 0))"
|
||||
"user break"
|
||||
"user break"
|
||||
2
|
||||
#rx"user break$"
|
||||
#rx"user break$"
|
||||
#rx"user break$"
|
||||
#rx"user break$"
|
||||
(cons (make-loc 0 0 0) (make-loc 0 35 35))
|
||||
#f
|
||||
#t
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "(let l()(l))"
|
||||
"user break"
|
||||
"user break"
|
||||
2
|
||||
#rx"user break$"
|
||||
#rx"user break$"
|
||||
#rx"user break$"
|
||||
#rx"user break$"
|
||||
(cons (make-loc 0 8 8) (make-loc 0 11 11))
|
||||
#f
|
||||
#t
|
||||
void
|
||||
void)
|
||||
|
||||
;; continuation tests
|
||||
(make-test "(define k (call/cc (lambda (x) x)))\n(k 17)\nk"
|
||||
"17" "17"
|
||||
#f
|
||||
"17"
|
||||
"17"
|
||||
"17"
|
||||
"17"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
(make-test "(define v (vector (call/cc (lambda (x) x))))\n((vector-ref v 0) 2)\nv"
|
||||
"#1(2)" "#1(2)"
|
||||
#f
|
||||
"#1(2)"
|
||||
"#1(2)"
|
||||
"#1(2)"
|
||||
"#1(2)"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
(make-test "(define v (vector (eval '(call/cc (lambda (x) x)))))\n((vector-ref v 0) 2)\nv"
|
||||
"#1(2)" "#1(2)"
|
||||
#f
|
||||
"#1(2)"
|
||||
"#1(2)"
|
||||
"#1(2)"
|
||||
"#1(2)"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test "(define x 1)\n(begin (set! x (call/cc (lambda (x) x)))\n(x 3))"
|
||||
"procedure application: expected procedure, given: 3; arguments were: 3"
|
||||
"procedure application: expected procedure, given: 3; arguments were: 3"
|
||||
#t
|
||||
"{bug09.gif} procedure application: expected procedure, given: 3; arguments were: 3"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss::62: procedure application: expected procedure, given: 3; arguments were: 3"
|
||||
(cons (make-loc 3 7 61) (make-loc 3 12 66))
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
|
|
@ -656,19 +658,19 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(make-test (list "((" '("Special" "Insert λ") "(x) x) 1)")
|
||||
"1"
|
||||
"1"
|
||||
#f
|
||||
"1"
|
||||
"1"
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test (list "(" '("Special" "Insert λ") "())")
|
||||
"~aλ: bad syntax in: (λ ())"
|
||||
"~aλ: bad syntax in: (λ ())"
|
||||
#f
|
||||
"λ: bad syntax in: (λ ())"
|
||||
"{file.gif} repl-test-tmp.ss:1:0: λ: bad syntax in: (λ ())"
|
||||
"λ: bad syntax in: (λ ())"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss:1:0: λ: bad syntax in: (λ ())"
|
||||
(cons (make-loc 0 0 0) (make-loc 0 5 5))
|
||||
'expand
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
|
@ -677,16 +679,21 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(make-test "(begin (thread (lambda () x)) (sleep 1/10))"
|
||||
"reference to undefined identifier: x"
|
||||
"reference to undefined identifier: x"
|
||||
#t
|
||||
"{bug09.gif} reference to undefined identifier: x"
|
||||
"{bug09.gif} {file.gif} repl-test-tmp.ss::27: reference to undefined identifier: x"
|
||||
(cons (make-loc 0 26 26) (make-loc 0 27 27))
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)))
|
||||
|
||||
(define backtrace-image-string "{bug09.gif}")
|
||||
(define file-image-string "{file.gif}")
|
||||
|
||||
(define tmp-load-directory
|
||||
(normal-case-path
|
||||
(normalize-path
|
||||
(collection-path "tests" "drscheme"))))
|
||||
|
||||
(define (run-test)
|
||||
|
||||
(define drscheme-frame (wait-for-drscheme-frame))
|
||||
|
|
@ -710,17 +717,12 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(define get-int-pos (lambda () (get-text-pos interactions-text)))
|
||||
|
||||
(define tmp-load-short-filename "repl-test-tmp.ss")
|
||||
(define tmp-load-filename
|
||||
(normal-case-path
|
||||
(normalize-path
|
||||
(build-path (collection-path "tests" "drscheme")
|
||||
tmp-load-short-filename))))
|
||||
(define tmp-load-filename (build-path tmp-load-directory tmp-load-short-filename))
|
||||
|
||||
(define short-tmp-load-filename
|
||||
(let-values ([(base name dir?) (split-path tmp-load-filename)])
|
||||
(path->string name)))
|
||||
|
||||
|
||||
;; setup-fraction-sum-interactions : -> void
|
||||
;; clears the definitions window, and executes `1/2' to
|
||||
;; get a fraction snip in the interactions window.
|
||||
|
|
@ -751,72 +753,23 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
; of the file "foo.ss". First, we insert its contents into the REPL
|
||||
; directly, and second, we use the load command. We compare the
|
||||
; the results of these operations against expected results.
|
||||
(define run-single-test
|
||||
(lambda (execute-text-start escape raw?)
|
||||
(lambda (in-vector)
|
||||
(define ((run-single-test execute-text-start escape raw?) in-vector)
|
||||
(let* ([program (test-program in-vector)]
|
||||
[execute-answer (test-execute-answer in-vector)]
|
||||
[execute-answer (if raw?
|
||||
(test-raw-execute-answer in-vector)
|
||||
(test-err-execute-answer in-vector))]
|
||||
[load-answer (if raw?
|
||||
(test-raw-load-answer in-vector)
|
||||
(test-err-load-answer in-vector))]
|
||||
[source-location (test-source-location in-vector)]
|
||||
[source-location-in-message (test-source-location-in-message in-vector)]
|
||||
[setup (test-setup in-vector)]
|
||||
[teardown (test-teardown in-vector)]
|
||||
[start-line (and source-location-in-message
|
||||
[start-line (and (pair? source-location)
|
||||
(number->string (+ 1 (loc-line (car source-location)))))]
|
||||
[start-col (and source-location-in-message
|
||||
[start-col (and (pair? source-location)
|
||||
(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)
|
||||
(not raw?))
|
||||
(string-append backtrace-image-string " ")
|
||||
"")]
|
||||
[final
|
||||
;; if there is a source-location for the message, put the
|
||||
;; icons just before it. Otherwise, but the icons at
|
||||
;; the beginning of the entire string.
|
||||
(if source-location-in-message
|
||||
(format execute-answer w/backtrace)
|
||||
(string-append w/backtrace execute-answer))])
|
||||
final)]
|
||||
[load-answer (test-load-answer in-vector)]
|
||||
[formatted-load-answer
|
||||
(and load-answer
|
||||
(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)
|
||||
|
|
@ -881,11 +834,18 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(loc-offset finish))))))]))
|
||||
|
||||
; check text for execute test
|
||||
(unless (string=? received-execute formatted-execute-answer)
|
||||
(next-test)
|
||||
(unless (cond
|
||||
[(string? execute-answer)
|
||||
(string=? execute-answer received-execute)]
|
||||
[(regexp? execute-answer)
|
||||
(regexp-match execute-answer received-execute)]
|
||||
[else #f])
|
||||
(failure)
|
||||
(printf "FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n"
|
||||
program
|
||||
raw?
|
||||
formatted-execute-answer received-execute))
|
||||
execute-answer received-execute))
|
||||
|
||||
(test:new-window interactions-canvas)
|
||||
|
||||
|
|
@ -922,26 +882,42 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(test:button-push (send drscheme-frame get-break-button)))
|
||||
(wait-for-execute)
|
||||
|
||||
(when load-answer
|
||||
(let* ([load-text-end (- (get-int-pos) 1)] ;; subtract one to eliminate newline
|
||||
[received-load
|
||||
(fetch-output drscheme-frame load-text-start load-text-end)])
|
||||
|
||||
; check load text
|
||||
(unless (string=? received-load formatted-load-answer)
|
||||
(next-test)
|
||||
(unless (cond
|
||||
[(string? load-answer)
|
||||
(string=? load-answer received-load)]
|
||||
[(regexp? load-answer)
|
||||
(regexp-match load-answer received-load)]
|
||||
[else #f])
|
||||
(failure)
|
||||
(printf "FAILED load test for ~s\n expected: ~s\n got: ~s\n"
|
||||
program formatted-load-answer received-load)))))
|
||||
program load-answer received-load))))
|
||||
|
||||
(teardown)
|
||||
|
||||
; check for edit-sequence
|
||||
(when (repl-in-edit-sequence?)
|
||||
(printf "FAILED: repl in edit-sequence")
|
||||
(escape)))))))
|
||||
(escape)))))
|
||||
|
||||
(define tests 0)
|
||||
(define failures 0)
|
||||
(define (next-test) (set! tests (+ tests 1)))
|
||||
(define (failure) (set! failures (+ failures 1)))
|
||||
(define (reset) (set! tests 0) (set! failures 0))
|
||||
(define (final-report)
|
||||
(if (= 0 failures)
|
||||
(printf "tests finished: ALL ~a TESTS PASSED\n" tests)
|
||||
(printf "tests finished: ~a failed out of ~a total\n" failures tests)))
|
||||
|
||||
(define (run-test-in-language-level raw?)
|
||||
(let ([level (list "PLT" (regexp "Graphical"))])
|
||||
(printf "running ~s (raw? ~a) tests\n" level raw?)
|
||||
(printf "running tests ~a debugging\n" (if raw? "without" "with"))
|
||||
(if raw?
|
||||
(begin
|
||||
(set-language-level! level #f)
|
||||
|
|
@ -996,22 +972,34 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
(error 'kill-test3 "in edit-sequence")))
|
||||
|
||||
(define (callcc-test)
|
||||
(error 'callcc-test)
|
||||
"(define kont #f) (let/cc empty (set! kont empty))" ;; in defs
|
||||
"(kont)" ;; in repl 1
|
||||
"x" ;; in repl2
|
||||
;; make sure error message comes out
|
||||
)
|
||||
;; run the tests
|
||||
(clear-definitions drscheme-frame)
|
||||
(type-in-definitions drscheme-frame "(define kont #f) (let/cc empty (set! kont empty))")
|
||||
(do-execute drscheme-frame)
|
||||
(wait-for-execute)
|
||||
|
||||
(for-each test:keystroke (string->list "(kont)"))
|
||||
(test:keystroke #\return)
|
||||
(wait-for-execute)
|
||||
|
||||
|
||||
(for-each test:keystroke (string->list "x"))
|
||||
(let ([start (+ 1 (send interactions-text last-position))])
|
||||
(test:keystroke #\return)
|
||||
(wait-for-execute)
|
||||
|
||||
(let* ([end (- (get-int-pos) 1)]
|
||||
[output (fetch-output drscheme-frame start end)]
|
||||
[expected "{bug09.gif} reference to undefined identifier: x"])
|
||||
(unless (equal? output expected)
|
||||
(error 'callcc-test "expected ~s, got ~s" expected output)))))
|
||||
|
||||
|
||||
(when (file-exists? tmp-load-filename)
|
||||
(delete-file tmp-load-filename))
|
||||
(save-drscheme-window-as tmp-load-filename)
|
||||
|
||||
;(set-language-level! (list "PLT" "Graphical (MrEd)")) (kill-tests)
|
||||
|
||||
(run-test-in-language-level #f)
|
||||
(run-test-in-language-level #t)
|
||||
(run-test-in-language-level #f)
|
||||
(kill-tests)
|
||||
(callcc-test)
|
||||
))
|
||||
(final-report)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user