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

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

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
;; field, but there still are keywords.
(define (annotate-raw-keyword stx id-map)
(unless (syntax-property stx 'origin)
(let ([lst (syntax-e stx)])
(when (pair? lst)
(let ([f-stx (car lst)])
(when (and (syntax-original? f-stx)
(identifier? f-stx))
(add-id id-map f-stx)))))))
(add-id id-map f-stx))))))
;; color-internal-structure : syntax str -> void
(define (color-internal-structure stx style-name)

View File

@ -118,6 +118,14 @@
"the second case in the case-lambda sets"
"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
((or/c string? (cons/c string? (listof string?)))
((is-a?/c area-container-window<%>)

View File

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

View File

@ -55,15 +55,16 @@ add this test:
(send text paragraph-start-position 2))))))
(channel-get chan)))
(define (output-style x) (equal? (list-ref x 9) '(150 0 150)))
(define (error-style x) (equal? (list-ref x 9) '(255 0 0)))
(define (output-style x) (eq? x '|ports out|))
(define (error-style x) (eq? x '|ports err|))
(define (value-style x) (eq? x '|ports value|))
(define prompt '("\n> " default-color))
;; 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)
(check-output "(port-next-location (current-input-port))"
(list '("1\n0\n1\n" value-style)
(list `("1\n0\n1\n" ,value-style)
prompt))
(check-output "(display 1)" (list (list "1" output-style) prompt))

View File

@ -258,7 +258,8 @@ the settings above should match r5rs
(test-expression "(define x 1)(define x 2)" "")
(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")
@ -358,7 +359,7 @@ the settings above should match r5rs
(test-expression "(define-struct spider (legs))(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")
@ -403,7 +404,7 @@ the settings above should match r5rs
(test-expression "'(1)" "quote: expected a name after a ', found something else")
(test-expression "(define shrd (list 1)) (list shrd shrd)"
"(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)"
"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")
@ -482,7 +483,7 @@ the settings above should match r5rs
(test-expression "(define-struct spider (legs))(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")
@ -525,7 +526,7 @@ the settings above should match r5rs
(test-expression "'(1)" "(list 1)")
(test-expression "(define shrd (list 1)) (list shrd shrd)"
"(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: 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")
@ -602,7 +603,7 @@ the settings above should match r5rs
(test-expression "(define-struct spider (legs))(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")
@ -644,7 +645,7 @@ the settings above should match r5rs
(test-expression "'(1)" "(list 1)")
(test-expression "(define shrd (list 1)) (list shrd shrd)"
"(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 "(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")
@ -714,7 +715,7 @@ the settings above should match r5rs
(test-expression "(define-struct spider (legs))(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")
@ -756,7 +757,7 @@ the settings above should match r5rs
(test-expression "'(1)" "(list 1)")
(test-expression "(define shrd (list 1)) (list shrd shrd)"
"(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 "(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")
@ -825,7 +826,7 @@ the settings above should match r5rs
(test-expression "(define-struct spider (legs))(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")
@ -858,13 +859,15 @@ the settings above should match r5rs
(test-expression "(set! x 1)"
"x: name is not defined"
"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 "(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 "(define shrd (list 1)) (list shrd shrd)"
"(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 "(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")
@ -1222,9 +1225,9 @@ the settings above should match r5rs
(define (run-test)
;(go mred)
;(go mzscheme)
;(go beginner) ;; not really done
;(go beginner/abbrev) ;; not really done
(go intermediate)
;(go beginner)
;(go beginner/abbrev)
;(go intermediate)
(go intermediate/lambda)
(go advanced)
(go r5rs)))

View File

@ -878,7 +878,7 @@
; 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)
(printf "\n>> testing ~s\n" (test-program in-vector))
;(printf "\n>> testing ~s\n" (test-program in-vector))
(let* ([program (test-program in-vector)]
[execute-answer (if raw?
(test-raw-execute-answer in-vector)
@ -1116,7 +1116,7 @@
(let* ([end (- (get-int-pos) 1)]
[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)
(error 'callcc-test "expected ~s, got ~s" expected output)))))

View File

@ -635,11 +635,22 @@
[after null]
[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)
(let loop ()
(cond
[(null? snips) (k #f)]
[(eq? 'unknown (car snips)) (k #f)]
[(null? snips)
(die 'hunt-for-list.1 id)
(k #f)]
[(eq? 'unknown (car snips))
(die 'hunt-for-list.2 id)
(k #f)]
[(list? (car snips))
(begin0 (car snips)
(set! snips (cdr snips)))]
@ -648,8 +659,12 @@
(define (hunt-for-list/error id)
(let loop ()
(cond
[(null? snips) (k #f)]
[(eq? 'unknown (car snips)) (k #f)]
[(null? snips)
(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)))
(begin0 (car snips)
(set! snips (cdr snips)))]
@ -658,15 +673,16 @@
(define (hunt-for-unknown id)
(let loop ()
(cond
[(null? snips) (k #f)]
[(null? snips)
(die 'hunt-for-unknown id)
(k #f)]
[(eq? 'unknown (car snips)) (set! snips (cdr snips))]
[else (set! snips (cdr snips))
(loop)])))
(set! program (hunt-for-list 'program))
(hunt-for-unknown 'before)
;(set! program (hunt-for-list 'program))
(set! before (hunt-for-list 'before))
(hunt-for-unknown 'after)
(hunt-for-unknown 'between)
(set! after (hunt-for-list/error 'after))
(make-step program

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))"
'(("(" default-color)
("define-for-syntax" imported-identifier)
("define-for-syntax" imported)
(" (" default-color)
("f" lexically-bound-identifier)
("f" lexically-bound)
(" " default-color)
("x" lexically-bound-identifier)
("x" lexically-bound)
(") " default-color)
("x" lexically-bound-identifier)
("x" lexically-bound)
(") (" default-color)
("define" imported-identifier)
("define" imported)
(" (" default-color)
("f" lexically-bound-identifier)
("f" lexically-bound)
(" " default-color)
("x" lexically-bound-identifier)
("x" lexically-bound)
(") " default-color)
("x" lexically-bound-identifier)
("x" lexically-bound)
(") " default-color)
("f" lexically-bound-identifier)
("f" lexically-bound)
(" (" default-color)
("define-syntax" imported-identifier)
("define-syntax" imported)
(" (" default-color)
("m" lexically-bound-identifier)
("m" lexically-bound)
(" " default-color)
("x" lexically-bound-identifier)
("x" lexically-bound)
(") (" default-color)
("f" lexically-bound-identifier)
("f" lexically-bound)
(" " default-color)
("x" lexically-bound-identifier)
("x" lexically-bound)
("))" default-color))
'(((20 21) (69 70))
((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)))"
'(("(" default-color)
("module" imported-identifier)
("module" imported)
(" m mzscheme (" default-color)
("define-for-syntax" imported-identifier)
("define-for-syntax" imported)
(" (" default-color)
("f" lexically-bound-identifier)
("f" lexically-bound)
(" " default-color)
("x" lexically-bound-identifier)
("x" lexically-bound)
(") " default-color)
("x" lexically-bound-identifier)
("x" lexically-bound)
(") (" default-color)
("define" imported-identifier)
("define" imported)
(" (" default-color)
("f" lexically-bound-identifier)
("f" lexically-bound)
(" " default-color)
("x" lexically-bound-identifier)
("x" lexically-bound)
(") " default-color)
("x" lexically-bound-identifier)
("x" lexically-bound)
(") " default-color)
("f" lexically-bound-identifier)
("f" lexically-bound)
(" (" default-color)
("define-syntax" imported-identifier)
("define-syntax" imported)
(" (" default-color)
("m" lexically-bound-identifier)
("m" lexically-bound)
(" " default-color)
("stx" lexically-bound-identifier)
("stx" lexically-bound)
(") (" default-color)
("f" lexically-bound-identifier)
("f" lexically-bound)
(" " default-color)
("stx" lexically-bound-identifier)
("stx" lexically-bound)
(")))" default-color))
'(((10 18) (20 37) (48 54) (67 80))
((39 40) (90 91))
@ -605,7 +605,7 @@
(" " default-color)
("object%" lexically-bound-variable)
(" " default-color)
("this" imported-identifier)
("this" imported)
(")" default-color)))
(build-test "(module m mzscheme (require (lib \"list.ss\")) foldl)"
'(("(" default-color)
@ -646,8 +646,8 @@
("foldl" imported-variable)
(")" default-color))
(list '((10 18) (20 27))
'((28 55) (73 80) (81 86))
'((56 71) (73 80) (81 86))))
'((28 55) (73 80))
'((56 71) (81 86))))
(build-test "(module m mzscheme (require (only (lib \"list.ss\") foldr) (only (lib \"list.ss\") foldl)) foldl foldr)"
'(("(" default-color)
@ -707,44 +707,55 @@
'((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 ++ +)))"
'(("(" default-color)
("module" imported-identifier)
("module" imported)
(" m mzscheme (" default-color)
("define-syntax" imported-identifier)
("define-syntax" imported)
(" " default-color)
("rename" lexically-bound-identifier)
("rename" lexically-bound)
(" #f) (" default-color)
("require" imported-identifier)
("require" imported)
(" (rename mzscheme ++ +)))" default-color))
(list '((10 18) (20 33) (46 53))
'((54 76) (20 33) (46 53))))
(list '((10 18) (20 33) (46 53))))
(build-test "(module m mzscheme (define-syntax rename #f) (define f 1) (provide (rename f g)))"
'(("(" default-color)
("module" imported-identifier)
("module" imported)
(" m mzscheme (" default-color)
("define-syntax" imported-identifier)
("define-syntax" imported)
(" " default-color)
("rename" lexically-bound-identifier)
("rename" lexically-bound)
(" #f) (" default-color)
("define" imported-identifier)
("define" imported)
(" " default-color)
("f" lexically-bound-identifier)
("f" lexically-bound)
(" 1) (" default-color)
("provide" imported-identifier)
("provide" imported)
(" (rename " default-color)
("f" lexically-bound-identifier)
("f" lexically-bound)
(" g)))" default-color))
(list '((10 18) (20 33) (46 52) (59 66))
'((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)"
'(("(" default-color)
("module" imported-syntax)
@ -816,10 +827,10 @@
(define remappings
'((constant default-color)
(imported-syntax imported-identifier)
(imported-variable imported-identifier)
(lexically-bound-syntax lexically-bound-identifier)
(lexically-bound-variable lexically-bound-identifier)))
(imported-syntax imported)
(imported-variable imported)
(lexically-bound-syntax lexically-bound)
(lexically-bound-variable lexically-bound)))
(define (collapse-and-rename expected)
(let ([renamed
@ -842,7 +853,8 @@
(cddr 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))]
;; -> void
(define (compare-arrows test-exp expected raw-actual)

View File

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

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)))

View File

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