1038 lines
34 KiB
Scheme
1038 lines
34 KiB
Scheme
#|
|
|
|
|
add this test:
|
|
|
|
(require (lib "pretty.ss"))
|
|
(pretty-print-print-hook (lambda x (car)))
|
|
(list 1 2 3)
|
|
|
|
There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|
|
|
|#
|
|
(module repl-test mzscheme
|
|
(require "drscheme-test-util.ss"
|
|
(lib "class.ss")
|
|
(lib "file.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "framework.ss" "framework"))
|
|
|
|
(provide run-test)
|
|
|
|
(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
|
|
|
|
execute-answer ;; : string
|
|
load-answer ;; : (union #f string)
|
|
|
|
has-backtrace? ;; : boolean
|
|
;; indicates if the backtrace icon should appear for this test
|
|
;; only applies to the debug tests
|
|
|
|
source-location ;; : (union 'definitions
|
|
;; 'interactions
|
|
;; (cons loc loc))
|
|
;; if cons, the car and cdr are the start and end positions resp.
|
|
;; if 'interactions, no source location and
|
|
;; the focus must be in the interactions window
|
|
;; if 'definitions, no source location and
|
|
;; the focus must be in the definitions window
|
|
|
|
source-location-in-message ;; : (union #f 'read 'expand)
|
|
;; 'read indicates that the error message is a read error, so
|
|
;; the source location is the port info, and 'expand indicates
|
|
;; that the error messsage is an expansion time error, so the
|
|
;; the source location is the repl.
|
|
;; #f indicates no source location error message
|
|
;; if this field is not #f, the execute-answer and load-answer fields
|
|
;; are expected to be `format'able strings with one ~a in them.
|
|
|
|
docs-icon? ;; : boolean
|
|
;; true if this should have a docs icon in front of the response.
|
|
|
|
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 test-data
|
|
(list
|
|
;; basic tests
|
|
(make-test "1"
|
|
"1"
|
|
"1"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "\"a\""
|
|
"\"a\""
|
|
"\"a\""
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test "1 2"
|
|
"1\n2"
|
|
"2"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test "\"a\" \"b\""
|
|
"\"a\"\n\"b\""
|
|
"\"b\""
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test "("
|
|
"~aread: expected a ')'"
|
|
"~aread: expected a ')'"
|
|
#f
|
|
(cons (make-loc 0 0 0) (make-loc 0 1 1))
|
|
'read
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "."
|
|
"~aread: illegal use of \".\""
|
|
"~aread: illegal use of \".\""
|
|
#f
|
|
(cons (make-loc 0 0 0) (make-loc 0 1 1))
|
|
'read
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "(lambda ())"
|
|
"~alambda: bad syntax in: (lambda ())"
|
|
"~alambda: bad syntax in: (lambda ())"
|
|
#f
|
|
(cons (make-loc 0 0 0) (make-loc 0 11 11))
|
|
'expand
|
|
#t
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "xx"
|
|
"reference to undefined identifier: xx"
|
|
"reference to undefined identifier: xx"
|
|
#t
|
|
(cons (make-loc 0 0 0) (make-loc 0 2 2))
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "(raise 1)"
|
|
"uncaught exception: 1"
|
|
"uncaught exception: 1"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "(raise #f)"
|
|
"uncaught exception: #f"
|
|
"uncaught exception: #f"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test "(values 1 2)"
|
|
"1\n2"
|
|
"1\n2"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "(list 1 2)"
|
|
"(1 2)"
|
|
"(1 2)"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test "(parameterize ([print-struct #t])(define-struct s (x) (make-inspector))(printf \"~s\\n\" (make-s 1)))"
|
|
"#(struct:s 1)"
|
|
"#(struct:s 1)"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; top-level semantics test
|
|
(make-test "(define (f) (+ 1 1)) (define + -) (f)"
|
|
"0"
|
|
"0"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test "(begin (define-struct a ()) (define-struct (b a) ()))"
|
|
""
|
|
""
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test "(begin (values) 1)"
|
|
"1"
|
|
"1"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test (string-append
|
|
"(module m mzscheme (provide e) (define e #'1))\n"
|
|
"(module n mzscheme (require-for-syntax m) (provide s) (define-syntax (s stx) e))\n"
|
|
"(require n)\n"
|
|
"s")
|
|
"compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
|
"compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
|
|
#f
|
|
(cons (make-loc 1 43 43) (make-loc 1 44 44))
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; leading comment test
|
|
(make-test "#!\n1"
|
|
"1"
|
|
"1"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
#|
|
|
(make-test (list "#!\n"
|
|
'("Special" "Insert XML Box")
|
|
"<a>")
|
|
"(a ())"
|
|
"(a ())"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; XML tests
|
|
(make-test
|
|
'(("Special" "Insert XML Box")
|
|
"<a>")
|
|
"(a ())"
|
|
"(a ())"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test
|
|
'(("Special" "Insert XML Box")
|
|
"<a>"
|
|
("Special" "Insert Scheme Box")
|
|
"1")
|
|
"(a () 1)"
|
|
"(a () 1)"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test
|
|
'(("Special" "Insert XML Box")
|
|
"<a>"
|
|
("Special" "Insert Scheme Splice Box")
|
|
"'(1)")
|
|
"(a () 1)"
|
|
"(a () 1)"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test
|
|
'(("Special" "Insert XML Box")
|
|
"<a>"
|
|
("Special" "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
|
|
#f
|
|
void
|
|
void)
|
|
|#
|
|
|
|
;; eval tests
|
|
(make-test " (eval '(values 1 2))"
|
|
"1\n2"
|
|
"1\n2"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test " (eval '(list 1 2))"
|
|
"(1 2)"
|
|
"(1 2)"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test " (eval '(lambda ()))"
|
|
"lambda: bad syntax in: (lambda ())"
|
|
"lambda: bad syntax in: (lambda ())"
|
|
2
|
|
(cons (make-loc 0 4 4) (make-loc 0 23 23))
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test " (eval 'x)"
|
|
"reference to undefined identifier: x"
|
|
"reference to undefined identifier: x"
|
|
2
|
|
(cons (make-loc 0 4 4) (make-loc 0 13 13))
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test "(eval (box 1))"
|
|
"#&1"
|
|
"#&1"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test "(eval '(box 1))"
|
|
"#&1"
|
|
"#&1"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
; printer setup test
|
|
(make-test "(car (void))"
|
|
"car: expects argument of type <pair>; given #<void>"
|
|
"car: expects argument of type <pair>; given #<void>"
|
|
2
|
|
(cons (make-loc 0 0 0) (make-loc 0 12 12))
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; error in the middle
|
|
(make-test "1 2 ( 3 4"
|
|
"1\n2\n~aread: expected a ')'"
|
|
"~aread: expected a ')'"
|
|
#f
|
|
(cons (make-loc 0 4 4) (make-loc 0 9 9))
|
|
'read
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "1 2 . 3 4"
|
|
"1\n2\n~aread: illegal use of \".\""
|
|
"~aread: illegal use of \".\""
|
|
#f
|
|
(cons (make-loc 0 4 4) (make-loc 0 5 5))
|
|
'read
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "1 2 (lambda ()) 3 4"
|
|
"1\n2\n~alambda: bad syntax in: (lambda ())"
|
|
"~alambda: bad syntax in: (lambda ())"
|
|
#f
|
|
(cons (make-loc 0 4 4) (make-loc 0 15 15))
|
|
'expand
|
|
#t
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "1 2 x 3 4"
|
|
"1\n2\nreference to undefined identifier: x"
|
|
"reference to undefined identifier: x"
|
|
#t
|
|
(cons (make-loc 0 4 4) (make-loc 0 5 5))
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "1 2 (raise 1) 3 4"
|
|
"1\n2\nuncaught exception: 1"
|
|
"uncaught exception: 1"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "1 2 (raise #f) 3 4"
|
|
"1\n2\nuncaught exception: #f"
|
|
"uncaught exception: #f"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; error across separate files
|
|
(let ([tmp-filename (make-temporary-file "dr-repl-test~a.ss")])
|
|
(make-test
|
|
(format "(load ~s) (f (lambda () (+ 1 (car 1))))" (path->string tmp-filename))
|
|
"car: expects argument of type <pair>; given 1"
|
|
"car: expects argument of type <pair>; given 1"
|
|
#t
|
|
(cons (make-loc -1 -1 (+ (string-length (path->string tmp-filename)) 29))
|
|
(make-loc -1 -1 (+ (string-length (path->string tmp-filename)) 36)))
|
|
#f
|
|
#f
|
|
#f
|
|
(lambda ()
|
|
(call-with-output-file tmp-filename
|
|
(lambda (port)
|
|
(write '(define (f t) (+ 1 (t)))
|
|
port))
|
|
'truncate))
|
|
(lambda ()
|
|
(delete-file tmp-filename))))
|
|
|
|
;; new namespace test
|
|
(make-test "(current-namespace (make-namespace))\nif"
|
|
"~aif: bad syntax in: if"
|
|
"~aif: bad syntax in: if"
|
|
#f
|
|
(cons (make-loc 1 0 37) (make-loc 1 2 39))
|
|
'expand
|
|
#t
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test "(current-namespace (make-namespace 'empty))\nif"
|
|
"~acompile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: if"
|
|
#f
|
|
#f
|
|
(cons (make-loc 1 0 44) (make-loc 1 0 46))
|
|
'expand
|
|
#t
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; macro tests
|
|
(make-test "(define-syntax (c stx) (syntax-case stx () [(_ p q r) (syntax (+ p q r))]))"
|
|
""
|
|
""
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
|
|
|
|
;; error escape handler test
|
|
(make-test
|
|
"(let ([old (error-escape-handler)])\n(+ (let/ec k\n(dynamic-wind\n(lambda () (error-escape-handler (lambda () (k 5))))\n(lambda () (car))\n(lambda () (error-escape-handler old))))\n10))"
|
|
"car: expects 1 argument, given 0\n15"
|
|
"car: expects 1 argument, given 0\n15"
|
|
#t
|
|
'definitions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
; fraction snip test
|
|
(make-test 'fraction-sum
|
|
"{number 5/6 \"5/6\" mixed}"
|
|
"{number 5/6 \"5/6\" mixed}"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; should produce a syntax object with a turn-down triangle.
|
|
(make-test "(write (list (syntax x)))"
|
|
"({embedded \".#<syntax:1:21>\"})"
|
|
"({embedded \".#<syntax:/Users/robby/svn/plt/collects/tests/drscheme/repl-test-tmp.ss:1:21>\"})"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; make sure syntax objects only go into good ports
|
|
(make-test "(define-syntax (foo stx) (with-handlers ([exn:fail? (lambda (x) #'10)]) (syntax-local-value #'foot))) (foo)"
|
|
"10"
|
|
"10"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; make sure syntax objects don't go into bad ports
|
|
(make-test "(parameterize ([current-output-port (open-output-string)]) (write #'1))"
|
|
""
|
|
""
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test "(parameterize ([current-output-port (open-output-string)]) (fprintf (current-error-port) \"~e\" #'foot))"
|
|
"#<syntax::79>"
|
|
"#<syntax::79>"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test
|
|
;; the begin/void combo is to make sure that no value printout
|
|
;; comes and messes up the source location for the error.
|
|
"(define s (make-semaphore 0))\n(queue-callback\n(lambda ()\n(dynamic-wind\nvoid\n(lambda () (car))\n(lambda () (semaphore-post s)))))\n(begin (yield s) (void))"
|
|
"car: expects 1 argument, given 0"
|
|
"car: expects 1 argument, given 0"
|
|
2
|
|
(cons (make-loc 0 99 99) (make-loc 0 104 104))
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; breaking tests
|
|
(make-test "(semaphore-wait (make-semaphore 0))"
|
|
"user break"
|
|
"user break"
|
|
2
|
|
(cons (make-loc 0 0 0) (make-loc 0 35 35))
|
|
#f
|
|
#f
|
|
#t
|
|
void
|
|
void)
|
|
|
|
(make-test "(let l()(l))"
|
|
"user break"
|
|
"user break"
|
|
2
|
|
(cons (make-loc 0 8 8) (make-loc 0 11 11))
|
|
#f
|
|
#f
|
|
#t
|
|
void
|
|
void)
|
|
|
|
;; continuation tests
|
|
(make-test "(define k (call/cc (lambda (x) x)))\n(k 17)\nk"
|
|
"17" "17"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "(define v (vector (call/cc (lambda (x) x))))\n((vector-ref v 0) 2)\nv"
|
|
"#1(2)" "#1(2)"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
(make-test "(define v (vector (eval '(call/cc (lambda (x) x)))))\n((vector-ref v 0) 2)\nv"
|
|
"#1(2)" "#1(2)"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test "(define x 1)\n(begin (set! x (call/cc (lambda (x) x)))\n(x 3))"
|
|
"procedure application: expected procedure, given: 3; arguments were: 3"
|
|
"procedure application: expected procedure, given: 3; arguments were: 3"
|
|
#t
|
|
(cons (make-loc 3 7 61) (make-loc 3 12 66))
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; graphical lambda tests
|
|
(make-test (list "((" '("Special" "Insert λ") "(x) x) 1)")
|
|
"1"
|
|
"1"
|
|
#f
|
|
'interactions
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)
|
|
|
|
(make-test (list "(" '("Special" "Insert λ") "())")
|
|
"~aλ: bad syntax in: (λ ())"
|
|
"~aλ: bad syntax in: (λ ())"
|
|
#f
|
|
(cons (make-loc 0 0 0) (make-loc 0 5 5))
|
|
'expand
|
|
#t
|
|
#f
|
|
void
|
|
void)
|
|
|
|
;; thread tests
|
|
(make-test "(begin (thread (lambda () x)) (sleep 1/10))"
|
|
"reference to undefined identifier: x"
|
|
"reference to undefined identifier: x"
|
|
#t
|
|
(cons (make-loc 0 26 26) (make-loc 0 27 27))
|
|
#f
|
|
#f
|
|
#f
|
|
void
|
|
void)))
|
|
|
|
(define backtrace-image-string "{bug09.gif}")
|
|
(define file-image-string "{file.gif}")
|
|
|
|
(define (run-test)
|
|
|
|
(define drscheme-frame (wait-for-drscheme-frame))
|
|
|
|
(define interactions-text (send drscheme-frame get-interactions-text))
|
|
(define interactions-canvas (send drscheme-frame get-interactions-canvas))
|
|
(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-int-pos (lambda () (get-text-pos interactions-text)))
|
|
|
|
(define tmp-load-short-filename "repl-test-tmp.ss")
|
|
(define tmp-load-filename
|
|
(normal-case-path
|
|
(normalize-path
|
|
(build-path (collection-path "tests" "drscheme")
|
|
tmp-load-short-filename))))
|
|
|
|
(define short-tmp-load-filename
|
|
(let-values ([(base name dir?) (split-path tmp-load-filename)])
|
|
(path->string name)))
|
|
|
|
|
|
;; setup-fraction-sum-interactions : -> void
|
|
;; clears the definitions window, and executes `1/2' to
|
|
;; get a fraction snip in the interactions window.
|
|
;; 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)
|
|
(let ([s (make-semaphore 0)])
|
|
(queue-callback
|
|
(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)
|
|
(semaphore-post s))))
|
|
(semaphore-wait s))
|
|
(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.ss". First, we insert its contents into the REPL
|
|
; directly, and second, we use the load command. We compare the
|
|
; the results of these operations against expected results.
|
|
(define run-single-test
|
|
(lambda (execute-text-start escape raw?)
|
|
(lambda (in-vector)
|
|
(let* ([program (test-program in-vector)]
|
|
[execute-answer (test-execute-answer in-vector)]
|
|
[source-location (test-source-location in-vector)]
|
|
[source-location-in-message (test-source-location-in-message in-vector)]
|
|
[setup (test-setup in-vector)]
|
|
[teardown (test-teardown in-vector)]
|
|
[start-line (and source-location-in-message
|
|
(number->string (+ 1 (loc-line (car source-location)))))]
|
|
[start-col (and source-location-in-message
|
|
(number->string (loc-col (car source-location))))]
|
|
[start-pos (and (pair? source-location)
|
|
(number->string (+ 1 (loc-offset (car source-location)))))]
|
|
[formatted-execute-answer
|
|
(let* ([w/backtrace
|
|
(if (and (test-has-backtrace? in-vector)
|
|
(not raw?))
|
|
(string-append backtrace-image-string " ")
|
|
"")]
|
|
[final
|
|
;; if there is a source-location for the message, put the
|
|
;; icons just before it. Otherwise, but the icons at
|
|
;; the beginning of the entire string.
|
|
(if source-location-in-message
|
|
(format execute-answer w/backtrace)
|
|
(string-append w/backtrace execute-answer))])
|
|
final)]
|
|
[load-answer (test-load-answer in-vector)]
|
|
[formatted-load-answer
|
|
(and load-answer
|
|
(let ([line-col-loc-str
|
|
(and source-location-in-message
|
|
(format "~a:~a:~a: "
|
|
short-tmp-load-filename
|
|
start-line
|
|
start-col))]
|
|
[pos-col-str
|
|
(if (pair? source-location)
|
|
(format "~a::~a:"
|
|
short-tmp-load-filename
|
|
start-pos)
|
|
"")])
|
|
(if raw?
|
|
(if source-location-in-message
|
|
(string-append file-image-string
|
|
" "
|
|
(format load-answer line-col-loc-str))
|
|
load-answer)
|
|
(cond
|
|
[source-location-in-message
|
|
;; syntax error or read time error, so has a back trace
|
|
;; (the call to load) and line/col info
|
|
(string-append backtrace-image-string " "
|
|
file-image-string " "
|
|
(format load-answer line-col-loc-str))]
|
|
[(or (eq? source-location 'definitions)
|
|
(pair? source-location))
|
|
;; run-time error, so has a backtrace (the call to to load)
|
|
;; but only offset info
|
|
(string-append backtrace-image-string " "
|
|
file-image-string " "
|
|
pos-col-str " "
|
|
load-answer)]
|
|
[else load-answer]))))]
|
|
[breaking-test? (test-breaking-test? in-vector)])
|
|
|
|
(setup)
|
|
|
|
(clear-definitions drscheme-frame)
|
|
; load contents of test-file into the REPL, recording
|
|
; the start and end positions of the text
|
|
|
|
(cond
|
|
[(string? program)
|
|
(insert-string program)]
|
|
[(eq? program 'fraction-sum)
|
|
(setup-fraction-sum-interactions)]
|
|
[(list? program)
|
|
(for-each
|
|
(lambda (item)
|
|
(cond
|
|
[(string? item) (insert-string item)]
|
|
[(eq? item 'left)
|
|
(send definitions-text
|
|
set-position
|
|
(- (send definitions-text get-start-position) 1)
|
|
(- (send definitions-text get-start-position) 1))]
|
|
[(pair? item) (apply test:menu-select item)]))
|
|
program)])
|
|
|
|
(do-execute drscheme-frame #f)
|
|
(when breaking-test?
|
|
(test:button-push (send drscheme-frame get-break-button)))
|
|
(wait-for-execute)
|
|
|
|
(let* ([execute-text-end (- (get-int-pos) 1)] ;; subtract one to skip last newline
|
|
[received-execute
|
|
(fetch-output drscheme-frame execute-text-start execute-text-end)])
|
|
|
|
; check focus and selection for execute test
|
|
(unless raw?
|
|
(cond
|
|
[(eq? source-location 'definitions)
|
|
(unless (send definitions-canvas has-focus?)
|
|
(printf "FAILED execute test for ~s\n expected definitions to have the focus\n"
|
|
program))]
|
|
[(eq? source-location 'interactions)
|
|
(unless (send interactions-canvas has-focus?)
|
|
(printf "FAILED execute test for ~s\n expected interactions to have the focus\n"
|
|
program))]
|
|
[(send definitions-canvas has-focus?)
|
|
(let ([start (car source-location)]
|
|
[finish (cdr source-location)])
|
|
(let* ([error-ranges (send interactions-text get-error-ranges)]
|
|
[error-range (and error-ranges
|
|
(not (null? error-ranges))
|
|
(car error-ranges))])
|
|
(unless (and error-range
|
|
(= (+ (srcloc-position error-range) -1) (loc-offset start))
|
|
(= (+ (srcloc-position error-range) -1 (srcloc-span error-range)) (loc-offset finish)))
|
|
(printf "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n"
|
|
program
|
|
(list (+ (srcloc-position error-range) -1)
|
|
(+ (srcloc-position error-range) -1 (srcloc-span error-range)))
|
|
(list (loc-offset start)
|
|
(loc-offset finish))))))]))
|
|
|
|
; check text for execute test
|
|
(unless (string=? received-execute formatted-execute-answer)
|
|
(printf "FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n"
|
|
program
|
|
raw?
|
|
formatted-execute-answer received-execute))
|
|
|
|
(test:new-window interactions-canvas)
|
|
|
|
; save the file so that load is in sync
|
|
(test:menu-select "File" "Save Definitions")
|
|
|
|
; make sure that a prompt is available at end of the REPL
|
|
(unless (and (char=? #\>
|
|
(send interactions-text get-character
|
|
(- (send interactions-text last-position) 2)))
|
|
(char=? #\space
|
|
(send interactions-text get-character
|
|
(- (send interactions-text last-position) 1))))
|
|
(test:keystroke #\return))
|
|
|
|
; stuff the load command into the REPL
|
|
(for-each test:keystroke
|
|
(string->list (format "(load ~s)" tmp-load-short-filename)))
|
|
|
|
; record current text position, then stuff a CR into the REPL
|
|
(let ([load-text-start (+ 1 (send interactions-text last-position))])
|
|
|
|
(test:keystroke #\return)
|
|
|
|
(when breaking-test?
|
|
(test:button-push (send drscheme-frame get-break-button)))
|
|
(wait-for-execute)
|
|
|
|
(when load-answer
|
|
(let* ([load-text-end (- (get-int-pos) 1)] ;; subtract one to eliminate newline
|
|
[received-load
|
|
(fetch-output drscheme-frame load-text-start load-text-end)])
|
|
|
|
; check load text
|
|
(unless (string=? received-load formatted-load-answer)
|
|
(printf "FAILED load test for ~s\n expected: ~s\n got: ~s\n"
|
|
program formatted-load-answer received-load)))))
|
|
|
|
(teardown)
|
|
|
|
; check for edit-sequence
|
|
(when (repl-in-edit-sequence?)
|
|
(printf "FAILED: repl in edit-sequence")
|
|
(escape)))))))
|
|
|
|
(define (run-test-in-language-level raw?)
|
|
(let ([level (list "PLT" (regexp "Graphical"))])
|
|
(printf "running ~s (raw? ~a) tests\n" level raw?)
|
|
(if 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)))
|
|
(set-language-level! level))
|
|
|
|
(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 raw?) test-data))))
|
|
|
|
(define (kill-tests)
|
|
(clear-definitions drscheme-frame)
|
|
(do-execute drscheme-frame)
|
|
|
|
(test:menu-select "Scheme" "Kill")
|
|
|
|
(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"))))
|
|
|
|
(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"))))
|
|
|
|
(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 "Scheme" "Kill")
|
|
(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")))
|
|
|
|
|
|
;; run the tests
|
|
|
|
(when (file-exists? tmp-load-filename)
|
|
(delete-file tmp-load-filename))
|
|
(save-drscheme-window-as tmp-load-filename)
|
|
|
|
;(set-language-level! (list "PLT" "Graphical (MrEd)")) (kill-tests)
|
|
|
|
(run-test-in-language-level #t)
|
|
(run-test-in-language-level #f)
|
|
))
|