From bfa6b1d953ea95dfe20a093ccc3385ba47ea1356 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 6 Nov 2011 08:17:10 -0600 Subject: [PATCH] Fixed some bugs in the double-stacktrace window; adjusted the repl to be able to insert more with-stack-checkpoint calls in useful places; adjust test suites to match the change in when the stacktrace icon shows up --- collects/drracket/private/debug.rkt | 39 +- collects/drracket/private/rep.rkt | 112 +- .../drracket/private/stack-checkpoint.rkt | 39 + collects/tests/drracket/language-test.rkt | 2922 ++++++++--------- collects/tests/drracket/module-lang-test.rkt | 4 +- collects/tests/drracket/repl-test.rkt | 55 +- 6 files changed, 1578 insertions(+), 1593 deletions(-) create mode 100644 collects/drracket/private/stack-checkpoint.rkt diff --git a/collects/drracket/private/debug.rkt b/collects/drracket/private/debug.rkt index 38e641d096..a79079a7a6 100644 --- a/collects/drracket/private/debug.rkt +++ b/collects/drracket/private/debug.rkt @@ -21,6 +21,7 @@ profile todo: "embedded-snip-utils.rkt" "drsig.rkt" "bindings-browser.rkt" + "stack-checkpoint.rkt" net/sendurl net/url racket/match @@ -282,7 +283,7 @@ profile todo: (send rep get-definitions-text)))]) (let* ([stack1 (or pre-stack '())] [stack2 (if (exn? exn) - (map cdr (filter cdr (continuation-mark-set->context (exn-continuation-marks exn)))) + (map cdr (filter cdr (cut-stack-at-checkpoint exn))) '())] [src-locs (cond [(exn:srclocs? exn) @@ -638,9 +639,9 @@ profile todo: (define (show-backtrace-window/edition-pairs/two error-text dis1 editions1 dis2 editions2 defs ints) (reset-backtrace-window) (when (mf-bday?) - (instantiate message% () - (label (string-constant happy-birthday-matthias)) - (parent (send current-backtrace-window get-area-container)))) + (new message% + [label (string-constant happy-birthday-matthias)] + [parent (send current-backtrace-window get-area-container)])) (define tab-panel (if (and (pair? dis1) (pair? dis2)) (new tab-panel% @@ -652,24 +653,22 @@ profile todo: (λ (l) (if (zero? (send tab-panel get-selection)) (list ec1) (list ec2)))))]) - (new panel% [parent (send current-backtrace-window get-area-container)]))) - (define text1 (and (pair? dis1) (new (text:wide-snip-mixin text:hide-caret/selection%)))) - (define ec1 (and (pair? dis1) - (new (canvas:color-mixin canvas:wide-snip%) - [parent tab-panel] - [editor text1]))) - (define text2 (and (pair? dis2) (new (text:wide-snip-mixin text:hide-caret/selection%)))) - (define ec2 (and (pair? dis2) - (new (canvas:color-mixin canvas:wide-snip%) - [parent tab-panel] - [editor text2]))) - (when (pair? dis1) - (add-one-set-to-frame text1 ec1 error-text dis1 editions1 defs ints)) - (when (pair? dis2) - (add-one-set-to-frame text2 ec2 error-text dis2 editions2 defs ints)) + (new vertical-panel% [parent (send current-backtrace-window get-area-container)]))) + (define ec1 (add-ec/text dis1 editions1 defs ints tab-panel error-text)) + (define ec2 (add-ec/text dis2 editions2 defs ints tab-panel error-text)) (when (and (pair? dis1) (pair? dis2)) (send tab-panel change-children (λ (l) (list ec1))))) - + + (define (add-ec/text dis1 editions1 defs ints tab-panel error-text) + (cond + [(pair? dis1) + (define text1 (new (text:wide-snip-mixin text:hide-caret/selection%))) + (define ec1 (new (canvas:color-mixin canvas:wide-snip%) + [parent tab-panel] + [editor text1])) + (add-one-set-to-frame text1 ec1 error-text dis1 editions1 defs ints) + ec1] + [else #f])) (define (add-one-set-to-frame text ec error-text dis editions defs ints) (letrec ([di-vec (list->vector dis)] diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index 413ab7753d..831a4061c0 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -29,6 +29,7 @@ TODO browser/external "drsig.rkt" "local-member-names.rkt" + "stack-checkpoint.rkt" ;; the dynamic-require below loads this module, ;; so we make the dependency explicit here, even @@ -40,42 +41,6 @@ TODO (define orig-output-port (current-output-port)) (define (oprintf . args) (apply fprintf orig-output-port args)) - -;; run a thunk, and if an exception is raised, make it possible to cut the -;; stack so that the surrounding context is hidden -(define checkpoints (make-weak-hasheq)) -(define (call-with-stack-checkpoint thunk) - (define checkpoint #f) - (call-with-exception-handler - (λ (exn) - (when (and checkpoint ; just in case there's an exception before it's set - (not (hash-has-key? checkpoints exn))) - (hash-set! checkpoints exn checkpoint)) - exn) - (lambda () - (set! checkpoint (current-continuation-marks)) - (thunk)))) -;; returns the stack of the input exception, cutting off any tail that was -;; registered as a checkpoint -(define (cut-stack-at-checkpoint exn) - (define stack (continuation-mark-set->context (exn-continuation-marks exn))) - (define checkpoint - (cond [(hash-ref checkpoints exn #f) => continuation-mark-set->context] - [else #f])) - (if (not checkpoint) - stack - (let loop ([st stack] - [sl (length stack)] - [cp checkpoint] - [cl (length checkpoint)]) - (cond [(sl . > . cl) (cons (car st) (loop (cdr st) (sub1 sl) cp cl))] - [(sl . < . cl) (loop st sl (cdr cp) (sub1 cl))] - [(equal? st cp) '()] - [else (loop st sl (cdr cp) (sub1 cl))])))) - -(define-syntax-rule (with-stack-checkpoint expr) - (call-with-stack-checkpoint (lambda () expr))) - (define no-breaks-break-parameterization (parameterize-break #f (current-break-parameterization))) @@ -164,37 +129,7 @@ TODO ;; the highlight must be set after the error message, because inserting into the text resets ;; the highlighting. (define (drracket-error-display-handler msg exn) - (let* ([cut-stack (if (and (exn? exn) - (main-user-eventspace-thread?)) - (cut-stack-at-checkpoint exn) - '())] - [srclocs-stack (filter values (map cdr cut-stack))] - [stack - (filter - values - (map (λ (srcloc) - (let ([source (srcloc-source srcloc)] - [pos (srcloc-position srcloc)] - [span (srcloc-span srcloc)]) - (and source pos span - srcloc))) - srclocs-stack))] - [src-locs (if (exn:srclocs? exn) - ((exn:srclocs-accessor exn) exn) - (if (null? stack) - '() - (list (car srclocs-stack))))]) - - ;; for use in debugging the stack trace stuff - #; - (when (exn? exn) - (parameterize ([print-struct #t]) - (for-each - (λ (frame) (printf " ~s\n" frame)) - (continuation-mark-set->context (exn-continuation-marks exn))) - (printf "\n"))) - - (drracket:debug:error-display-handler/stacktrace msg exn stack))) + (drracket:debug:error-display-handler/stacktrace msg exn)) (define (main-user-eventspace-thread?) (let ([rep (current-rep)]) @@ -1114,17 +1049,38 @@ TODO (let loop () (let ([sexp/syntax/eof (with-stack-checkpoint (get-sexp/syntax/eof))]) (unless (eof-object? sexp/syntax/eof) - (call-with-values - (λ () - (call-with-continuation-prompt - (λ () (with-stack-checkpoint (eval-syntax sexp/syntax/eof))) - (default-continuation-prompt-tag) - (and complete-program? - (λ args - (abort-current-continuation - (default-continuation-prompt-tag)))))) - (λ x (parameterize ([pretty-print-columns pretty-print-width]) - (for-each (λ (x) ((current-print) x)) x)))) + (define results + ;; we duplicate the 'expand-syntax-to-top-form' dance that eval-syntax + ;; does here, so that we can put 'with-stack-checkpoint's in to limit + ;; the amount of DrRacket code we see in stacktraces + (let loop ([stx sexp/syntax/eof]) + (define top-expanded (with-stack-checkpoint (expand-syntax-to-top-form stx))) + (syntax-case top-expanded (begin) + [(begin a1 . args) + (let lloop ([args (syntax->list #'(a1 . args))]) + (cond + [(null? (cdr args)) + (loop (car args))] + [else + (loop (car args)) + (lloop (cdr args))]))] + [_ + (let ([expanded (with-stack-checkpoint (expand-syntax top-expanded))]) + (call-with-values + (λ () + (call-with-continuation-prompt + (λ () + (with-stack-checkpoint (eval-syntax expanded))) + (default-continuation-prompt-tag) + (λ args + (apply + abort-current-continuation + (default-continuation-prompt-tag) + args)))) + list))]))) + (parameterize ([pretty-print-columns pretty-print-width]) + (for ([x (in-list results)]) + ((current-print) x))) (loop))))))) (default-continuation-prompt-tag) (λ args (void))) diff --git a/collects/drracket/private/stack-checkpoint.rkt b/collects/drracket/private/stack-checkpoint.rkt new file mode 100644 index 0000000000..28e7afb4a6 --- /dev/null +++ b/collects/drracket/private/stack-checkpoint.rkt @@ -0,0 +1,39 @@ +#lang racket/base +(provide cut-stack-at-checkpoint with-stack-checkpoint) + +;; run a thunk, and if an exception is raised, make it possible to cut the +;; stack so that the surrounding context is hidden +(define checkpoints (make-weak-hasheq)) +(define (call-with-stack-checkpoint thunk) + (define checkpoint #f) + (call-with-exception-handler + (λ (exn) + (when (and checkpoint ; just in case there's an exception before it's set + (not (hash-has-key? checkpoints exn))) + (hash-set! checkpoints exn checkpoint)) + exn) + (lambda () + (set! checkpoint (current-continuation-marks)) + (thunk)))) +;; returns the stack of the input exception, cutting off any tail that was +;; registered as a checkpoint +(define (cut-stack-at-checkpoint exn) + (define stack (continuation-mark-set->context (exn-continuation-marks exn))) + (define checkpoint + (cond [(hash-ref checkpoints exn #f) => continuation-mark-set->context] + [else #f])) + (if (not checkpoint) + stack + (let loop ([st stack] + [sl (length stack)] + [cp checkpoint] + [cl (length checkpoint)]) + (cond [(sl . > . cl) (cons (car st) (loop (cdr st) (sub1 sl) cp cl))] + [(sl . < . cl) (loop st sl (cdr cp) (sub1 cl))] + [(equal? st cp) '()] + [else (loop st sl (cdr cp) (sub1 cl))])))) + + +(define-syntax-rule (with-stack-checkpoint expr) + (call-with-stack-checkpoint (lambda () expr))) + diff --git a/collects/tests/drracket/language-test.rkt b/collects/tests/drracket/language-test.rkt index 8bf26b1bf7..c9253919ec 100644 --- a/collects/tests/drracket/language-test.rkt +++ b/collects/tests/drracket/language-test.rkt @@ -1,1462 +1,1460 @@ -#lang scheme - -#| - -Make sure there are tests that cover these parameters: - - (read-case-sensitive #f) - (read-square-bracket-as-paren #f) -- test: (symbol? '[]) - (read-curly-brace-as-paren #f) - (print-vector-length #f) - -the settings above should match r5rs - -|# - - -(require "private/drracket-test-util.rkt" - tests/utils/gui - mred - framework - (prefix-in fw: framework)) - -(define language (make-parameter "<>")) -(define defs-prefix (make-parameter "")) - -;; set-language : boolean -> void -(define (set-language close-dialog?) - (if (eq? (car (language)) 'module) - (set-module-language! close-dialog?) - (set-language-level! (language) close-dialog?))) - - -; -; -; -; -; ;; ;; -; ;; ;; -; ;;;;; ;; ;;; ;;;;; ;; ;; ;; ;;;; -; ;;;;;;;;; ;;;;; ;;;;; ;; ;; ;; ;; ;;; -; ;; ;; ;; ;;; ;;;;; ;; ;; ;; ;; ;;;;;;; -; ;; ;; ;; ;;; ;;;;; ;; ;; ;; ;; ;;; -; ;; ;; ;; ;;;;; ;;;;; ;;;;; ;; ;; ;; -; ;; ;; ;; ;;; ;;;;; ;;;;; ;; ;;;; -; -; -; -; - -(define (module-lang) - (parameterize ([language '(module "racket")] - [defs-prefix "#lang racket\n"]) - - (check-top-of-repl) - - (prepare-for-test-expression) - - (test-expression "'|.|" "'|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "#t") - (test-expression "(define x 1)(define x 2)" #rx"duplicate definition for identifier in: x" "") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "#" - "define-values: cannot re-define a constant: struct:spider\n#") - - (test-expression "(sqrt -1)" "0+1i") - - (test-expression "class" (regexp "class: bad syntax in: class")) - (test-expression "shared" (regexp "shared: bad syntax in: shared")) - - (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"" "") - (test-expression "'(1 . 2)" "'(1 . 2)") - - (test-expression "(define (f define) 1)" "" "define-values: cannot re-define a constant: f") - (test-expression "(define (f car) 1)" "" "define-values: cannot re-define a constant: f") - (test-expression "(define (f empty) 1)" "" "define-values: cannot re-define a constant: f") - - (test-expression "call/cc" "#") - - (test-expression "(error 'a \"~a\" 1)" "{stop-multi.png} {stop-22x22.png} a: 1") - (test-expression "(error \"a\" \"a\")" "{stop-multi.png} {stop-22x22.png} a \"a\"") - - (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") - - (test-expression "true" "#t") - (test-expression "mred^" - #rx"unbound identifier in module in: mred\\^" - #rx"reference to undefined identifier: mred\\^") - (test-expression "(eq? 'a 'A)" "#f") - (test-expression "(set! x 1)" - #rx"set!: unbound identifier in module in: x" - #rx"set!: cannot set undefined variable: x") - (test-expression "(define qqq 2) (set! qqq 1)" "") - (test-expression "(cond [(= 1 2) 3])" "") - (test-expression "(cons 1 2)" "'(1 . 2)") - (test-expression "(+ (list 1) 2)" (regexp (regexp-quote "+: expects type as 1st argument, given: '(1); other arguments were: 2"))) - (test-expression "'(1)" "'(1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "'(#&1 #&1)" - "define-values: cannot re-define a constant: shrd\n'(#&1 #&1)") - (test-expression "(local ((define x x)) 1)" "1") - (test-expression "(letrec ([x x]) 1)" "1") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") - (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") - (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") - (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") - (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") - (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") - (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") - (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+1/2i") - (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") - (test-expression "(exact? 1.5)" "#f") - (test-expression "(print (floor (sqrt 2)))" "1.0") - - (test-expression "(let ([f (lambda (x) x)]) f)" "#") - (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") - - (test-expression "(list 1)" "'(1)") - (test-expression "(car (list))" "{stop-multi.png} {stop-22x22.png} car: expects argument of type ; given '()") - - (test-expression "(current-command-line-arguments)" "'#()") - (test-expression "(define-syntax app syntax-case)" "{stop-22x22.png} syntax-case: bad syntax in: syntax-case") - - (test-expression "#lang racket" #rx"module: illegal use \\(not at top-level\\)" #rx"read: #lang not enabled in the current context") - (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" - "a: b"))) - - -; -; -; -; ; ; ;;;; ;; -; ;; ;; ;;;; ;; -; ;;;;;;; ;;; ;;; ;;; ;;;;; ;;;;; ;;; ;;; ;;;;;;; ;;;;;;; -; ;;;;;;;; ;;;;;;; ;;;;; ;;;;;; ;;;;;; ;;; ;;;; ;;;;;;;; ;;;; ;;;;;;;; -; ;;;;;;;;; ;;;; ;; ;;;; ;; ;;;; ;;;; ;;;;;; ;;;;;;;;; ;;;; ;;; ;;;; -; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;;; -; ;;;;;;;;; ;;;; ;;;;; ;;;;; ;;;;; ;;;;; ;;;;;;;;; ;;;; ;;;;;;; -; ;;;;;;;; ;;;; ;;;;;; ;;;;; ;;;;; ;;;; ;;;;;;;; ;;;; ; ;;;; -; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;;;;;; -; ;;;; ;;;; ;;;;;;;; -; ;;;; ;;;; ;;;;;; -; - -(define (pretty-big) - (parameterize ([language (list #rx"Pretty Big")]) - - (check-top-of-repl) - - (generic-settings #f) - (generic-output #t #t #t #t) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" "|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "#t") - (test-expression "(define x 1)(define x 2)" "") - - (test-expression "(define-struct spider (legs))(make-spider 4)" "#") - - (test-expression "(sqrt -1)" "0+1i") - - (test-expression "class" (regexp "class: bad syntax in: class")) - (test-expression "shared" (regexp "shared: bad syntax in: shared")) - - (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"") - (test-expression "'(1 . 2)" "(1 . 2)") - - (test-expression "(define (f define) 1)" "") - (test-expression "(define (f car) 1)" "") - (test-expression "(define (f empty) 1)" "") - - (test-expression "call/cc" "#") - - (test-expression "(error 'a \"~a\" 1)" "{stop-multi.png} {stop-22x22.png} a: 1") - (test-expression "(error \"a\" \"a\")" "{stop-multi.png} {stop-22x22.png} a \"a\"") - - (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") - - (test-expression "true" "#t") - (test-expression "mred^" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: mred^") - (test-expression "(eq? 'a 'A)" "#f") - (test-expression "(set! x 1)" "{stop-multi.png} {stop-22x22.png} set!: cannot set undefined variable: x") - (test-expression "(define qqq 2) (set! qqq 1)" "") - (test-expression "(cond [(= 1 2) 3])" "") - (test-expression "(cons 1 2)" "(1 . 2)") - (test-expression "(+ (list 1) 2)" "{stop-multi.png} {stop-22x22.png} +: expects type as 1st argument, given: (1); other arguments were: 2") - (test-expression "'(1)" "(1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "(#&1 #&1)") - (test-expression "(local ((define x x)) 1)" "1") - (test-expression "(letrec ([x x]) 1)" "1") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") - (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") - (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") - (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") - (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") - (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") - (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") - (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+1/2i") - (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") - (test-expression "(exact? 1.5)" "#f") - (test-expression "(print (floor (sqrt 2)))" "1.0") - - (test-expression "(let ([f (lambda (x) x)]) f)" "#") - (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") - - (test-expression "(list 1)" "(1)") - (test-expression "(car (list))" "{stop-multi.png} {stop-22x22.png} car: expects argument of type ; given ()") - - (test-expression "(current-command-line-arguments)" "#()") - (test-expression "(define-syntax app syntax-case)" "{stop-22x22.png} syntax-case: bad syntax in: syntax-case") - - (test-expression "#lang racket" - "" - #rx"read: #lang not enabled in the current context") - (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" - "a: b"))) - -; -; -; ;;;;;;; ;;;;;;; ;;;;;; -; ;; ;; ;; ;; ;; ;; -; ;; ;; ;;;;; ;; ;; ;; ; -; ;; ;; ;;;;; ;; ;; ;;;; -; ;;;;;; ; ;;;;;; ;;;;; -; ;; ;; ;;;; ;; ;; ;;; -; ;; ;; ;; ;; ;; ; ;; -; ;; ;; ;; ;; ;; ;; ;; -; ;;;; ;;; ;; ;; ;;;; ;;;;;;;;; -; ;; ;; -; ;;;; -; - - -(define (r5rs) - (parameterize ([language (list (regexp "R5RS"))]) - - (check-top-of-repl) - - (generic-settings #f) - (generic-output #t #t #t #t) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" "|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "#t") - (test-expression "(define x 1)(define x 2)" "") - - (test-expression - "(define-struct spider (legs))(make-spider 4)" - "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: define-struct" - "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: define-struct\n{stop-multi.png} {stop-22x22.png} reference to undefined identifier: make-spider") - - (test-expression "(sqrt -1)" "0+1i") - - (test-expression "class" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: class") - (test-expression "shared" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: shared") - - (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"") - (test-expression "'(1 . 2)" "(1 . 2)") - - (test-expression "(define (f define) 1)" "") - (test-expression "(define (f car) 1)" "") - (test-expression "(define (f empty) 1)" "") - - (test-expression "call/cc" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: call/cc") - - (test-expression "(error 'a \"~a\" 1)" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: error") - (test-expression "(error \"a\" \"a\")" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: error") - - (test-expression "(time 1)" - "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: time") - - (test-expression "true" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: true") - (test-expression "mred^" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: mred^") - (test-expression "(eq? 'a 'A)" "#t") - (test-expression "(set! x 1)" "{stop-multi.png} {stop-22x22.png} set!: cannot set undefined variable: x") - (test-expression "(define qqq 2) (set! qqq 1)" "") - (test-expression "(cond ((= 1 2) 3))" "") - (test-expression "(cons 1 2)" "(1 . 2)") - (test-expression "(+ (list 1) 2)" "{stop-multi.png} {stop-22x22.png} +: expects type as 1st argument, given: (1); other arguments were: 2") - (test-expression "'(1)" "(1)") - (test-expression "(define shrd (cons 1 1)) (list shrd shrd)" - "((1 . 1) (1 . 1))") - (test-expression - "(local ((define x x)) 1)" - #rx"define: not allowed in an expression context") - (test-expression "(letrec ((x x)) 1)" "1") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") - (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") - (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") - (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") - (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") - (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") - (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") - (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") - (test-expression "+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+1/2i") - (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") - (test-expression "(exact? 1.5)" "#f") - (test-expression "(print (floor (sqrt 2)))" #rx"reference to undefined identifier: print") - - (test-expression "(let ((f (lambda (x) x))) f)" "#") - (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") - - (test-expression "(list 1)" "(1)") - (test-expression "(car (list))" - "{stop-multi.png} {stop-22x22.png} mcar: expects argument of type ; given ()") - - (test-expression "argv" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: argv") - (test-expression "(define-syntax app syntax-case)" - "{stop-22x22.png} macro-transformer: only a `syntax-rules' form is allowed in: syntax-case") - - (test-expression "#lang racket" - (regexp (regexp-quote "#%module-begin: illegal use (not a module body) in: (#%module-begin)")) - #rx"read: #lang not enabled in the current context") - (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" - #rx"reference to undefined identifier"))) - - -; -; ;;; ;; -; ;; ;; -; ;; -; ;;;;; ;;;; ;;;;;;;;; ;;; ;; ;;; ;; ;;;; ;;; ;; -; ;; ;; ;; ;; ;; ;; ;; ;;; ;; ;;; ;; ;; ;; ;;;;; -; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; -; ;; ;; ;;;;;; ;;;; ;; ;; ;; ;; ;; ;;;;;; ;; -; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; -; ;; ;; ;; ; ;;;;; ;; ;; ;; ;; ;; ;; ; ;; -; ;;;;; ;;;; ;;;;;;;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;;; -; ;; ;; -; ;; ;; -; ;;;;; - -(define (beginner) - (parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")]) - (check-top-of-repl) - (generic-settings #t) - (generic-output #f #f #f #f) - (teaching-language-fraction-output) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" - "'|.|" - "'|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "true" - "true") - - (test-expression "(define x 1)(define x 2)" - "x: this name was defined previously and cannot be re-defined" - "x: this name was defined previously and cannot be re-defined") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "(make-spider 4)" - "spider: this name was defined previously and cannot be re-defined\n(make-spider 4)") - - (test-expression "(sqrt -1)" - "0+1i" - "0+1i\n") - - (test-undefined-var "class") - (test-undefined-var "shared") - (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") - (test-expression "'(1 . 2)" "read: illegal use of \".\"") - - (test-undefined-var "call/cc") - - (test-expression "(error 'a \"~a\" 1)" "a: ~a1") - (test-expression "(error \"a\" \"a\")" "aa") - - (test-undefined-fn "(time 1)" "time")) - - (test-expression "true" - "true" - "true") - (test-undefined-var "mred^") - (test-expression "(eq? 'a 'A)" - "false" - "false") - (test-undefined-fn "(set! x 1)" "set!") - (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!") - - (test-expression "(cond [(= 1 2) 3])" - "cond: all question results were false") - (test-expression "(cons 1 2)" - "cons: second argument must be a list, but received 1 and 2") - (test-expression "(+ (list 1) 2)" - "+: expects a number as 1st argument, given (cons 1 empty)") - (test-expression "'(1)" - "quote: expected the name of the symbol after the quote, but found a part") - (test-expression "(define shrd (list 1)) (list shrd shrd)" - "(cons (cons 1 empty) (cons (cons 1 empty) empty))" - "shrd: this name was defined previously and cannot be re-defined\n(cons (cons 1 empty) (cons (cons 1 empty) empty))") - (test-expression "(local ((define x x)) 1)" - "local: this function is not defined" - "function call: expected a function after the open parenthesis, but found a part") - (test-expression "(letrec ([x x]) 1)" - "letrec: this function is not defined" - "function call: expected a function after the open parenthesis, but found a part") - (test-expression "(if 1 1 1)" "if: question result is not true or false: 1") - (test-expression "(+ 1)" "+: expects at least 2 arguments, but found only 1") - - (test-expression "1.0" "1" "1") - (test-expression "#i1.0" "#i1.0" "#i1.0") - (test-expression "4/3" - "{number 4/3 \"1.3\" decimal}" - "{number 4/3 \"1.3\" decimal}") - (test-expression "1/3" - "{number 1/3 \"0.3\" decimal}" - "{number 1/3 \"0.3\" decimal}") - (test-expression "-4/3" - "{number -4/3 \"-1.3\" decimal}" - "{number -4/3 \"-1.3\" decimal}") - (test-expression "-1/3" - "{number -1/3 \"-0.3\" decimal}" - "{number -1/3 \"-0.3\" decimal}") - (test-expression "3/2" - "{number 3/2 \"1.5\" decimal}" - "{number 3/2 \"1.5\" decimal}") - (test-expression "1/2" - "{number 1/2 \"0.5\" decimal}" - "{number 1/2 \"0.5\" decimal}") - (test-expression "-1/2" - "{number -1/2 \"-0.5\" decimal}" - "{number -1/2 \"-0.5\" decimal}") - (test-expression "-3/2" - "{number -3/2 \"-1.5\" decimal}" - "{number -3/2 \"-1.5\" decimal}") - (test-expression "+1/3i" - "0+1/3i" - "0+1/3i") - (test-expression "+1/2i" - "0+0.5i" - "0+0.5i") - (test-expression "779625/32258" - "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" - "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") - (test-expression "(exact? 1.5)" "true") - (test-undefined-fn "(print (floor (sqrt 2)))" "print") - - (test-expression "(let ([f (lambda (x) x)]) f)" - "let: this function is not defined" - "function call: expected a function after the open parenthesis, but found a part") - (test-expression ",1" - "read: illegal use of comma") - - (test-expression "(list 1)" - "(cons 1 empty)" - "(cons 1 empty)") - (test-expression "(car (list))" - "car: expects a pair; given empty") - - (test-undefined-var "argv") - (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") - - (test-expression "#lang racket" - "module: this function is not defined" - "read: #lang not enabled in the current context") - (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" - "define: expected at least one variable after the function name, but found none" - #rx"define: function definitions are not allowed in the interactions window")) - - -; -; ;;; ;;; ;;; -; ;; ; ;; ;; -; ;; ; ;; ;; -; ;;;;; ;;;; ;;;;;; ; ;;;; ;;;;; ;;;;; ;;; ;; ;;;; ;;; ;;; -; ;; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;;;;; ;; ;; ;; ; -; ;; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ;; ;; ; -; ;; ;; ;;;;;; ;;;; ; ;;;;; ;; ;; ;; ;; ;; ;;;;;; ;;; -; ;; ;; ;; ; ; ;; ;; ;; ;; ;; ;; ;; ;; ;;; -; ;; ;; ;; ; ;;;;; ; ;; ;; ;; ;; ;; ;; ;; ;; ; ;;; -; ;;;;; ;;;; ;;;;;; ; ;;;;;; ;;;;; ;;;;; ;;;; ;;;; ; -; ;; ;;; -; ;; ;;; -; ;;;;; - - -(define (beginner/abbrev) - (parameterize ([language (list "How to Design Programs" - #rx"Beginning Student with List Abbreviations(;|$)")]) - (check-top-of-repl) - - (generic-settings #t) - (generic-output #t #f #f #f) - (teaching-language-fraction-output) - - (test-hash-bang) - - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" - "'|.|" - "'|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "true" - "true") - - (test-expression "(define x 1)(define x 2)" - "x: this name was defined previously and cannot be re-defined" - "x: this name was defined previously and cannot be re-defined") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "(make-spider 4)" - "spider: this name was defined previously and cannot be re-defined\n(make-spider 4)") - - (test-expression "(sqrt -1)" - "0+1i" - "0+1i") - - (test-undefined-var "class") - (test-undefined-var "shared") - - (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") - (test-expression "'(1 . 2)" "read: illegal use of \".\"") - - (test-undefined-var "call/cc") - - (test-expression "(error 'a \"~a\" 1)" "a: ~a1") - (test-expression "(error \"a\" \"a\")" "aa") - - (test-undefined-fn "(time 1)" "time") - - (test-expression "true" - "true" - "true") - (test-undefined-var "mred^") - (test-expression "(eq? 'a 'A)" - "false" - "false") - (test-undefined-fn "(set! x 1)" "set!") - (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!") - (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") - (test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2") - (test-expression "(+ (list 1) 2)" "+: expects a number as 1st argument, given (list 1)") - (test-expression "'(1)" - "(list 1)" - "(list 1)") - (test-expression "(define shrd (list 1)) (list shrd shrd)" - "(list (list 1) (list 1))" - "shrd: this name was defined previously and cannot be re-defined\n(list (list 1) (list 1))") - (test-expression "(local ((define x x)) 1)" - "local: this function is not defined" - "function call: expected a function after the open parenthesis, but found a part") - (test-expression "(letrec ([x x]) 1)" - "letrec: this function is not defined" - "function call: expected a function after the open parenthesis, but found a part") - (test-expression "(if 1 1 1)" "if: question result is not true or false: 1") - (test-expression "(+ 1)" "+: expects at least 2 arguments, but found only 1") - - (test-expression "1.0" "1" "1") - (test-expression "#i1.0" "#i1.0" "#i1.0") - (test-expression "4/3" - "{number 4/3 \"1.3\" decimal}" - "{number 4/3 \"1.3\" decimal}") - (test-expression "1/3" - "{number 1/3 \"0.3\" decimal}" - "{number 1/3 \"0.3\" decimal}") - (test-expression "-4/3" - "{number -4/3 \"-1.3\" decimal}" - "{number -4/3 \"-1.3\" decimal}") - (test-expression "-1/3" - "{number -1/3 \"-0.3\" decimal}" - "{number -1/3 \"-0.3\" decimal}") - (test-expression "3/2" - "{number 3/2 \"1.5\" decimal}" - "{number 3/2 \"1.5\" decimal}") - (test-expression "1/2" - "{number 1/2 \"0.5\" decimal}" - "{number 1/2 \"0.5\" decimal}") - (test-expression "-1/2" - "{number -1/2 \"-0.5\" decimal}" - "{number -1/2 \"-0.5\" decimal}") - (test-expression "-3/2" - "{number -3/2 \"-1.5\" decimal}" - "{number -3/2 \"-1.5\" decimal}") - (test-expression "+1/3i" - "0+1/3i" - "0+1/3i") - (test-expression "+1/2i" - "0+0.5i" - "0+0.5i") - (test-expression "779625/32258" - "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" - "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") - (test-expression "(exact? 1.5)" "true") - (test-undefined-fn "(print (floor (sqrt 2)))" "print") - - (test-expression "(let ([f (lambda (x) x)]) f)" - "let: this function is not defined" - "function call: expected a function after the open parenthesis, but found a part") - (test-expression ",1" - "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") - - (test-expression "(list 1)" - "(list 1)" - "(list 1)") - (test-expression "(car (list))" "car: expects a pair; given empty") - - (test-undefined-var "argv") - - (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") - - (test-expression "#lang racket" - "module: this function is not defined" - "read: #lang not enabled in the current context") - (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" - "define: expected at least one variable after the function name, but found none" - #rx"define: function definitions are not allowed in the interactions window"))) - - -; -; ;; ;;; ;; -; ;; ;; ;; ;; ;; -; ;; ;; ;; -; ;;; ;;; ;; ;;;;; ;;;; ;;; ;; ;;; ;; ;; ;;;; ;;;;; ;;; ;;;; ;;;;; ;;;; -; ;; ;;; ;; ;; ;; ;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; -; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; -; ;; ;; ;; ;; ;;;;;; ;; ;; ;; ;; ;;;;;; ;; ;; ;; ;;;;; ;; ;;;;;; -; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; -; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ; -; ;;;; ;;;; ;;; ;;; ;;;; ;;;; ;;;; ;;; ;;; ;;;; ;;;;;; ;;;; ;;;;;; ;;; ;;;; -; -; -; - - -(define (intermediate) - (parameterize ([language (list "How to Design Programs" #rx"Intermediate Student(;|$)")]) - (check-top-of-repl) - - (generic-settings #t) - (generic-output #t #f #f #f) - (teaching-language-fraction-output) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" - "'|.|" - "'|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "true" - "true") - - (test-expression "(define x 1)(define x 2)" - "x: this name was defined previously and cannot be re-defined" - "x: this name was defined previously and cannot be re-defined") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "(make-spider 4)" - "spider: this name was defined previously and cannot be re-defined\n(make-spider 4)") - - (test-expression "(sqrt -1)" - "0+1i" - "0+1i") - - (test-undefined-var "class") - (test-undefined-var "shared") - - (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") - (test-expression "'(1 . 2)" "read: illegal use of \".\"") - - (test-undefined-var "call/cc") - - (test-expression "(error 'a \"~a\" 1)" "a: ~a1") - (test-expression "(error \"a\" \"a\")" "aa") - - (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") - - (test-expression "true" - "true" - "true") - (test-undefined-var "mred^") - (test-expression "(eq? 'a 'A)" - "false" - "false") - (test-undefined-fn "(set! x 1)" "set!") - (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!") - (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") - (test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2") - (test-expression "(+ (list 1) 2)" "+: expects a number as 1st argument, given (list 1)") - (test-expression "'(1)" - "(list 1)" - "(list 1)") - (test-expression "(define shrd (list 1)) (list shrd shrd)" - "(list (list 1) (list 1))" - "shrd: this name was defined previously and cannot be re-defined\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") - (test-expression "(+ 1)" "1") - - (test-expression "1.0" "1" "1") - (test-expression "#i1.0" "#i1.0" "#i1.0") - (test-expression "4/3" - "{number 4/3 \"1.3\" decimal}" - "{number 4/3 \"1.3\" decimal}") - (test-expression "1/3" - "{number 1/3 \"0.3\" decimal}" - "{number 1/3 \"0.3\" decimal}") - (test-expression "-4/3" - "{number -4/3 \"-1.3\" decimal}" - "{number -4/3 \"-1.3\" decimal}") - (test-expression "-1/3" - "{number -1/3 \"-0.3\" decimal}" - "{number -1/3 \"-0.3\" decimal}") - (test-expression "3/2" - "{number 3/2 \"1.5\" decimal}" - "{number 3/2 \"1.5\" decimal}") - (test-expression "1/2" - "{number 1/2 \"0.5\" decimal}" - "{number 1/2 \"0.5\" decimal}") - (test-expression "-1/2" - "{number -1/2 \"-0.5\" decimal}" - "{number -1/2 \"-0.5\" decimal}") - (test-expression "-3/2" - "{number -3/2 \"-1.5\" decimal}" - "{number -3/2 \"-1.5\" decimal}") - (test-expression "+1/3i" - "0+1/3i" - "0+1/3i") - (test-expression "+1/2i" - "0+0.5i" - "0+0.5i") - (test-expression "779625/32258" - "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" - "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") - (test-expression "(exact? 1.5)" "true") - (test-undefined-fn "(print (floor (sqrt 2)))" "print") - - (test-expression "(let ([f (lambda (x) x)]) f)" - "function:f" - "function:f") - (test-expression ",1" - "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") - - (test-expression "(list 1)" - "(list 1)" - "(list 1)") - (test-expression "(car (list))" "car: expects a pair; given empty") - (test-undefined-var "argv") - - (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") - - (test-expression "#lang racket" - "module: this function is not defined" - "read: #lang not enabled in the current context") - (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" - "define: expected at least one variable after the function name, but found none" - #rx"define: expected at least one variable after the function name, but found none"))) - - - -; -; -; -; ;; ; ;;;;;; ;;;; ;;;; -; ;; ;; ;;;;;; ;;;; ;;;; -; ;;;; ;;; ;;;;; ;;;;;; ;;;;;;; ;;;;;;; ;;;; ;;;;;;; ;;;;;;; ;;;;;;; -; ;;;; ;;;;;;;;; ;;;;;; ;;;;;; ;;;;;;;; ;;;;;;;;;;;;; ;;;;;;;; ;;;;;;;; ;;;;;;;; -; ;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;;;; -; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; -; ;;;; ;;;; ;;;; ;;;;; ;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;; ;;;; -; ;;;; ;;;; ;;;; ;;;;; ;; ;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;;;; ;;;;;;;; ;;;;;;;; -; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;;;;; ;;;;;;; ;; ;;;; -; ;; -; -; - - -(define (intermediate/lambda) - (parameterize ([language (list "How to Design Programs" - #rx"Intermediate Student with lambda(;|$)")]) - (check-top-of-repl) - - (generic-settings #t) - (generic-output #t #f #f #f) - (teaching-language-fraction-output) - - (test-hash-bang) - (test-error-after-definition) - - (prepare-for-test-expression) - - (test-expression "'|.|" - "'|.|" - "'|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "true" - "true") - (test-expression "(define x 1)(define x 2)" - "x: this name was defined previously and cannot be re-defined" - "x: this name was defined previously and cannot be re-defined") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "(make-spider 4)" - "spider: this name was defined previously and cannot be re-defined\n(make-spider 4)") - - (test-expression "(sqrt -1)" - "0+1i" - "0+1i") - - (test-undefined-var "class") - (test-undefined-var "shared") - - (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") - (test-expression "'(1 . 2)" "read: illegal use of \".\"") - - (test-undefined-var "call/cc") - - (test-expression "(error 'a \"~a\" 1)" "a: ~a1") - (test-expression "(error \"a\" \"a\")" "aa") - - (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") - - (test-expression "true" - "true" - "true") - (test-undefined-var "mred^") - (test-expression "(eq? 'a 'A)" - "false" - "false") - (test-undefined-fn "(set! x 1)" "set!") - (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!") - (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") - (test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2") - (test-expression "(+ (list 1) 2)" "+: expects a number as 1st argument, given (list 1)") - (test-expression "'(1)" - "(list 1)" - "(list 1)") - (test-expression "(define shrd (list 1)) (list shrd shrd)" - "(list (list 1) (list 1))" - "shrd: this name was defined previously and cannot be re-defined\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") - (test-expression "(+ 1)" "1") - - (test-expression "1.0" "1" "1") - (test-expression "#i1.0" "#i1.0" "#i1.0") - (test-expression "4/3" - "{number 4/3 \"1.3\" decimal}" - "{number 4/3 \"1.3\" decimal}") - (test-expression "1/3" - "{number 1/3 \"0.3\" decimal}" - "{number 1/3 \"0.3\" decimal}") - (test-expression "-4/3" - "{number -4/3 \"-1.3\" decimal}" - "{number -4/3 \"-1.3\" decimal}") - (test-expression "-1/3" - "{number -1/3 \"-0.3\" decimal}" - "{number -1/3 \"-0.3\" decimal}") - (test-expression "3/2" - "{number 3/2 \"1.5\" decimal}" - "{number 3/2 \"1.5\" decimal}") - (test-expression "1/2" - "{number 1/2 \"0.5\" decimal}" - "{number 1/2 \"0.5\" decimal}") - (test-expression "-1/2" - "{number -1/2 \"-0.5\" decimal}" - "{number -1/2 \"-0.5\" decimal}") - (test-expression "-3/2" - "{number -3/2 \"-1.5\" decimal}" - "{number -3/2 \"-1.5\" decimal}") - (test-expression "+1/3i" "0+1/3i" "0+1/3i") - (test-expression "+1/2i" "0+0.5i" "0+0.5i") - (test-expression "779625/32258" - "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" - "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") - (test-expression "(exact? 1.5)" "true") - (test-undefined-fn "(print (floor (sqrt 2)))" "print") - - (test-expression "(let ([f (lambda (x) x)]) f)" - "(lambda (a1) ...)" - "(lambda (a1) ...)") - (test-expression ",1" - "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") - - (test-expression "(list 1)" - "(list 1)" - "(list 1)") - (test-expression "(car (list))" "car: expects a pair; given empty") - (test-undefined-var "argv") - - (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") - - (test-expression "#lang racket" - "module: this function is not defined" - "read: #lang not enabled in the current context") - (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" - "define: expected at least one variable after the function name, but found none" - #rx"define: expected at least one variable after the function name, but found none"))) - - - -; -; -; -; ;;;; ;;;; -; ;;;; ;;;; -; ;;;;;;; ;;;;;;; ;;; ;;; ;;;;;;; ;;;; ;;; ;;;;; ;;; ;;;;;;; -; ;;;;;;;; ;;;;;;;; ;;; ;;; ;;;;;;;; ;;;;;;;;; ;;;;;; ;;;;; ;;;;;;;; -; ;;;; ;;;;;;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;; ;;;;;;;;; -; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; -; ;; ;;;; ;;;;;;;;; ;;;;;; ;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;; ;;;;;;;;; -; ;;;;;;;; ;;;;;;;; ;;;; ;;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;; ;;;;;;;; -; ;; ;;;; ;;;;;;; ;;;; ;; ;;;; ;;;; ;;;; ;;;;; ;;;; ;;;;;;; -; -; -; - - -(define (advanced) - (parameterize ([language (list "How to Design Programs" #rx"Advanced Student(;|$)")]) -; (check-top-of-repl) - -; (generic-settings #t) -; (generic-output #t #t #t #f) -; (teaching-language-fraction-output) - -; (test-hash-bang) -; (test-error-after-definition) - - (prepare-for-test-expression) - #| - (test-expression "'|.|" - "'|.|" - "'|.|") - (test-expression '("(equal? (list " image ") (list " image "))") - "true" - "true") - (test-expression "(define x 1)(define x 2)" - "x: this name was defined previously and cannot be re-defined" - "x: this name was defined previously and cannot be re-defined") - - (test-expression "(define-struct spider (legs))(make-spider 4)" - "(make-spider 4)" - "spider: this name was defined previously and cannot be re-defined\n(make-spider 4)") - - (test-expression "(sqrt -1)" - "0+1i" - "0+1i") - |# - (test-undefined-var "class") - - (test-expression "shared" "shared: expected an open parenthesis before shared, but found none") - - (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") - (test-expression "'(1 . 2)" "read: illegal use of \".\"") - - (test-undefined-var "call/cc") - - (test-expression "(error 'a \"~a\" 1)" "a: ~a1") - (test-expression "(error \"a\" \"a\")" "aa") - - (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") - - (test-expression "true" - "true" - "true") - (test-undefined-var "mred^") - (test-expression "(eq? 'a 'A)" - "false" - "false") - (test-expression "(set! x 1)" - "x: this variable is not defined" - "set!: cannot set variable before its definition: x") - (test-expression "(define qqq 2) (set! qqq 1)" - "(void)" - "qqq: this name was defined previously and cannot be re-defined\n(void)") - (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") - (test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2") - (test-expression "(+ (list 1) 2)" "+: expects a number as 1st argument, given (list 1)") - (test-expression "'(1)" - "(list 1)" - "(list 1)") - (test-expression "(define shrd (list 1)) (list shrd shrd)" - "(shared ((-1- (list 1))) (list -1- -1-))" - "shrd: this name was defined previously and cannot be re-defined\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") - (test-expression "(+ 1)" "1") - - (test-expression "1.0" "1" "1") - (test-expression "#i1.0" "#i1.0" "#i1.0") - (test-expression "4/3" - "{number 4/3 \"1.3\" decimal}" - "{number 4/3 \"1.3\" decimal}") - (test-expression "1/3" - "{number 1/3 \"0.3\" decimal}" - "{number 1/3 \"0.3\" decimal}") - (test-expression "-4/3" - "{number -4/3 \"-1.3\" decimal}" - "{number -4/3 \"-1.3\" decimal}") - (test-expression "-1/3" - "{number -1/3 \"-0.3\" decimal}" - "{number -1/3 \"-0.3\" decimal}") - (test-expression "3/2" - "{number 3/2 \"1.5\" decimal}" - "{number 3/2 \"1.5\" decimal}") - (test-expression "1/2" - "{number 1/2 \"0.5\" decimal}" - "{number 1/2 \"0.5\" decimal}") - (test-expression "-1/2" - "{number -1/2 \"-0.5\" decimal}" - "{number -1/2 \"-0.5\" decimal}") - (test-expression "-3/2" - "{number -3/2 \"-1.5\" decimal}" - "{number -3/2 \"-1.5\" decimal}") - (test-expression "+1/3i" - "0+1/3i" - "0+1/3i") - (test-expression "+1/2i" - "0+0.5i" - "0+0.5i") - (test-expression "779625/32258" - "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" - "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") - (test-expression "(exact? 1.5)" "true") - (test-expression "(print (floor (sqrt 2)))" "#i1.0") - - (test-expression "(let ([f (lambda (x) x)]) f)" - "(lambda (a1) ...)" - "(lambda (a1) ...)") - (test-expression ",1" - "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") - - (test-expression "(list 1)" - "(list 1)" - "(list 1)") - (test-expression "(car (list))" "car: expects a pair; given empty") - (test-undefined-var "argv") - - (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") - - (test-expression "#lang racket" - "module: this function is not defined" - "read: #lang not enabled in the current context") - (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" - #rx"raise-user-error" - #rx"raise-user-error"))) - - - - -(define (prepare-for-test-expression) - (let ([drs (wait-for-drscheme-frame)]) - (clear-definitions drs) - (set-language #t) - (sleep 1) ;; this shouldn't be neccessary.... - (do-execute drs))) - -;; test-setting : (-> void) string string string -> void -;; opens the language dialog, runs `set-setting' -;; closes the language dialog, executes, -;; makes sure that `expression' produces -;; `result'. `set-setting' is expected to click around -;; in the language dialog. -;; `setting-name' is used in the error message when the test fails. -(define (test-setting set-setting setting-name expression result) - (set-language #f) - (set-setting) - (let ([f (test:get-active-top-level-window)]) - (fw:test:button-push "OK") - (wait-for-new-frame f)) - (let* ([drs (test:get-active-top-level-window)] - [interactions (send drs get-interactions-text)]) - (clear-definitions drs) - (type-in-definitions drs expression) - (do-execute drs) - (let* ([got (fetch-output/should-be-tested drs)]) - (unless (string=? result got) - (fprintf (current-error-port) - "FAILED: ~s ~s ~s test\n expected: ~s\n got: ~s\n" - (language) setting-name expression result got))))) - -(define (test-hash-bang) - (let* ([expression "#!/bin/sh\n1"] - [result "1"] - [drs (test:get-active-top-level-window)] - [interactions (queue-callback (λ () (send drs get-interactions-text)))]) - (clear-definitions drs) - (type-in-definitions drs expression) - (do-execute drs) - (let* ([got (fetch-output/should-be-tested drs)]) - (unless (string=? "1" got) - (fprintf (current-error-port) - "FAILED: ~s ~a test\n expected: ~s\n got: ~s\n" - (language) expression result got))))) - -(define (fetch-output/should-be-tested . args) - (regexp-replace (regexp - (string-append - (regexp-quote "") - "$")) - (apply fetch-output args) - "")) - -(define (check-top-of-repl) - (let ([drs (wait-for-drscheme-frame)]) - (set-language #t) - (with-handlers ([exn:fail? void]) - (fw:test:menu-select "Testing" "Disable tests")) - (do-execute drs) - (let* ([interactions (send drs get-interactions-text)] - [short-lang (last (language))] - [get-line (lambda (n) - (queue-callback/res - (λ () - (send interactions get-text - (send interactions paragraph-start-position n) - (send interactions paragraph-end-position n)))))] - [line0-expect (format "Welcome to DrRacket, version ~a [~a]." - (version:version) - (system-type 'gc))] - [line1-expect - (if (string? short-lang) - (format "Language: ~a" short-lang) - short-lang)] - [line0-got (get-line 0)] - [line1-got (get-line 1)]) - (unless (and (string=? line0-expect line0-got) - (if (string? short-lang) - (string=? line1-expect (substring line1-got - 0 - (min (string-length line1-expect) - (string-length line1-got)))) - (regexp-match line1-expect line1-got))) - (fprintf (current-error-port) - "expected lines: \n ~a\n ~a\ngot lines:\n ~a\n ~a\n" - line0-expect line1-expect - line0-got line1-got) - (error 'language-test.rkt "failed get top of repl test"))))) - - -;; teaching-language-fraction-output -;; tests that the teaching languages properly handle repeating decimals -(define (teaching-language-fraction-output) - (test-setting - (lambda () (fw:test:set-radio-box! "Fraction Style" "Mixed fractions")) - "Fraction Style -- Mixed fractions" - "4/3" - "{number 4/3 \"1 1/3\" mixed}") - (test-setting - (lambda () (fw:test:set-radio-box! "Fraction Style" "Repeating decimals")) - "Fraction Style -- Repeating decimals" - "4/3" - "{number 4/3 \"1.3\" decimal}")) - -;; plt-language-fraction-output : -> void -;; tests that the PLT languages properly handle repeating decimals -(define (plt-language-fraction-output) - (test-setting - (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #f)) - "Use decimal notation for rationals -- #f" - "4/3 1/2 -1/3" - "{number 4/3 \"1 1/3\" mixed}\n{number 1/2 \"1/2\" mixed}\n{number -1/3 \"- 1/3\" mixed}") - (test-setting - (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #t)) - "Use decimal notation for rationals -- #t" - "4/3 1/2 -1/3" - "{number 4/3 \"#e1.3\" decimal}\n{number 1/2 \"#e0.5\" decimal}\n{number -1/3 \"#e-0.3\" decimal}")) - -(define (generic-settings false/true?) - (test-setting - (lambda () (fw:test:set-check-box! "Case sensitive" #t)) - "Case sensitive -- #t" - "(eq? 'g 'G)" - (if false/true? "false" "#f")) - (test-setting - (lambda () (fw:test:set-check-box! "Case sensitive" #f)) - "Case sensitive -- #f" - "(eq? 'g 'G)" - (if false/true? "true" "#t"))) - -(define (generic-output list? quasi-quote? has-sharing? has-print-printing?) - (let* ([plain-print-style (if has-print-printing? "print" "write")] - [drs (wait-for-drscheme-frame)] - [expression "(define x (list 2))\n(list x x)"] - [set-output-choice - (lambda (option show-sharing pretty?) - (set-language #f) - (fw:test:set-radio-box! "Output Style" option) - (when (and has-sharing? show-sharing) - (fw:test:set-check-box! - "Show sharing in values" - (if (eq? show-sharing 'on) #t #f))) - (fw:test:set-check-box! - "Insert newlines in printed values" - pretty?) - (let ([f (test:get-active-top-level-window)]) - (fw:test:button-push "OK") - (wait-for-new-frame f)))] - [shorten - (lambda (str) - (if ((string-length str) . <= . 45) - str - (string-append (substring str 0 45) "...")))] - [test - ;; answer must either be a string, or a procedure that accepts both zero and 1 - ;; argument. When the procedure accepts 1 arg, the argument is `got' and - ;; the result must be a boolean indicating if the result was satisfactory. - ;; if the procedure receives no arguments, it must return a descriptive string - ;; for the error message - (lambda (option show-sharing pretty? answer) - (set-output-choice option show-sharing pretty?) - (do-execute drs) - (let ([got (fetch-output/should-be-tested drs)]) - (unless (if (procedure? answer) - (answer got) - (whitespace-string=? answer got)) - (fprintf (current-error-port) - "FAILED ~s ~a, sharing ~a pretty? ~a\n got ~s\n expected ~s\n" - (language) option show-sharing pretty? - (shorten got) - (if (procedure? answer) (answer) answer)))))]) - - (clear-definitions drs) - (type-in-definitions drs expression) - - (test plain-print-style 'off #t "((2) (2))") - (when has-sharing? - (test plain-print-style 'on #t "(#0=(2) #0#)")) - (when quasi-quote? - (test "Quasiquote" 'off #t "`((2) (2))") - (when has-sharing? - (test "Quasiquote" 'on #t "(shared ((-1- `(2))) `(,-1- ,-1-))"))) - - (test "Constructor" 'off #t - (if list? - "(list (list 2) (list 2))" - "(cons (cons 2 empty) (cons (cons 2 empty) empty))")) - (when has-sharing? - (test "Constructor" 'on #t - (if list? - "(shared ((-1- (list 2))) (list -1- -1-))" - "(shared ((-1- (cons 2 empty))) (cons -1- (cons -1- empty)))"))) - - ;; setup print / pretty-print difference - (clear-definitions drs) - (for-each fw:test:keystroke - (string->list - "(define (f n)\n(cond ((zero? n) (list))\n(else (cons n (f (- n 1))))))\n(f 200)")) - (test "Constructor" #f #f - (case-lambda - [(x) (not (member #\newline (string->list x)))] - [() "no newlines in result"])) - (test "Constructor" #f #t - (case-lambda - [(x) (member #\newline (string->list x))] - [() "newlines in result (may need to make the window smaller)"])) - (test plain-print-style #f #f - (case-lambda - [(x) (not (member #\newline (string->list x)))] - [() "no newlines in result"])) - (test plain-print-style #f #t - (case-lambda - [(x) (member #\newline (string->list x))] - [() "newlines in result (may need to make the window smaller)"])))) - -(define re:out-of-sync - (regexp - "WARNING: Interactions window is out of sync with the definitions window\\.")) - -(define (test-error-after-definition) - (let* ([drs (wait-for-drscheme-frame)] - [interactions-text (queue-callback/res (λ () (send drs get-interactions-text)))]) - (clear-definitions drs) - (type-in-definitions drs "(define y 0) (define (f x) (/ x y)) (f 2)") - (do-execute drs) - (let ([last-para (queue-callback/res (λ () (send interactions-text last-paragraph)))]) - (type-in-interactions drs "y\n") - (wait-for-computation drs) - (let ([got - (fetch-output/should-be-tested - drs - (queue-callback/res (λ () (send interactions-text paragraph-start-position (+ last-para 1)))) - (queue-callback/res - (λ () - (send interactions-text paragraph-end-position - (- (send interactions-text last-paragraph) 1)))))]) - (unless (equal? got "0") - (fprintf (current-error-port) - "FAILED: test-error-after-definition failed, expected 0, got ~s\n" got)))))) - - -;; test-expression : (union string 'xml 'image (listof (union string 'xml 'image))) -;; (union string regexp (string -> boolean)) -;; -> void -;; types an expression in the definitions window, executes it and tests the output -;; types an expression in the REPL and tests the output from the REPL. -(define (test-expression expression defs-expected [repl-expected defs-expected]) - (printf "test-expression ~a~n" expression) - (let* ([drs (wait-for-drscheme-frame)] - [interactions-text (queue-callback/res (λ () (send drs get-interactions-text)))] - [definitions-text (queue-callback/res (λ () (send drs get-definitions-text)))] - [handle-insertion - (lambda (item) - (cond - [(eq? item 'image) - (use-get/put-dialog - (lambda () (fw:test:menu-select "Insert" "Insert Image...")) - (simplify-path (build-path (collection-path "icons") "recycle.png")))] - [(string? item) - (insert-in-definitions drs item)] - [(eq? item 'xml) - (fw:test:menu-select "Insert" "Insert XML Box") - (for-each fw:test:keystroke (string->list ""))] - [else (error 'handle-insertion "unknown thing to insert ~s" item)]))] - [check-expectation - (lambda (expected got) - (cond - [(string? expected) - (whitespace-string=? expected got)] - [(regexp? expected) - (regexp-match expected got)] - [(procedure? expected) - (expected got)]))] - [make-err-msg - (lambda (expected) - (cond - [(string? expected) - "FAILED: ~s ~s expected ~s to produce:\n ~s\ngot:\n ~s\ninstead\n"] - [(regexp? expected) - "FAILED: ~s ~s expected ~s to match ~s, got ~s instead\n"] - [(procedure? expected) - "FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s\n"]))]) - (clear-definitions drs) - (insert-in-definitions drs (defs-prefix)) - (cond - [(pair? expression) (for-each handle-insertion expression)] - [else (handle-insertion expression)]) - (do-execute drs) - - (let ([got - (fetch-output - drs - (queue-callback/res (λ () (send interactions-text paragraph-start-position 2))) - (queue-callback/res - (λ () - (send interactions-text paragraph-end-position - (- (send interactions-text last-paragraph) 1)))))]) - (when (regexp-match re:out-of-sync got) - (error 'text-expression "got out of sync message")) - (unless (check-expectation defs-expected got) - (fprintf (current-error-port) - (make-err-msg defs-expected) - 'definitions (language) expression defs-expected got))) - - (let ([dp (defs-prefix)]) - (queue-callback/res - (λ () - ;; select all except the defs-prefix - (send definitions-text set-position - (string-length dp) - (send definitions-text last-position)) - - (send definitions-text copy) - (send interactions-text set-position - (send interactions-text last-position) - (send interactions-text last-position)) - (send interactions-text paste)))) - - (let ([last-para (queue-callback/res (λ () (send interactions-text last-paragraph)))]) - (alt-return-in-interactions drs) - (wait-for-computation drs) - (let ([got - (fetch-output - drs - (queue-callback/res - (λ () - (send interactions-text paragraph-start-position (+ last-para 1)))) - (queue-callback/res - (λ () - (send interactions-text paragraph-end-position - (- (send interactions-text last-paragraph) 1)))))]) - (when (regexp-match re:out-of-sync got) - (error 'text-expression "got out of sync message")) - (unless (check-expectation repl-expected got) - (fprintf (current-error-port) - (make-err-msg repl-expected) - 'interactions - (language) - expression repl-expected got)))))) - -(define (test-undefined-var id) - (test-expression id (format "~a: this variable is not defined" id))) - -(define (test-undefined-fn exp id) - (test-expression exp (format "~a: this function is not defined" id))) - -(define-syntax (go stx) - (syntax-case stx () - [(_ arg) - (identifier? (syntax arg)) - (syntax (begin (flush-output) - (printf ">> starting ~a\n" 'arg) - (flush-output) - (arg) - (flush-output) - (printf ">> finished ~a\n" 'arg) - (flush-output)))])) - -(define (run-test) - (go module-lang) - (go pretty-big) - (go r5rs) - (go beginner) - (go beginner/abbrev) - (go intermediate) - (go intermediate/lambda) - (go advanced) - ) - -(fire-up-drscheme-and-run-tests run-test) +#lang scheme + +#| + +Make sure there are tests that cover these parameters: + + (read-case-sensitive #f) + (read-square-bracket-as-paren #f) -- test: (symbol? '[]) + (read-curly-brace-as-paren #f) + (print-vector-length #f) + +the settings above should match r5rs + +|# + + +(require "private/drracket-test-util.rkt" + tests/utils/gui + mred + framework + (prefix-in fw: framework)) + +(define language (make-parameter "<>")) +(define defs-prefix (make-parameter "")) + +;; set-language : boolean -> void +(define (set-language close-dialog?) + (if (eq? (car (language)) 'module) + (set-module-language! close-dialog?) + (set-language-level! (language) close-dialog?))) + + +; +; +; +; +; ;; ;; +; ;; ;; +; ;;;;; ;; ;;; ;;;;; ;; ;; ;; ;;;; +; ;;;;;;;;; ;;;;; ;;;;; ;; ;; ;; ;; ;;; +; ;; ;; ;; ;;; ;;;;; ;; ;; ;; ;; ;;;;;;; +; ;; ;; ;; ;;; ;;;;; ;; ;; ;; ;; ;;; +; ;; ;; ;; ;;;;; ;;;;; ;;;;; ;; ;; ;; +; ;; ;; ;; ;;; ;;;;; ;;;;; ;; ;;;; +; +; +; +; + +(define (module-lang) + (parameterize ([language '(module "racket")] + [defs-prefix "#lang racket\n"]) + + (check-top-of-repl) + + (prepare-for-test-expression) + + (test-expression "'|.|" "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#t") + (test-expression "(define x 1)(define x 2)" #rx"duplicate definition for identifier in: x" "") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "#" + "define-values: cannot re-define a constant: struct:spider") + + (test-expression "(sqrt -1)" "0+1i") + + (test-expression "class" (regexp "class: bad syntax in: class")) + (test-expression "shared" (regexp "shared: bad syntax in: shared")) + + (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"" "") + (test-expression "'(1 . 2)" "'(1 . 2)") + + (test-expression "(define (f define) 1)" "" "define-values: cannot re-define a constant: f") + (test-expression "(define (f car) 1)" "" "define-values: cannot re-define a constant: f") + (test-expression "(define (f empty) 1)" "" "define-values: cannot re-define a constant: f") + + (test-expression "call/cc" "#") + + (test-expression "(error 'a \"~a\" 1)" "{stop-multi.png} {stop-22x22.png} a: 1") + (test-expression "(error \"a\" \"a\")" "{stop-multi.png} {stop-22x22.png} a \"a\"") + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" "#t") + (test-expression "mred^" + #rx"unbound identifier in module in: mred\\^" + #rx"reference to undefined identifier: mred\\^") + (test-expression "(eq? 'a 'A)" "#f") + (test-expression "(set! x 1)" + #rx"set!: unbound identifier in module in: x" + #rx"set!: cannot set undefined variable: x") + (test-expression "(define qqq 2) (set! qqq 1)" "") + (test-expression "(cond [(= 1 2) 3])" "") + (test-expression "(cons 1 2)" "'(1 . 2)") + (test-expression "(+ (list 1) 2)" (regexp (regexp-quote "+: expects type as 1st argument, given: '(1); other arguments were: 2"))) + (test-expression "'(1)" "'(1)") + (test-expression "(define shrd (box 1)) (list shrd shrd)" + "'(#&1 #&1)" + "define-values: cannot re-define a constant: shrd") + (test-expression "(local ((define x x)) 1)" "1") + (test-expression "(letrec ([x x]) 1)" "1") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1.0") + (test-expression "#i1.0" "1.0") + (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") + (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") + (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") + (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") + (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") + (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") + (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") + (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") + (test-expression "+1/3i" "0+1/3i") + (test-expression "+1/2i" "0+1/2i") + (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") + (test-expression "(exact? 1.5)" "#f") + (test-expression "(print (floor (sqrt 2)))" "1.0") + + (test-expression "(let ([f (lambda (x) x)]) f)" "#") + (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") + + (test-expression "(list 1)" "'(1)") + (test-expression "(car (list))" "{stop-multi.png} {stop-22x22.png} car: expects argument of type ; given '()") + + (test-expression "(current-command-line-arguments)" "'#()") + (test-expression "(define-syntax app syntax-case)" "{stop-22x22.png} syntax-case: bad syntax in: syntax-case") + + (test-expression "#lang racket" #rx"module: illegal use \\(not at top-level\\)" #rx"read: #lang not enabled in the current context") + (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" + "a: b"))) + + +; +; +; +; ; ; ;;;; ;; +; ;; ;; ;;;; ;; +; ;;;;;;; ;;; ;;; ;;; ;;;;; ;;;;; ;;; ;;; ;;;;;;; ;;;;;;; +; ;;;;;;;; ;;;;;;; ;;;;; ;;;;;; ;;;;;; ;;; ;;;; ;;;;;;;; ;;;; ;;;;;;;; +; ;;;;;;;;; ;;;; ;; ;;;; ;; ;;;; ;;;; ;;;;;; ;;;;;;;;; ;;;; ;;; ;;;; +; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;;; +; ;;;;;;;;; ;;;; ;;;;; ;;;;; ;;;;; ;;;;; ;;;;;;;;; ;;;; ;;;;;;; +; ;;;;;;;; ;;;; ;;;;;; ;;;;; ;;;;; ;;;; ;;;;;;;; ;;;; ; ;;;; +; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;;;;;; +; ;;;; ;;;; ;;;;;;;; +; ;;;; ;;;; ;;;;;; +; + +(define (pretty-big) + (parameterize ([language (list #rx"Pretty Big")]) + + (check-top-of-repl) + + (generic-settings #f) + (generic-output #t #t #t #t) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" "|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#t") + (test-expression "(define x 1)(define x 2)" "") + + (test-expression "(define-struct spider (legs))(make-spider 4)" "#") + + (test-expression "(sqrt -1)" "0+1i") + + (test-expression "class" (regexp "class: bad syntax in: class")) + (test-expression "shared" (regexp "shared: bad syntax in: shared")) + + (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"") + (test-expression "'(1 . 2)" "(1 . 2)") + + (test-expression "(define (f define) 1)" "") + (test-expression "(define (f car) 1)" "") + (test-expression "(define (f empty) 1)" "") + + (test-expression "call/cc" "#") + + (test-expression "(error 'a \"~a\" 1)" "{stop-multi.png} {stop-22x22.png} a: 1") + (test-expression "(error \"a\" \"a\")" "{stop-multi.png} {stop-22x22.png} a \"a\"") + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" "#t") + (test-expression "mred^" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: mred^") + (test-expression "(eq? 'a 'A)" "#f") + (test-expression "(set! x 1)" "{stop-multi.png} {stop-22x22.png} set!: cannot set undefined variable: x") + (test-expression "(define qqq 2) (set! qqq 1)" "") + (test-expression "(cond [(= 1 2) 3])" "") + (test-expression "(cons 1 2)" "(1 . 2)") + (test-expression "(+ (list 1) 2)" "{stop-multi.png} {stop-22x22.png} +: expects type as 1st argument, given: (1); other arguments were: 2") + (test-expression "'(1)" "(1)") + (test-expression "(define shrd (box 1)) (list shrd shrd)" + "(#&1 #&1)") + (test-expression "(local ((define x x)) 1)" "1") + (test-expression "(letrec ([x x]) 1)" "1") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1.0") + (test-expression "#i1.0" "1.0") + (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") + (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") + (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") + (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") + (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") + (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") + (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") + (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") + (test-expression "+1/3i" "0+1/3i") + (test-expression "+1/2i" "0+1/2i") + (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") + (test-expression "(exact? 1.5)" "#f") + (test-expression "(print (floor (sqrt 2)))" "1.0") + + (test-expression "(let ([f (lambda (x) x)]) f)" "#") + (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") + + (test-expression "(list 1)" "(1)") + (test-expression "(car (list))" "{stop-multi.png} {stop-22x22.png} car: expects argument of type ; given ()") + + (test-expression "(current-command-line-arguments)" "#()") + (test-expression "(define-syntax app syntax-case)" "{stop-22x22.png} syntax-case: bad syntax in: syntax-case") + + (test-expression "#lang racket" + "" + #rx"read: #lang not enabled in the current context") + (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" + "a: b"))) + +; +; +; ;;;;;;; ;;;;;;; ;;;;;; +; ;; ;; ;; ;; ;; ;; +; ;; ;; ;;;;; ;; ;; ;; ; +; ;; ;; ;;;;; ;; ;; ;;;; +; ;;;;;; ; ;;;;;; ;;;;; +; ;; ;; ;;;; ;; ;; ;;; +; ;; ;; ;; ;; ;; ; ;; +; ;; ;; ;; ;; ;; ;; ;; +; ;;;; ;;; ;; ;; ;;;; ;;;;;;;;; +; ;; ;; +; ;;;; +; + + +(define (r5rs) + (parameterize ([language (list (regexp "R5RS"))]) + + (check-top-of-repl) + + (generic-settings #f) + (generic-output #t #t #t #t) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" "|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "#t") + (test-expression "(define x 1)(define x 2)" "") + + (test-expression + "(define-struct spider (legs))(make-spider 4)" + "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: define-struct") + + (test-expression "(sqrt -1)" "0+1i") + + (test-expression "class" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: class") + (test-expression "shared" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: shared") + + (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"") + (test-expression "'(1 . 2)" "(1 . 2)") + + (test-expression "(define (f define) 1)" "") + (test-expression "(define (f car) 1)" "") + (test-expression "(define (f empty) 1)" "") + + (test-expression "call/cc" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: call/cc") + + (test-expression "(error 'a \"~a\" 1)" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: error") + (test-expression "(error \"a\" \"a\")" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: error") + + (test-expression "(time 1)" + "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: time") + + (test-expression "true" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: true") + (test-expression "mred^" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: mred^") + (test-expression "(eq? 'a 'A)" "#t") + (test-expression "(set! x 1)" "{stop-multi.png} {stop-22x22.png} set!: cannot set undefined variable: x") + (test-expression "(define qqq 2) (set! qqq 1)" "") + (test-expression "(cond ((= 1 2) 3))" "") + (test-expression "(cons 1 2)" "(1 . 2)") + (test-expression "(+ (list 1) 2)" "{stop-multi.png} {stop-22x22.png} +: expects type as 1st argument, given: (1); other arguments were: 2") + (test-expression "'(1)" "(1)") + (test-expression "(define shrd (cons 1 1)) (list shrd shrd)" + "((1 . 1) (1 . 1))") + (test-expression + "(local ((define x x)) 1)" + #rx"define: not allowed in an expression context") + (test-expression "(letrec ((x x)) 1)" "1") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1.0") + (test-expression "#i1.0" "1.0") + (test-expression "4/3" "{number 4/3 \"1 1/3\" mixed}") + (test-expression "1/3" "{number 1/3 \"1/3\" mixed}") + (test-expression "-4/3" "{number -4/3 \"-1 1/3\" mixed}") + (test-expression "-1/3" "{number -1/3 \"-1/3\" mixed}") + (test-expression "3/2" "{number 3/2 \"1 1/2\" mixed}") + (test-expression "1/2" "{number 1/2 \"1/2\" mixed}") + (test-expression "-1/2" "{number -1/2 \"-1/2\" mixed}") + (test-expression "-3/2" "{number -3/2 \"-1 1/2\" mixed}") + (test-expression "+1/3i" "0+1/3i") + (test-expression "+1/2i" "0+1/2i") + (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") + (test-expression "(exact? 1.5)" "#f") + (test-expression "(print (floor (sqrt 2)))" #rx"reference to undefined identifier: print") + + (test-expression "(let ((f (lambda (x) x))) f)" "#") + (test-expression ",1" "{stop-22x22.png} unquote: not in quasiquote in: (unquote 1)") + + (test-expression "(list 1)" "(1)") + (test-expression "(car (list))" + "{stop-multi.png} {stop-22x22.png} mcar: expects argument of type ; given ()") + + (test-expression "argv" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: argv") + (test-expression "(define-syntax app syntax-case)" + "{stop-22x22.png} macro-transformer: only a `syntax-rules' form is allowed in: syntax-case") + + (test-expression "#lang racket" + (regexp (regexp-quote "#%module-begin: illegal use (not a module body) in: (#%module-begin)")) + #rx"read: #lang not enabled in the current context") + (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" + #rx"reference to undefined identifier"))) + + +; +; ;;; ;; +; ;; ;; +; ;; +; ;;;;; ;;;; ;;;;;;;;; ;;; ;; ;;; ;; ;;;; ;;; ;; +; ;; ;; ;; ;; ;; ;; ;; ;;; ;; ;;; ;; ;; ;; ;;;;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;;;;;; ;;;; ;; ;; ;; ;; ;; ;;;;;; ;; +; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ; ;;;;; ;; ;; ;; ;; ;; ;; ; ;; +; ;;;;; ;;;; ;;;;;;;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;;; +; ;; ;; +; ;; ;; +; ;;;;; + +(define (beginner) + (parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")]) + (check-top-of-repl) + (generic-settings #t) + (generic-output #f #f #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|" + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "true" + "true") + + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "x: this name was defined previously and cannot be re-defined") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)" + "spider: this name was defined previously and cannot be re-defined") + + (test-expression "(sqrt -1)" + "0+1i" + "0+1i\n") + + (test-undefined-var "class") + (test-undefined-var "shared") + (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") + (test-expression "'(1 . 2)" "read: illegal use of \".\"") + + (test-undefined-var "call/cc") + + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") + + (test-undefined-fn "(time 1)" "time")) + + (test-expression "true" + "true" + "true") + (test-undefined-var "mred^") + (test-expression "(eq? 'a 'A)" + "false" + "false") + (test-undefined-fn "(set! x 1)" "set!") + (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!") + + (test-expression "(cond [(= 1 2) 3])" + "cond: all question results were false") + (test-expression "(cons 1 2)" + "cons: second argument must be a list, but received 1 and 2") + (test-expression "(+ (list 1) 2)" + "+: expects a number as 1st argument, given (cons 1 empty)") + (test-expression "'(1)" + "quote: expected the name of the symbol after the quote, but found a part") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(cons (cons 1 empty) (cons (cons 1 empty) empty))" + "shrd: this name was defined previously and cannot be re-defined") + (test-expression "(local ((define x x)) 1)" + "local: this function is not defined" + "function call: expected a function after the open parenthesis, but found a part") + (test-expression "(letrec ([x x]) 1)" + "letrec: this function is not defined" + "function call: expected a function after the open parenthesis, but found a part") + (test-expression "(if 1 1 1)" "if: question result is not true or false: 1") + (test-expression "(+ 1)" "+: expects at least 2 arguments, but found only 1") + + (test-expression "1.0" "1" "1") + (test-expression "#i1.0" "#i1.0" "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}" + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}" + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}" + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}" + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}" + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}" + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}" + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}" + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i" + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i" + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" "true") + (test-undefined-fn "(print (floor (sqrt 2)))" "print") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "let: this function is not defined" + "function call: expected a function after the open parenthesis, but found a part") + (test-expression ",1" + "read: illegal use of comma") + + (test-expression "(list 1)" + "(cons 1 empty)" + "(cons 1 empty)") + (test-expression "(car (list))" + "car: expects a pair; given empty") + + (test-undefined-var "argv") + (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") + + (test-expression "#lang racket" + "module: this function is not defined" + "read: #lang not enabled in the current context") + (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" + "define: expected at least one variable after the function name, but found none" + #rx"define: function definitions are not allowed in the interactions window")) + + +; +; ;;; ;;; ;;; +; ;; ; ;; ;; +; ;; ; ;; ;; +; ;;;;; ;;;; ;;;;;; ; ;;;; ;;;;; ;;;;; ;;; ;; ;;;; ;;; ;;; +; ;; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;;;;; ;; ;; ;; ; +; ;; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ;; ;; ; +; ;; ;; ;;;;;; ;;;; ; ;;;;; ;; ;; ;; ;; ;; ;;;;;; ;;; +; ;; ;; ;; ; ; ;; ;; ;; ;; ;; ;; ;; ;; ;;; +; ;; ;; ;; ; ;;;;; ; ;; ;; ;; ;; ;; ;; ;; ;; ; ;;; +; ;;;;; ;;;; ;;;;;; ; ;;;;;; ;;;;; ;;;;; ;;;; ;;;; ; +; ;; ;;; +; ;; ;;; +; ;;;;; + + +(define (beginner/abbrev) + (parameterize ([language (list "How to Design Programs" + #rx"Beginning Student with List Abbreviations(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #t #f #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|" + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "true" + "true") + + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "x: this name was defined previously and cannot be re-defined") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)" + "spider: this name was defined previously and cannot be re-defined") + + (test-expression "(sqrt -1)" + "0+1i" + "0+1i") + + (test-undefined-var "class") + (test-undefined-var "shared") + + (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") + (test-expression "'(1 . 2)" "read: illegal use of \".\"") + + (test-undefined-var "call/cc") + + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") + + (test-undefined-fn "(time 1)" "time") + + (test-expression "true" + "true" + "true") + (test-undefined-var "mred^") + (test-expression "(eq? 'a 'A)" + "false" + "false") + (test-undefined-fn "(set! x 1)" "set!") + (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!") + (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") + (test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2") + (test-expression "(+ (list 1) 2)" "+: expects a number as 1st argument, given (list 1)") + (test-expression "'(1)" + "(list 1)" + "(list 1)") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(list (list 1) (list 1))" + "shrd: this name was defined previously and cannot be re-defined") + (test-expression "(local ((define x x)) 1)" + "local: this function is not defined" + "function call: expected a function after the open parenthesis, but found a part") + (test-expression "(letrec ([x x]) 1)" + "letrec: this function is not defined" + "function call: expected a function after the open parenthesis, but found a part") + (test-expression "(if 1 1 1)" "if: question result is not true or false: 1") + (test-expression "(+ 1)" "+: expects at least 2 arguments, but found only 1") + + (test-expression "1.0" "1" "1") + (test-expression "#i1.0" "#i1.0" "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}" + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}" + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}" + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}" + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}" + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}" + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}" + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}" + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i" + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i" + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" "true") + (test-undefined-fn "(print (floor (sqrt 2)))" "print") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "let: this function is not defined" + "function call: expected a function after the open parenthesis, but found a part") + (test-expression ",1" + "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") + + (test-expression "(list 1)" + "(list 1)" + "(list 1)") + (test-expression "(car (list))" "car: expects a pair; given empty") + + (test-undefined-var "argv") + + (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") + + (test-expression "#lang racket" + "module: this function is not defined" + "read: #lang not enabled in the current context") + (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" + "define: expected at least one variable after the function name, but found none" + #rx"define: function definitions are not allowed in the interactions window"))) + + +; +; ;; ;;; ;; +; ;; ;; ;; ;; ;; +; ;; ;; ;; +; ;;; ;;; ;; ;;;;; ;;;; ;;; ;; ;;; ;; ;; ;;;; ;;;;; ;;; ;;;; ;;;;; ;;;; +; ;; ;;; ;; ;; ;; ;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;;;;;; ;; ;; ;; ;; ;;;;;; ;; ;; ;; ;;;;; ;; ;;;;;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ; +; ;;;; ;;;; ;;; ;;; ;;;; ;;;; ;;;; ;;; ;;; ;;;; ;;;;;; ;;;; ;;;;;; ;;; ;;;; +; +; +; + + +(define (intermediate) + (parameterize ([language (list "How to Design Programs" #rx"Intermediate Student(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #t #f #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|" + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "true" + "true") + + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "x: this name was defined previously and cannot be re-defined") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)" + "spider: this name was defined previously and cannot be re-defined") + + (test-expression "(sqrt -1)" + "0+1i" + "0+1i") + + (test-undefined-var "class") + (test-undefined-var "shared") + + (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") + (test-expression "'(1 . 2)" "read: illegal use of \".\"") + + (test-undefined-var "call/cc") + + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" + "true" + "true") + (test-undefined-var "mred^") + (test-expression "(eq? 'a 'A)" + "false" + "false") + (test-undefined-fn "(set! x 1)" "set!") + (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!") + (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") + (test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2") + (test-expression "(+ (list 1) 2)" "+: expects a number as 1st argument, given (list 1)") + (test-expression "'(1)" + "(list 1)" + "(list 1)") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(list (list 1) (list 1))" + "shrd: this name was defined previously and cannot be re-defined") + (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") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1" "1") + (test-expression "#i1.0" "#i1.0" "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}" + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}" + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}" + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}" + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}" + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}" + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}" + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}" + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i" + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i" + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" "true") + (test-undefined-fn "(print (floor (sqrt 2)))" "print") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "function:f" + "function:f") + (test-expression ",1" + "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") + + (test-expression "(list 1)" + "(list 1)" + "(list 1)") + (test-expression "(car (list))" "car: expects a pair; given empty") + (test-undefined-var "argv") + + (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") + + (test-expression "#lang racket" + "module: this function is not defined" + "read: #lang not enabled in the current context") + (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" + "define: expected at least one variable after the function name, but found none" + #rx"define: expected at least one variable after the function name, but found none"))) + + + +; +; +; +; ;; ; ;;;;;; ;;;; ;;;; +; ;; ;; ;;;;;; ;;;; ;;;; +; ;;;; ;;; ;;;;; ;;;;;; ;;;;;;; ;;;;;;; ;;;; ;;;;;;; ;;;;;;; ;;;;;;; +; ;;;; ;;;;;;;;; ;;;;;; ;;;;;; ;;;;;;;; ;;;;;;;;;;;;; ;;;;;;;; ;;;;;;;; ;;;;;;;; +; ;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;;;; +; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; +; ;;;; ;;;; ;;;; ;;;;; ;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;; ;;;; +; ;;;; ;;;; ;;;; ;;;;; ;; ;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;;;; ;;;;;;;; ;;;;;;;; +; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;; ;;;; ;;;; ;;; ;;;; ;;;;;;; ;;;;;;; ;; ;;;; +; ;; +; +; + + +(define (intermediate/lambda) + (parameterize ([language (list "How to Design Programs" + #rx"Intermediate Student with lambda(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #t #f #f #f) + (teaching-language-fraction-output) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|" + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "true" + "true") + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "x: this name was defined previously and cannot be re-defined") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)" + "spider: this name was defined previously and cannot be re-defined") + + (test-expression "(sqrt -1)" + "0+1i" + "0+1i") + + (test-undefined-var "class") + (test-undefined-var "shared") + + (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") + (test-expression "'(1 . 2)" "read: illegal use of \".\"") + + (test-undefined-var "call/cc") + + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" + "true" + "true") + (test-undefined-var "mred^") + (test-expression "(eq? 'a 'A)" + "false" + "false") + (test-undefined-fn "(set! x 1)" "set!") + (test-undefined-fn "(define qqq 2) (set! qqq 1)" "set!") + (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") + (test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2") + (test-expression "(+ (list 1) 2)" "+: expects a number as 1st argument, given (list 1)") + (test-expression "'(1)" + "(list 1)" + "(list 1)") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(list (list 1) (list 1))" + "shrd: this name was defined previously and cannot be re-defined") + (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") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1" "1") + (test-expression "#i1.0" "#i1.0" "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}" + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}" + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}" + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}" + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}" + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}" + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}" + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}" + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" "0+1/3i" "0+1/3i") + (test-expression "+1/2i" "0+0.5i" "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" "true") + (test-undefined-fn "(print (floor (sqrt 2)))" "print") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "(lambda (a1) ...)" + "(lambda (a1) ...)") + (test-expression ",1" + "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") + + (test-expression "(list 1)" + "(list 1)" + "(list 1)") + (test-expression "(car (list))" "car: expects a pair; given empty") + (test-undefined-var "argv") + + (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") + + (test-expression "#lang racket" + "module: this function is not defined" + "read: #lang not enabled in the current context") + (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" + "define: expected at least one variable after the function name, but found none" + #rx"define: expected at least one variable after the function name, but found none"))) + + + +; +; +; +; ;;;; ;;;; +; ;;;; ;;;; +; ;;;;;;; ;;;;;;; ;;; ;;; ;;;;;;; ;;;; ;;; ;;;;; ;;; ;;;;;;; +; ;;;;;;;; ;;;;;;;; ;;; ;;; ;;;;;;;; ;;;;;;;;; ;;;;;; ;;;;; ;;;;;;;; +; ;;;; ;;;;;;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;; ;;;;;;;;; +; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; +; ;; ;;;; ;;;;;;;;; ;;;;;; ;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;; ;;;;;;;;; +; ;;;;;;;; ;;;;;;;; ;;;; ;;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;; ;;;;;;;; +; ;; ;;;; ;;;;;;; ;;;; ;; ;;;; ;;;; ;;;; ;;;;; ;;;; ;;;;;;; +; +; +; + + +(define (advanced) + (parameterize ([language (list "How to Design Programs" #rx"Advanced Student(;|$)")]) + (check-top-of-repl) + + (generic-settings #t) + (generic-output #t #t #t #f) + (teaching-language-fraction-output) + + (test-hash-bang) + (test-error-after-definition) + + (prepare-for-test-expression) + + (test-expression "'|.|" + "'|.|" + "'|.|") + (test-expression '("(equal? (list " image ") (list " image "))") + "true" + "true") + (test-expression "(define x 1)(define x 2)" + "x: this name was defined previously and cannot be re-defined" + "x: this name was defined previously and cannot be re-defined") + + (test-expression "(define-struct spider (legs))(make-spider 4)" + "(make-spider 4)" + "spider: this name was defined previously and cannot be re-defined") + + (test-expression "(sqrt -1)" + "0+1i" + "0+1i") + + (test-undefined-var "class") + + (test-expression "shared" "shared: expected an open parenthesis before shared, but found none") + + (test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") + (test-expression "'(1 . 2)" "read: illegal use of \".\"") + + (test-undefined-var "call/cc") + + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") + + (test-expression "(time 1)" + #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + + (test-expression "true" + "true" + "true") + (test-undefined-var "mred^") + (test-expression "(eq? 'a 'A)" + "false" + "false") + (test-expression "(set! x 1)" + "x: this variable is not defined" + "set!: cannot set variable before its definition: x") + (test-expression "(define qqq 2) (set! qqq 1)" + "(void)" + "qqq: this name was defined previously and cannot be re-defined") + (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") + (test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2") + (test-expression "(+ (list 1) 2)" "+: expects a number as 1st argument, given (list 1)") + (test-expression "'(1)" + "(list 1)" + "(list 1)") + (test-expression "(define shrd (list 1)) (list shrd shrd)" + "(shared ((-1- (list 1))) (list -1- -1-))" + "shrd: this name was defined previously and cannot be re-defined") + (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") + (test-expression "(+ 1)" "1") + + (test-expression "1.0" "1" "1") + (test-expression "#i1.0" "#i1.0" "#i1.0") + (test-expression "4/3" + "{number 4/3 \"1.3\" decimal}" + "{number 4/3 \"1.3\" decimal}") + (test-expression "1/3" + "{number 1/3 \"0.3\" decimal}" + "{number 1/3 \"0.3\" decimal}") + (test-expression "-4/3" + "{number -4/3 \"-1.3\" decimal}" + "{number -4/3 \"-1.3\" decimal}") + (test-expression "-1/3" + "{number -1/3 \"-0.3\" decimal}" + "{number -1/3 \"-0.3\" decimal}") + (test-expression "3/2" + "{number 3/2 \"1.5\" decimal}" + "{number 3/2 \"1.5\" decimal}") + (test-expression "1/2" + "{number 1/2 \"0.5\" decimal}" + "{number 1/2 \"0.5\" decimal}") + (test-expression "-1/2" + "{number -1/2 \"-0.5\" decimal}" + "{number -1/2 \"-0.5\" decimal}") + (test-expression "-3/2" + "{number -3/2 \"-1.5\" decimal}" + "{number -3/2 \"-1.5\" decimal}") + (test-expression "+1/3i" + "0+1/3i" + "0+1/3i") + (test-expression "+1/2i" + "0+0.5i" + "0+0.5i") + (test-expression "779625/32258" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}" + "{number 779625/32258 \"24.1684233368466736933473866...\" decimal}") + (test-expression "(exact? 1.5)" "true") + (test-expression "(print (floor (sqrt 2)))" "#i1.0") + + (test-expression "(let ([f (lambda (x) x)]) f)" + "(lambda (a1) ...)" + "(lambda (a1) ...)") + (test-expression ",1" + "unquote: misuse of a comma or unquote, not under a quasiquoting backquote") + + (test-expression "(list 1)" + "(list 1)" + "(list 1)") + (test-expression "(car (list))" "car: expects a pair; given empty") + (test-undefined-var "argv") + + (test-undefined-fn "(define-syntax app syntax-case)" "define-syntax") + + (test-expression "#lang racket" + "module: this function is not defined" + "read: #lang not enabled in the current context") + (test-expression "(define (f)\n(+ (raise-user-error 'a \"b\")))\n(if (zero? (random 1)) (void) (set! f void))\n(f)" + #rx"raise-user-error" + #rx"raise-user-error"))) + + + + +(define (prepare-for-test-expression) + (let ([drs (wait-for-drscheme-frame)]) + (clear-definitions drs) + (set-language #t) + (sleep 1) ;; this shouldn't be neccessary.... + (do-execute drs))) + +;; test-setting : (-> void) string string string -> void +;; opens the language dialog, runs `set-setting' +;; closes the language dialog, executes, +;; makes sure that `expression' produces +;; `result'. `set-setting' is expected to click around +;; in the language dialog. +;; `setting-name' is used in the error message when the test fails. +(define (test-setting set-setting setting-name expression result) + (set-language #f) + (set-setting) + (let ([f (test:get-active-top-level-window)]) + (fw:test:button-push "OK") + (wait-for-new-frame f)) + (let* ([drs (test:get-active-top-level-window)] + [interactions (send drs get-interactions-text)]) + (clear-definitions drs) + (type-in-definitions drs expression) + (do-execute drs) + (let* ([got (fetch-output/should-be-tested drs)]) + (unless (string=? result got) + (fprintf (current-error-port) + "FAILED: ~s ~s ~s test\n expected: ~s\n got: ~s\n" + (language) setting-name expression result got))))) + +(define (test-hash-bang) + (let* ([expression "#!/bin/sh\n1"] + [result "1"] + [drs (test:get-active-top-level-window)] + [interactions (queue-callback (λ () (send drs get-interactions-text)))]) + (clear-definitions drs) + (type-in-definitions drs expression) + (do-execute drs) + (let* ([got (fetch-output/should-be-tested drs)]) + (unless (string=? "1" got) + (fprintf (current-error-port) + "FAILED: ~s ~a test\n expected: ~s\n got: ~s\n" + (language) expression result got))))) + +(define (fetch-output/should-be-tested . args) + (regexp-replace (regexp + (string-append + (regexp-quote "") + "$")) + (apply fetch-output args) + "")) + +(define (check-top-of-repl) + (let ([drs (wait-for-drscheme-frame)]) + (set-language #t) + (with-handlers ([exn:fail? void]) + (fw:test:menu-select "Testing" "Disable tests")) + (do-execute drs) + (let* ([interactions (send drs get-interactions-text)] + [short-lang (last (language))] + [get-line (lambda (n) + (queue-callback/res + (λ () + (send interactions get-text + (send interactions paragraph-start-position n) + (send interactions paragraph-end-position n)))))] + [line0-expect (format "Welcome to DrRacket, version ~a [~a]." + (version:version) + (system-type 'gc))] + [line1-expect + (if (string? short-lang) + (format "Language: ~a" short-lang) + short-lang)] + [line0-got (get-line 0)] + [line1-got (get-line 1)]) + (unless (and (string=? line0-expect line0-got) + (if (string? short-lang) + (string=? line1-expect (substring line1-got + 0 + (min (string-length line1-expect) + (string-length line1-got)))) + (regexp-match line1-expect line1-got))) + (fprintf (current-error-port) + "expected lines: \n ~a\n ~a\ngot lines:\n ~a\n ~a\n" + line0-expect line1-expect + line0-got line1-got) + (error 'language-test.rkt "failed get top of repl test"))))) + + +;; teaching-language-fraction-output +;; tests that the teaching languages properly handle repeating decimals +(define (teaching-language-fraction-output) + (test-setting + (lambda () (fw:test:set-radio-box! "Fraction Style" "Mixed fractions")) + "Fraction Style -- Mixed fractions" + "4/3" + "{number 4/3 \"1 1/3\" mixed}") + (test-setting + (lambda () (fw:test:set-radio-box! "Fraction Style" "Repeating decimals")) + "Fraction Style -- Repeating decimals" + "4/3" + "{number 4/3 \"1.3\" decimal}")) + +;; plt-language-fraction-output : -> void +;; tests that the PLT languages properly handle repeating decimals +(define (plt-language-fraction-output) + (test-setting + (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #f)) + "Use decimal notation for rationals -- #f" + "4/3 1/2 -1/3" + "{number 4/3 \"1 1/3\" mixed}\n{number 1/2 \"1/2\" mixed}\n{number -1/3 \"- 1/3\" mixed}") + (test-setting + (lambda () (fw:test:set-check-box! "Use decimal notation for rationals" #t)) + "Use decimal notation for rationals -- #t" + "4/3 1/2 -1/3" + "{number 4/3 \"#e1.3\" decimal}\n{number 1/2 \"#e0.5\" decimal}\n{number -1/3 \"#e-0.3\" decimal}")) + +(define (generic-settings false/true?) + (test-setting + (lambda () (fw:test:set-check-box! "Case sensitive" #t)) + "Case sensitive -- #t" + "(eq? 'g 'G)" + (if false/true? "false" "#f")) + (test-setting + (lambda () (fw:test:set-check-box! "Case sensitive" #f)) + "Case sensitive -- #f" + "(eq? 'g 'G)" + (if false/true? "true" "#t"))) + +(define (generic-output list? quasi-quote? has-sharing? has-print-printing?) + (let* ([plain-print-style (if has-print-printing? "print" "write")] + [drs (wait-for-drscheme-frame)] + [expression "(define x (list 2))\n(list x x)"] + [set-output-choice + (lambda (option show-sharing pretty?) + (set-language #f) + (fw:test:set-radio-box! "Output Style" option) + (when (and has-sharing? show-sharing) + (fw:test:set-check-box! + "Show sharing in values" + (if (eq? show-sharing 'on) #t #f))) + (fw:test:set-check-box! + "Insert newlines in printed values" + pretty?) + (let ([f (test:get-active-top-level-window)]) + (fw:test:button-push "OK") + (wait-for-new-frame f)))] + [shorten + (lambda (str) + (if ((string-length str) . <= . 45) + str + (string-append (substring str 0 45) "...")))] + [test + ;; answer must either be a string, or a procedure that accepts both zero and 1 + ;; argument. When the procedure accepts 1 arg, the argument is `got' and + ;; the result must be a boolean indicating if the result was satisfactory. + ;; if the procedure receives no arguments, it must return a descriptive string + ;; for the error message + (lambda (option show-sharing pretty? answer) + (set-output-choice option show-sharing pretty?) + (do-execute drs) + (let ([got (fetch-output/should-be-tested drs)]) + (unless (if (procedure? answer) + (answer got) + (whitespace-string=? answer got)) + (fprintf (current-error-port) + "FAILED ~s ~a, sharing ~a pretty? ~a\n got ~s\n expected ~s\n" + (language) option show-sharing pretty? + (shorten got) + (if (procedure? answer) (answer) answer)))))]) + + (clear-definitions drs) + (type-in-definitions drs expression) + + (test plain-print-style 'off #t "((2) (2))") + (when has-sharing? + (test plain-print-style 'on #t "(#0=(2) #0#)")) + (when quasi-quote? + (test "Quasiquote" 'off #t "`((2) (2))") + (when has-sharing? + (test "Quasiquote" 'on #t "(shared ((-1- `(2))) `(,-1- ,-1-))"))) + + (test "Constructor" 'off #t + (if list? + "(list (list 2) (list 2))" + "(cons (cons 2 empty) (cons (cons 2 empty) empty))")) + (when has-sharing? + (test "Constructor" 'on #t + (if list? + "(shared ((-1- (list 2))) (list -1- -1-))" + "(shared ((-1- (cons 2 empty))) (cons -1- (cons -1- empty)))"))) + + ;; setup print / pretty-print difference + (clear-definitions drs) + (for-each fw:test:keystroke + (string->list + "(define (f n)\n(cond ((zero? n) (list))\n(else (cons n (f (- n 1))))))\n(f 200)")) + (test "Constructor" #f #f + (case-lambda + [(x) (not (member #\newline (string->list x)))] + [() "no newlines in result"])) + (test "Constructor" #f #t + (case-lambda + [(x) (member #\newline (string->list x))] + [() "newlines in result (may need to make the window smaller)"])) + (test plain-print-style #f #f + (case-lambda + [(x) (not (member #\newline (string->list x)))] + [() "no newlines in result"])) + (test plain-print-style #f #t + (case-lambda + [(x) (member #\newline (string->list x))] + [() "newlines in result (may need to make the window smaller)"])))) + +(define re:out-of-sync + (regexp + "WARNING: Interactions window is out of sync with the definitions window\\.")) + +(define (test-error-after-definition) + (let* ([drs (wait-for-drscheme-frame)] + [interactions-text (queue-callback/res (λ () (send drs get-interactions-text)))]) + (clear-definitions drs) + (type-in-definitions drs "(define y 0) (define (f x) (/ x y)) (f 2)") + (do-execute drs) + (let ([last-para (queue-callback/res (λ () (send interactions-text last-paragraph)))]) + (type-in-interactions drs "y\n") + (wait-for-computation drs) + (let ([got + (fetch-output/should-be-tested + drs + (queue-callback/res (λ () (send interactions-text paragraph-start-position (+ last-para 1)))) + (queue-callback/res + (λ () + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))))]) + (unless (equal? got "0") + (fprintf (current-error-port) + "FAILED: test-error-after-definition failed, expected 0, got ~s\n" got)))))) + + +;; test-expression : (union string 'xml 'image (listof (union string 'xml 'image))) +;; (union string regexp (string -> boolean)) +;; -> void +;; types an expression in the definitions window, executes it and tests the output +;; types an expression in the REPL and tests the output from the REPL. +(define (test-expression expression defs-expected [repl-expected defs-expected]) + (let* ([drs (wait-for-drscheme-frame)] + [interactions-text (queue-callback/res (λ () (send drs get-interactions-text)))] + [definitions-text (queue-callback/res (λ () (send drs get-definitions-text)))] + [handle-insertion + (lambda (item) + (cond + [(eq? item 'image) + (use-get/put-dialog + (lambda () (fw:test:menu-select "Insert" "Insert Image...")) + (simplify-path (build-path (collection-path "icons") "recycle.png")))] + [(string? item) + (insert-in-definitions drs item)] + [(eq? item 'xml) + (fw:test:menu-select "Insert" "Insert XML Box") + (for-each fw:test:keystroke (string->list ""))] + [else (error 'handle-insertion "unknown thing to insert ~s" item)]))] + [check-expectation + (lambda (expected got) + (cond + [(string? expected) + (whitespace-string=? expected got)] + [(regexp? expected) + (regexp-match expected got)] + [(procedure? expected) + (expected got)]))] + [make-err-msg + (lambda (expected) + (cond + [(string? expected) + "FAILED: ~s ~s expected ~s to produce:\n ~s\ngot:\n ~s\ninstead\n"] + [(regexp? expected) + "FAILED: ~s ~s expected ~s to match ~s, got ~s instead\n"] + [(procedure? expected) + "FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s\n"]))]) + (clear-definitions drs) + (insert-in-definitions drs (defs-prefix)) + (cond + [(pair? expression) (for-each handle-insertion expression)] + [else (handle-insertion expression)]) + (do-execute drs) + + (let ([got + (fetch-output + drs + (queue-callback/res (λ () (send interactions-text paragraph-start-position 2))) + (queue-callback/res + (λ () + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))))]) + (when (regexp-match re:out-of-sync got) + (error 'text-expression "got out of sync message")) + (unless (check-expectation defs-expected got) + (fprintf (current-error-port) + (make-err-msg defs-expected) + 'definitions (language) expression defs-expected got))) + + (let ([dp (defs-prefix)]) + (queue-callback/res + (λ () + ;; select all except the defs-prefix + (send definitions-text set-position + (string-length dp) + (send definitions-text last-position)) + + (send definitions-text copy) + (send interactions-text set-position + (send interactions-text last-position) + (send interactions-text last-position)) + (send interactions-text paste)))) + + (let ([last-para (queue-callback/res (λ () (send interactions-text last-paragraph)))]) + (alt-return-in-interactions drs) + (wait-for-computation drs) + (let ([got + (fetch-output + drs + (queue-callback/res + (λ () + (send interactions-text paragraph-start-position (+ last-para 1)))) + (queue-callback/res + (λ () + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))))]) + (when (regexp-match re:out-of-sync got) + (error 'text-expression "got out of sync message")) + (unless (check-expectation repl-expected got) + (fprintf (current-error-port) + (make-err-msg repl-expected) + 'interactions + (language) + expression repl-expected got)))))) + +(define (test-undefined-var id) + (test-expression id (format "~a: this variable is not defined" id))) + +(define (test-undefined-fn exp id) + (test-expression exp (format "~a: this function is not defined" id))) + +(define-syntax (go stx) + (syntax-case stx () + [(_ arg) + (identifier? (syntax arg)) + (syntax (begin (flush-output) + (printf ">> starting ~a\n" 'arg) + (flush-output) + (arg) + (flush-output) + (printf ">> finished ~a\n" 'arg) + (flush-output)))])) + +(define (run-test) + (go module-lang) + (go pretty-big) + (go r5rs) + (go beginner) + (go beginner/abbrev) + (go intermediate) + (go intermediate/lambda) + (go advanced) + ) + +(fire-up-drscheme-and-run-tests run-test) diff --git a/collects/tests/drracket/module-lang-test.rkt b/collects/tests/drracket/module-lang-test.rkt index f36fe787ef..050b08a3f2 100644 --- a/collects/tests/drracket/module-lang-test.rkt +++ b/collects/tests/drracket/module-lang-test.rkt @@ -140,7 +140,7 @@ (require-for-syntax (file @in-here{module-lang-test-tmp2.rkt})) (provide s) (define-syntax (s stx) e))} - @t{(require m) s} + @t{(require 'm) s} @rx{compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1$}) @@ -157,7 +157,7 @@ (test @t{#lang racket (eval 'cons)} #f - @rx{. compile: unbound identifier \(and no #%top syntax transformer is bound\) in: cons}) + @rx{compile: unbound identifier \(and no #%top syntax transformer is bound\) in: cons}) (test @t{(module m (file @in-here{module-lang-test-tmp1.rkt}) 1 2 3)} @t{1} ;; just make sure no errors. "1") diff --git a/collects/tests/drracket/repl-test.rkt b/collects/tests/drracket/repl-test.rkt index d32d03a809..ca48777096 100644 --- a/collects/tests/drracket/repl-test.rkt +++ b/collects/tests/drracket/repl-test.rkt @@ -157,13 +157,12 @@ This produces an ACK message 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 ())") + "{stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-22x22.png} repl-test-tmp3.rkt:1:0: lambda: bad syntax in: (lambda ())") 'definitions #f void @@ -171,13 +170,12 @@ This produces an ACK message ;; 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 ())") + "{stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-22x22.png} repl-test-tmp3.rkt:1:7: lambda: bad syntax in: (lambda ())") 'definitions #f void @@ -246,7 +244,6 @@ This produces an ACK message 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)" @@ -260,10 +257,9 @@ This produces an ACK message ;; 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: +" + #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: \\+" "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: \\+") @@ -273,7 +269,6 @@ This produces an ACK message void) (mktest "(begin (define-struct a ()) (define-struct (b a) ()))" - ("" "" "" @@ -321,8 +316,8 @@ This produces an ACK message "{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") + "{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") 'definitions #f void @@ -385,13 +380,12 @@ This produces an ACK message 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 ())" "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 ())" + "lambda: bad syntax in: (lambda ())" + "lambda: bad syntax in: (lambda ())" + "lambda: bad syntax in: (lambda ())") 'interactions #f void @@ -494,8 +488,8 @@ This produces an ACK message "{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 ())") + "{stop-22x22.png} lambda: bad syntax in: (lambda ())" + "{stop-22x22.png} repl-test-tmp3.rkt:1:4: lambda: bad syntax in: (lambda ())") 'definitions #f void @@ -542,9 +536,9 @@ This produces an ACK message ("{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") + "{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") 'definitions #f void @@ -577,8 +571,8 @@ This produces an ACK message "{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") + "{stop-22x22.png} if: bad syntax in: if" + "{stop-22x22.png} repl-test-tmp3.rkt:2:0: if: bad syntax in: if") 'definitions #f void @@ -590,8 +584,8 @@ This produces an ACK message "{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") + "{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") 'definitions #f void @@ -869,8 +863,8 @@ This produces an ACK message "{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: (λ ())") + "{stop-22x22.png} λ: bad syntax in: (λ ())" + "{stop-22x22.png} repl-test-tmp3.rkt:1:0: λ: bad syntax in: (λ ())") 'definitions #f void @@ -998,7 +992,6 @@ This produces an ACK message "(with-handlers ((void values)) (eval '(lambda ())))))\n" "(lambda ()\n" "(display (get-output-string p)))))\n") - ("x in: (lambda ())" "x in: (lambda ())" "x in: (lambda ())"