diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss
index 1fc452778d..e81b2941d2 100644
--- a/collects/drscheme/private/debug.ss
+++ b/collects/drscheme/private/debug.ss
@@ -189,17 +189,14 @@ profile todo:
[(begin expr ...)
;; Found a `begin', so expand/eval each contained
;; expression one at a time
- (let ([exprs (syntax->list #'(expr ...))]
- [last-one (list (void))])
- (let i-loop ()
- (cond
- [(null? exprs)
- (apply values last-one)]
- [else
- (let ([exp (car exprs)])
- (set! exprs (cdr exprs))
- (set! last-one (call-with-values (λ () (loop exp)) list))
- (i-loop))])))]
+ (let i-loop ([exprs (syntax->list #'(expr ...))]
+ [last-one (list (void))])
+ (cond
+ [(null? exprs) (apply values last-one)]
+ [else (i-loop (cdr exprs)
+ (call-with-values
+ (λ () (loop (car exprs)))
+ list))]))]
[_else
;; Not `begin', so proceed with normal expand and eval
(let* ([annotated (annotate-top (expand-syntax top-e) #f)])
diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss
index b1f998b333..2c85ab75c2 100644
--- a/collects/drscheme/private/rep.ss
+++ b/collects/drscheme/private/rep.ss
@@ -172,11 +172,10 @@ 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* ([cut-stack (if (and (exn? exn)
- (main-user-eventspace-thread?))
- (cut-out-top-of-stack exn)
- '())]
- [srclocs-stack (filter values (map cdr cut-stack))]
+ (let* ([srclocs-stack
+ (if (exn? exn)
+ (filter values (map cdr (continuation-mark-set->context (exn-continuation-marks exn))))
+ '())]
[stack
(filter
values
@@ -192,16 +191,6 @@ 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)
@@ -220,79 +209,27 @@ 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)])
-
- ;; 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)))))
+ ;; 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%))
@@ -1023,8 +960,7 @@ 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)]
- [dummy-value (box #f)])
+ [settings (drscheme:language-configuration:language-settings-settings settings)])
(set! get-sexp/syntax/eof
(if complete-program?
(send lang front-end/complete-program port settings user-teachpack-cache)
@@ -1045,33 +981,19 @@ TODO
(current-error-escape-k (λ ()
(set! cleanup? #t)
(k (void)))))
-
(λ ()
(let loop ()
- (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)))))])
+ (let ([sexp/syntax/eof (get-sexp/syntax/eof)])
(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
- (λ ()
- (begin0 (eval-syntax sexp/syntax/eof)
- (void))))
+ (λ ()
+ (eval-syntax sexp/syntax/eof))
(λ x (display-results x)))))
(loop))))
(set! cleanup? #t))
-
(λ ()
(current-error-escape-k saved-error-escape-k)
(when cleanup?
@@ -1152,11 +1074,10 @@ TODO
(current-error-escape-k (λ ()
(set! cleanup? #t)
(k (void)))))
- (rec cut-stacktrace-above-here2
- (λ ()
- (thunk)
- ; Breaks must be off!
- (set! cleanup? #t)))
+ (λ ()
+ (thunk)
+ ; Breaks must be off!
+ (set! cleanup? #t))
(λ ()
(current-error-escape-k saved-error-escape-k)
(when cleanup?
@@ -1391,12 +1312,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/mrlib/graph.ss b/collects/mrlib/graph.ss
index 4aa788d044..a1be52580c 100644
--- a/collects/mrlib/graph.ss
+++ b/collects/mrlib/graph.ss
@@ -748,18 +748,18 @@
(send dc draw-polygon points dx dy))
(when (named-link? from-link)
(let*-values ([(text-len h d v) (send dc get-text-extent (link-label from-link))]
- [(theta) (angle (- to-pt from-pt))]
- [(cx cy) (values (/ (+ from-x to-x) 2)
- (/ (+ from-y to-y) 2))]
-
- ;; ax, ay is the location of the beginning of the string
- ;; offset from cx,cy by enough to make the string centered
- ;; (but it doesn't seem to be quite right; i'm not sure why)
- [(ax ay) (values (- cx (* 1/2 text-len (cos theta)))
- (- cy (* 1/2 text-len (sin theta))))]
-
- [(x y) (values (- ax (* h (cos theta)))
- (- ay (* h (sin theta))))]
+ [(x) (/ (+ from-x to-x) 2)]
+ [(y) (/ (+ from-y to-y) 2)]
+ [(theta) (- (angle (- to-pt from-pt)))]
+ [(flip?) #f #;(negative? (- to-x from-x))]
+ [(text-angle)
+ (if flip?
+ (+ theta pi)
+ theta)]
+ [(x)
+ (- x (* h (cos (if flip? (+ (- theta) pi) (- theta)))))]
+ [(y)
+ (- y (* h (sin (if flip? (+ (- theta) pi) (- theta)))))]
[(sqr) (λ (x) (* x x))])
(when (> (sqrt (+ (sqr (- to-x from-x)) (sqr (- to-y from-y)))) text-len)
(send dc draw-text (link-label from-link)
@@ -767,7 +767,7 @@
(+ dy y)
#f
0
- (- theta)))
+ text-angle))
))]))))))))
(define (named-link? l) (link-label l))
diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss
index 1d1db452fd..5070da2510 100644
--- a/collects/mzlib/private/contract.ss
+++ b/collects/mzlib/private/contract.ss
@@ -552,15 +552,9 @@ add struct contracts for immutable structs?
;; builds a begin expression for the entire contract and provide
;; the first syntax object is used for source locations
(define (code-for-one-id/new-name stx id ctrct user-rename-id)
- (with-syntax ([id-rename (a:mangle-id provide-stx
- "provide/contract-id"
- (or user-rename-id id))]
- [contract-id (a:mangle-id provide-stx
- "provide/contract-contract-id"
- (or user-rename-id id))]
- [pos-module-source (a:mangle-id provide-stx
- "provide/contract-pos-module-source"
- (or user-rename-id id))]
+ (with-syntax ([id-rename (a:mangle-id provide-stx "provide/contract-id" id)]
+ [contract-id (a:mangle-id provide-stx "provide/contract-contract-id" id)]
+ [pos-module-source (a:mangle-id provide-stx "provide/contract-pos-module-source" id)]
[pos-stx (datum->syntax-object provide-stx 'here)]
[id id]
[ctrct (syntax-property ctrct 'inferred-name id)]
@@ -827,40 +821,28 @@ add struct contracts for immutable structs?
[else
(loop ho-contracts (cons arg fc/predicates) (cdr args))]))]))])
(let ([flat-contracts (map (λ (x) (if (flat-contract? x)
- x
- (flat-contract x)))
- fc/predicates)]
- [pred
- (cond
- [(null? fc/predicates) not]
- [else
- (let loop ([fst (car fc/predicates)]
- [rst (cdr fc/predicates)])
- (let ([fst-pred (if (flat-contract? fst)
- ((flat-get fst) fst)
- fst)])
- (cond
- [(null? rst) fst-pred]
- [else
- (let ([r (loop (car rst) (cdr rst))])
- (λ (x) (or (fst-pred x) (r x))))])))])])
+ x
+ (flat-contract x)))
+ fc/predicates)])
(cond
[(null? ho-contracts)
- (make-flat-or/c pred flat-contracts)]
+ (make-flat-or/c flat-contracts)]
[(null? (cdr ho-contracts))
- (make-or/c pred flat-contracts (car ho-contracts))]
+ (make-or/c flat-contracts (car ho-contracts))]
[else
(make-multi-or/c flat-contracts ho-contracts)])))]))
- (define-struct/prop or/c (pred flat-ctcs ho-ctc)
+ (define-struct/prop or/c (flat-ctcs ho-ctc)
((proj-prop (λ (ctc)
(let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
- [pred (or/c-pred ctc)])
+ [predicates (map (λ (x) ((flat-get x) x))
+ (or/c-flat-ctcs ctc))])
(λ (pos-blame neg-blame src-info orig-str)
(let ([partial-contract (c-proc pos-blame neg-blame src-info orig-str)])
(λ (val)
(cond
- [(pred val) val]
+ [(ormap (λ (pred) (pred val)) predicates)
+ val]
[else
(partial-contract val)])))))))
@@ -888,6 +870,49 @@ add struct contracts for immutable structs?
this-ctcs
that-ctcs))))))))
+ (define (make-multi-or/c-proj pos-proj-get)
+ (λ (ctc)
+ (let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
+ [c-procs (map (λ (x) ((pos-proj-get x) x)) ho-contracts)]
+ [first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)]
+ [predicates (map (λ (x) ((flat-get x) x))
+ (multi-or/c-flat-ctcs ctc))])
+ (λ (pos src-info orig-str)
+ (let ([partial-contracts (map (λ (c-proc) (c-proc pos src-info orig-str)) c-procs)])
+ (λ (val)
+ (cond
+ [(ormap (λ (pred) (pred val)) predicates)
+ val]
+ [else
+ (let loop ([checks first-order-checks]
+ [procs partial-contracts]
+ [contracts ho-contracts]
+ [candidate-proc #f]
+ [candidate-contract #f])
+ (cond
+ [(null? checks)
+ (if candidate-proc
+ (candidate-proc val)
+ (raise-contract-error val src-info pos orig-str
+ "none of the branches of the or/c matched"))]
+ [((car checks) val)
+ (if candidate-proc
+ (error 'or/c "two arguments, ~s and ~s, might both match ~s"
+ (contract-name candidate-contract)
+ (contract-name (car contracts))
+ val)
+ (loop (cdr checks)
+ (cdr procs)
+ (cdr contracts)
+ (car procs)
+ (car contracts)))]
+ [else
+ (loop (cdr checks)
+ (cdr procs)
+ (cdr contracts)
+ candidate-proc
+ candidate-contract)]))])))))))
+
(define (multi-or/c-proj ctc)
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
[c-procs (map (λ (x) ((proj-get x) x)) ho-contracts)]
@@ -936,8 +961,8 @@ add struct contracts for immutable structs?
(apply build-compound-type-name
'or/c
(append
- (multi-or/c-flat-ctcs ctc)
- (reverse (multi-or/c-ho-ctcs ctc))))))
+ (multi-or/c-ho-ctcs ctc)
+ (multi-or/c-flat-ctcs ctc)))))
(first-order-prop
(λ (ctc)
(let ([flats (map (λ (x) ((flat-get x) x)) (multi-or/c-flat-ctcs ctc))]
@@ -962,7 +987,7 @@ add struct contracts for immutable structs?
this-ctcs
that-ctcs))))))))
- (define-struct/prop flat-or/c (pred flat-ctcs)
+ (define-struct/prop flat-or/c (flat-ctcs)
((proj-prop flat-proj)
(name-prop (λ (ctc)
(apply build-compound-type-name
@@ -977,7 +1002,11 @@ add struct contracts for immutable structs?
(andmap contract-stronger?
this-ctcs
that-ctcs))))))
- (flat-prop (λ (ctc) (flat-or/c-pred ctc)))))
+ (flat-prop (λ (ctc)
+ (let ([preds
+ (map (λ (x) ((flat-get x) x))
+ (flat-or/c-flat-ctcs ctc))])
+ (λ (x) (ormap (λ (p?) (p? x)) preds)))))))
(define false/c
(flat-named-contract
diff --git a/collects/profj/info.ss b/collects/profj/info.ss
index 16ba7ec36e..e4b864c3a7 100644
--- a/collects/profj/info.ss
+++ b/collects/profj/info.ss
@@ -13,7 +13,7 @@
("profj" "libs" "java" "util")))
(define textbook-pls
(list (list '("htdch-icon.png" "profj")
- "How to Design Classes"
+ "How to Design Class Hierarchies"
(string-constant experimental-languages)
"ProfessorJ"
"Beginner"))))
diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss
index 391dc55312..912ea06969 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) (list))\n(else (cons n (f (- n 1))))))\n(f 200)"))
+ "(define (f n)\n(cond ((zero? n) null)\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 833e465c20..08f937bddc 100644
--- a/collects/tests/drscheme/repl-test.ss
+++ b/collects/tests/drscheme/repl-test.ss
@@ -31,10 +31,12 @@ 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
- 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)
+ 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
source-location ;; : (union 'definitions
;; 'interactions
@@ -45,6 +47,15 @@ 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.
@@ -55,101 +66,98 @@ 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"
- "1"
- "1"
+ #f
'interactions
#f
+ #f
void
void)
-
(make-test "\"a\""
"\"a\""
"\"a\""
- "\"a\""
- "\"a\""
+ #f
'interactions
#f
+ #f
void
void)
(make-test "1 2"
"1\n2"
"2"
- "1\n2"
- "2"
+ #f
'interactions
#f
+ #f
void
void)
(make-test "\"a\" \"b\""
"\"a\"\n\"b\""
"\"b\""
- "\"a\"\n\"b\""
- "\"b\""
+ #f
'interactions
#f
+ #f
void
void)
(make-test "("
- "{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 ')'"
+ "~aread: expected a ')'"
+ "~aread: expected a ')'"
+ #f
(cons (make-loc 0 0 0) (make-loc 0 1 1))
+ 'read
#f
void
void)
-
(make-test "."
- "{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))
+ "~aread: illegal use of \".\""
+ "~aread: illegal use of \".\""
#f
- void
+ (cons (make-loc 0 0 0) (make-loc 0 1 1))
+ 'read
+ #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 ())"
+ "~alambda: bad syntax in: (lambda ())"
+ "~alambda: bad syntax in: (lambda ())"
+ #f
(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"
- "{bug09.gif} reference to undefined identifier: xx"
- "{bug09.gif} {file.gif} repl-test-tmp.ss::1: reference to undefined identifier: xx"
+ #t
(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"
- "uncaught exception: 1"
- "uncaught exception: 1"
+ #f
'interactions
#f
+ #f
void
void)
(make-test "(raise #f)"
"uncaught exception: #f"
"uncaught exception: #f"
- "uncaught exception: #f"
- "uncaught exception: #f"
+ #f
'interactions
+ #f
#f
void
void)
@@ -157,18 +165,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"
- "1\n2"
- "1\n2"
+ #f
'interactions
#f
+ #f
void
void)
(make-test "(list 1 2)"
"(1 2)"
"(1 2)"
- "(1 2)"
- "(1 2)"
+ #f
'interactions
+ #f
#f
void
void)
@@ -176,9 +184,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)"
- "#(struct:s 1)"
- "#(struct:s 1)"
+ #f
'interactions
+ #f
#f
void
void)
@@ -187,63 +195,54 @@ 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"
- "0"
- "0"
+ #f
'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"
- "1"
- "1"
+ #f
'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")
- "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))
+ "~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
+ (cons (make-loc 0 43 43) (make-loc 0 44 44))
+ 'expand
+ #f
void
void)
-
;; leading comment test
(make-test "#!\n1"
"1"
"1"
- "1"
- "1"
+ #f
'interactions
+ #f
#f
void
void)
@@ -251,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"
- "{bug09.gif} reference to undefined identifier: xx"
- "{bug09.gif} {file.gif} repl-test-tmp.ss::11: reference to undefined identifier: xx"
+ #t
(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 ())"
- "(a ())"
+ #f
'interactions
#f
+ #f
void
void)
- #|
- ;; XML tests
+ ;; XML tests
(make-test
'(("Special" "Insert XML Box")
"")
@@ -325,44 +324,43 @@ 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"
- "1\n2"
- "1\n2"
+ #f
'interactions
#f
+ #f
void
void)
-
(make-test " (eval '(list 1 2))"
"(1 2)"
"(1 2)"
- "(1 2)"
- "(1 2)"
+ #f
'interactions
#f
+ #f
void
void)
-
(make-test " (eval '(lambda ()))"
"lambda: bad syntax in: (lambda ())"
"lambda: bad syntax in: (lambda ())"
- "{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))
+ 2
+ (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"
- "{bug09.gif} reference to undefined identifier: x"
- "{bug09.gif} {file.gif} repl-test-tmp.ss::5: reference to undefined identifier: x"
+ 2
(cons (make-loc 0 4 4) (make-loc 0 13 13))
+ #f
#f
void
void)
@@ -370,124 +368,127 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
(make-test "(eval (box 1))"
"#&1"
"#&1"
- "#&1"
- "#&1"
+ #f
'interactions
#f
+ #f
void
void)
(make-test "(eval '(box 1))"
"#&1"
"#&1"
- "#&1"
- "#&1"
+ #f
'interactions
#f
+ #f
void
void)
+
; printer setup test
(make-test "(car (void))"
"car: expects argument of type ; given #"
"car: expects argument of type ; given #"
- "{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))
+ 2
+ (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{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 ')'"
+ "1\n2\n~aread: expected a ')'"
+ "~aread: expected a ')'"
+ #f
(cons (make-loc 0 4 4) (make-loc 0 9 9))
+ 'read
#f
void
void)
(make-test "1 2 . 3 4"
- "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 \".\""
+ "1\n2\n~aread: illegal use of \".\""
+ "~aread: illegal use of \".\""
+ #f
(cons (make-loc 0 4 4) (make-loc 0 5 5))
+ 'read
#f
void
void)
(make-test "1 2 (lambda ()) 3 4"
- "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 ())"
+ "1\n2\n~alambda: bad syntax in: (lambda ())"
+ "~alambda: bad syntax in: (lambda ())"
+ #f
(cons (make-loc 0 4 4) (make-loc 0 15 15))
- #f
+ 'expand
+ #f
void
void)
(make-test "1 2 x 3 4"
"1\n2\nreference to undefined identifier: x"
"reference to undefined identifier: x"
- "1\n2\n{bug09.gif} reference to undefined identifier: x"
- "{bug09.gif} {file.gif} repl-test-tmp.ss::5: reference to undefined identifier: x"
+ #t
(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"
- "1\n2\nuncaught exception: 1"
- "uncaught exception: 1"
+ #f
'interactions
+ #f
#f
void
void)
(make-test "1 2 (raise #f) 3 4"
"1\n2\nuncaught exception: #f"
"uncaught exception: #f"
- "1\n2\nuncaught exception: #f"
- "uncaught exception: #f"
+ #f
'interactions
+ #f
#f
void
void)
;; error across separate files
- (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"))))
+ (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))))
;; new namespace test
(make-test "(current-namespace (make-namespace))\nif"
- "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"
+ "~aif: bad syntax in: if"
+ "~aif: bad syntax in: if"
+ #f
(cons (make-loc 1 0 37) (make-loc 1 2 39))
+ 'expand
#f
void
void)
(make-test "(current-namespace (make-namespace 'empty))\nif"
- "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"
+ "~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))
+ 'expand
#f
void
void)
@@ -495,11 +496,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)
@@ -508,10 +509,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"
- "{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"
+ #t
'definitions
#f
+ #f
void
void)
@@ -519,11 +520,11 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
;; this test depends on the state of the 'framework:fraction-snip-style preference
;; make sure this preference is set to the default when running this test.
(make-test 'fraction-sum
- #rx"{number 5/6 \"5/6\" (improper|mixed)}"
- #rx"{number 5/6 \"5/6\" (improper|mixed)}"
- #rx"{number 5/6 \"5/6\" (improper|mixed)}"
- #rx"{number 5/6 \"5/6\" (improper|mixed)}"
+ "{number 5/6 \"5/6\" improper}"
+ "{number 5/6 \"5/6\" improper}"
+ #f
'interactions
+ #f
#f
void
void)
@@ -532,9 +533,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 \".#\"})"
- "({embedded \".#\"})"
- "({embedded \".#\"})"
+ #f
'interactions
+ #f
#f
void
void)
@@ -543,9 +544,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"
- "10"
- "10"
+ #f
'interactions
+ #f
#f
void
void)
@@ -554,9 +555,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)
@@ -564,9 +565,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)
@@ -574,95 +575,80 @@ 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"
- "1#t"
- "1#t"
+ #f
'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"
- "{bug09.gif} car: expects 1 argument, given 0"
- "{bug09.gif} {file.gif} repl-test-tmp.ss::100: car: expects 1 argument, given 0"
+ 2
(cons (make-loc 0 99 99) (make-loc 0 104 104))
#f
+ #f
void
void)
-
-
+
;; breaking tests
(make-test "(semaphore-wait (make-semaphore 0))"
- #rx"user break$"
- #rx"user break$"
- #rx"user break$"
- #rx"user break$"
- (cons (make-loc 0 0 0) (make-loc 0 35 35))
- #t
+ "user break"
+ "user break"
+ 2
+ (cons (make-loc 0 0 0) (make-loc 0 35 35))
+ #f
+ #t
void
void)
(make-test "(let l()(l))"
- #rx"user break$"
- #rx"user break$"
- #rx"user break$"
- #rx"user break$"
+ "user break"
+ "user break"
+ 2
(cons (make-loc 0 8 8) (make-loc 0 11 11))
- #t
+ #f
+ #t
void
void)
;; continuation tests
(make-test "(define k (call/cc (lambda (x) x)))\n(k 17)\nk"
- "17"
- "17"
- "17"
- "17"
+ "17" "17"
+ #f
'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)"
- "#1(2)"
- "#1(2)"
+ "#1(2)" "#1(2)"
+ #f
'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)"
- "#1(2)"
- "#1(2)"
+ "#1(2)" "#1(2)"
+ #f
'interactions
#f
- void
- void)
-
- (make-test "(define x 1)\n((λ (x y) y) (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"
- "{bug09.gif} procedure application: expected procedure, given: 3; arguments were: 3"
- "{bug09.gif} {file.gif} repl-test-tmp.ss::74: procedure application: expected procedure, given: 3; arguments were: 3"
- (cons (make-loc 3 19 73) (make-loc 3 24 78))
#f
void
void)
- ;; top-level & continuation interaction test
- (make-test "(begin (define k (call/cc (λ (x) x)))\n(define x 'wrong))\n(set! x 'right)\n(k 1)\nx"
- "right"
- "right"
- "right"
- "right"
- 'interactions
- #f
+ (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
+ (cons (make-loc 3 7 61) (make-loc 3 12 66))
+ #f
+ #f
void
void)
@@ -670,19 +656,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"
- "1"
- "1"
+ #f
'interactions
#f
+ #f
void
void)
(make-test (list "(" '("Special" "Insert λ") "())")
- "λ: 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: (λ ())"
+ "~aλ: bad syntax in: (λ ())"
+ "~aλ: bad syntax in: (λ ())"
+ #f
(cons (make-loc 0 0 0) (make-loc 0 5 5))
+ 'expand
#f
void
void)
@@ -691,21 +677,16 @@ 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"
- "{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))
+ #t
+ (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))
@@ -729,12 +710,17 @@ 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 (build-path tmp-load-directory tmp-load-short-filename))
+ (define tmp-load-filename
+ (normal-case-path
+ (normalize-path
+ (build-path (collection-path "tests" "drscheme")
+ 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.
@@ -765,171 +751,197 @@ 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 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?
+ (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
+
(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
- (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)
+ [(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* ([load-text-end (- (get-int-pos) 1)] ;; subtract one to eliminate newline
- [received-load
- (fetch-output drscheme-frame load-text-start load-text-end)])
+ (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 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)))
+ ; 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)))))))
(define (run-test-in-language-level raw?)
(let ([level (list "PLT" (regexp "Graphical"))])
- (printf "running tests ~a debugging\n" (if raw? "without" "with"))
+ (printf "running ~s (raw? ~a) tests\n" level raw?)
(if raw?
(begin
(set-language-level! level #f)
@@ -984,34 +996,22 @@ 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)
- (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)))))
-
+ (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
(when (file-exists? tmp-load-filename)
(delete-file tmp-load-filename))
(save-drscheme-window-as tmp-load-filename)
- ;(run-test-in-language-level #t)
+ ;(set-language-level! (list "PLT" "Graphical (MrEd)")) (kill-tests)
+
(run-test-in-language-level #f)
+ (run-test-in-language-level #t)
(kill-tests)
(callcc-test)
- (final-report)))
+ ))
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index fe131fa0e1..782edcebdc 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -4243,7 +4243,7 @@
;; (at the end, becuase they are slow w/out .zo files)
;;
- (test/spec-passed
+ (test/spec-passed
'provide/contract1
'(let ()
(eval '(module contract-test-suite1 mzscheme
@@ -4417,19 +4417,6 @@
[s-a 3])))
(eval '(require n))))
- (test/spec-passed
- 'provide/contract11
- '(parameterize ([current-namespace (make-namespace)])
- (eval '(module m mzscheme
- (require (lib "contract.ss"))
- (define x 1)
- (provide/contract [rename x y integer?]
- [rename x z integer?])))
- (eval '(module n mzscheme
- (require m)
- (+ y z)))
- (eval '(require n))))
-
;; this test is broken, not sure why
#|
(test/spec-failed