suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

brought test suites up to date

Browse Source 
svn: r16105
This commit is contained in:
Robby Findler 2009-09-21 22:43:39 +00:00
parent 725708e7a7
commit 5fb6d5ef47
6 changed files with 291 additions and 239 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/tests/drscheme/drscheme-test-util.ss
View File

@ -41,7 +41,8 @@
repl-in-edit-sequence? repl-in-edit-sequence?
fetch-output fetch-output
has-error? has-error?
run-one/sync) run-one/sync
alt-return-in-interactions)
;; save-drscheme-window-as : string -> void ;; save-drscheme-window-as : string -> void
;; use the "save as" dialog in drscheme to save the definitions ;; use the "save as" dialog in drscheme to save the definitions
@ -214,9 +215,28 @@
(let ([canvas (get-canvas frame)]) (let ([canvas (get-canvas frame)])
(fw:test:new-window canvas) (fw:test:new-window canvas)
(let ([editor (send canvas get-editor)]) (let ([editor (send canvas get-editor)])
(send editor set-caret-owner #f) (cond
(if just-insert? (send editor insert str) (type-string str)))))) [just-insert?
(let ([s (make-semaphore 0)])
(queue-callback
(λ ()
(send editor set-caret-owner #f)
(send editor insert str)
(semaphore-post s)))
(unless (sync/timeout 3 s)
(error who "callback didn't run for 3 seconds; trying to insert ~s" str/sexp)))]
[else
(send editor set-caret-owner #f)
(type-string str)])))))
(define (alt-return-in-interactions frame)
(verify-drscheme-frame-frontmost 'alt-return-in-interactions frame)
(let ([canvas (send frame get-interactions-canvas)])
(fw:test:new-window canvas)
(let ([editor (send canvas get-editor)])
(send editor set-caret-owner #f)
(fw:test:keystroke #\return '(alt)))))
;; type-string : string -> void ;; type-string : string -> void
;; to call test:keystroke repeatedly with the characters ;; to call test:keystroke repeatedly with the characters
(define (type-string str) (define (type-string str)

409
collects/tests/drscheme/language-test.ss
View File

@ -1,3 +1,5 @@
#lang scheme
#| #|
Make sure there are tests that cover these parameters: Make sure there are tests that cover these parameters:
@ -11,7 +13,6 @@ the settings above should match r5rs
|# |#
#lang scheme
(require "drscheme-test-util.ss" (require "drscheme-test-util.ss"
tests/utils/gui tests/utils/gui
@ -247,7 +248,6 @@ the settings above should match r5rs
(define (beginner) (define (beginner)
(parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")]) (parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")])
(check-top-of-repl) (check-top-of-repl)
(generic-settings #t) (generic-settings #t)
(generic-output #f #f #f #f) (generic-output #f #f #f #f)
(teaching-language-fraction-output) (teaching-language-fraction-output)
@ -258,10 +258,10 @@ the settings above should match r5rs
(prepare-for-test-expression) (prepare-for-test-expression)
(test-expression "'|.|" (test-expression "'|.|"
"'|.|\nThis program should be tested." "'|.|"
"'|.|") "'|.|")
(test-expression '("(equal? (list " image ") (list " image "))") (test-expression '("(equal? (list " image ") (list " image "))")
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "(define x 1)(define x 2)" (test-expression "(define x 1)(define x 2)"
@ -269,11 +269,11 @@ the settings above should match r5rs
"define: cannot redefine name: x") "define: cannot redefine name: x")
(test-expression "(define-struct spider (legs))(make-spider 4)" (test-expression "(define-struct spider (legs))(make-spider 4)"
"(make-spider 4)\nThis program should be tested." "(make-spider 4)"
"define-struct: cannot redefine name: spider\n(make-spider 4)") "define-struct: cannot redefine name: spider\n(make-spider 4)")
(test-expression "(sqrt -1)" (test-expression "(sqrt -1)"
"0+1i\nThis program should be tested." "0+1i"
"0+1i\n") "0+1i\n")
(test-expression "class" (test-expression "class"
@ -282,7 +282,6 @@ the settings above should match r5rs
(test-expression "shared" (test-expression "shared"
"shared: name is not defined, not a parameter, and not a primitive name" "shared: name is not defined, not a parameter, and not a primitive name"
"reference to an identifier before its definition: shared") "reference to an identifier before its definition: shared")
(test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
(test-expression "'(1 . 2)" "read: illegal use of \".\"") (test-expression "'(1 . 2)" "read: illegal use of \".\"")
@ -300,13 +299,13 @@ the settings above should match r5rs
"reference to an identifier before its definition: time") "reference to an identifier before its definition: time")
(test-expression "true" (test-expression "true"
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "mred^" (test-expression "mred^"
"mred^: name is not defined, not a parameter, and not a primitive name" "mred^: name is not defined, not a parameter, and not a primitive name"
"reference to an identifier before its definition: mred^") "reference to an identifier before its definition: mred^")
(test-expression "(eq? 'a 'A)" (test-expression "(eq? 'a 'A)"
"false\nThis program should be tested." "false"
"false") "false")
(test-expression "(set! x 1)" (test-expression "(set! x 1)"
"set!: name is not defined, not a parameter, and not a primitive name" "set!: name is not defined, not a parameter, and not a primitive name"
@ -324,7 +323,7 @@ the settings above should match r5rs
(test-expression "'(1)" (test-expression "'(1)"
"quote: expected a name after a ', found something else") "quote: expected a name after a ', found something else")
(test-expression "(define shrd (list 1)) (list shrd shrd)" (test-expression "(define shrd (list 1)) (list shrd shrd)"
"(cons (cons 1 empty) (cons (cons 1 empty) empty))\nThis program should be tested." "(cons (cons 1 empty) (cons (cons 1 empty) empty))"
"define: cannot redefine name: shrd\n(cons (cons 1 empty) (cons (cons 1 empty) empty))") "define: cannot redefine name: shrd\n(cons (cons 1 empty) (cons (cons 1 empty) empty))")
(test-expression "(local ((define x x)) 1)" (test-expression "(local ((define x x)) 1)"
"local: name is not defined, not a parameter, and not a primitive name" "local: name is not defined, not a parameter, and not a primitive name"
@ -335,43 +334,43 @@ the settings above should match r5rs
(test-expression "(if 1 1 1)" "if: question result is not true or false: 1") (test-expression "(if 1 1 1)" "if: question result is not true or false: 1")
(test-expression "(+ 1)" "procedure +: expects at least 2 arguments, given 1: 1") (test-expression "(+ 1)" "procedure +: expects at least 2 arguments, given 1: 1")
(test-expression "1.0" "1\nThis program should be tested." "1") (test-expression "1.0" "1" "1")
(test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") (test-expression "#i1.0" "#i1.0" "#i1.0")
(test-expression "4/3" (test-expression "4/3"
"{number 4/3 \"1.3\" decimal}\nThis program should be tested." "{number 4/3 \"1.3\" decimal}"
"{number 4/3 \"1.3\" decimal}") "{number 4/3 \"1.3\" decimal}")
(test-expression "1/3" (test-expression "1/3"
"{number 1/3 \"0.3\" decimal}\nThis program should be tested." "{number 1/3 \"0.3\" decimal}"
"{number 1/3 \"0.3\" decimal}") "{number 1/3 \"0.3\" decimal}")
(test-expression "-4/3" (test-expression "-4/3"
"{number -4/3 \"-1.3\" decimal}\nThis program should be tested." "{number -4/3 \"-1.3\" decimal}"
"{number -4/3 \"-1.3\" decimal}") "{number -4/3 \"-1.3\" decimal}")
(test-expression "-1/3" (test-expression "-1/3"
"{number -1/3 \"-0.3\" decimal}\nThis program should be tested." "{number -1/3 \"-0.3\" decimal}"
"{number -1/3 \"-0.3\" decimal}") "{number -1/3 \"-0.3\" decimal}")
(test-expression "3/2" (test-expression "3/2"
"{number 3/2 \"1.5\" decimal}\nThis program should be tested." "{number 3/2 \"1.5\" decimal}"
"{number 3/2 \"1.5\" decimal}") "{number 3/2 \"1.5\" decimal}")
(test-expression "1/2" (test-expression "1/2"
"{number 1/2 \"0.5\" decimal}\nThis program should be tested." "{number 1/2 \"0.5\" decimal}"
"{number 1/2 \"0.5\" decimal}") "{number 1/2 \"0.5\" decimal}")
(test-expression "-1/2" (test-expression "-1/2"
"{number -1/2 \"-0.5\" decimal}\nThis program should be tested." "{number -1/2 \"-0.5\" decimal}"
"{number -1/2 \"-0.5\" decimal}") "{number -1/2 \"-0.5\" decimal}")
(test-expression "-3/2" (test-expression "-3/2"
"{number -3/2 \"-1.5\" decimal}\nThis program should be tested." "{number -3/2 \"-1.5\" decimal}"
"{number -3/2 \"-1.5\" decimal}") "{number -3/2 \"-1.5\" decimal}")
(test-expression "+1/3i" (test-expression "+1/3i"
"0+1/3i\nThis program should be tested." "0+1/3i"
"0+1/3i") "0+1/3i")
(test-expression "+1/2i" (test-expression "+1/2i"
"0+0.5i\nThis program should be tested." "0+0.5i"
"0+0.5i") "0+0.5i")
(test-expression "779625/32258" (test-expression "779625/32258"
"{number 779625/32258 \"24.1684233368466736933473866...\" decimal}\nThis program should be tested." "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}"
"{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}")
(test-expression "(exact? 1.5)" (test-expression "(exact? 1.5)"
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "(let ([f (lambda (x) x)]) f)" (test-expression "(let ([f (lambda (x) x)]) f)"
@ -381,7 +380,7 @@ the settings above should match r5rs
"read: illegal use of comma") "read: illegal use of comma")
(test-expression "(list 1)" (test-expression "(list 1)"
"(cons 1 empty)\nThis program should be tested." "(cons 1 empty)"
"(cons 1 empty)") "(cons 1 empty)")
(test-expression "(car (list))" "car: expects argument of type <pair>; given empty") (test-expression "(car (list))" "car: expects argument of type <pair>; given empty")
@ -393,7 +392,6 @@ the settings above should match r5rs
"reference to an identifier before its definition: define-syntax"))) "reference to an identifier before its definition: define-syntax")))
; ;
; ;;; ;;; ;;; ; ;;; ;;; ;;;
; ;; ; ;; ;; ; ;; ; ;; ;;
@ -426,10 +424,10 @@ the settings above should match r5rs
(prepare-for-test-expression) (prepare-for-test-expression)
(test-expression "'|.|" (test-expression "'|.|"
"'|.|\nThis program should be tested." "'|.|"
"'|.|") "'|.|")
(test-expression '("(equal? (list " image ") (list " image "))") (test-expression '("(equal? (list " image ") (list " image "))")
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "(define x 1)(define x 2)" (test-expression "(define x 1)(define x 2)"
@ -437,11 +435,11 @@ the settings above should match r5rs
"define: cannot redefine name: x") "define: cannot redefine name: x")
(test-expression "(define-struct spider (legs))(make-spider 4)" (test-expression "(define-struct spider (legs))(make-spider 4)"
"(make-spider 4)\nThis program should be tested." "(make-spider 4)"
"define-struct: cannot redefine name: spider\n(make-spider 4)") "define-struct: cannot redefine name: spider\n(make-spider 4)")
(test-expression "(sqrt -1)" (test-expression "(sqrt -1)"
"0+1i\nThis program should be tested." "0+1i"
"0+1i") "0+1i")
(test-expression "class" (test-expression "class"
@ -468,13 +466,13 @@ the settings above should match r5rs
"reference to an identifier before its definition: time") "reference to an identifier before its definition: time")
(test-expression "true" (test-expression "true"
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "mred^" (test-expression "mred^"
"mred^: name is not defined, not a parameter, and not a primitive name" "mred^: name is not defined, not a parameter, and not a primitive name"
"reference to an identifier before its definition: mred^") "reference to an identifier before its definition: mred^")
(test-expression "(eq? 'a 'A)" (test-expression "(eq? 'a 'A)"
"false\nThis program should be tested." "false"
"false") "false")
(test-expression "(set! x 1)" (test-expression "(set! x 1)"
"set!: name is not defined, not a parameter, and not a primitive name" "set!: name is not defined, not a parameter, and not a primitive name"
@ -486,10 +484,10 @@ the settings above should match r5rs
(test-expression "(cons 1 2)" "cons: second argument must be of type <list>, given 1 and 2") (test-expression "(cons 1 2)" "cons: second argument must be of type <list>, given 1 and 2")
(test-expression "(+ (list 1) 2)" "+: expects type <number> as 1st argument, given: (list 1); other arguments were: 2") (test-expression "(+ (list 1) 2)" "+: expects type <number> as 1st argument, given: (list 1); other arguments were: 2")
(test-expression "'(1)" (test-expression "'(1)"
"(list 1)\nThis program should be tested." "(list 1)"
"(list 1)") "(list 1)")
(test-expression "(define shrd (list 1)) (list shrd shrd)" (test-expression "(define shrd (list 1)) (list shrd shrd)"
"(list (list 1) (list 1))\nThis program should be tested." "(list (list 1) (list 1))"
"define: cannot redefine name: shrd\n(list (list 1) (list 1))") "define: cannot redefine name: shrd\n(list (list 1) (list 1))")
(test-expression "(local ((define x x)) 1)" (test-expression "(local ((define x x)) 1)"
"local: name is not defined, not a parameter, and not a primitive name" "local: name is not defined, not a parameter, and not a primitive name"
@ -500,43 +498,43 @@ the settings above should match r5rs
(test-expression "(if 1 1 1)" "if: question result is not true or false: 1") (test-expression "(if 1 1 1)" "if: question result is not true or false: 1")
(test-expression "(+ 1)" "procedure +: expects at least 2 arguments, given 1: 1") (test-expression "(+ 1)" "procedure +: expects at least 2 arguments, given 1: 1")
(test-expression "1.0" "1\nThis program should be tested." "1") (test-expression "1.0" "1" "1")
(test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") (test-expression "#i1.0" "#i1.0" "#i1.0")
(test-expression "4/3" (test-expression "4/3"
"{number 4/3 \"1.3\" decimal}\nThis program should be tested." "{number 4/3 \"1.3\" decimal}"
"{number 4/3 \"1.3\" decimal}") "{number 4/3 \"1.3\" decimal}")
(test-expression "1/3" (test-expression "1/3"
"{number 1/3 \"0.3\" decimal}\nThis program should be tested." "{number 1/3 \"0.3\" decimal}"
"{number 1/3 \"0.3\" decimal}") "{number 1/3 \"0.3\" decimal}")
(test-expression "-4/3" (test-expression "-4/3"
"{number -4/3 \"-1.3\" decimal}\nThis program should be tested." "{number -4/3 \"-1.3\" decimal}"
"{number -4/3 \"-1.3\" decimal}") "{number -4/3 \"-1.3\" decimal}")
(test-expression "-1/3" (test-expression "-1/3"
"{number -1/3 \"-0.3\" decimal}\nThis program should be tested." "{number -1/3 \"-0.3\" decimal}"
"{number -1/3 \"-0.3\" decimal}") "{number -1/3 \"-0.3\" decimal}")
(test-expression "3/2" (test-expression "3/2"
"{number 3/2 \"1.5\" decimal}\nThis program should be tested." "{number 3/2 \"1.5\" decimal}"
"{number 3/2 \"1.5\" decimal}") "{number 3/2 \"1.5\" decimal}")
(test-expression "1/2" (test-expression "1/2"
"{number 1/2 \"0.5\" decimal}\nThis program should be tested." "{number 1/2 \"0.5\" decimal}"
"{number 1/2 \"0.5\" decimal}") "{number 1/2 \"0.5\" decimal}")
(test-expression "-1/2" (test-expression "-1/2"
"{number -1/2 \"-0.5\" decimal}\nThis program should be tested." "{number -1/2 \"-0.5\" decimal}"
"{number -1/2 \"-0.5\" decimal}") "{number -1/2 \"-0.5\" decimal}")
(test-expression "-3/2" (test-expression "-3/2"
"{number -3/2 \"-1.5\" decimal}\nThis program should be tested." "{number -3/2 \"-1.5\" decimal}"
"{number -3/2 \"-1.5\" decimal}") "{number -3/2 \"-1.5\" decimal}")
(test-expression "+1/3i" (test-expression "+1/3i"
"0+1/3i\nThis program should be tested." "0+1/3i"
"0+1/3i") "0+1/3i")
(test-expression "+1/2i" (test-expression "+1/2i"
"0+0.5i\nThis program should be tested." "0+0.5i"
"0+0.5i") "0+0.5i")
(test-expression "779625/32258" (test-expression "779625/32258"
"{number 779625/32258 \"24.1684233368466736933473866...\" decimal}\nThis program should be tested." "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}"
"{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}")
(test-expression "(exact? 1.5)" (test-expression "(exact? 1.5)"
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "(let ([f (lambda (x) x)]) f)" (test-expression "(let ([f (lambda (x) x)]) f)"
@ -546,7 +544,7 @@ the settings above should match r5rs
"unquote: misuse of a comma or `unquote', not under a quasiquoting backquote") "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote")
(test-expression "(list 1)" (test-expression "(list 1)"
"(list 1)\nThis program should be tested." "(list 1)"
"(list 1)") "(list 1)")
(test-expression "(car (list))" "car: expects argument of type <pair>; given empty") (test-expression "(car (list))" "car: expects argument of type <pair>; given empty")
@ -589,10 +587,10 @@ the settings above should match r5rs
(prepare-for-test-expression) (prepare-for-test-expression)
(test-expression "'|.|" (test-expression "'|.|"
"'|.|\nThis program should be tested." "'|.|"
"'|.|") "'|.|")
(test-expression '("(equal? (list " image ") (list " image "))") (test-expression '("(equal? (list " image ") (list " image "))")
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "(define x 1)(define x 2)" (test-expression "(define x 1)(define x 2)"
@ -600,11 +598,11 @@ the settings above should match r5rs
"define: cannot redefine name: x") "define: cannot redefine name: x")
(test-expression "(define-struct spider (legs))(make-spider 4)" (test-expression "(define-struct spider (legs))(make-spider 4)"
"(make-spider 4)\nThis program should be tested." "(make-spider 4)"
"define-struct: cannot redefine name: spider\n(make-spider 4)") "define-struct: cannot redefine name: spider\n(make-spider 4)")
(test-expression "(sqrt -1)" (test-expression "(sqrt -1)"
"0+1i\nThis program should be tested." "0+1i"
"0+1i") "0+1i")
(test-expression "class" (test-expression "class"
@ -630,13 +628,13 @@ the settings above should match r5rs
#rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
(test-expression "true" (test-expression "true"
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "mred^" (test-expression "mred^"
"mred^: name is not defined, not a parameter, and not a primitive name" "mred^: name is not defined, not a parameter, and not a primitive name"
"reference to an identifier before its definition: mred^") "reference to an identifier before its definition: mred^")
(test-expression "(eq? 'a 'A)" (test-expression "(eq? 'a 'A)"
"false\nThis program should be tested." "false"
"false") "false")
(test-expression "(set! x 1)" (test-expression "(set! x 1)"
"set!: name is not defined, not a parameter, and not a primitive name" "set!: name is not defined, not a parameter, and not a primitive name"
@ -648,63 +646,63 @@ the settings above should match r5rs
(test-expression "(cons 1 2)" "cons: second argument must be of type <list>, given 1 and 2") (test-expression "(cons 1 2)" "cons: second argument must be of type <list>, given 1 and 2")
(test-expression "(+ (list 1) 2)" "+: expects type <number> as 1st argument, given: (list 1); other arguments were: 2") (test-expression "(+ (list 1) 2)" "+: expects type <number> as 1st argument, given: (list 1); other arguments were: 2")
(test-expression "'(1)" (test-expression "'(1)"
"(list 1)\nThis program should be tested." "(list 1)"
"(list 1)") "(list 1)")
(test-expression "(define shrd (list 1)) (list shrd shrd)" (test-expression "(define shrd (list 1)) (list shrd shrd)"
"(list (list 1) (list 1))\nThis program should be tested." "(list (list 1) (list 1))"
"define: cannot redefine name: shrd\n(list (list 1) (list 1))") "define: cannot redefine name: shrd\n(list (list 1) (list 1))")
(test-expression "(local ((define x x)) 1)" "local variable used before its definition: x") (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x")
(test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x") (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x")
(test-expression "(if 1 1 1)" "if: question result is not true or false: 1") (test-expression "(if 1 1 1)" "if: question result is not true or false: 1")
(test-expression "(+ 1)" "1\nThis program should be tested.") (test-expression "(+ 1)" "1")
(test-expression "1.0" "1\nThis program should be tested." "1") (test-expression "1.0" "1" "1")
(test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") (test-expression "#i1.0" "#i1.0" "#i1.0")
(test-expression "4/3" (test-expression "4/3"
"{number 4/3 \"1.3\" decimal}\nThis program should be tested." "{number 4/3 \"1.3\" decimal}"
"{number 4/3 \"1.3\" decimal}") "{number 4/3 \"1.3\" decimal}")
(test-expression "1/3" (test-expression "1/3"
"{number 1/3 \"0.3\" decimal}\nThis program should be tested." "{number 1/3 \"0.3\" decimal}"
"{number 1/3 \"0.3\" decimal}") "{number 1/3 \"0.3\" decimal}")
(test-expression "-4/3" (test-expression "-4/3"
"{number -4/3 \"-1.3\" decimal}\nThis program should be tested." "{number -4/3 \"-1.3\" decimal}"
"{number -4/3 \"-1.3\" decimal}") "{number -4/3 \"-1.3\" decimal}")
(test-expression "-1/3" (test-expression "-1/3"
"{number -1/3 \"-0.3\" decimal}\nThis program should be tested." "{number -1/3 \"-0.3\" decimal}"
"{number -1/3 \"-0.3\" decimal}") "{number -1/3 \"-0.3\" decimal}")
(test-expression "3/2" (test-expression "3/2"
"{number 3/2 \"1.5\" decimal}\nThis program should be tested." "{number 3/2 \"1.5\" decimal}"
"{number 3/2 \"1.5\" decimal}") "{number 3/2 \"1.5\" decimal}")
(test-expression "1/2" (test-expression "1/2"
"{number 1/2 \"0.5\" decimal}\nThis program should be tested." "{number 1/2 \"0.5\" decimal}"
"{number 1/2 \"0.5\" decimal}") "{number 1/2 \"0.5\" decimal}")
(test-expression "-1/2" (test-expression "-1/2"
"{number -1/2 \"-0.5\" decimal}\nThis program should be tested." "{number -1/2 \"-0.5\" decimal}"
"{number -1/2 \"-0.5\" decimal}") "{number -1/2 \"-0.5\" decimal}")
(test-expression "-3/2" (test-expression "-3/2"
"{number -3/2 \"-1.5\" decimal}\nThis program should be tested." "{number -3/2 \"-1.5\" decimal}"
"{number -3/2 \"-1.5\" decimal}") "{number -3/2 \"-1.5\" decimal}")
(test-expression "+1/3i" (test-expression "+1/3i"
"0+1/3i\nThis program should be tested." "0+1/3i"
"0+1/3i") "0+1/3i")
(test-expression "+1/2i" (test-expression "+1/2i"
"0+0.5i\nThis program should be tested." "0+0.5i"
"0+0.5i") "0+0.5i")
(test-expression "779625/32258" (test-expression "779625/32258"
"{number 779625/32258 \"24.1684233368466736933473866...\" decimal}\nThis program should be tested." "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}"
"{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}")
(test-expression "(exact? 1.5)" (test-expression "(exact? 1.5)"
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "(let ([f (lambda (x) x)]) f)" (test-expression "(let ([f (lambda (x) x)]) f)"
"function:f\nThis program should be tested." "function:f"
"function:f") "function:f")
(test-expression ",1" (test-expression ",1"
"unquote: misuse of a comma or `unquote', not under a quasiquoting backquote") "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote")
(test-expression "(list 1)" (test-expression "(list 1)"
"(list 1)\nThis program should be tested." "(list 1)"
"(list 1)") "(list 1)")
(test-expression "(car (list))" "car: expects argument of type <pair>; given empty") (test-expression "(car (list))" "car: expects argument of type <pair>; given empty")
(test-expression "argv" (test-expression "argv"
@ -749,21 +747,21 @@ the settings above should match r5rs
(prepare-for-test-expression) (prepare-for-test-expression)
(test-expression "'|.|" (test-expression "'|.|"
"'|.|\nThis program should be tested." "'|.|"
"'|.|") "'|.|")
(test-expression '("(equal? (list " image ") (list " image "))") (test-expression '("(equal? (list " image ") (list " image "))")
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "(define x 1)(define x 2)" (test-expression "(define x 1)(define x 2)"
"x: this name was defined previously and cannot be re-defined" "x: this name was defined previously and cannot be re-defined"
"define: cannot redefine name: x") "define: cannot redefine name: x")
(test-expression "(define-struct spider (legs))(make-spider 4)" (test-expression "(define-struct spider (legs))(make-spider 4)"
"(make-spider 4)\nThis program should be tested." "(make-spider 4)"
"define-struct: cannot redefine name: spider\n(make-spider 4)") "define-struct: cannot redefine name: spider\n(make-spider 4)")
(test-expression "(sqrt -1)" (test-expression "(sqrt -1)"
"0+1i\nThis program should be tested." "0+1i"
"0+1i") "0+1i")
(test-expression "class" (test-expression "class"
@ -789,13 +787,13 @@ the settings above should match r5rs
#rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
(test-expression "true" (test-expression "true"
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "mred^" (test-expression "mred^"
"mred^: name is not defined, not a parameter, and not a primitive name" "mred^: name is not defined, not a parameter, and not a primitive name"
"reference to an identifier before its definition: mred^") "reference to an identifier before its definition: mred^")
(test-expression "(eq? 'a 'A)" (test-expression "(eq? 'a 'A)"
"false\nThis program should be tested." "false"
"false") "false")
(test-expression "(set! x 1)" (test-expression "(set! x 1)"
"set!: name is not defined, not a parameter, and not a primitive name" "set!: name is not defined, not a parameter, and not a primitive name"
@ -807,59 +805,59 @@ the settings above should match r5rs
(test-expression "(cons 1 2)" "cons: second argument must be of type <list>, given 1 and 2") (test-expression "(cons 1 2)" "cons: second argument must be of type <list>, given 1 and 2")
(test-expression "(+ (list 1) 2)" "+: expects type <number> as 1st argument, given: (list 1); other arguments were: 2") (test-expression "(+ (list 1) 2)" "+: expects type <number> as 1st argument, given: (list 1); other arguments were: 2")
(test-expression "'(1)" (test-expression "'(1)"
"(list 1)\nThis program should be tested." "(list 1)"
"(list 1)") "(list 1)")
(test-expression "(define shrd (list 1)) (list shrd shrd)" (test-expression "(define shrd (list 1)) (list shrd shrd)"
"(list (list 1) (list 1))\nThis program should be tested." "(list (list 1) (list 1))"
"define: cannot redefine name: shrd\n(list (list 1) (list 1))") "define: cannot redefine name: shrd\n(list (list 1) (list 1))")
(test-expression "(local ((define x x)) 1)" "local variable used before its definition: x") (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x")
(test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x") (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x")
(test-expression "(if 1 1 1)" "if: question result is not true or false: 1") (test-expression "(if 1 1 1)" "if: question result is not true or false: 1")
(test-expression "(+ 1)" "1\nThis program should be tested.") (test-expression "(+ 1)" "1")
(test-expression "1.0" "1\nThis program should be tested." "1") (test-expression "1.0" "1" "1")
(test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") (test-expression "#i1.0" "#i1.0" "#i1.0")
(test-expression "4/3" (test-expression "4/3"
"{number 4/3 \"1.3\" decimal}\nThis program should be tested." "{number 4/3 \"1.3\" decimal}"
"{number 4/3 \"1.3\" decimal}") "{number 4/3 \"1.3\" decimal}")
(test-expression "1/3" (test-expression "1/3"
"{number 1/3 \"0.3\" decimal}\nThis program should be tested." "{number 1/3 \"0.3\" decimal}"
"{number 1/3 \"0.3\" decimal}") "{number 1/3 \"0.3\" decimal}")
(test-expression "-4/3" (test-expression "-4/3"
"{number -4/3 \"-1.3\" decimal}\nThis program should be tested." "{number -4/3 \"-1.3\" decimal}"
"{number -4/3 \"-1.3\" decimal}") "{number -4/3 \"-1.3\" decimal}")
(test-expression "-1/3" (test-expression "-1/3"
"{number -1/3 \"-0.3\" decimal}\nThis program should be tested." "{number -1/3 \"-0.3\" decimal}"
"{number -1/3 \"-0.3\" decimal}") "{number -1/3 \"-0.3\" decimal}")
(test-expression "3/2" (test-expression "3/2"
"{number 3/2 \"1.5\" decimal}\nThis program should be tested." "{number 3/2 \"1.5\" decimal}"
"{number 3/2 \"1.5\" decimal}") "{number 3/2 \"1.5\" decimal}")
(test-expression "1/2" (test-expression "1/2"
"{number 1/2 \"0.5\" decimal}\nThis program should be tested." "{number 1/2 \"0.5\" decimal}"
"{number 1/2 \"0.5\" decimal}") "{number 1/2 \"0.5\" decimal}")
(test-expression "-1/2" (test-expression "-1/2"
"{number -1/2 \"-0.5\" decimal}\nThis program should be tested." "{number -1/2 \"-0.5\" decimal}"
"{number -1/2 \"-0.5\" decimal}") "{number -1/2 \"-0.5\" decimal}")
(test-expression "-3/2" (test-expression "-3/2"
"{number -3/2 \"-1.5\" decimal}\nThis program should be tested." "{number -3/2 \"-1.5\" decimal}"
"{number -3/2 \"-1.5\" decimal}") "{number -3/2 \"-1.5\" decimal}")
(test-expression "+1/3i" "0+1/3i\nThis program should be tested." "0+1/3i") (test-expression "+1/3i" "0+1/3i" "0+1/3i")
(test-expression "+1/2i" "0+0.5i\nThis program should be tested." "0+0.5i") (test-expression "+1/2i" "0+0.5i" "0+0.5i")
(test-expression "779625/32258" (test-expression "779625/32258"
"{number 779625/32258 \"24.1684233368466736933473866...\" decimal}\nThis program should be tested." "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}"
"{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}")
(test-expression "(exact? 1.5)" (test-expression "(exact? 1.5)"
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "(let ([f (lambda (x) x)]) f)" (test-expression "(let ([f (lambda (x) x)]) f)"
"(lambda (a1) ...)\nThis program should be tested." "(lambda (a1) ...)"
"(lambda (a1) ...)") "(lambda (a1) ...)")
(test-expression ",1" (test-expression ",1"
"unquote: misuse of a comma or `unquote', not under a quasiquoting backquote") "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote")
(test-expression "(list 1)" (test-expression "(list 1)"
"(list 1)\nThis program should be tested." "(list 1)"
"(list 1)") "(list 1)")
(test-expression "(car (list))" "car: expects argument of type <pair>; given empty") (test-expression "(car (list))" "car: expects argument of type <pair>; given empty")
(test-expression "argv" (test-expression "argv"
@ -903,21 +901,21 @@ the settings above should match r5rs
(prepare-for-test-expression) (prepare-for-test-expression)
(test-expression "'|.|" (test-expression "'|.|"
"'|.|\nThis program should be tested." "'|.|"
"'|.|") "'|.|")
(test-expression '("(equal? (list " image ") (list " image "))") (test-expression '("(equal? (list " image ") (list " image "))")
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "(define x 1)(define x 2)" (test-expression "(define x 1)(define x 2)"
"x: this name was defined previously and cannot be re-defined" "x: this name was defined previously and cannot be re-defined"
"define: cannot redefine name: x") "define: cannot redefine name: x")
(test-expression "(define-struct spider (legs))(make-spider 4)" (test-expression "(define-struct spider (legs))(make-spider 4)"
"(make-spider 4)\nThis program should be tested." "(make-spider 4)"
"define-struct: cannot redefine name: spider\n(make-spider 4)") "define-struct: cannot redefine name: spider\n(make-spider 4)")
(test-expression "(sqrt -1)" (test-expression "(sqrt -1)"
"0+1i\nThis program should be tested." "0+1i"
"0+1i") "0+1i")
(test-expression "class" (test-expression "class"
@ -942,81 +940,81 @@ the settings above should match r5rs
#rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
(test-expression "true" (test-expression "true"
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "mred^" (test-expression "mred^"
"mred^: name is not defined, not a parameter, and not a primitive name" "mred^: name is not defined, not a parameter, and not a primitive name"
"reference to an identifier before its definition: mred^") "reference to an identifier before its definition: mred^")
(test-expression "(eq? 'a 'A)" (test-expression "(eq? 'a 'A)"
"false\nThis program should be tested." "false"
"false") "false")
(test-expression "(set! x 1)" (test-expression "(set! x 1)"
"x: name is not defined" "x: name is not defined"
"set!: cannot set identifier before its definition: x") "set!: cannot set identifier before its definition: x")
(test-expression "(define qqq 2) (set! qqq 1)" (test-expression "(define qqq 2) (set! qqq 1)"
"(void)\nThis program should be tested." "(void)"
"define: cannot redefine name: qqq\n(void)") "define: cannot redefine name: qqq\n(void)")
(test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false")
(test-expression "(cons 1 2)" "cons: second argument must be of type <list or cyclic list>, given 1 and 2") (test-expression "(cons 1 2)" "cons: second argument must be of type <list or cyclic list>, given 1 and 2")
(test-expression "(+ (list 1) 2)" "+: expects type <number> as 1st argument, given: (list 1); other arguments were: 2") (test-expression "(+ (list 1) 2)" "+: expects type <number> as 1st argument, given: (list 1); other arguments were: 2")
(test-expression "'(1)" (test-expression "'(1)"
"(list 1)\nThis program should be tested." "(list 1)"
"(list 1)") "(list 1)")
(test-expression "(define shrd (list 1)) (list shrd shrd)" (test-expression "(define shrd (list 1)) (list shrd shrd)"
"(shared ((-1- (list 1))) (list -1- -1-))\nThis program should be tested." "(shared ((-1- (list 1))) (list -1- -1-))"
"define: cannot redefine name: shrd\n(shared ((-1- (list 1))) (list -1- -1-))") "define: cannot redefine name: shrd\n(shared ((-1- (list 1))) (list -1- -1-))")
(test-expression "(local ((define x x)) 1)" "local variable used before its definition: x") (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x")
(test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x") (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x")
(test-expression "(if 1 1 1)" "if: question result is not true or false: 1") (test-expression "(if 1 1 1)" "if: question result is not true or false: 1")
(test-expression "(+ 1)" "procedure +: expects at least 2 arguments, given 1: 1") (test-expression "(+ 1)" "1")
(test-expression "1.0" "1\nThis program should be tested." "1") (test-expression "1.0" "1" "1")
(test-expression "#i1.0" "#i1.0\nThis program should be tested." "#i1.0") (test-expression "#i1.0" "#i1.0" "#i1.0")
(test-expression "4/3" (test-expression "4/3"
"{number 4/3 \"1.3\" decimal}\nThis program should be tested." "{number 4/3 \"1.3\" decimal}"
"{number 4/3 \"1.3\" decimal}") "{number 4/3 \"1.3\" decimal}")
(test-expression "1/3" (test-expression "1/3"
"{number 1/3 \"0.3\" decimal}\nThis program should be tested." "{number 1/3 \"0.3\" decimal}"
"{number 1/3 \"0.3\" decimal}") "{number 1/3 \"0.3\" decimal}")
(test-expression "-4/3" (test-expression "-4/3"
"{number -4/3 \"-1.3\" decimal}\nThis program should be tested." "{number -4/3 \"-1.3\" decimal}"
"{number -4/3 \"-1.3\" decimal}") "{number -4/3 \"-1.3\" decimal}")
(test-expression "-1/3" (test-expression "-1/3"
"{number -1/3 \"-0.3\" decimal}\nThis program should be tested." "{number -1/3 \"-0.3\" decimal}"
"{number -1/3 \"-0.3\" decimal}") "{number -1/3 \"-0.3\" decimal}")
(test-expression "3/2" (test-expression "3/2"
"{number 3/2 \"1.5\" decimal}\nThis program should be tested." "{number 3/2 \"1.5\" decimal}"
"{number 3/2 \"1.5\" decimal}") "{number 3/2 \"1.5\" decimal}")
(test-expression "1/2" (test-expression "1/2"
"{number 1/2 \"0.5\" decimal}\nThis program should be tested." "{number 1/2 \"0.5\" decimal}"
"{number 1/2 \"0.5\" decimal}") "{number 1/2 \"0.5\" decimal}")
(test-expression "-1/2" (test-expression "-1/2"
"{number -1/2 \"-0.5\" decimal}\nThis program should be tested." "{number -1/2 \"-0.5\" decimal}"
"{number -1/2 \"-0.5\" decimal}") "{number -1/2 \"-0.5\" decimal}")
(test-expression "-3/2" (test-expression "-3/2"
"{number -3/2 \"-1.5\" decimal}\nThis program should be tested." "{number -3/2 \"-1.5\" decimal}"
"{number -3/2 \"-1.5\" decimal}") "{number -3/2 \"-1.5\" decimal}")
(test-expression "+1/3i" (test-expression "+1/3i"
"0+1/3i\nThis program should be tested." "0+1/3i"
"0+1/3i") "0+1/3i")
(test-expression "+1/2i" (test-expression "+1/2i"
"0+0.5i\nThis program should be tested." "0+0.5i"
"0+0.5i") "0+0.5i")
(test-expression "779625/32258" (test-expression "779625/32258"
"{number 779625/32258 \"24.1684233368466736933473866...\" decimal}\nThis program should be tested." "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}"
"{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}")
(test-expression "(exact? 1.5)" (test-expression "(exact? 1.5)"
"true\nThis program should be tested." "true"
"true") "true")
(test-expression "(let ([f (lambda (x) x)]) f)" (test-expression "(let ([f (lambda (x) x)]) f)"
"(lambda (a1) ...)\nThis program should be tested." "(lambda (a1) ...)"
"(lambda (a1) ...)") "(lambda (a1) ...)")
(test-expression ",1" (test-expression ",1"
"unquote: misuse of a comma or `unquote', not under a quasiquoting backquote") "unquote: misuse of a comma or `unquote', not under a quasiquoting backquote")
(test-expression "(list 1)" (test-expression "(list 1)"
"(list 1)\nThis program should be tested." "(list 1)"
"(list 1)") "(list 1)")
(test-expression "(car (list))" "car: expects argument of type <pair>; given empty") (test-expression "(car (list))" "car: expects argument of type <pair>; given empty")
(test-expression "argv" (test-expression "argv"
@ -1076,7 +1074,7 @@ the settings above should match r5rs
(define (fetch-output/should-be-tested . args) (define (fetch-output/should-be-tested . args)
(regexp-replace (regexp (regexp-replace (regexp
(string-append (string-append
(regexp-quote "\nThis program should be tested.") (regexp-quote "")
"$")) "$"))
(apply fetch-output args) (apply fetch-output args)
"")) ""))
@ -1264,87 +1262,84 @@ the settings above should match r5rs
;; -> void ;; -> void
;; types an expression in the definitions window, executes it and tests the output ;; types an expression in the definitions window, executes it and tests the output
;; types an expression in the REPL and tests the output from the REPL. ;; types an expression in the REPL and tests the output from the REPL.
(define test-expression (define (test-expression expression defs-expected [repl-expected defs-expected])
(case-lambda (let* ([drs (wait-for-drscheme-frame)]
[(expression expected) (test-expression expression expected expected)] [interactions-text (send drs get-interactions-text)]
[(expression defs-expected repl-expected) [definitions-text (send drs get-definitions-text)]
(let* ([drs (wait-for-drscheme-frame)] [handle-insertion
[interactions-text (send drs get-interactions-text)] (lambda (item)
[definitions-text (send drs get-definitions-text)] (cond
[handle-insertion [(eq? item 'image)
(lambda (item) (use-get/put-dialog
(cond (lambda () (fw:test:menu-select "Insert" "Insert Image..."))
[(eq? item 'image) (simplify-path (build-path (collection-path "icons") "recycle.png")))]
(use-get/put-dialog [(string? item)
(lambda () (fw:test:menu-select "Insert" "Insert Image...")) (type-in-definitions drs item)]
(simplify-path (build-path (collection-path "icons") "recycle.png")))] [(eq? item 'xml)
[(string? item) (fw:test:menu-select "Insert" "Insert XML Box")
(type-in-definitions drs item)] (for-each fw:test:keystroke (string->list "<a><b>"))]
[(eq? item 'xml) [else (error 'handle-insertion "unknown thing to insert ~s" item)]))]
(fw:test:menu-select "Insert" "Insert XML Box") [check-expectation
(for-each fw:test:keystroke (string->list "<a><b>"))] (lambda (expected got)
[else (error 'handle-insertion "unknown thing to insert ~s" item)]))] (cond
[check-expectation [(string? expected)
(lambda (expected got) (whitespace-string=? expected got)]
(cond [(regexp? expected)
[(string? expected) (regexp-match expected got)]
(whitespace-string=? expected got)] [(procedure? expected)
[(regexp? expected) (expected got)]))]
(regexp-match expected got)] [make-err-msg
[(procedure? expected) (lambda (expected)
(expected got)]))] (cond
[make-err-msg [(string? expected)
(lambda (expected) "FAILED: ~s ~s expected ~s to produce:\n ~s\ngot:\n ~s\ninstead~n"]
(cond [(regexp? expected)
[(string? expected) "FAILED: ~s ~s expected ~s to match ~s, got ~s instead~n"]
"FAILED: ~s ~s expected ~s to produce:\n ~s\ngot:\n ~s\ninstead~n"] [(procedure? expected)
[(regexp? expected) "FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s~n"]))])
"FAILED: ~s ~s expected ~s to match ~s, got ~s instead~n"] (clear-definitions drs)
[(procedure? expected) (cond
"FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s~n"]))]) [(pair? expression) (for-each handle-insertion expression)]
(clear-definitions drs) [else (handle-insertion expression)])
(cond (do-execute drs)
[(pair? expression) (for-each handle-insertion expression)]
[else (handle-insertion expression)]) (let ([got
(do-execute drs) (fetch-output
drs
(let ([got (send interactions-text paragraph-start-position 2)
(fetch-output (send interactions-text paragraph-end-position
drs (- (send interactions-text last-paragraph) 1)))])
(send interactions-text paragraph-start-position 2) (when (regexp-match re:out-of-sync got)
(send interactions-text paragraph-end-position (error 'text-expression "got out of sync message"))
(- (send interactions-text last-paragraph) 1)))]) (unless (check-expectation defs-expected got)
(when (regexp-match re:out-of-sync got) (printf (make-err-msg defs-expected)
(error 'text-expression "got out of sync message")) 'definitions (language) expression defs-expected got)))
(unless (check-expectation defs-expected got)
(printf (make-err-msg defs-expected) (let ([s (make-semaphore 0)])
'definitions (language) expression defs-expected got))) (queue-callback
(λ ()
(let ([s (make-semaphore 0)]) (send definitions-text select-all)
(queue-callback (send definitions-text copy)
(λ () (send interactions-text set-position
(send definitions-text select-all) (send interactions-text last-position)
(send definitions-text copy) (send interactions-text last-position))
(send interactions-text set-position (send interactions-text paste)
(send interactions-text last-position) (semaphore-post s)))
(send interactions-text last-position)) (semaphore-wait s))
(send interactions-text paste)
(semaphore-post s))) (let ([last-para (send interactions-text last-paragraph)])
(semaphore-wait s)) (alt-return-in-interactions drs)
(wait-for-computation drs)
(let ([last-para (send interactions-text last-paragraph)]) (let ([got
(type-in-interactions drs (string #\newline)) (fetch-output
(wait-for-computation drs) drs
(let ([got (send interactions-text paragraph-start-position (+ last-para 1))
(fetch-output (send interactions-text paragraph-end-position
drs (- (send interactions-text last-paragraph) 1)))])
(send interactions-text paragraph-start-position (+ last-para 1)) (when (regexp-match re:out-of-sync got)
(send interactions-text paragraph-end-position (error 'text-expression "got out of sync message"))
(- (send interactions-text last-paragraph) 1)))]) (unless (check-expectation repl-expected got)
(when (regexp-match re:out-of-sync got) (printf (make-err-msg repl-expected) 'interactions (language) expression repl-expected got))))))
(error 'text-expression "got out of sync message"))
(unless (check-expectation repl-expected got)
(printf (make-err-msg repl-expected) 'interactions (language) expression repl-expected got)))))]))
(define-syntax (go stx) (define-syntax (go stx)

45
collects/tests/drscheme/module-lang-test-utils.ss
View File

@ -124,13 +124,56 @@
(send interactions-text get-error-ranges))))]))))) (send interactions-text get-error-ranges))))])))))
(define (run-test) (define (run-test)
(run-use-compiled-file-paths-tests)
(set-language-level! '("Module") #f) (set-language-level! '("Module") #f)
(test:set-radio-box-item! "Debugging") (test:set-radio-box-item! "Debugging")
(let ([f (get-top-level-focus-window)]) (let ([f (get-top-level-focus-window)])
(test:button-push "OK") (test:button-push "OK")
(wait-for-new-frame f)) (wait-for-new-frame f))
(for-each single-test (reverse tests)) (for-each single-test (reverse tests))
(clear-definitions drs) (clear-definitions drs)
(send (send drs get-definitions-text) set-modified #f) (send (send drs get-definitions-text) set-modified #f)
(for ([file temp-files]) (when (file-exists? file) (delete-file file)))) (for ([file temp-files]) (when (file-exists? file) (delete-file file))))
(define (run-use-compiled-file-paths-tests)
(define (setup-dialog/run proc)
(set-language-level! '("Module") #f)
(proc)
(let ([f (get-top-level-focus-window)])
(test:button-push "OK")
(wait-for-new-frame f))
(do-execute drs)
(fetch-output drs))
(define (run-one-test radio-box expected [no-check-expected #f])
(let ([got (setup-dialog/run (λ () (test:set-radio-box-item! radio-box)))])
(unless (equal? got (format "~s" expected))
(error 'r-u-c-f-p-t "got ~s expected ~s"
got
expected)))
(when no-check-expected
(let ([got (setup-dialog/run
(λ ()
(test:set-radio-box-item! radio-box)
(test:set-check-box! "Populate compiled/ directories (for faster loading)" #f)))])
(unless (equal? got (format "~s" no-check-expected))
(error 'r-u-c-f-p-t.2 "got ~s expected ~s"
got
expected)))))
(define drs/compiled/et (build-path "compiled" "drscheme" "errortrace"))
(define drs/compiled (build-path "compiled" "drscheme"))
(define compiled/et (build-path "compiled" "errortrace"))
(define compiled (build-path "compiled"))
(clear-definitions drs)
(insert-in-definitions drs "#lang scheme\n(use-compiled-file-paths)")
(run-one-test "No debugging or profiling" (list drs/compiled compiled) (list compiled))
(run-one-test "Debugging" (list drs/compiled/et compiled/et compiled) (list compiled/et compiled))
(run-one-test "Debugging and profiling" (list compiled))
(run-one-test "Syntactic test suite coverage" (list compiled)))

6
collects/tests/drscheme/module-lang-test.ss
View File

@ -1,8 +1,8 @@
#reader scribble/reader #lang at-exp scheme/gui
#lang scheme/gui
(require "module-lang-test-utils.ss") (require "module-lang-test-utils.ss")
(provide run-test) (provide run-test)
#;
(error #<<-- (error #<<--
need to add tests cases that check the value of the use-compiled-file handler: need to add tests cases that check the value of the use-compiled-file handler:
@ -269,7 +269,7 @@ non-errortrace mode, not saving compiled files:
@t{(f)} @t{(f)}
#<<-- #<<--
> (f) > (f)
. . both in: . both in:
f f
(f) (f)
-- --

40
collects/tests/drscheme/repl-test.ss
View File

@ -645,23 +645,17 @@ This produces an ACK message
void) void)
;; should produce a syntax object with a turn-down triangle. ;; should produce a syntax object with a turn-down triangle.
(let ([printout (mktest "(write (list (syntax x)))"
(regexp (#rx"({embedded \".#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:21.*>\"})"
(string-append (regexp-quote "({embedded \".") #rx"({embedded \".#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:21.*>\"})"
syntax-regexp-prefix #rx"({embedded \".#<syntax:.*/collects/tests/drscheme/repl-test-tmp3.ss:1:21.*>\"})"
(regexp-quote ":1:21>\"})")))]) #rx"({embedded \".#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:21.*>\"})"
(mktest "(write (list (syntax x)))" #rx"({embedded \".#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:21.*>\"})"
#rx"({embedded \".#<syntax:.*/collects/tests/drscheme/repl-test-tmp3.ss:1:21.*>\"})")
(#rx"({embedded \".#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:21>\"})" 'interactions
#rx"({embedded \".#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:21>\"})" #f
#rx"({embedded \".#<syntax:.*/collects/tests/drscheme/repl-test-tmp3.ss:1:21>\"})" void
#rx"({embedded \".#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:21>\"})" void)
#rx"({embedded \".#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:21>\"})"
#rx"({embedded \".#<syntax:.*/collects/tests/drscheme/repl-test-tmp3.ss:1:21>\"})")
'interactions
#f
void
void))
;; make sure syntax objects only go into good ports ;; make sure syntax objects only go into good ports
(mktest "(define-syntax (foo stx) (with-handlers ([exn:fail? (lambda (x) #'10)]) (syntax-local-value #'foot))) (foo)" (mktest "(define-syntax (foo stx) (with-handlers ([exn:fail? (lambda (x) #'10)]) (syntax-local-value #'foot))) (foo)"
@ -693,12 +687,12 @@ This produces an ACK message
(mktest "(parameterize ([current-output-port (open-output-string)]) (fprintf (current-error-port) \"~e\" #'foot))" (mktest "(parameterize ([current-output-port (open-output-string)]) (fprintf (current-error-port) \"~e\" #'foot))"
(#rx"#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:96>" (#rx"#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:96.*>"
#rx"#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:96>" #rx"#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:96.*>"
#rx"#<syntax:.*/collects/tests/drscheme/repl-test-tmp3.ss:1:96>" #rx"#<syntax:.*/collects/tests/drscheme/repl-test-tmp3.ss:1:96.*>"
#rx"#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:96>" #rx"#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:96.*>"
#rx"#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:96>" #rx"#<syntax:.*/collects/tests/drscheme/repl-test-tmp.ss:1:96.*>"
#rx"#<syntax:.*/collects/tests/drscheme/repl-test-tmp3.ss:1:96>") #rx"#<syntax:.*/collects/tests/drscheme/repl-test-tmp3.ss:1:96.*>")
'interactions 'interactions
#f #f
void void

2
collects/tests/drscheme/teachpack.ss
View File

@ -207,7 +207,7 @@
(do-execute drs-frame) (do-execute drs-frame)
(let ([got (fetch-output drs-frame)] (let ([got (fetch-output drs-frame)]
[expected (format "Teachpack: ~a.\n1\nThis program should be tested." [expected (format "Teachpack: ~a.\n1"
(path->string teachpack))]) (path->string teachpack))])
(unless (equal? got expected) (unless (equal? got expected)
(printf "FAILED built in teachpack test: ~a~n" (path->string teachpack)) (printf "FAILED built in teachpack test: ~a~n" (path->string teachpack))