diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss
index 2c85ab75c2..b1f998b333 100644
--- a/collects/drscheme/private/rep.ss
+++ b/collects/drscheme/private/rep.ss
@@ -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,27 +220,79 @@ TODO
src-locs
(filter (λ (x) (is-a? (car x) text%)) stack)))))))))
- ;; drscheme-error-value->string-handler : TST number -> string
- (define (drscheme-error-value->string-handler x n)
- (let ([port (open-output-string)])
-
- ;; using a string port here means no snips allowed,
- ;; even though this string may eventually end up
- ;; displayed in a place where snips are allowed.
- (print x port)
-
- (let* ([long-string (get-output-string port)])
- (close-output-port port)
- (if (<= (string-length long-string) n)
- long-string
- (let ([short-string (substring long-string 0 n)]
- [trim 3])
- (unless (n . <= . trim)
- (let loop ([i trim])
- (unless (i . <= . 0)
- (string-set! short-string (- n i) #\.)
- (loop (sub1 i)))))
- short-string)))))
+ (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)])
+
+ ;; using a string port here means no snips allowed,
+ ;; even though this string may eventually end up
+ ;; displayed in a place where snips are allowed.
+ (print x port)
+
+ (let* ([long-string (get-output-string port)])
+ (close-output-port port)
+ (if (<= (string-length long-string) n)
+ long-string
+ (let ([short-string (substring long-string 0 n)]
+ [trim 3])
+ (unless (n . <= . trim)
+ (let loop ([i trim])
+ (unless (i . <= . 0)
+ (string-set! short-string (- n i) #\.)
+ (loop (sub1 i)))))
+ short-string)))))
(define drs-bindings-keymap (make-object keymap:aug-keymap%))
@@ -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
- (λ ()
- (eval-syntax sexp/syntax/eof))
+ (rec cut-stacktrace-above-here1
+ (λ ()
+ (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)))))
- (λ ()
- (thunk)
- ; Breaks must be off!
- (set! cleanup? #t))
+ (rec cut-stacktrace-above-here2
+ (λ ()
+ (thunk)
+ ; Breaks must be off!
+ (set! cleanup? #t)))
(λ ()
(current-error-escape-k saved-error-escape-k)
(when cleanup?
@@ -1312,12 +1391,12 @@ TODO
(break-enabled break-ok?)
(unless ub?
(set! user-break-enabled 'user)))
- (λ ()
- (primitive-dispatch-handler eventspace))
- (λ ()
- (unless ub?
- (set! user-break-enabled (break-enabled)))
- (break-enabled #f))))
+ (λ ()
+ (primitive-dispatch-handler eventspace))
+ (λ ()
+ (unless ub?
+ (set! user-break-enabled (break-enabled)))
+ (break-enabled #f))))
; Cleanup after dispatch
(λ ()
;; in principle, the line below might cause
diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss
index 912ea06969..391dc55312 100644
--- a/collects/tests/drscheme/language-test.ss
+++ b/collects/tests/drscheme/language-test.ss
@@ -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)))]
diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss
index 08f937bddc..5e0d0a0536 100644
--- a/collects/tests/drscheme/repl-test.ss
+++ b/collects/tests/drscheme/repl-test.ss
@@ -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,98 +55,100 @@ 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
+ void
+ void)
+
+ (make-test "(lambda ())"
+ "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)
@@ -165,18 +156,18 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
(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)
@@ -184,9 +175,9 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
(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,54 +186,63 @@ 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
+ #f
void
void)
+
;; leading comment test
(make-test "#!\n1"
"1"
"1"
- #f
+ "1"
+ "1"
'interactions
- #f
#f
void
void)
@@ -250,27 +250,27 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
(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 ())"
- #f
+ "(a ())"
+ "(a ())"
'interactions
#f
- #f
void
void)
- ;; XML tests
+ #|
+ ;; XML tests
(make-test
'(("Special" "Insert XML Box")
"")
@@ -324,43 +324,44 @@ 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
- (cons (make-loc 0 4 4) (make-loc 0 23 23))
+ "{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)
@@ -368,127 +369,124 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
(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 ; given #"
"car: expects argument of type ; given #"
- 2
- (cons (make-loc 0 0 0) (make-loc 0 12 12))
+ "{bug09.gif} car: expects argument of type ; given #"
+ "{bug09.gif} {file.gif} repl-test-tmp.ss::1: car: expects argument of type ; given #"
+ (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
+ #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 ; given 1"
- "car: expects argument of type ; 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)))
- #f
- #f
- (lambda ()
- (call-with-output-file tmp-filename
- (lambda (port)
- (write '(define (f t) (+ 1 (t)))
- port))
- 'truncate))
- (lambda ()
- (delete-file tmp-filename))))
+ (make-test
+ "(load \"repl-test-tmp2.ss\") (define (g) (+ 1 (car 1))) (f g)"
+ "{bug09.gif} car: expects argument of type ; given 1"
+ "{bug09.gif} {file.gif} repl-test-tmp.ss:1:27: car: expects argument of type ; given 1"
+ "{bug09.gif} car: expects argument of type ; given 1"
+ "{bug09.gif} {file.gif} repl-test-tmp.ss::45: car: expects argument of type ; given 1"
+ (cons (make-loc -1 -1 44)
+ (make-loc -1 -1 51))
+ #f
+ (λ ()
+ (call-with-output-file (build-path tmp-load-directory "repl-test-tmp2.ss")
+ (lambda (port)
+ (write '(define (f t) (+ 1 (t)))
+ port))
+ 'truncate))
+ (λ () (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)
@@ -496,11 +494,11 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
;; macro tests
(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,9 +520,9 @@ 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,9 +531,9 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
(make-test "(write (list (syntax x)))"
"({embedded \".#\"})"
"({embedded \".#\"})"
- #f
+ "({embedded \".#\"})"
+ "({embedded \".#\"})"
'interactions
- #f
#f
void
void)
@@ -544,9 +542,9 @@ 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,9 +553,9 @@ 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)
@@ -565,9 +563,9 @@ 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)]) (fprintf (current-error-port) \"~e\" #'foot))"
"#"
"#"
- #f
+ "#"
+ "#"
'interactions
- #f
#f
void
void)
@@ -575,80 +573,84 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
(make-test "(write-special 1)"
"1#t"
"1#t"
- #f
+ "1#t"
+ "1#t"
'interactions
- #f
#f
void
void)
-
+
(make-test
;; the begin/void combo is to make sure that no value printout
;; comes and messes up the source location for the error.
"(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
- (cons (make-loc 0 0 0) (make-loc 0 35 35))
- #f
- #t
+ #rx"user break$"
+ #rx"user break$"
+ #rx"user break$"
+ #rx"user break$"
+ (cons (make-loc 0 0 0) (make-loc 0 35 35))
+ #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
+ #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
- (cons (make-loc 0 26 26) (make-loc 0 27 27))
+ "{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,197 +753,171 @@ 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)
- (let* ([program (test-program in-vector)]
- [execute-answer (test-execute-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
- (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)
- (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)
-
- (clear-definitions drscheme-frame)
- ; load contents of test-file into the REPL, recording
- ; the start and end positions of the text
-
+ (define ((run-single-test execute-text-start escape raw?) in-vector)
+ (let* ([program (test-program 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)]
+ [setup (test-setup in-vector)]
+ [teardown (test-teardown in-vector)]
+ [start-line (and (pair? source-location)
+ (number->string (+ 1 (loc-line (car source-location)))))]
+ [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)))))]
+ [breaking-test? (test-breaking-test? in-vector)])
+
+ (setup)
+
+ (clear-definitions drscheme-frame)
+ ; load contents of test-file into the REPL, recording
+ ; the start and end positions of the text
+
+ (cond
+ [(string? program)
+ (insert-string program)]
+ [(eq? program 'fraction-sum)
+ (setup-fraction-sum-interactions)]
+ [(list? program)
+ (for-each
+ (lambda (item)
+ (cond
+ [(string? item) (insert-string item)]
+ [(eq? item 'left)
+ (send definitions-text
+ set-position
+ (- (send definitions-text get-start-position) 1)
+ (- (send definitions-text get-start-position) 1))]
+ [(pair? item) (apply test:menu-select item)]))
+ program)])
+
+ (do-execute drscheme-frame #f)
+ (when breaking-test?
+ (test:button-push (send drscheme-frame get-break-button)))
+ (wait-for-execute)
+
+ (let* ([execute-text-end (- (get-int-pos) 1)] ;; subtract one to skip last newline
+ [received-execute
+ (fetch-output drscheme-frame execute-text-start execute-text-end)])
+
+ ; check focus and selection for execute test
+ (unless raw?
(cond
- [(string? program)
- (insert-string program)]
- [(eq? program 'fraction-sum)
- (setup-fraction-sum-interactions)]
- [(list? program)
- (for-each
- (lambda (item)
- (cond
- [(string? item) (insert-string item)]
- [(eq? item 'left)
- (send definitions-text
- set-position
- (- (send definitions-text get-start-position) 1)
- (- (send definitions-text get-start-position) 1))]
- [(pair? item) (apply test:menu-select item)]))
- program)])
+ [(eq? source-location 'definitions)
+ (unless (send definitions-canvas has-focus?)
+ (printf "FAILED execute test for ~s\n expected definitions to have the focus\n"
+ program))]
+ [(eq? source-location 'interactions)
+ (unless (send interactions-canvas has-focus?)
+ (printf "FAILED execute test for ~s\n expected interactions to have the focus\n"
+ program))]
+ [(send definitions-canvas has-focus?)
+ (let ([start (car source-location)]
+ [finish (cdr source-location)])
+ (let* ([error-ranges (send interactions-text get-error-ranges)]
+ [error-range (and error-ranges
+ (not (null? error-ranges))
+ (car error-ranges))])
+ (unless (and error-range
+ (= (+ (srcloc-position error-range) -1) (loc-offset start))
+ (= (+ (srcloc-position error-range) -1 (srcloc-span error-range)) (loc-offset finish)))
+ (printf "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n"
+ program
+ (list (+ (srcloc-position error-range) -1)
+ (+ (srcloc-position error-range) -1 (srcloc-span error-range)))
+ (list (loc-offset start)
+ (loc-offset finish))))))]))
+
+ ; check text for execute test
+ (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?
+ execute-answer received-execute))
+
+ (test:new-window interactions-canvas)
+
+ ; save the file so that load is in sync
+ (test:menu-select "File" "Save Definitions")
+
+ ; make sure that a prompt is available at end of the REPL
+ (unless (and (char=? #\>
+ (send interactions-text get-character
+ (- (send interactions-text last-position) 2)))
+ (char=? #\space
+ (send interactions-text get-character
+ (- (send interactions-text last-position) 1))))
+ (test:keystroke #\return))
+
+ ; in order to erase the state in the namespace already, we clear (but don't save!)
+ ; the definitions and click execute with the empty buffer
+ (test:new-window definitions-canvas)
+ (test:menu-select "Edit" "Select All")
+ (test:menu-select "Edit" "Delete")
+ (do-execute drscheme-frame #f)
+ (wait-for-execute)
+
+ ; stuff the load command into the REPL
+ (for-each test:keystroke
+ (string->list (format "(load ~s)" tmp-load-short-filename)))
+
+ ; record current text position, then stuff a CR into the REPL
+ (let ([load-text-start (+ 1 (send interactions-text last-position))])
+
+ (test:keystroke #\return)
- (do-execute drscheme-frame #f)
(when breaking-test?
(test:button-push (send drscheme-frame get-break-button)))
(wait-for-execute)
- (let* ([execute-text-end (- (get-int-pos) 1)] ;; subtract one to skip last newline
- [received-execute
- (fetch-output drscheme-frame execute-text-start execute-text-end)])
+ (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 focus and selection for execute test
- (unless raw?
- (cond
- [(eq? source-location 'definitions)
- (unless (send definitions-canvas has-focus?)
- (printf "FAILED execute test for ~s\n expected definitions to have the focus\n"
- program))]
- [(eq? source-location 'interactions)
- (unless (send interactions-canvas has-focus?)
- (printf "FAILED execute test for ~s\n expected interactions to have the focus\n"
- program))]
- [(send definitions-canvas has-focus?)
- (let ([start (car source-location)]
- [finish (cdr source-location)])
- (let* ([error-ranges (send interactions-text get-error-ranges)]
- [error-range (and error-ranges
- (not (null? error-ranges))
- (car error-ranges))])
- (unless (and error-range
- (= (+ (srcloc-position error-range) -1) (loc-offset start))
- (= (+ (srcloc-position error-range) -1 (srcloc-span error-range)) (loc-offset finish)))
- (printf "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n"
- program
- (list (+ (srcloc-position error-range) -1)
- (+ (srcloc-position error-range) -1 (srcloc-span error-range)))
- (list (loc-offset start)
- (loc-offset finish))))))]))
-
- ; check text for execute test
- (unless (string=? received-execute formatted-execute-answer)
- (printf "FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n"
- program
- raw?
- formatted-execute-answer received-execute))
-
- (test:new-window interactions-canvas)
-
- ; save the file so that load is in sync
- (test:menu-select "File" "Save Definitions")
-
- ; make sure that a prompt is available at end of the REPL
- (unless (and (char=? #\>
- (send interactions-text get-character
- (- (send interactions-text last-position) 2)))
- (char=? #\space
- (send interactions-text get-character
- (- (send interactions-text last-position) 1))))
- (test:keystroke #\return))
-
- ; in order to erase the state in the namespace already, we clear (but don't save!)
- ; the definitions and click execute with the empty buffer
- (test:new-window definitions-canvas)
- (test:menu-select "Edit" "Select All")
- (test:menu-select "Edit" "Delete")
- (do-execute drscheme-frame #f)
- (wait-for-execute)
-
- ; stuff the load command into the REPL
- (for-each test:keystroke
- (string->list (format "(load ~s)" tmp-load-short-filename)))
-
- ; record current text position, then stuff a CR into the REPL
- (let ([load-text-start (+ 1 (send interactions-text last-position))])
-
- (test:keystroke #\return)
-
- (when breaking-test?
- (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)
- (printf "FAILED load test for ~s\n expected: ~s\n got: ~s\n"
- program formatted-load-answer received-load)))))
-
- (teardown)
-
- ; check for edit-sequence
- (when (repl-in-edit-sequence?)
- (printf "FAILED: repl in edit-sequence")
- (escape)))))))
+ ; check load text
+ (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 load-answer received-load))))
+
+ (teardown)
+
+ ; check for edit-sequence
+ (when (repl-in-edit-sequence?)
+ (printf "FAILED: repl in edit-sequence")
+ (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)))