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

fixed up minor bugs in program and lots of little problems in the test suites

Browse Source 
svn: r6173
This commit is contained in:
Robby Findler 2007-05-08 01:02:40 +00:00
parent a58e476dd6
commit 3c5f2c7395
11 changed files with 157 additions and 243 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/drscheme/syncheck.ss
View File

@ -2145,13 +2145,12 @@ If the namespace does not, they are colored the unbound color.
;; if someone just types `(λ (x) x)' it has no 'origin ;; if someone just types `(λ (x) x)' it has no 'origin
;; field, but there still are keywords. ;; field, but there still are keywords.
(define (annotate-raw-keyword stx id-map) (define (annotate-raw-keyword stx id-map)
(unless (syntax-property stx 'origin) (let ([lst (syntax-e stx)])
(let ([lst (syntax-e stx)]) (when (pair? lst)
(when (pair? lst) (let ([f-stx (car lst)])
(let ([f-stx (car lst)]) (when (and (syntax-original? f-stx)
(when (and (syntax-original? f-stx) (identifier? f-stx))
(identifier? f-stx)) (add-id id-map f-stx))))))
(add-id id-map f-stx)))))))
;; color-internal-structure : syntax str -> void ;; color-internal-structure : syntax str -> void
(define (color-internal-structure stx style-name) (define (color-internal-structure stx style-name)

8
collects/framework/framework.ss
View File

@ -118,6 +118,14 @@
"the second case in the case-lambda sets" "the second case in the case-lambda sets"
"the name of the application to \\var{name}.") "the name of the application to \\var{name}.")
(preferences:put-preferences/gui
(-> (listof symbol?)
(listof any/c)
any)
(name-list val-list)
"Like \\scheme{put-preferences}, but passes along"
"a \\var{locked-proc} that asks the user if they want to"
"try again.")
(preferences:add-panel (preferences:add-panel
((or/c string? (cons/c string? (listof string?))) ((or/c string? (cons/c string? (listof string?)))
((is-a?/c area-container-window<%>) ((is-a?/c area-container-window<%>)

5
collects/tests/drscheme/README
View File

@ -50,9 +50,4 @@ the function, all tests will be run.
|# syncheck-test.ss #| |# syncheck-test.ss #|
|# test-box-test.ss #|
Test test boxes.
|#) |#)

7
collects/tests/drscheme/io.ss
View File

@ -55,15 +55,16 @@ add this test:
(send text paragraph-start-position 2)))))) (send text paragraph-start-position 2))))))
(channel-get chan))) (channel-get chan)))
(define (output-style x) (equal? (list-ref x 9) '(150 0 150))) (define (output-style x) (eq? x '|ports out|))
(define (error-style x) (equal? (list-ref x 9) '(255 0 0))) (define (error-style x) (eq? x '|ports err|))
(define (value-style x) (eq? x '|ports value|))
(define prompt '("\n> " default-color)) (define prompt '("\n> " default-color))
;; this test has to be first to test an uninitialized state of the port ;; this test has to be first to test an uninitialized state of the port
;; NOTE: missing a name for the "value" style ... so this test appears to fail (altho it actually passes) ;; NOTE: missing a name for the "value" style ... so this test appears to fail (altho it actually passes)
(check-output "(port-next-location (current-input-port))" (check-output "(port-next-location (current-input-port))"
(list '("1\n0\n1\n" value-style) (list `("1\n0\n1\n" ,value-style)
prompt)) prompt))
(check-output "(display 1)" (list (list "1" output-style) prompt)) (check-output "(display 1)" (list (list "1" output-style) prompt))

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

@ -258,7 +258,8 @@ the settings above should match r5rs
(test-expression "(define x 1)(define x 2)" "") (test-expression "(define x 1)(define x 2)" "")
(test-expression "(define-struct spider (legs))(make-spider 4)" (test-expression "(define-struct spider (legs))(make-spider 4)"
"{bug09.png} reference to undefined identifier: define-struct") "{bug09.png} reference to undefined identifier: define-struct"
"{bug09.png} reference to undefined identifier: define-struct\n{bug09.png} reference to undefined identifier: make-spider")
(test-expression "(sqrt -1)" "0+1i") (test-expression "(sqrt -1)" "0+1i")
@ -358,7 +359,7 @@ the settings above should match r5rs
(test-expression "(define-struct spider (legs))(make-spider 4)" (test-expression "(define-struct spider (legs))(make-spider 4)"
"(make-spider 4)" "(make-spider 4)"
"define-struct: cannot redefine name: spider") "define-struct: cannot redefine name: spider\n(make-spider 4)")
(test-expression "(sqrt -1)" "0+1i") (test-expression "(sqrt -1)" "0+1i")
@ -403,7 +404,7 @@ the settings above should match r5rs
(test-expression "'(1)" "quote: expected a name after a ', found something else") (test-expression "'(1)" "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))" "(cons (cons 1 empty) (cons (cons 1 empty) empty))"
"define: cannot redefine name: shrd") "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 an argument, and not a primitive name" "local: name is not defined, not an argument, and not a primitive name"
"function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else")
@ -482,7 +483,7 @@ the settings above should match r5rs
(test-expression "(define-struct spider (legs))(make-spider 4)" (test-expression "(define-struct spider (legs))(make-spider 4)"
"(make-spider 4)" "(make-spider 4)"
"define-struct: cannot redefine name: spider") "define-struct: cannot redefine name: spider\n(make-spider 4)")
(test-expression "(sqrt -1)" "0+1i") (test-expression "(sqrt -1)" "0+1i")
@ -525,7 +526,7 @@ the settings above should match r5rs
(test-expression "'(1)" "(list 1)") (test-expression "'(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))" "(list (list 1) (list 1))"
"define: cannot redefine name: shrd") "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 an argument, and not a primitive name" "local: name is not defined, not an argument, and not a primitive name"
"function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else")
@ -602,7 +603,7 @@ the settings above should match r5rs
(test-expression "(define-struct spider (legs))(make-spider 4)" (test-expression "(define-struct spider (legs))(make-spider 4)"
"(make-spider 4)" "(make-spider 4)"
"define-struct: cannot redefine name: spider") "define-struct: cannot redefine name: spider\n(make-spider 4)")
(test-expression "(sqrt -1)" "0+1i") (test-expression "(sqrt -1)" "0+1i")
@ -644,7 +645,7 @@ the settings above should match r5rs
(test-expression "'(1)" "(list 1)") (test-expression "'(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))" "(list (list 1) (list 1))"
"define: cannot redefine name: shrd") "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")
@ -714,7 +715,7 @@ the settings above should match r5rs
(test-expression "(define-struct spider (legs))(make-spider 4)" (test-expression "(define-struct spider (legs))(make-spider 4)"
"(make-spider 4)" "(make-spider 4)"
"define-struct: cannot redefine name: spider") "define-struct: cannot redefine name: spider\n(make-spider 4)")
(test-expression "(sqrt -1)" "0+1i") (test-expression "(sqrt -1)" "0+1i")
@ -756,7 +757,7 @@ the settings above should match r5rs
(test-expression "'(1)" "(list 1)") (test-expression "'(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))" "(list (list 1) (list 1))"
"define: cannot redefine name: shrd") "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")
@ -825,7 +826,7 @@ the settings above should match r5rs
(test-expression "(define-struct spider (legs))(make-spider 4)" (test-expression "(define-struct spider (legs))(make-spider 4)"
"(make-spider 4)" "(make-spider 4)"
"define-struct: cannot redefine name: spider") "define-struct: cannot redefine name: spider\n(make-spider 4)")
(test-expression "(sqrt -1)" "0+1i") (test-expression "(sqrt -1)" "0+1i")
@ -858,13 +859,15 @@ the settings above should match r5rs
(test-expression "(set! x 1)" (test-expression "(set! x 1)"
"x: name is not defined" "x: name is not defined"
"set!: cannot set undefined identifier: x") "set!: cannot set undefined identifier: x")
(test-expression "(define qqq 2) (set! qqq 1)" "(void)" "define: cannot redefine name: qqq") (test-expression "(define qqq 2) (set! qqq 1)"
"(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 "'(1)" "(list 1)") (test-expression "'(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-))" "(shared ((-1- (list 1))) (list -1- -1-))"
"define: cannot redefine name: shrd") "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")
@ -1222,9 +1225,9 @@ the settings above should match r5rs
(define (run-test) (define (run-test)
;(go mred) ;(go mred)
;(go mzscheme) ;(go mzscheme)
;(go beginner) ;; not really done ;(go beginner)
;(go beginner/abbrev) ;; not really done ;(go beginner/abbrev)
(go intermediate) ;(go intermediate)
(go intermediate/lambda) (go intermediate/lambda)
(go advanced) (go advanced)
(go r5rs))) (go r5rs)))

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

@ -878,7 +878,7 @@
; directly, and second, we use the load command. We compare the ; directly, and second, we use the load command. We compare the
; the results of these operations against expected results. ; the results of these operations against expected results.
(define ((run-single-test execute-text-start escape raw?) in-vector) (define ((run-single-test execute-text-start escape raw?) in-vector)
(printf "\n>> testing ~s\n" (test-program in-vector)) ;(printf "\n>> testing ~s\n" (test-program in-vector))
(let* ([program (test-program in-vector)] (let* ([program (test-program in-vector)]
[execute-answer (if raw? [execute-answer (if raw?
(test-raw-execute-answer in-vector) (test-raw-execute-answer in-vector)
@ -1116,7 +1116,7 @@
(let* ([end (- (get-int-pos) 1)] (let* ([end (- (get-int-pos) 1)]
[output (fetch-output drscheme-frame start end)] [output (fetch-output drscheme-frame start end)]
[expected "{bug09.png} reference to undefined identifier: x"]) [expected "reference to undefined identifier: x"])
(unless (equal? output expected) (unless (equal? output expected)
(error 'callcc-test "expected ~s, got ~s" expected output))))) (error 'callcc-test "expected ~s, got ~s" expected output)))))

32
collects/tests/drscheme/stepper-test.ss
View File

@ -635,11 +635,22 @@
[after null] [after null]
[snips snips]) [snips snips])
(define (die which when)
(printf "~a: didn't find ~s\n ~s\n ~s\n ~s\n ~s\n" which when
program
before
after
snips))
(define (hunt-for-list id) (define (hunt-for-list id)
(let loop () (let loop ()
(cond (cond
[(null? snips) (k #f)] [(null? snips)
[(eq? 'unknown (car snips)) (k #f)] (die 'hunt-for-list.1 id)
(k #f)]
[(eq? 'unknown (car snips))
(die 'hunt-for-list.2 id)
(k #f)]
[(list? (car snips)) [(list? (car snips))
(begin0 (car snips) (begin0 (car snips)
(set! snips (cdr snips)))] (set! snips (cdr snips)))]
@ -648,8 +659,12 @@
(define (hunt-for-list/error id) (define (hunt-for-list/error id)
(let loop () (let loop ()
(cond (cond
[(null? snips) (k #f)] [(null? snips)
[(eq? 'unknown (car snips)) (k #f)] (die 'hunt-for-list/error.1 id)
(k #f)]
[(eq? 'unknown (car snips))
(die 'hunt-for-list/error.2 id)
(k #f)]
[(or (err? (car snips)) (list? (car snips))) [(or (err? (car snips)) (list? (car snips)))
(begin0 (car snips) (begin0 (car snips)
(set! snips (cdr snips)))] (set! snips (cdr snips)))]
@ -658,15 +673,16 @@
(define (hunt-for-unknown id) (define (hunt-for-unknown id)
(let loop () (let loop ()
(cond (cond
[(null? snips) (k #f)] [(null? snips)
(die 'hunt-for-unknown id)
(k #f)]
[(eq? 'unknown (car snips)) (set! snips (cdr snips))] [(eq? 'unknown (car snips)) (set! snips (cdr snips))]
[else (set! snips (cdr snips)) [else (set! snips (cdr snips))
(loop)]))) (loop)])))
(set! program (hunt-for-list 'program)) ;(set! program (hunt-for-list 'program))
(hunt-for-unknown 'before)
(set! before (hunt-for-list 'before)) (set! before (hunt-for-list 'before))
(hunt-for-unknown 'after) (hunt-for-unknown 'between)
(set! after (hunt-for-list/error 'after)) (set! after (hunt-for-list/error 'after))
(make-step program (make-step program

124
collects/tests/drscheme/syncheck-test.ss
View File

@ -335,33 +335,33 @@
(build-test "(define-for-syntax (f x) x) (define (f x) x) f (define-syntax (m x) (f x))" (build-test "(define-for-syntax (f x) x) (define (f x) x) f (define-syntax (m x) (f x))"
'(("(" default-color) '(("(" default-color)
("define-for-syntax" imported-identifier) ("define-for-syntax" imported)
(" (" default-color) (" (" default-color)
("f" lexically-bound-identifier) ("f" lexically-bound)
(" " default-color) (" " default-color)
("x" lexically-bound-identifier) ("x" lexically-bound)
(") " default-color) (") " default-color)
("x" lexically-bound-identifier) ("x" lexically-bound)
(") (" default-color) (") (" default-color)
("define" imported-identifier) ("define" imported)
(" (" default-color) (" (" default-color)
("f" lexically-bound-identifier) ("f" lexically-bound)
(" " default-color) (" " default-color)
("x" lexically-bound-identifier) ("x" lexically-bound)
(") " default-color) (") " default-color)
("x" lexically-bound-identifier) ("x" lexically-bound)
(") " default-color) (") " default-color)
("f" lexically-bound-identifier) ("f" lexically-bound)
(" (" default-color) (" (" default-color)
("define-syntax" imported-identifier) ("define-syntax" imported)
(" (" default-color) (" (" default-color)
("m" lexically-bound-identifier) ("m" lexically-bound)
(" " default-color) (" " default-color)
("x" lexically-bound-identifier) ("x" lexically-bound)
(") (" default-color) (") (" default-color)
("f" lexically-bound-identifier) ("f" lexically-bound)
(" " default-color) (" " default-color)
("x" lexically-bound-identifier) ("x" lexically-bound)
("))" default-color)) ("))" default-color))
'(((20 21) (69 70)) '(((20 21) (69 70))
((22 23) (25 26)) ((22 23) (25 26))
@ -371,35 +371,35 @@
(build-test "(module m mzscheme (define-for-syntax (f x) x) (define (f x) x) f (define-syntax (m stx) (f stx)))" (build-test "(module m mzscheme (define-for-syntax (f x) x) (define (f x) x) f (define-syntax (m stx) (f stx)))"
'(("(" default-color) '(("(" default-color)
("module" imported-identifier) ("module" imported)
(" m mzscheme (" default-color) (" m mzscheme (" default-color)
("define-for-syntax" imported-identifier) ("define-for-syntax" imported)
(" (" default-color) (" (" default-color)
("f" lexically-bound-identifier) ("f" lexically-bound)
(" " default-color) (" " default-color)
("x" lexically-bound-identifier) ("x" lexically-bound)
(") " default-color) (") " default-color)
("x" lexically-bound-identifier) ("x" lexically-bound)
(") (" default-color) (") (" default-color)
("define" imported-identifier) ("define" imported)
(" (" default-color) (" (" default-color)
("f" lexically-bound-identifier) ("f" lexically-bound)
(" " default-color) (" " default-color)
("x" lexically-bound-identifier) ("x" lexically-bound)
(") " default-color) (") " default-color)
("x" lexically-bound-identifier) ("x" lexically-bound)
(") " default-color) (") " default-color)
("f" lexically-bound-identifier) ("f" lexically-bound)
(" (" default-color) (" (" default-color)
("define-syntax" imported-identifier) ("define-syntax" imported)
(" (" default-color) (" (" default-color)
("m" lexically-bound-identifier) ("m" lexically-bound)
(" " default-color) (" " default-color)
("stx" lexically-bound-identifier) ("stx" lexically-bound)
(") (" default-color) (") (" default-color)
("f" lexically-bound-identifier) ("f" lexically-bound)
(" " default-color) (" " default-color)
("stx" lexically-bound-identifier) ("stx" lexically-bound)
(")))" default-color)) (")))" default-color))
'(((10 18) (20 37) (48 54) (67 80)) '(((10 18) (20 37) (48 54) (67 80))
((39 40) (90 91)) ((39 40) (90 91))
@ -605,7 +605,7 @@
(" " default-color) (" " default-color)
("object%" lexically-bound-variable) ("object%" lexically-bound-variable)
(" " default-color) (" " default-color)
("this" imported-identifier) ("this" imported)
(")" default-color))) (")" default-color)))
(build-test "(module m mzscheme (require (lib \"list.ss\")) foldl)" (build-test "(module m mzscheme (require (lib \"list.ss\")) foldl)"
'(("(" default-color) '(("(" default-color)
@ -646,8 +646,8 @@
("foldl" imported-variable) ("foldl" imported-variable)
(")" default-color)) (")" default-color))
(list '((10 18) (20 27)) (list '((10 18) (20 27))
'((28 55) (73 80) (81 86)) '((28 55) (73 80))
'((56 71) (73 80) (81 86)))) '((56 71) (81 86))))
(build-test "(module m mzscheme (require (only (lib \"list.ss\") foldr) (only (lib \"list.ss\") foldl)) foldl foldr)" (build-test "(module m mzscheme (require (only (lib \"list.ss\") foldr) (only (lib \"list.ss\") foldl)) foldl foldr)"
'(("(" default-color) '(("(" default-color)
@ -668,7 +668,7 @@
("module" imported-syntax) ("module" imported-syntax)
(" m mzscheme (" default-color) (" m mzscheme (" default-color)
("require" imported-syntax) ("require" imported-syntax)
("(prefix x: mzscheme)) " default-color) (" (prefix x: mzscheme)) " default-color)
("x:+" imported-variable) ("x:+" imported-variable)
(" " default-color) (" " default-color)
("+" imported-variable) ("+" imported-variable)
@ -707,44 +707,55 @@
'((62 63) (64 65) (68 69)))) '((62 63) (64 65) (68 69))))
;; the next two tests are new, complex ones that need to
;; move to the bottom of the test file, when the rest of these
;; tests are cleaned up.
;; right now, there is a bug that causes lots of tests to fail for a stupid reason
(build-test "(module m mzscheme (define-syntax rename #f) (require (rename mzscheme ++ +)))" (build-test "(module m mzscheme (define-syntax rename #f) (require (rename mzscheme ++ +)))"
'(("(" default-color) '(("(" default-color)
("module" imported-identifier) ("module" imported)
(" m mzscheme (" default-color) (" m mzscheme (" default-color)
("define-syntax" imported-identifier) ("define-syntax" imported)
(" " default-color) (" " default-color)
("rename" lexically-bound-identifier) ("rename" lexically-bound)
(" #f) (" default-color) (" #f) (" default-color)
("require" imported-identifier) ("require" imported)
(" (rename mzscheme ++ +)))" default-color)) (" (rename mzscheme ++ +)))" default-color))
(list '((10 18) (20 33) (46 53)) (list '((10 18) (20 33) (46 53))))
'((54 76) (20 33) (46 53))))
(build-test "(module m mzscheme (define-syntax rename #f) (define f 1) (provide (rename f g)))" (build-test "(module m mzscheme (define-syntax rename #f) (define f 1) (provide (rename f g)))"
'(("(" default-color) '(("(" default-color)
("module" imported-identifier) ("module" imported)
(" m mzscheme (" default-color) (" m mzscheme (" default-color)
("define-syntax" imported-identifier) ("define-syntax" imported)
(" " default-color) (" " default-color)
("rename" lexically-bound-identifier) ("rename" lexically-bound)
(" #f) (" default-color) (" #f) (" default-color)
("define" imported-identifier) ("define" imported)
(" " default-color) (" " default-color)
("f" lexically-bound-identifier) ("f" lexically-bound)
(" 1) (" default-color) (" 1) (" default-color)
("provide" imported-identifier) ("provide" imported)
(" (rename " default-color) (" (rename " default-color)
("f" lexically-bound-identifier) ("f" lexically-bound)
(" g)))" default-color)) (" g)))" default-color))
(list '((10 18) (20 33) (46 52) (59 66)) (list '((10 18) (20 33) (46 52) (59 66))
'((53 54) (75 76)))) '((53 54) (75 76))))
(build-test "(module m mzscheme (require-for-syntax mzscheme) (require-for-template mzscheme) (quote-syntax +))"
'(("(" default-color)
("module" imported)
(" m mzscheme (" default-color)
("require-for-syntax" imported)
(" mzscheme) (" default-color)
("require-for-template" imported)
(" mzscheme) (" default-color)
("quote-syntax" imported)
(" +))" default-color))
(list
'((71 79) (95 96))
'((10 18) (20 38) (50 70) (82 94) (95 96))
'((39 47) (95 96))))
(make-dir-test "(module m mzscheme (require \"~a/list.ss\") foldl foldl)" (make-dir-test "(module m mzscheme (require \"~a/list.ss\") foldl foldl)"
'(("(" default-color) '(("(" default-color)
("module" imported-syntax) ("module" imported-syntax)
@ -816,10 +827,10 @@
(define remappings (define remappings
'((constant default-color) '((constant default-color)
(imported-syntax imported-identifier) (imported-syntax imported)
(imported-variable imported-identifier) (imported-variable imported)
(lexically-bound-syntax lexically-bound-identifier) (lexically-bound-syntax lexically-bound)
(lexically-bound-variable lexically-bound-identifier))) (lexically-bound-variable lexically-bound)))
(define (collapse-and-rename expected) (define (collapse-and-rename expected)
(let ([renamed (let ([renamed
@ -842,7 +853,8 @@
(cddr ids))) (cddr ids)))
(cons fst (loop (cdr ids)))))])))) (cons fst (loop (cdr ids)))))]))))
;; compare-arrows : (listof (cons (list number number) (listof (list number number)))) ;; compare-arrows : expression
;; (listof (cons (list number number) (listof (list number number))))
;; hash-table[(list text number number) -o> (listof (list text number number))] ;; hash-table[(list text number number) -o> (listof (list text number number))]
;; -> void ;; -> void
(define (compare-arrows test-exp expected raw-actual) (define (compare-arrows test-exp expected raw-actual)

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

@ -158,10 +158,8 @@
"3")) "3"))
(define (good-tests) (define (good-tests)
(set-language-level! `("PLT" ,(regexp "Graphical")))
(generic-tests)
(set-language-level! '("How to Design Programs" "Beginning Student")) (set-language-level! '("How to Design Programs" "Beginning Student"))
(do-execute drs-frame)
(generic-tests)) (generic-tests))
(define (bad-tests) (define (bad-tests)
@ -196,29 +194,39 @@
(when (or (equal? #"ss" (filename-extension teachpack)) (when (or (equal? #"ss" (filename-extension teachpack))
(equal? #"scm" (filename-extension teachpack))) (equal? #"scm" (filename-extension teachpack)))
(unless (equal? "graphing.ss" (path->string teachpack)) (unless (equal? "graphing.ss" (path->string teachpack))
(printf " testing ~a~n" (build-path dir teachpack)) (printf " testing ~a~n" teachpack)
(let ([filename (normal-case-path (build-path dir teachpack))]) (fw:test:menu-select "Language" "Clear All Teachpacks")
(fw:test:menu-select "Language" "Clear All Teachpacks") (fw:test:menu-select "Language" "Add Teachpack...")
(use-get/put-dialog (wait-for-new-frame drs-frame)
(lambda () (let* ([tp-dialog (get-top-level-focus-window)]
(fw:test:menu-select "Language" "Add Teachpack...")) [choice (find-leftmost-choice tp-dialog)])
filename) (fw:test:set-list-box! choice (path->string teachpack))
(do-execute drs-frame) (fw:test:button-push "OK")
(wait-for-new-frame tp-dialog))
(do-execute drs-frame)
(let ([got (fetch-output drs-frame)] (let ([got (fetch-output drs-frame)]
[expected (format "Teachpack: ~a.~n1" filename)]) [expected (format "Teachpack: ~a.\n1" (path->string teachpack))])
(unless (equal? got expected) (unless (equal? got expected)
(printf "FAILED built in teachpack test: ~a~n" filename) (printf "FAILED built in teachpack test: ~a~n" (path->string teachpack))
(printf " got: ~s~n expected: ~s~n" got expected))))))))] (printf " got: ~s~n expected: ~s~n" got expected)))))))]
[test-teachpacks [test-teachpacks
(lambda (dir) (lambda (dir)
(for-each (test-teachpack dir) (for-each (test-teachpack dir)
(directory-list dir)))] (directory-list dir)))]
[teachpack-dir (normalize-path (collection-path "teachpack"))]) [teachpack-dir (normalize-path (collection-path "teachpack"))])
(set-language-level! '("How to Design Programs" "Advanced Student")) (set-language-level! '("How to Design Programs" "Advanced Student"))
(test-teachpacks teachpack-dir) (do-execute drs-frame)
(test-teachpacks (build-path teachpack-dir "htdp")))) (test-teachpacks (build-path teachpack-dir "htdp"))))
(define (find-leftmost-choice frame)
(let loop ([p frame])
(cond
[(is-a? p list-box%) p]
[(is-a? p area-container<%>)
(ormap loop (send p get-children))]
[else #f])))
(define (run-test) (define (run-test)
;(good-tests) ;(good-tests)
;(bad-tests) ;(bad-tests)

129
collects/tests/drscheme/test-box-test.ss
View File

@ -1,129 +0,0 @@
(module test-box-test mzscheme
(require "drscheme-test-util.ss"
(lib "class.ss")
(lib "file.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(rename (lib "teachprims.ss" "lang" "private") beginner-equal? beginner-equal?))
(provide run-test)
(define (run-test)
(define drscheme-frame (wait-for-drscheme-frame))
(define definitions-text (send drscheme-frame get-definitions-text))
(define definitions-canvas (send drscheme-frame get-definitions-canvas))
(define execute-button (send drscheme-frame get-execute-button))
(define (insert-string string)
(let loop ([n 0])
(unless (= n (string-length string))
(let ([c (string-ref string n)])
(if (char=? c #\newline)
(test:keystroke #\return)
(test:keystroke c)))
(loop (+ n 1)))))
(define wait-for-execute (lambda () (wait-for-button execute-button)))
(define (get-test-box)
(send definitions-text find-snip (send definitions-text last-position) 'before))
(define (get-test-image fn)
(make-object
image-snip%
(make-object bitmap% (build-path (collection-path "test-suite" "private" "icons") fn))))
(define check-img (get-test-image "small-check-mark.jpeg"))
(define cross-img (get-test-image "small-cross.jpeg"))
(define non-img (get-test-image "small-empty.gif"))
(define red-square (make-object image-snip%
(let* ([bm (make-object bitmap% 20 20)]
[dc (make-object bitmap-dc% bm)])
(send dc set-brush "red" 'solid)
(send dc set-pen "red" 1 'solid)
(send dc draw-rectangle 0 0 20 20)
(send dc set-bitmap #f)
bm)))
(define (same-img? a b)
(beginner-equal? a b))
(define (test-box-status s)
(let eloop ([e (send s get-editor)])
(let sloop ([s (send e find-first-snip)])
(and s
(or
(cond
[(s . is-a? . editor-snip%)
(eloop (send s get-editor))]
[(s . is-a? . image-snip%)
(cond
[(same-img? s check-img) 'pass]
[(same-img? s cross-img) 'fail]
[(same-img? s non-img) 'not-run]
[else #f])]
[else #f])
(sloop (send s next)))))))
(define (check-test-box-status v s)
(let ([u (test-box-status s)])
(if (eq? v u)
(printf "~a - good\n" v)
(printf "FAILED: ~a != ~a\n" u v))))
(define (try-test preamble expr expect result)
(test:new-window definitions-canvas)
(send definitions-text erase)
(insert-string preamble)
(test:menu-select "Special" "Insert Test Case")
(insert-string expr)
(insert-string "\t")
(let loop ([expect expect])
(cond
[(expect . is-a? . snip%)
(send (send drscheme-frame get-edit-target-object) insert (send expect copy))]
[(list? expect)
(for-each loop expect)]
[else
(insert-string expect)]))
(check-test-box-status 'not-run (get-test-box))
(do-execute drscheme-frame #t)
(check-test-box-status result (get-test-box)))
(define scheme-languages
'(("How to Design Programs" "Beginning Student")
("How to Design Programs" "Intermediate Student")
("How to Design Programs" "Advanced Student")
("PLT" #rx"Textual")
("PLT" #rx"Graphical")))
(for-each (lambda (lang)
(set-language-level! lang #t)
(try-test "" "(+ 1 2)" "3" 'pass)
(try-test "" "(+ 1 -2)" "3" 'fail)
(try-test "" "(list 1)" "(list 1)" 'pass)
(try-test "" "not-defined" "3" 'not-run)
(try-test "(define (f x) (+ x 1))" "(f 2)" "3" 'pass)
(use-get/put-dialog
(lambda ()
(test:menu-select "Language" "Add Teachpack..."))
(build-path (collection-path "mzlib") 'up 'up "teachpack" "htdp" "image.ss"))
(try-test "" "(rectangle 20 20 'solid \"red\")" "3" 'fail)
(try-test "" "(rectangle 20 20 'solid \"red\")" red-square 'pass)
(try-test "" "(list (rectangle 20 20 'solid \"red\") 17)" `("(list " ,red-square " 17)") 'pass)
(test:menu-select "Language" "Clear All Teachpacks")
(void))
scheme-languages)
(void)))

1
collects/tests/framework/load.ss
View File

@ -40,6 +40,7 @@
;; these extra evals let me submit multiple, independent top-level ;; these extra evals let me submit multiple, independent top-level
;; expressions in the newly created namespace. ;; expressions in the newly created namespace.
'(begin (eval '(require (lib "unit.ss"))) '(begin (eval '(require (lib "unit.ss")))
(eval '(require-for-syntax mzscheme))
(eval '(require-for-syntax (lib "unit-exptime.ss"))) (eval '(require-for-syntax (lib "unit-exptime.ss")))
(eval '(define-syntax (signature->symbols stx) (eval '(define-syntax (signature->symbols stx)
(syntax-case stx () (syntax-case stx ()