From 961e280a98d6b565c0510c1aa023f151084ee753 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 10 Nov 2011 16:13:49 -0600 Subject: [PATCH] add a bunch of tests to the module language test suite based on test cases in the repl test suite (since the repl test suite tests the pretty big language's repl and since there was a test case there that would have discovered a bug that we only found in the hours before the release but had been lurking for a few days) --- collects/tests/drracket/module-lang-test.rkt | 111 +++++++++++++- .../{ => private}/module-lang-test-utils.rkt | 140 ++++++++++-------- 2 files changed, 183 insertions(+), 68 deletions(-) rename collects/tests/drracket/{ => private}/module-lang-test-utils.rkt (64%) diff --git a/collects/tests/drracket/module-lang-test.rkt b/collects/tests/drracket/module-lang-test.rkt index b113bb0c38..4d0b224849 100644 --- a/collects/tests/drracket/module-lang-test.rkt +++ b/collects/tests/drracket/module-lang-test.rkt @@ -1,5 +1,5 @@ #lang at-exp racket/gui -(require "module-lang-test-utils.rkt") +(require "private/module-lang-test-utils.rkt") (provide run-test) ;; set up for tests that need external files @@ -164,8 +164,7 @@ (test @t{#lang racket} @t{(begin-for-syntax (+ 1 2))} - @t{> (begin-for-syntax (+ 1 2))} - #t) + @t{}) (test @t{#lang racket} @t{(begin (struct s (x)) (struct t s (y)) (s-x (t 1 2)))} @@ -255,6 +254,112 @@ " (f)") #t) +(test @t{#lang racket/base} + @t{(begin (values) 1)} + "1") + +(test @t{#lang racket/base} + @t{ (eval '(values 1 2))} + @t{1@"\n"2}) +(test @t{#lang racket/base} + @t{ (eval '(list 1 2))} + @t{'(1 2)}) +(test @t{#lang racket/base} + @t{ (eval '(lambda ()))} + @t{lambda: bad syntax in: (lambda ())}) +(test @t{#lang racket/base} + @t{(expt 3 (void))} + @rx{expt: expected argument of type ; given #}) +(test @t{#lang racket/base} + @t{1 2 ( 3 4} + @t{1@"\n"2@"\n". read: expected a `)' to close `('}) +(test @t{#lang racket/base} + "1 2 . 3 4" + "1\n2\n. read: illegal use of \".\"") +(test @t{#lang racket/base} + "1 2 (lambda ()) 3 4" + "1\n2\n. lambda: bad syntax in: (lambda ())") +(test @t{#lang racket/base} + "1 2 x 3 4" + "1\n2\n. . reference to an identifier before its definition: x") +(test @t{#lang racket/base} + "1 2 (raise 1) 3 4" + "1\n2\nuncaught exception: 1") +(test @t{#lang racket/base} + "1 2 (raise #f) 3 4" + "1\n2\nuncaught exception: #f") +(test @t{#lang racket/base} + "(current-namespace (make-empty-namespace)) if" + ". compile: unbound identifier (and no #%app syntax transformer is bound) in: #%top-interaction") +(test @t{#lang racket/base} + (string-append + "(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))))\n" + "10))") + ". . expt: expected argument of type ; given #f\n15") +(test @t{#lang racket/base} + "(write (list (syntax x)))" + "(.)") +(test @t{#lang racket/base} + "(parameterize ([current-output-port (open-output-string)]) (write #'1))" + "") +(test @t{#lang racket/base} + "(write-special 1)" + "1#t") +(test @t{#lang racket/gui} + (format "~s ~s ~s" + '(define s (make-semaphore 0)) + '(queue-callback + (lambda () + (dynamic-wind + void + (lambda () (expt 3 #f)) + (lambda () (semaphore-post s))))) + '(begin (yield s) (void))) + ". . expt: expected argument of type ; given #f") +(test @t{#lang racket/base} + (format "~s ~s" + '(define x 1) + '((λ (x y) y) (set! x (call/cc (lambda (x) x))) (x 3))) + ". . procedure application: expected procedure, given: 3; arguments were: 3") +(test @t{#lang racket/base} + (format "~s ~s ~s ~s" + '(begin (define k (call/cc (λ (x) x))) + (define x 'wrong)) + '(set! x 'right) + '(k 1) + 'x) + "'right") +(test @t{#lang racket/base} + (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)") +(test @t{#lang racket/gui} + "(vector (new snip%))" + "(vector .)") +(test @t{#lang racket/base} + "(begin (thread (lambda () x)) (sleep 1/10))" + ". . reference to an identifier before its definition: x") +(test @t{#lang racket/base} + "(require texpict/utils)(disk 3)" + ".") +(test @t{#lang racket/base} + (string-append + "(require mzlib/pretty)" + "(pretty-print-print-hook (lambda x (expt 3 #f)))" + "(list 1 2 3)") + "'(1 2 3)") + ;; test protection against user-code changing the namespace (test @t{#lang racket/base (current-namespace (make-base-namespace))} diff --git a/collects/tests/drracket/module-lang-test-utils.rkt b/collects/tests/drracket/private/module-lang-test-utils.rkt similarity index 64% rename from collects/tests/drracket/module-lang-test-utils.rkt rename to collects/tests/drracket/private/module-lang-test-utils.rkt index 284899f0d9..17bc6e44d6 100644 --- a/collects/tests/drracket/module-lang-test-utils.rkt +++ b/collects/tests/drracket/private/module-lang-test-utils.rkt @@ -1,5 +1,8 @@ -#lang scheme/gui -(require "private/drracket-test-util.rkt" mzlib/etc framework scheme/string) +#lang racket/gui +(require "drracket-test-util.rkt" + mzlib/etc + framework + racket/string) (provide test t rx run-test in-here write-test-modules) @@ -65,73 +68,80 @@ (clear-definitions drs) (insert-in-definitions drs (test-definitions test)) (do-execute drs) - - (let ([ints (test-interactions test)]) - - (when ints - (let ([after-execute-output - (queue-callback/res - (λ () - (send interactions-text - get-text - (send interactions-text paragraph-start-position 2) - (send interactions-text paragraph-end-position 2))))]) - (unless (or (test-all? test) (string=? "> " after-execute-output)) - (fprintf (current-error-port) - "FAILED (line ~a): ~a\n ~a\n expected no output after execution, got: ~s\n" - (test-line test) - (test-definitions test) - (or (test-interactions test) 'no-interactions) - after-execute-output) - (k (void))) - (type-in-interactions drs ints) - (test:keystroke #\return) - (wait-for-computation drs))) - - (let* ([text - (queue-callback/res - (λ () - (if (test-all? test) - (let* ([para (- (send interactions-text position-paragraph - (send interactions-text last-position)) - 1)]) - (send interactions-text - get-text - (send interactions-text paragraph-start-position 2) - (send interactions-text paragraph-end-position para))) - (let* ([para (- (send interactions-text position-paragraph - (send interactions-text last-position)) - 1)]) - (send interactions-text - get-text - (send interactions-text paragraph-start-position para) - (send interactions-text paragraph-end-position para))))))] - [output-passed? (let ([r (test-result test)]) - ((cond [(string? r) string=?] - [(regexp? r) regexp-match?] - [else 'module-lang-test "bad test value: ~e" r]) - r text))]) - (unless output-passed? + + (define ints (test-interactions test)) + + (define output-start-paragraph 2) + + (when ints + (let ([after-execute-output + (queue-callback/res + (λ () + (send interactions-text + get-text + (send interactions-text paragraph-start-position 2) + (send interactions-text paragraph-end-position 2))))]) + (unless (or (test-all? test) (string=? "> " after-execute-output)) (fprintf (current-error-port) - "FAILED (line ~a): ~a\n ~a\n expected: ~s\n got: ~s\n" + "FAILED (line ~a): ~a\n ~a\n expected no output after execution, got: ~s\n" (test-line test) (test-definitions test) (or (test-interactions test) 'no-interactions) - (test-result test) - text)) - (cond - [(eq? (test-error-ranges test) 'dont-test) - (void)] - [else - (let ([error-ranges-expected - ((test-error-ranges test) definitions-text interactions-text)]) - (unless (equal? error-ranges-expected (send interactions-text get-error-ranges)) - (fprintf (current-error-port) - "FAILED (line ~a; ranges): ~a\n expected: ~s\n got: ~s\n" - (test-line test) - (test-definitions test) - error-ranges-expected - (send interactions-text get-error-ranges))))]))))) + after-execute-output) + (k (void))) + (type-in-interactions drs ints) + ;; set to be the paragraph right after the insertion. + (set! output-start-paragraph + (queue-callback/res + (λ () (+ (send interactions-text position-paragraph + (send interactions-text last-position)) + 1)))) + (test:keystroke #\return '(alt)) + (wait-for-computation drs))) + + (define text + (queue-callback/res + (λ () + (define para-before-prompt + (- (send interactions-text position-paragraph + (send interactions-text last-position)) + 1)) + (if (test-all? test) + (send interactions-text + get-text + (send interactions-text paragraph-start-position 2) + (send interactions-text paragraph-end-position para-before-prompt)) + (send interactions-text + get-text + (send interactions-text paragraph-start-position output-start-paragraph) + (send interactions-text paragraph-end-position para-before-prompt)))))) + (define output-passed? + (let ([r (test-result test)]) + ((cond [(string? r) string=?] + [(regexp? r) regexp-match?] + [else 'module-lang-test "bad test value: ~e" r]) + r text))) + (unless output-passed? + (fprintf (current-error-port) + "FAILED (line ~a): ~a\n ~a\n expected: ~s\n got: ~s\n" + (test-line test) + (test-definitions test) + (or (test-interactions test) 'no-interactions) + (test-result test) + text)) + (cond + [(eq? (test-error-ranges test) 'dont-test) + (void)] + [else + (let ([error-ranges-expected + ((test-error-ranges test) definitions-text interactions-text)]) + (unless (equal? error-ranges-expected (send interactions-text get-error-ranges)) + (fprintf (current-error-port) + "FAILED (line ~a; ranges): ~a\n expected: ~s\n got: ~s\n" + (test-line test) + (test-definitions test) + error-ranges-expected + (send interactions-text get-error-ranges))))]))) (define drs 'not-yet-drs-frame) (define interactions-text 'not-yet-interactions-text)