1539 lines
55 KiB
Racket
1539 lines
55 KiB
Racket
#lang scheme
|
|
|
|
;; NOTES:
|
|
;; - (expt 3 #f) is likely to never be optimized, making the stack traces produced from it predictable
|
|
|
|
#|
|
|
|
|
This produces an ACK message
|
|
|
|
#lang scheme
|
|
(require scheme/sandbox)
|
|
(make-evaluator '(file "/tmp/foo.rkt"))
|
|
|
|
|#
|
|
|
|
(require "drracket-test-util.rkt"
|
|
mred
|
|
framework)
|
|
|
|
(define-struct loc (line col offset))
|
|
;; loc = (make-loc number number number)
|
|
;; all numbers in loc structs start at zero.
|
|
|
|
(define-struct test (program
|
|
;; : (union
|
|
;; string
|
|
;; 'fraction-sum
|
|
;; (listof
|
|
;; (union string? // typed in
|
|
;; 'left // left arrow key
|
|
;; (list string? string?)))) // menu item select
|
|
|
|
|
|
answer ;; : answer
|
|
;; the answers for the various modes of the test, specifically:
|
|
;; with debugging enabled: execute, load with different filename, load with same filename
|
|
;; as in ordinary mzscheme: execute, load with different filename, load with same filename
|
|
|
|
source-location ;; (or/c 'interactions 'definitions (cons number number))
|
|
|
|
breaking-test? ;; : boolean
|
|
|
|
;; setup is called before the test case is run.
|
|
setup ;; : -> void
|
|
;; teardown is called after the test case is complete.
|
|
teardown ;; : -> void
|
|
))
|
|
|
|
(define-struct answer (debug-execute debug-load-fn debug-load raw-execute raw-load-fn raw-load))
|
|
|
|
(define-syntax (mktest stx)
|
|
(syntax-case stx ()
|
|
[(_ program (a b c d e f) di breaking-test?)
|
|
#'(make-test program (make-answer a b c d e f) di breaking-test? void void)]
|
|
[(_ program (a b c d e f) di breaking-test? setup teardown)
|
|
#'(make-test program (make-answer a b c d e f) di breaking-test? setup teardown)]))
|
|
|
|
(define syntax-regexp-prefix
|
|
(string-append
|
|
(regexp-quote "#<syntax:")
|
|
".*"
|
|
(regexp-quote "tests/drracket/repl-test-tmp")
|
|
"3?"
|
|
(regexp-quote ".rkt")))
|
|
|
|
|
|
(define (to-strings . args)
|
|
(apply string-append (map (λ (x) (format "~s\n" x)) args)))
|
|
|
|
(define (add-load-handler-context str)
|
|
(regexp
|
|
(string-append (regexp-quote (string-append
|
|
backtrace-image-string
|
|
" "
|
|
file-image-string
|
|
" .*rkt:"))
|
|
"[0-9]+:[0-9]+: "
|
|
(regexp-quote str))))
|
|
|
|
(define test-data
|
|
(list
|
|
;; basic tests
|
|
(mktest "1"
|
|
("1"
|
|
"1"
|
|
"1"
|
|
"1"
|
|
"1"
|
|
"1")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "\"a\""
|
|
|
|
("\"a\""
|
|
"\"a\""
|
|
"\"a\""
|
|
"\"a\""
|
|
"\"a\""
|
|
"\"a\"")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "1 2"
|
|
|
|
("1\n2"
|
|
"2"
|
|
"2"
|
|
"1\n2"
|
|
"2"
|
|
"2")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "\"a\" \"b\""
|
|
|
|
("\"a\"\n\"b\""
|
|
"\"b\""
|
|
"\"b\""
|
|
"\"a\"\n\"b\""
|
|
"\"b\""
|
|
"\"b\"")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "("
|
|
("{stop-22x22.png} read: expected a `)' to close `('"
|
|
"{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:0: read: expected a `)' to close `('"
|
|
"{stop-22x22.png} read: expected a `)' to close `('"
|
|
"{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:0: read: expected a `)' to close `('")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "."
|
|
|
|
("{stop-22x22.png} read: illegal use of \".\""
|
|
"{stop-multi.png} {stop-22x22.png} read: illegal use of \".\""
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:0: read: illegal use of \".\""
|
|
"{stop-22x22.png} read: illegal use of \".\""
|
|
"{stop-multi.png} {stop-22x22.png} read: illegal use of \".\""
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:0: read: illegal use of \".\"")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(lambda ())"
|
|
|
|
("{stop-22x22.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-22x22.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-22x22.png} repl-test-tmp3.rkt:1:0: lambda: bad syntax in: (lambda ())"
|
|
"{stop-22x22.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-multi.png} {stop-22x22.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:0: lambda: bad syntax in: (lambda ())")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; make sure only a single syntax error occurs when in nested begin situation
|
|
(mktest "(begin (lambda ()) (lambda ()))"
|
|
|
|
("{stop-22x22.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-22x22.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-22x22.png} repl-test-tmp3.rkt:1:7: lambda: bad syntax in: (lambda ())"
|
|
"{stop-22x22.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-multi.png} {stop-22x22.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:7: lambda: bad syntax in: (lambda ())")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "xx"
|
|
|
|
("{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx"
|
|
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:0: reference to undefined identifier: xx"
|
|
"reference to undefined identifier: xx"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: reference to undefined identifier: xx"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: reference to undefined identifier: xx")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
(mktest "(raise 1)"
|
|
|
|
("uncaught exception: 1"
|
|
"uncaught exception: 1"
|
|
"uncaught exception: 1"
|
|
"uncaught exception: 1"
|
|
"uncaught exception: 1"
|
|
"uncaught exception: 1")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
(mktest "(raise #f)"
|
|
|
|
("uncaught exception: #f"
|
|
"uncaught exception: #f"
|
|
"uncaught exception: #f"
|
|
"uncaught exception: #f"
|
|
"uncaught exception: #f"
|
|
"uncaught exception: #f")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(values 1 2)"
|
|
|
|
("1\n2"
|
|
"1\n2"
|
|
"1\n2"
|
|
"1\n2"
|
|
"1\n2"
|
|
"1\n2")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
(mktest "(list 1 2)"
|
|
|
|
("(1 2)"
|
|
"(1 2)"
|
|
"(1 2)"
|
|
"(1 2)"
|
|
"(1 2)"
|
|
"(1 2)")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(parameterize ([print-struct #t])(define-struct s (x) (make-inspector))(printf \"~s\\n\" (make-s 1)))"
|
|
|
|
("#(struct:s 1)"
|
|
"#(struct:s 1)"
|
|
"#(struct:s 1)"
|
|
"#(struct:s 1)"
|
|
"#(struct:s 1)"
|
|
"#(struct:s 1)")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; top-level semantics test
|
|
(mktest "(define (f) (+ 1 1)) (define + -) (f)"
|
|
|
|
("define-values: cannot change constant variable: +"
|
|
"define-values: cannot change constant variable: +"
|
|
"define-values: cannot change constant variable: +"
|
|
"define-values: cannot change constant variable: +"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: define-values: cannot change constant variable: \\+"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: define-values: cannot change constant variable: \\+")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(begin (define-struct a ()) (define-struct (b a) ()))"
|
|
|
|
(""
|
|
""
|
|
""
|
|
""
|
|
""
|
|
"")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(begin (values) 1)"
|
|
|
|
("1"
|
|
"1"
|
|
"1"
|
|
"1"
|
|
"1"
|
|
"1")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(begin xx (printf \"hi\\n\"))"
|
|
|
|
("{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx"
|
|
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:7: reference to undefined identifier: xx"
|
|
"reference to undefined identifier: xx"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: reference to undefined identifier: xx"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: reference to undefined identifier: xx")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest (string-append
|
|
"(module m mzscheme (provide e) (define e #'1))\n"
|
|
"(module n mzscheme (require-for-syntax 'm) (provide s) (define-syntax (s stx) e))\n"
|
|
"(require 'n)\n"
|
|
"s")
|
|
|
|
("{stop-22x22.png} compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
|
"{stop-22x22.png} compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
|
"{stop-22x22.png} repl-test-tmp3.rkt:1:43: compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
|
"{stop-22x22.png} compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
|
"{stop-multi.png} {stop-22x22.png} compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:43: compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
|
|
;; leading comment test
|
|
(mktest "#!/bin/sh\n1"
|
|
|
|
("1"
|
|
"1"
|
|
"1"
|
|
"1"
|
|
"1"
|
|
"1")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "#!/bin/sh\nxx"
|
|
|
|
("{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx"
|
|
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:2:0: reference to undefined identifier: xx"
|
|
"reference to undefined identifier: xx"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: reference to undefined identifier: xx"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: reference to undefined identifier: xx")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; eval tests
|
|
|
|
(mktest " (eval '(values 1 2))"
|
|
|
|
("1\n2"
|
|
"1\n2"
|
|
"1\n2"
|
|
"1\n2"
|
|
"1\n2"
|
|
"1\n2")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest " (eval '(list 1 2))"
|
|
|
|
("(1 2)"
|
|
"(1 2)"
|
|
"(1 2)"
|
|
"(1 2)"
|
|
"(1 2)"
|
|
"(1 2)")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest " (eval '(lambda ()))"
|
|
|
|
("{stop-multi.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-multi.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-multi.png} lambda: bad syntax in: (lambda ())"
|
|
"lambda: bad syntax in: (lambda ())"
|
|
"{stop-multi.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-multi.png} lambda: bad syntax in: (lambda ())")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest " (read (open-input-string \".\"))"
|
|
|
|
("{stop-multi.png} read: illegal use of \".\""
|
|
"{stop-multi.png} read: illegal use of \".\""
|
|
"{stop-multi.png} read: illegal use of \".\""
|
|
"read: illegal use of \".\""
|
|
"{stop-multi.png} read: illegal use of \".\""
|
|
"{stop-multi.png} read: illegal use of \".\"")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest " (eval 'x)"
|
|
|
|
("{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x"
|
|
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:4: reference to undefined identifier: x"
|
|
"reference to undefined identifier: x"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: reference to undefined identifier: x"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: reference to undefined identifier: x")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(eval (box 1))"
|
|
|
|
("#&1"
|
|
"#&1"
|
|
"#&1"
|
|
"#&1"
|
|
"#&1"
|
|
"#&1")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(eval '(box 1))"
|
|
|
|
("#&1"
|
|
"#&1"
|
|
"#&1"
|
|
"#&1"
|
|
"#&1"
|
|
"#&1")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
; printer setup test
|
|
(mktest "(expt 3 (void))"
|
|
|
|
("{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #<void>"
|
|
"{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #<void>"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:0: expt: expected argument of type <number>; given #<void>"
|
|
"expt: expected argument of type <number>; given #<void>"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: expt: expected argument of type <number>; given #<void>"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: expt: expected argument of type <number>; given #<void>")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; error in the middle
|
|
(mktest "1 2 ( 3 4"
|
|
|
|
("1\n2\n{stop-22x22.png} read: expected a `)' to close `('"
|
|
"{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:4: read: expected a `)' to close `('"
|
|
"1\n2\n{stop-22x22.png} read: expected a `)' to close `('"
|
|
"{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:4: read: expected a `)' to close `('")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
(mktest "1 2 . 3 4"
|
|
|
|
("1\n2\n{stop-22x22.png} read: illegal use of \".\""
|
|
"{stop-multi.png} {stop-22x22.png} read: illegal use of \".\""
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:4: read: illegal use of \".\""
|
|
"1\n2\n{stop-22x22.png} read: illegal use of \".\""
|
|
"{stop-multi.png} {stop-22x22.png} read: illegal use of \".\""
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:4: read: illegal use of \".\"")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
(mktest "1 2 (lambda ()) 3 4"
|
|
|
|
("1\n2\n{stop-22x22.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-22x22.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-22x22.png} repl-test-tmp3.rkt:1:4: lambda: bad syntax in: (lambda ())"
|
|
"1\n2\n{stop-22x22.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-multi.png} {stop-22x22.png} lambda: bad syntax in: (lambda ())"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:4: lambda: bad syntax in: (lambda ())")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
(mktest "1 2 x 3 4"
|
|
|
|
("1\n2\n{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x"
|
|
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:4: reference to undefined identifier: x"
|
|
"1\n2\nreference to undefined identifier: x"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: reference to undefined identifier: x"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: reference to undefined identifier: x")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
(mktest "1 2 (raise 1) 3 4"
|
|
|
|
("1\n2\nuncaught exception: 1"
|
|
"uncaught exception: 1"
|
|
"uncaught exception: 1"
|
|
"1\n2\nuncaught exception: 1"
|
|
"uncaught exception: 1"
|
|
"uncaught exception: 1")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
(mktest "1 2 (raise #f) 3 4"
|
|
|
|
("1\n2\nuncaught exception: #f"
|
|
"uncaught exception: #f"
|
|
"uncaught exception: #f"
|
|
"1\n2\nuncaught exception: #f"
|
|
"uncaught exception: #f"
|
|
"uncaught exception: #f")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(require lang/htdp-beginner)\n(cond [1 2 3 4])"
|
|
|
|
("{stop-22x22.png} cond: expected a clause with a question and an answer, but found a clause with 4 parts in:\n 1\n 2\n 3\n 4"
|
|
"{stop-22x22.png} cond: expected a clause with a question and an answer, but found a clause with 4 parts in:\n 1\n 2\n 3\n 4"
|
|
"{stop-22x22.png} repl-test-tmp3.rkt:2:7: cond: expected a clause with a question and an answer, but found a clause with 4 parts in:\n 1\n 2\n 3\n 4"
|
|
"{stop-multi.png} {stop-22x22.png} cond: expected a clause with a question and an answer, but found a clause with 4 parts in:\n 1\n 2\n 3\n 4"
|
|
"{stop-multi.png} {stop-22x22.png} cond: expected a clause with a question and an answer, but found a clause with 4 parts in:\n 1\n 2\n 3\n 4"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:2:7: cond: expected a clause with a question and an answer, but found a clause with 4 parts in:\n 1\n 2\n 3\n 4")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; error across separate files
|
|
(mktest
|
|
"(load \"repl-test-tmp2.rkt\") (define (g) (+ 1 (expt 3 #f))) (f g)"
|
|
|
|
("{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #f"
|
|
"{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #f"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:45: expt: expected argument of type <number>; given #f"
|
|
"{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #f"
|
|
"{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #f"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:28: expt: expected argument of type <number>; given #f")
|
|
'definitions
|
|
#f
|
|
(λ ()
|
|
(call-with-output-file (build-path tmp-load-directory "repl-test-tmp2.rkt")
|
|
(lambda (port)
|
|
(write '(define (f t) (+ 1 (t)))
|
|
port))
|
|
#:exists 'truncate))
|
|
(λ () (delete-file (build-path tmp-load-directory "repl-test-tmp2.rkt"))))
|
|
|
|
;; new namespace test
|
|
(mktest "(current-namespace (make-namespace))\nif"
|
|
|
|
("{stop-22x22.png} if: bad syntax in: if"
|
|
"{stop-22x22.png} if: bad syntax in: if"
|
|
"{stop-22x22.png} repl-test-tmp3.rkt:2:0: if: bad syntax in: if"
|
|
"{stop-22x22.png} if: bad syntax in: if"
|
|
"{stop-multi.png} {stop-22x22.png} if: bad syntax in: if"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:2:0: if: bad syntax in: if")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(current-namespace (make-namespace 'empty))\nif"
|
|
|
|
("{stop-22x22.png} compile: unbound identifier (and no #%app syntax transformer is bound) in: #%top-interaction"
|
|
"{stop-22x22.png} compile: unbound identifier (and no #%app syntax transformer is bound) in: #%top-interaction"
|
|
"{stop-22x22.png} repl-test-tmp3.rkt:2:0: compile: unbound identifier (and no #%app syntax transformer is bound) in: #%top-interaction"
|
|
"{stop-22x22.png} compile: unbound identifier (and no #%app syntax transformer is bound) in: #%top-interaction"
|
|
"{stop-multi.png} {stop-22x22.png} compile: unbound identifier (and no #%app syntax transformer is bound) in: #%top-interaction"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:2:0: compile: unbound identifier (and no #%app syntax transformer is bound) in: #%top-interaction")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; macro tests
|
|
(mktest "(define-syntax (c stx) (syntax-case stx () [(_ p q r) (syntax (+ p q r))]))"
|
|
|
|
(""
|
|
""
|
|
""
|
|
""
|
|
""
|
|
"")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; error escape handler test
|
|
(mktest
|
|
"(let ([old (error-escape-handler)])\n(+ (let/ec k\n(dynamic-wind\n(lambda () (error-escape-handler (lambda () (k 5))))\n(lambda () (expt 3 #f))\n(lambda () (error-escape-handler old))))\n10))"
|
|
|
|
("{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #f\n15"
|
|
"{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #f\n15"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:5:19: expt: expected argument of type <number>; given #f\n15"
|
|
"expt: expected argument of type <number>; given #f\n15"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: expt: expected argument of type <number>; given #f\n15"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: expt: expected argument of type <number>; given #f\n15")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
; fraction snip test
|
|
;; this test depends on the state of the 'framework:fraction-snip-style preference
|
|
;; make sure this preference is set to the default when running this test.
|
|
(mktest 'fraction-sum
|
|
("{number 5/6 \"5/6\" mixed}"
|
|
"{number 5/6 \"5/6\" mixed}"
|
|
"{number 5/6 \"5/6\" mixed}"
|
|
"{number 5/6 \"5/6\" mixed}"
|
|
"{number 5/6 \"5/6\" mixed}"
|
|
"{number 5/6 \"5/6\" mixed}")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; should produce a syntax object with a turn-down triangle.
|
|
(mktest "(write (list (syntax x)))"
|
|
(#rx"({embedded \".#<syntax:.*repl-test-tmp.rkt:1:21.*>\"})"
|
|
#rx"({embedded \".#<syntax:.*repl-test-tmp.rkt:1:21.*>\"})"
|
|
#rx"({embedded \".#<syntax:.*repl-test-tmp3.rkt:1:21.*>\"})"
|
|
#rx"({embedded \".#<syntax:.*repl-test-tmp.rkt:1:21.*>\"})"
|
|
#rx"({embedded \".#<syntax:.*repl-test-tmp.rkt:1:21.*>\"})"
|
|
#rx"({embedded \".#<syntax:.*repl-test-tmp3.rkt:1:21.*>\"})")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; 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)"
|
|
|
|
("10"
|
|
"10"
|
|
"10"
|
|
"10"
|
|
"10"
|
|
"10")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; make sure syntax objects don't go into bad ports
|
|
(mktest "(parameterize ([current-output-port (open-output-string)]) (write #'1))"
|
|
|
|
(""
|
|
""
|
|
""
|
|
""
|
|
""
|
|
"")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(parameterize ([current-output-port (open-output-string)]) (fprintf (current-error-port) \"~e\" #'foot))"
|
|
|
|
(#rx"#<syntax:.*repl-test-tmp.rkt:1:96.*>"
|
|
#rx"#<syntax:.*repl-test-tmp.rkt:1:96.*>"
|
|
#rx"#<syntax:.*repl-test-tmp3.rkt:1:96.*>"
|
|
#rx"#<syntax:.*repl-test-tmp.rkt:1:96.*>"
|
|
#rx"#<syntax:.*repl-test-tmp.rkt:1:96.*>"
|
|
#rx"#<syntax:.*repl-test-tmp3.rkt:1:96.*>")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
|
|
(mktest "(write-special 1)"
|
|
|
|
("1#t"
|
|
"1#t"
|
|
"1#t"
|
|
"1#t"
|
|
"1#t"
|
|
"1#t")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest
|
|
;; the begin/void combo is to make sure that no value printout
|
|
;; comes and messes up the source location for the error.
|
|
"(define s (make-semaphore 0))\n(queue-callback\n(lambda ()\n(dynamic-wind\nvoid\n(lambda () (expt 3 #f))\n(lambda () (semaphore-post s)))))\n(begin (yield s) (void))"
|
|
|
|
(#rx"expt: expected argument of type <number>; given #f"
|
|
#rx"expt: expected argument of type <number>; given #f"
|
|
#rx"expt: expected argument of type <number>; given #f"
|
|
#rx"expt: expected argument of type <number>; given #f"
|
|
#rx"expt: expected argument of type <number>; given #f"
|
|
#rx"expt: expected argument of type <number>; given #f")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
|
|
;; breaking tests
|
|
(mktest "(semaphore-wait (make-semaphore 0))"
|
|
(#rx"user break"
|
|
#rx"user break"
|
|
#rx"user break"
|
|
#rx"user break"
|
|
#rx"user break"
|
|
#rx"user break")
|
|
'definitions
|
|
#t
|
|
void
|
|
void)
|
|
|
|
(mktest "(let l()(l))"
|
|
(#rx"user break"
|
|
#rx"user break"
|
|
#rx"user break"
|
|
#rx"user break"
|
|
#rx"user break"
|
|
#rx"user break")
|
|
'definitions
|
|
#t
|
|
void
|
|
void)
|
|
|
|
;; continuation tests
|
|
(mktest "(define k (call/cc (lambda (x) x)))\n(k 17)\nk"
|
|
|
|
("17"
|
|
"17"
|
|
"17"
|
|
"17"
|
|
"17"
|
|
"17")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
(mktest "(define v (vector (call/cc (lambda (x) x))))\n((vector-ref v 0) 2)\nv"
|
|
|
|
("#(2)"
|
|
"#(2)"
|
|
"#(2)"
|
|
"#(2)"
|
|
"#(2)"
|
|
"#(2)")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
(mktest "(define v (vector (eval '(call/cc (lambda (x) x)))))\n((vector-ref v 0) 2)\nv"
|
|
|
|
("#(2)"
|
|
"#(2)"
|
|
"#(2)"
|
|
"#(2)"
|
|
"#(2)"
|
|
"#(2)")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(define x 1)\n((λ (x y) y) (set! x (call/cc (lambda (x) x)))\n(x 3))"
|
|
|
|
("{stop-multi.png} {stop-22x22.png} procedure application: expected procedure, given: 3; arguments were: 3"
|
|
"{stop-multi.png} {stop-22x22.png} procedure application: expected procedure, given: 3; arguments were: 3"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:3:13: procedure application: expected procedure, given: 3; arguments were: 3"
|
|
"procedure application: expected procedure, given: 3; arguments were: 3"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; top-level & continuation interaction test
|
|
(mktest "(begin (define k (call/cc (λ (x) x)))\n(define x 'wrong))\n(set! x 'right)\n(k 1)\nx"
|
|
|
|
("right"
|
|
"right"
|
|
"right"
|
|
"right"
|
|
"right"
|
|
"right")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest (format "~s"
|
|
'(call-with-continuation-prompt
|
|
(lambda ()
|
|
(eval '(begin (abort-current-continuation
|
|
(default-continuation-prompt-tag)
|
|
1 2 3)
|
|
10)))
|
|
(default-continuation-prompt-tag)
|
|
list))
|
|
|
|
("(1 2 3)"
|
|
"(1 2 3)"
|
|
"(1 2 3)"
|
|
"(1 2 3)"
|
|
"(1 2 3)"
|
|
"(1 2 3)")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest "(new snip%)"
|
|
("{unknown snip: #(struct:object:snip% ...)}\n"
|
|
"{unknown snip: #(struct:object:snip% ...)}\n"
|
|
"{unknown snip: #(struct:object:snip% ...)}\n"
|
|
"{unknown snip: #(struct:object:snip% ...)}\n"
|
|
"{unknown snip: #(struct:object:snip% ...)}\n"
|
|
"{unknown snip: #(struct:object:snip% ...)}\n")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; graphical lambda tests
|
|
(mktest (list "((" '("Insert" "Insert λ") "(x) x) 1)")
|
|
|
|
("1"
|
|
"1"
|
|
"1"
|
|
"1"
|
|
"1"
|
|
"1")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest (list "(" '("Insert" "Insert λ") "())")
|
|
|
|
("{stop-22x22.png} λ: bad syntax in: (λ ())"
|
|
"{stop-22x22.png} λ: bad syntax in: (λ ())"
|
|
"{stop-22x22.png} repl-test-tmp3.rkt:1:0: λ: bad syntax in: (λ ())"
|
|
"{stop-22x22.png} λ: bad syntax in: (λ ())"
|
|
"{stop-multi.png} {stop-22x22.png} λ: bad syntax in: (λ ())"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:0: λ: bad syntax in: (λ ())")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; thread tests
|
|
(mktest "(begin (thread (lambda () x)) (sleep 1/10))"
|
|
|
|
("{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x"
|
|
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:26: reference to undefined identifier: x"
|
|
"reference to undefined identifier: x"
|
|
"reference to undefined identifier: x"
|
|
"reference to undefined identifier: x")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; brought down from above for comparison
|
|
(mktest "xx"
|
|
|
|
("{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx"
|
|
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx"
|
|
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.rkt:1:0: reference to undefined identifier: xx"
|
|
"reference to undefined identifier: xx"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: reference to undefined identifier: xx"
|
|
#rx"{stop-multi.png} {stop-22x22.png} .*rkt:[0-9]+:[0-9]+: reference to undefined identifier: xx")
|
|
'definitions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; setup of the namespaces for pict printing (from slideshow)
|
|
|
|
(mktest "(require texpict/utils)(disk 3)"
|
|
|
|
("{image}"
|
|
"{image}"
|
|
"{image}"
|
|
"{image}"
|
|
"{image}"
|
|
"{image}")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest (to-strings
|
|
'(require texpict/utils)
|
|
'(let ()
|
|
(current-namespace (make-namespace))
|
|
(namespace-set-variable-value! 'd (disk 3)))
|
|
'd)
|
|
|
|
("#<pict>"
|
|
"#<pict>"
|
|
"#<pict>"
|
|
"#<pict>"
|
|
"#<pict>"
|
|
"#<pict>")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
(mktest (to-strings
|
|
'(let ([on (current-namespace)]
|
|
[n ((current-module-name-resolver) 'mred #f #f)])
|
|
(current-namespace (make-namespace))
|
|
(namespace-attach-module on n))
|
|
'(require texpict/utils)
|
|
'(disk 3))
|
|
|
|
("{image}"
|
|
"{image}"
|
|
"{image}"
|
|
"{image}"
|
|
"{image}"
|
|
"{image}")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest (string-append
|
|
"(require mzlib/pretty)"
|
|
"(pretty-print-print-hook (lambda x (expt 3 #f)))"
|
|
"(list 1 2 3)")
|
|
|
|
("(1 2 3)"
|
|
"(1 2 3)"
|
|
"(1 2 3)"
|
|
"(1 2 3)"
|
|
"(1 2 3)"
|
|
"(1 2 3)")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest (format "~s\n~s"
|
|
`(require scheme/pretty)
|
|
`(parameterize ((pretty-print-exact-as-decimal #t)) (display 1/4)))
|
|
|
|
("1/4"
|
|
"1/4"
|
|
"1/4"
|
|
"1/4"
|
|
"1/4"
|
|
"1/4")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest
|
|
(string-append
|
|
"(define p (open-output-string))\n"
|
|
"(parameterize ([current-error-port p])\n"
|
|
"(dynamic-wind\n"
|
|
"void\n"
|
|
"(lambda ()\n"
|
|
"((error-display-handler)\n"
|
|
"\"x\"\n"
|
|
"(with-handlers ((void values)) (eval '(lambda ())))))\n"
|
|
"(lambda ()\n"
|
|
"(display (get-output-string p)))))\n")
|
|
|
|
("x in: (lambda ())"
|
|
"x in: (lambda ())"
|
|
"x in: (lambda ())"
|
|
"x in: (lambda ())"
|
|
"x in: (lambda ())"
|
|
"x in: (lambda ())")
|
|
'interactions
|
|
#f
|
|
void
|
|
void)))
|
|
|
|
;; these tests aren't used at the moment.
|
|
#;
|
|
(define xml-tests
|
|
(list
|
|
;; XML tests
|
|
(mktest (list "#!/bin/sh\n"
|
|
'("Insert" "Insert XML Box")
|
|
"<a>")
|
|
"(a ())"
|
|
"(a ())"
|
|
#f #f #f
|
|
'interactions
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest
|
|
'(("Insert" "Insert XML Box")
|
|
"<a>")
|
|
"(a ())"
|
|
"(a ())"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest
|
|
'(("Insert" "Insert XML Box")
|
|
"<a>"
|
|
("Insert" "Insert Scheme Box")
|
|
"1")
|
|
"(a () 1)"
|
|
"(a () 1)"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest
|
|
'(("Insert" "Insert XML Box")
|
|
"<a>"
|
|
("Insert" "Insert Scheme Splice Box")
|
|
"'(1)")
|
|
"(a () 1)"
|
|
"(a () 1)"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(mktest
|
|
'(("Insert" "Insert XML Box")
|
|
"<a>"
|
|
("Insert" "Insert Scheme Splice Box")
|
|
"1")
|
|
"scheme-splice-box: expected a list, found: 1"
|
|
"scheme-splice-box: expected a list, found: 1"
|
|
#t
|
|
'definitions
|
|
#f
|
|
#f
|
|
void
|
|
void)))
|
|
|
|
(define backtrace-image-string "{stop-multi.png}")
|
|
(define file-image-string "{stop-22x22.png}")
|
|
|
|
(define tmp-load-directory (find-system-path 'temp-dir)
|
|
#;
|
|
(normal-case-path
|
|
(normalize-path
|
|
(collection-path "tests" "drracket"))))
|
|
|
|
(define tmp-load-short-filename "repl-test-tmp.rkt")
|
|
(define tmp-load-filename (build-path tmp-load-directory tmp-load-short-filename))
|
|
|
|
(define tmp-load3-short-filename "repl-test-tmp3.rkt")
|
|
(define tmp-load3-filename (build-path tmp-load-directory tmp-load3-short-filename))
|
|
|
|
(define (cleanup-tmp-files)
|
|
(when (file-exists? tmp-load-filename) (delete-file tmp-load-filename))
|
|
(when (file-exists? tmp-load3-filename) (delete-file tmp-load3-filename)))
|
|
|
|
(define (run-test)
|
|
|
|
(define drscheme-frame (wait-for-drscheme-frame))
|
|
|
|
(define interactions-text (queue-callback/res (λ () (send drscheme-frame get-interactions-text))))
|
|
(define interactions-canvas (queue-callback/res (λ () (send drscheme-frame get-interactions-canvas))))
|
|
(define definitions-text (queue-callback/res (λ () (send drscheme-frame get-definitions-text))))
|
|
(define definitions-canvas (queue-callback/res (λ () (send drscheme-frame get-definitions-canvas))))
|
|
(define execute-button (queue-callback/res (λ () (send drscheme-frame get-execute-button))))
|
|
|
|
(define wait-for-execute (lambda () (wait-for-button execute-button)))
|
|
(define get-int-pos (lambda () (queue-callback/res (λ () (get-text-pos interactions-text)))))
|
|
|
|
|
|
(define short-tmp-load-filename
|
|
(let-values ([(base name dir?) (split-path tmp-load-filename)])
|
|
(path->string name)))
|
|
|
|
;; setup-fraction-sum-interactions : -> void
|
|
;; clears the definitions window, and executes `1/2' to
|
|
;; get a fraction snip in the interactions window.
|
|
;; Then, copies that and uses it to construct the sum
|
|
;; of the 1/2 image and 1/3.
|
|
(define (setup-fraction-sum-interactions)
|
|
(clear-definitions drscheme-frame)
|
|
(type-in-definitions drscheme-frame "1/2")
|
|
(do-execute drscheme-frame)
|
|
(queue-callback/res
|
|
(lambda ()
|
|
(let* ([start (send interactions-text paragraph-start-position 2)]
|
|
;; since the fraction is supposed to be one char wide, we just
|
|
;; select one char, so that, if the regular number prints out,
|
|
;; this test will fail.
|
|
[end (+ start 1)])
|
|
(send interactions-text set-position start end))))
|
|
(test:menu-select "Edit" "Copy")
|
|
(clear-definitions drscheme-frame)
|
|
(type-in-definitions drscheme-frame "(+ ")
|
|
(test:menu-select "Edit" "Paste")
|
|
(type-in-definitions drscheme-frame " 1/3)"))
|
|
|
|
; given a filename "foo", we perform two operations on the contents
|
|
; of the file "foo.rkt". First, we insert its contents into the REPL
|
|
; directly, and second, we use the load command. We compare the
|
|
; results of these operations against expected results.
|
|
(define ((run-single-test execute-text-start escape language-cust) in-vector)
|
|
;(printf "\n>> testing ~s\n" (test-program in-vector))
|
|
(let* ([program (test-program in-vector)]
|
|
[execute-answer (make-execute-answer in-vector language-cust)]
|
|
[source-location (test-source-location in-vector)]
|
|
[setup (test-setup in-vector)]
|
|
[teardown (test-teardown in-vector)]
|
|
[start-line (and (pair? source-location)
|
|
(number->string (+ 1 (loc-line (car source-location)))))]
|
|
[start-col (and (pair? source-location)
|
|
(number->string (loc-col (car source-location))))]
|
|
[start-pos (and (pair? source-location)
|
|
(number->string (+ 1 (loc-offset (car source-location)))))]
|
|
[breaking-test? (test-breaking-test? in-vector)])
|
|
|
|
(setup)
|
|
|
|
(clear-definitions drscheme-frame)
|
|
; load contents of test-file into the REPL, recording
|
|
; the start and end positions of the text
|
|
|
|
(wait-for-drscheme-frame)
|
|
|
|
(cond
|
|
[(string? program)
|
|
(insert-in-definitions/newlines drscheme-frame program)]
|
|
[(eq? program 'fraction-sum)
|
|
(setup-fraction-sum-interactions)]
|
|
[(list? program)
|
|
(for-each
|
|
(lambda (item)
|
|
(cond
|
|
[(string? item) (insert-in-definitions/newlines drscheme-frame item)]
|
|
[(eq? item 'left)
|
|
(queue-callback/res
|
|
(λ ()
|
|
(send definitions-text
|
|
set-position
|
|
(- (send definitions-text get-start-position) 1)
|
|
(- (send definitions-text get-start-position) 1))))]
|
|
[(pair? item) (apply test:menu-select item)]))
|
|
program)])
|
|
|
|
(do-execute drscheme-frame #f)
|
|
(queue-callback/res void) ;; make sure that the execute callback has really completed (is this necc w/ test:run-one below?)
|
|
(when breaking-test?
|
|
(test:run-one (λ () (send (send drscheme-frame get-break-button) command))))
|
|
(wait-for-execute)
|
|
|
|
(let* ([execute-text-end (max 0 (- (get-int-pos) 1))] ;; subtract one to skip last newline
|
|
[received-execute
|
|
(fetch-output drscheme-frame execute-text-start execute-text-end)])
|
|
|
|
; check focus and selection for execute test
|
|
(case language-cust
|
|
[(raw) (void)]
|
|
[else
|
|
(cond
|
|
[(eq? source-location 'definitions)
|
|
(unless (send definitions-canvas has-focus?)
|
|
(fprintf (current-error-port)
|
|
"FAILED execute test for ~s\n expected definitions to have the focus\n"
|
|
program))]
|
|
[(eq? source-location 'interactions)
|
|
(unless (send interactions-canvas has-focus?)
|
|
(fprintf (current-error-port)
|
|
"FAILED execute test for ~s\n expected interactions to have the focus\n"
|
|
program))]
|
|
[(queue-callback/res (λ () (send definitions-canvas has-focus?)))
|
|
(let ([start (car source-location)]
|
|
[finish (cdr source-location)])
|
|
(let* ([error-ranges (queue-callback/res (λ () (send interactions-text get-error-ranges)))]
|
|
[error-range (and error-ranges
|
|
(not (null? error-ranges))
|
|
(car error-ranges))])
|
|
(unless (and error-range
|
|
(= (+ (srcloc-position error-range) -1) (loc-offset start))
|
|
(= (+ (srcloc-position error-range) -1 (srcloc-span error-range))
|
|
(loc-offset finish)))
|
|
(fprintf (current-error-port)
|
|
"FAILED execute test for ~s\n error-range is ~s\n expected ~s\n"
|
|
program
|
|
(and error-range
|
|
(list (+ (srcloc-position error-range) -1)
|
|
(+ (srcloc-position error-range) -1 (srcloc-span error-range))))
|
|
(list (loc-offset start)
|
|
(loc-offset finish))))))])])
|
|
|
|
; check text for execute test
|
|
(next-test)
|
|
(unless (cond
|
|
[(string? execute-answer)
|
|
(string=? execute-answer received-execute)]
|
|
[(regexp? execute-answer)
|
|
(regexp-match execute-answer received-execute)]
|
|
[else #f])
|
|
(failure)
|
|
(fprintf (current-error-port)
|
|
"FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n"
|
|
program
|
|
language-cust
|
|
execute-answer received-execute))
|
|
|
|
(test:new-window interactions-canvas)
|
|
|
|
; save the file so that load is in sync
|
|
(test:menu-select "File" "Save Definitions")
|
|
|
|
; make sure that a prompt is available at end of the REPL
|
|
(unless (queue-callback/res
|
|
(λ ()
|
|
(and (char=? #\>
|
|
(send interactions-text get-character
|
|
(- (send interactions-text last-position) 2)))
|
|
(char=? #\space
|
|
(send interactions-text get-character
|
|
(- (send interactions-text last-position) 1))))))
|
|
(test:keystroke #\return))
|
|
|
|
(let ([load-test
|
|
(lambda (short-filename load-answer)
|
|
;; in order to erase the state in the namespace already, we clear (but don't save!)
|
|
;; the definitions and click execute with the empty buffer
|
|
(test:new-window definitions-canvas)
|
|
(test:menu-select "Edit" "Select All")
|
|
(test:menu-select "Edit" "Delete")
|
|
(do-execute drscheme-frame #f)
|
|
(wait-for-execute)
|
|
|
|
;; stuff the load command into the REPL
|
|
(insert-in-interactions drscheme-frame (format "(load ~s)" short-filename))
|
|
|
|
;; record current text position, then stuff a CR into the REPL
|
|
(let ([load-text-start (+ 1 (queue-callback/res (λ () (send interactions-text last-position))))])
|
|
|
|
(test:keystroke #\return)
|
|
|
|
(when breaking-test?
|
|
(test:run-one (λ () (send (send drscheme-frame get-break-button) command))))
|
|
(wait-for-execute)
|
|
|
|
(let* ([load-text-end (- (get-int-pos) 1)] ;; subtract one to eliminate newline
|
|
[received-load
|
|
(fetch-output drscheme-frame load-text-start load-text-end)])
|
|
|
|
;; check load text
|
|
(next-test)
|
|
(unless (cond
|
|
[(string? load-answer)
|
|
(string=? load-answer received-load)]
|
|
[(regexp? load-answer)
|
|
(regexp-match load-answer received-load)]
|
|
[else #f])
|
|
(failure)
|
|
(fprintf (current-error-port)
|
|
"FAILED load test ~a for ~s\n expected: ~s\n got: ~s\n"
|
|
short-filename
|
|
program load-answer received-load)))))])
|
|
(load-test tmp-load-short-filename (make-load-answer in-vector language-cust #f))
|
|
(when (file-exists? tmp-load3-filename)
|
|
(delete-file tmp-load3-filename))
|
|
(copy-file tmp-load-filename tmp-load3-filename)
|
|
(load-test tmp-load3-short-filename (make-load-answer in-vector language-cust tmp-load3-short-filename)))
|
|
|
|
(teardown)
|
|
|
|
; check for edit-sequence
|
|
(when (repl-in-edit-sequence?)
|
|
(fprintf (current-error-port) "FAILED: repl in edit-sequence")
|
|
(escape)))))
|
|
|
|
(define tests 0)
|
|
(define failures 0)
|
|
(define (next-test) (set! tests (+ tests 1)))
|
|
(define (failure) (set! failures (+ failures 1)))
|
|
(define (reset) (set! tests 0) (set! failures 0))
|
|
(define (final-report)
|
|
(if (= 0 failures)
|
|
(printf "tests finished: all ~a tests passed\n" tests)
|
|
(fprintf (current-error-port) "tests finished: ~a failed out of ~a total\n" failures tests)))
|
|
|
|
(define (run-test-in-language-level language-cust)
|
|
(let ([level (list #rx"Pretty Big")])
|
|
(printf "running tests: ~a\n" language-cust)
|
|
(case language-cust
|
|
[(raw)
|
|
(begin
|
|
(set-language-level! level #f)
|
|
(test:set-radio-box-item! "No debugging or profiling")
|
|
(let ([f (get-top-level-focus-window)])
|
|
(test:button-push "OK")
|
|
(wait-for-new-frame f)))]
|
|
[(debug)
|
|
(set-language-level! level)]
|
|
[(debug/profile)
|
|
(begin
|
|
(set-language-level! level #f)
|
|
(test:set-radio-box-item! "Debugging and profiling")
|
|
(let ([f (get-top-level-focus-window)])
|
|
(test:button-push "OK")
|
|
(wait-for-new-frame f)))])
|
|
|
|
|
|
(random-seed-test)
|
|
|
|
(test:new-window definitions-canvas)
|
|
(clear-definitions drscheme-frame)
|
|
(do-execute drscheme-frame)
|
|
(let/ec escape
|
|
(for-each (run-single-test (get-int-pos) escape language-cust) test-data))))
|
|
|
|
(define kill-menu-item "Force the Program to Quit")
|
|
|
|
(define (kill-tests)
|
|
|
|
(next-test)
|
|
(clear-definitions drscheme-frame)
|
|
(do-execute drscheme-frame)
|
|
(test:menu-select "Racket" kill-menu-item)
|
|
(let ([win (wait-for-new-frame drscheme-frame)])
|
|
(test:button-push "OK")
|
|
(let ([drs2 (wait-for-new-frame win)])
|
|
(unless (eq? drs2 drscheme-frame)
|
|
(error 'kill-test1 "expected original drscheme frame to come back to the front"))))
|
|
|
|
(next-test)
|
|
(type-in-definitions drscheme-frame "(kill-thread (current-thread))")
|
|
(do-execute drscheme-frame #f)
|
|
(let ([win (wait-for-new-frame drscheme-frame)])
|
|
(test:button-push "OK")
|
|
(let ([drs2 (wait-for-new-frame win)])
|
|
(unless (eq? drs2 drscheme-frame)
|
|
(error 'kill-test2 "expected original drscheme frame to come back to the front"))))
|
|
|
|
(next-test)
|
|
(clear-definitions drscheme-frame)
|
|
(do-execute drscheme-frame)
|
|
(type-in-definitions
|
|
drscheme-frame
|
|
"(define (f) (queue-callback f) (error 'ouch)) (f)")
|
|
(do-execute drscheme-frame #f)
|
|
(sleep 1/2)
|
|
(test:menu-select "Racket" kill-menu-item)
|
|
(let ([win (wait-for-new-frame drscheme-frame null 360)])
|
|
(test:button-push "OK")
|
|
(let ([drs2 (wait-for-new-frame win)])
|
|
(unless (eq? drs2 drscheme-frame)
|
|
(error
|
|
'kill-test3
|
|
"expected original drscheme frame to come back to the front"))))
|
|
(when (send (send drscheme-frame get-interactions-text) local-edit-sequence?)
|
|
(error 'kill-test3 "in edit-sequence")))
|
|
|
|
(define (callcc-test)
|
|
(next-test)
|
|
(clear-definitions drscheme-frame)
|
|
(type-in-definitions drscheme-frame "(define kont #f) (let/cc empty (set! kont empty))")
|
|
(do-execute drscheme-frame)
|
|
(wait-for-execute)
|
|
|
|
(for-each test:keystroke (string->list "(kont)"))
|
|
(test:keystroke #\return)
|
|
(wait-for-execute)
|
|
|
|
(for-each test:keystroke (string->list "x"))
|
|
(let ([start (+ 1 (queue-callback/res (λ () (send interactions-text last-position))))])
|
|
(test:keystroke #\return)
|
|
(wait-for-execute)
|
|
|
|
(let* ([end (- (get-int-pos) 1)]
|
|
[output (fetch-output drscheme-frame start end)]
|
|
[expected #rx"reference to undefined identifier: x"])
|
|
(unless (regexp-match expected output)
|
|
(failure)
|
|
(fprintf (current-error-port) "callcc-test: expected something matching ~s, got ~s\n" expected output)))))
|
|
|
|
(define (random-seed-test)
|
|
(define expression (format "~s" '(pseudo-random-generator->vector (current-pseudo-random-generator))))
|
|
(next-test)
|
|
(clear-definitions drscheme-frame)
|
|
(do-execute drscheme-frame)
|
|
(wait-for-execute)
|
|
|
|
(insert-in-interactions drscheme-frame expression)
|
|
(let ([start1 (+ 1 (queue-callback/res (λ () (send interactions-text last-position))))])
|
|
(test:keystroke #\return)
|
|
(wait-for-execute)
|
|
(let ([output1 (fetch-output drscheme-frame start1 (- (get-int-pos) 1))])
|
|
(insert-in-interactions drscheme-frame expression)
|
|
(let ([start2 (+ 1 (queue-callback/res (λ () (send interactions-text last-position))))])
|
|
(test:keystroke #\return)
|
|
(wait-for-execute)
|
|
(let ([output2 (fetch-output drscheme-frame start2 (- (get-int-pos) 1))])
|
|
(unless (equal? output1 output2)
|
|
(failure)
|
|
(fprintf (current-error-port)
|
|
"random-seed-test: expected\n ~s\nand\n ~s\nto be the same"
|
|
output1
|
|
output2)))))))
|
|
|
|
(define (top-interaction-test)
|
|
(clear-definitions drscheme-frame)
|
|
(do-execute drscheme-frame)
|
|
(wait-for-execute)
|
|
(let ([ints-just-after-welcome (queue-callback/res (λ () (+ 1 (send interactions-text last-position))))])
|
|
|
|
(type-in-definitions drscheme-frame "(define-syntax #%top-interaction (syntax-rules () [(_ . e) 'e]))\n(+ 1 2)\n")
|
|
(test:menu-select "File" "Save Definitions")
|
|
|
|
(clear-definitions drscheme-frame)
|
|
(do-execute drscheme-frame)
|
|
(wait-for-execute)
|
|
|
|
(for-each test:keystroke (string->list (format "(load ~s)" tmp-load-short-filename)))
|
|
(let ([start (+ 1 (queue-callback/res (λ () (send interactions-text last-position))))])
|
|
(test:keystroke #\return)
|
|
(wait-for-execute)
|
|
(let* ([end (- (get-int-pos) 1)]
|
|
[output (fetch-output drscheme-frame start end)]
|
|
[expected "(+ 1 2)"])
|
|
(unless (equal? output expected)
|
|
(error 'top-interaction-test "expected.1 ~s, got ~s" expected output))
|
|
(next-test)))
|
|
|
|
(for-each test:keystroke (string->list "(+ 4 5)"))
|
|
(let ([start (+ 1 (queue-callback/res (λ () (send interactions-text last-position))))])
|
|
(test:keystroke #\return)
|
|
(wait-for-execute)
|
|
(let* ([end (- (get-int-pos) 1)]
|
|
[output (fetch-output drscheme-frame start end)]
|
|
[expected "(+ 4 5)"])
|
|
(unless (equal? output expected)
|
|
(error 'top-interaction-test "expected.2 ~s, got ~s" expected output))
|
|
(next-test)))))
|
|
|
|
(when (file-exists? tmp-load-filename)
|
|
(delete-file tmp-load-filename))
|
|
(save-drscheme-window-as tmp-load-filename)
|
|
|
|
;; the debug and debug/profile tests should not differ in their output
|
|
;; they are both run here because debug uses the automatic-compilation
|
|
;; stuff and debug/profile does not (so they use different instantiations
|
|
;; of the stacktrace module.
|
|
(run-test-in-language-level 'raw)
|
|
(run-test-in-language-level 'debug)
|
|
(run-test-in-language-level 'debug/profile)
|
|
|
|
(kill-tests)
|
|
(callcc-test)
|
|
(top-interaction-test)
|
|
(final-report))
|
|
|
|
(define (insert-in-definitions/newlines drs str)
|
|
(let loop ([strs (regexp-split #rx"\n" str)])
|
|
(insert-in-definitions drs (car strs))
|
|
(unless (null? (cdr strs))
|
|
(test:keystroke #\return)
|
|
(loop (cdr strs)))))
|
|
|
|
(define (make-execute-answer test language-cust)
|
|
((case language-cust
|
|
[(debug debug/profile)
|
|
answer-debug-execute]
|
|
[(raw)
|
|
answer-raw-execute])
|
|
(test-answer test)))
|
|
|
|
(define (make-load-answer test language-cust src-file)
|
|
((case language-cust
|
|
[(debug debug/profile)
|
|
(if src-file
|
|
answer-debug-load
|
|
answer-debug-load-fn)]
|
|
[(raw)
|
|
(if src-file
|
|
answer-raw-load
|
|
answer-raw-load-fn)])
|
|
(test-answer test)))
|
|
|
|
(define (string/rx-append a b)
|
|
(if (regexp? b)
|
|
(regexp (string-append (regexp-quote a) (object-name b)))
|
|
(string-append a b)))
|
|
|
|
|
|
(exit-handler
|
|
(let ([eh (exit-handler)])
|
|
(λ (val)
|
|
(cleanup-tmp-files)
|
|
(eh val))))
|
|
|
|
(fire-up-drscheme-and-run-tests run-test)
|