From de72d31f2b23ffcb8103ee6f466fa2f8b6cd2855 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 30 Jul 2005 05:46:43 +0000 Subject: [PATCH] drscheme test suites now run svn: r498 --- collects/drscheme/private/debug.ss | 77 ++++++++------- collects/drscheme/private/drsig.ss | 5 +- collects/drscheme/private/language.ss | 118 +++++++++++++---------- collects/drscheme/private/rep.ss | 43 +++++---- collects/drscheme/syncheck.ss | 15 ++- collects/tests/drscheme/language-test.ss | 32 +++--- collects/tests/drscheme/repl-test.ss | 80 ++++++++------- 7 files changed, 216 insertions(+), 154 deletions(-) diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index 5669f94f84..a0ef109ea1 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -243,23 +243,7 @@ profile todo: (display #\space (current-error-port)))))) (let ([srcs-to-display (find-src-to-display exn cms)]) - (for-each (λ (src-to-display) - (let ([src (srcloc-source src-to-display)]) - (when (and (path? src) file-note%) - (let ([note (new file-note%)]) - (send note set-callback - (λ () (open-and-highlight-in-file src-to-display))) - (write-special note (current-error-port)) - (display #\space (current-error-port)) - (display (path->string (find-relative-path (current-directory) src)) - (current-error-port)) - (let ([line (srcloc-line src-to-display)] - [col (srcloc-column src-to-display)]) - (when (and (number? line) - (number? col)) - (fprintf (current-error-port) ":~a:~a" line col))) - (display ": " (current-error-port)))))) - srcs-to-display) + (for-each display-srcloc-in-error srcs-to-display) (display msg (current-error-port)) (when (exn:fail:syntax? exn) @@ -281,6 +265,48 @@ profile todo: (number? (cddr x)))) cms)))))) + ;; display-srcloc-in-error : src-loc -> void + ;; prints out the src location information for src-to-display + ;; as it would appear in an error message + (define (display-srcloc-in-error src-to-display) + (let ([src (srcloc-source src-to-display)]) + (when (and (path? src) file-note%) + (let ([note (new file-note%)]) + (send note set-callback + (λ () (open-and-highlight-in-file src-to-display))) + (write-special note (current-error-port)) + (display #\space (current-error-port)) + (display (path->string (find-relative-path (current-directory) src)) + (current-error-port)) + (let ([line (srcloc-line src-to-display)] + [col (srcloc-column src-to-display)] + [pos (srcloc-position src-to-display)]) + (cond + [(and (number? line) (number? col)) + (fprintf (current-error-port) ":~a:~a" line col)] + [pos + (fprintf (current-error-port) "::~a" pos)])) + (display ": " (current-error-port)))))) + + ;; find-src-to-display : exn (union #f (listof (list* number number))) + ;; -> (listof srclocs) + ;; finds the source location to display, choosing between + ;; the stack trace and the exception record. + ;; returns #f if the source isn't a string. + (define (find-src-to-display exn cms) + (cond + [(exn:srclocs? exn) + ((exn:srclocs-accessor exn) exn)] + [(pair? cms) + (let ([fst (car cms)]) + (list (make-srcloc (car fst) + #f + #f + (cadr fst) + (cddr fst))))] + [else '()])) + + (define (show-syntax-error-context port exn) (let ([error-text-style-delta (make-object style-delta%)]) (send error-text-style-delta set-delta-foreground (make-object color% 200 0 0)) @@ -308,23 +334,6 @@ profile todo: (λ (rep errs arrows) (send rep highlight-errors errs arrows)) orig-error-display-handler)) - ;; find-src-to-display : exn (union #f (listof (list* number number))) - ;; -> (listof srclocs) - ;; finds the source location to display, choosing between - ;; the stack trace and the exception record. - ;; returns #f if the source isn't a string. - (define (find-src-to-display exn cms) - (cond - [(exn:srclocs? exn) - ((exn:srclocs-accessor exn) exn)] - [(pair? cms) - (let ([fst (car cms)]) - (list (make-srcloc (car fst) - #f - #f - (cadr fst) - (cddr fst))))] - [else '()])) ;; insert/clickback : (instanceof text%) (union string (instanceof snip%)) (-> void) ;; inserts `note' and a space at the end of `rep' diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index 4565f604f5..166788390d 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -62,7 +62,10 @@ show-error-and-highlight open-and-highlight-in-file show-backtrace-window - get-cm-key)) + get-cm-key + + display-srcloc-in-error + show-syntax-error-context)) (define-signature drscheme:module-language^ (add-module-language diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 9f19af7796..6226800d53 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -316,62 +316,69 @@ (if (eq? (simple-settings-printing-style settings) 'current-print) (parameterize ([current-output-port port]) ((current-print) value)) - (let ([converted-value - (simple-module-based-language-convert-value value settings)] - [use-number-snip? + (let ([converted-value (simple-module-based-language-convert-value value settings)]) + (setup-printing-parameters + (λ () + (cond + [(simple-settings-insert-newlines settings) + (if (number? width) + (parameterize ([pretty-print-columns width]) + (pretty-print converted-value port)) + (pretty-print converted-value port))] + [else + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print converted-value port)) + (newline port)])) + settings + width)))) + + ;; setup-printing-parameters : (-> void) -> void + (define (setup-printing-parameters thunk settings width) + (let ([use-number-snip? (λ (x) (and (number? x) (exact? x) (real? x) (not (integer? x))))]) - (parameterize ([pretty-print-columns width] - [pretty-print-size-hook - (λ (value display? port) - (cond - [(is-a? value snip%) 1] - [(use-number-snip? value) 1] - [(syntax? value) 1] - [(to-snip-value? value) 1] - [else #f]))] - [pretty-print-print-hook - (λ (value display? port) - (cond - [(is-a? value snip%) - (write-special value port) - 1] - [(use-number-snip? value) - (write-special - (case (simple-settings-fraction-style settings) - [(mixed-fraction) - (number-snip:make-fraction-snip value #f)] - [(mixed-fraction-e) - (number-snip:make-fraction-snip value #t)] - [(repeating-decimal) - (number-snip:make-repeating-decimal-snip value #f)] - [(repeating-decimal-e) - (number-snip:make-repeating-decimal-snip value #t)]) - port) - 1] - [(syntax? value) - (write-special (render-syntax/snip value))] - [else (write-special (value->snip value))]))] - [print-graph - ;; only turn on print-graph when using `write' printing - ;; style because the sharing is being taken care of - ;; by the print-convert sexp construction when using - ;; other printing styles. - (and (eq? (simple-settings-printing-style settings) 'write) - (simple-settings-show-sharing settings))]) - (cond - [(simple-settings-insert-newlines settings) - (if (number? width) - (parameterize ([pretty-print-columns width]) - (pretty-print converted-value port)) - (pretty-print converted-value port))] - [else - (parameterize ([pretty-print-columns 'infinity]) - (pretty-print converted-value port)) - (newline port)]))))) + (parameterize ([pretty-print-columns width] + [pretty-print-size-hook + (λ (value display? port) + (cond + [(is-a? value snip%) 1] + [(use-number-snip? value) 1] + [(syntax? value) 1] + [(to-snip-value? value) 1] + [else #f]))] + [pretty-print-print-hook + (λ (value display? port) + (cond + [(is-a? value snip%) + (write-special value port) + 1] + [(use-number-snip? value) + (write-special + (case (simple-settings-fraction-style settings) + [(mixed-fraction) + (number-snip:make-fraction-snip value #f)] + [(mixed-fraction-e) + (number-snip:make-fraction-snip value #t)] + [(repeating-decimal) + (number-snip:make-repeating-decimal-snip value #f)] + [(repeating-decimal-e) + (number-snip:make-repeating-decimal-snip value #t)]) + port) + 1] + [(syntax? value) + (write-special (render-syntax/snip value))] + [else (write-special (value->snip value))]))] + [print-graph + ;; only turn on print-graph when using `write' printing + ;; style because the sharing is being taken care of + ;; by the print-convert sexp construction when using + ;; other printing styles. + (and (eq? (simple-settings-printing-style settings) 'write) + (simple-settings-show-sharing settings))]) + (thunk)))) ;; drscheme-inspector : inspector (define drscheme-inspector (current-inspector)) @@ -412,6 +419,15 @@ (error-display-handler)))) (drscheme:debug:profiling-enabled (eq? annotations 'debug/profile)) (drscheme:debug:test-coverage-enabled (eq? annotations 'test-coverage))) + (global-port-print-handler + (λ (value port) + (let ([converted-value (simple-module-based-language-convert-value value setting)]) + (setup-printing-parameters + (λ () + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print converted-value port))) + setting + 'infinity)))) (current-inspector (make-inspector)) (read-case-sensitive (simple-settings-case-sensitive setting))))) diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 6b3e583047..a73b416dc4 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -172,16 +172,22 @@ TODO ;; the highlight must be set after the error message, because inserting into the text resets ;; the highlighting. (define (drscheme-error-display-handler msg exn) - (display msg (current-error-port)) - (newline (current-error-port)) - (flush-output (current-error-port)) - (let ([rep (current-rep)]) - (when (and (is-a? rep -text<%>) - (eq? (current-error-port) (send rep get-err-port))) - (parameterize ([current-eventspace drscheme:init:system-eventspace]) - (queue-callback - (λ () - (send rep highlight-errors/exn exn))))))) + (let ([src-locs (if (exn:srclocs? exn) + ((exn:srclocs-accessor exn) exn) + '())]) + (for-each drscheme:debug:display-srcloc-in-error src-locs) + (display msg (current-error-port)) + (when (exn:fail:syntax? exn) + (drscheme:debug:show-syntax-error-context (current-error-port) exn)) + (newline (current-error-port)) + (flush-output (current-error-port)) + (let ([rep (current-rep)]) + (when (and (is-a? rep -text<%>) + (eq? (current-error-port) (send rep get-err-port))) + (parameterize ([current-eventspace drscheme:init:system-eventspace]) + (queue-callback + (λ () + (send rep highlight-errors/exn exn)))))))) ;; drscheme-error-value->string-handler : TST number -> string (define (drscheme-error-value->string-handler x n) @@ -1241,7 +1247,6 @@ TODO (current-error-port (get-err-port)) (current-value-port (get-value-port)) (current-input-port (get-in-box-port)) - ;(current-input-port (make-input-port #f (λ (bytes) eof) #f void)) (break-enabled #t) (let* ([primitive-dispatch-handler (event-dispatch-handler)]) (event-dispatch-handler @@ -1505,7 +1510,7 @@ TODO (define input-delta (make-object style-delta%)) (send input-delta set-delta-foreground (make-object color% 0 150 0)) - + ;; insert-error-in-text : (is-a?/c text%) ;; (union #f (is-a?/c drscheme:rep:text<%>)) ;; string? @@ -1533,13 +1538,13 @@ TODO [insert-file-name/icon ;; insert-file-name/icon : string number number number number -> void (λ (source-name start span row col) - (let* ([range-spec - (cond - [(and row col) - (format ":~a:~a" row col)] - [start - (format "::~a" start)] - [else ""])]) + (let ([range-spec + (cond + [(and row col) + (format ":~a:~a" row col)] + [start + (format "::~a" start)] + [else ""])]) (cond [(file-exists? source-name) (let* ([normalized-name (normalize-path source-name)] diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 130a6a2179..ae26cfb65a 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -1015,7 +1015,7 @@ If the namespace does not, they are colored the unbound color. (drscheme:eval:expand-program (drscheme:language:make-text/pos definitions-text - 0 + (get-post-hash-bang-start definitions-text) (send definitions-text last-position)) (send definitions-text get-next-settings) #t @@ -1051,6 +1051,19 @@ If the namespace does not, they are colored the unbound color. (update-status-line 'drscheme:check-syntax status-expanding-expression) (loop)]))))))))))])) + (define/private (get-post-hash-bang-start definitions-text) + (cond + [(< (send definitions-text last-position) 2) + 0] + [(equal? '(#\# #\!) + (list (send definitions-text get-character 0) + (send definitions-text get-character 1))) + (let ([last-para (send definitions-text last-paragraph)]) + (if (zero? last-para) + (send definitions-text last-position) + (send definitions-text paragraph-start-position 1)))] + [else 0])) + ;; set-directory : text -> void ;; sets the current-directory and current-load-relative-directory ;; based on the file saved in the definitions-text diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index 1b66e8d16d..5c02d58190 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -118,7 +118,7 @@ the settings above should match r5rs (test-expression "(exact? 1.5)" "#f") (test-expression "(list 1)" "(1)") - (test-expression "(car (list))" "car: expects argument of type ; given ()") + (test-expression "(car (list))" "{bug09.gif} car: expects argument of type ; given ()") (test-expression "argv" "#0()"))) @@ -213,7 +213,7 @@ the settings above should match r5rs (test-expression ",1" "unquote: not in quasiquote in: (unquote 1)") (test-expression "(list 1)" "(1)") - (test-expression "(car (list))" "car: expects argument of type ; given ()") + (test-expression "(car (list))" "{bug09.gif} car: expects argument of type ; given ()") (test-expression "argv" "#0()"))) @@ -255,7 +255,8 @@ the settings above should match r5rs "#f") (test-expression "(define x 1)(define x 2)" "") - (test-expression "(define-struct spider (legs))(make-spider 4)" "#") + (test-expression "(define-struct spider (legs))(make-spider 4)" + "{bug09.gif} reference to undefined identifier: define-struct") (test-expression "(sqrt -1)" "0+1i") @@ -269,27 +270,27 @@ the settings above should match r5rs (test-expression "(define (f car) 1)" "") (test-expression "(define (f empty) 1)" "") - (test-expression "call/cc" "#") + (test-expression "call/cc" "{bug09.gif} reference to undefined identifier: call/cc") - (test-expression "(error 'a \"~a\" 1)" "{bug09.gif} a: 1") - (test-expression "(error \"a\" \"a\")" "{bug09.gif} a \"a\"") + (test-expression "(error 'a \"~a\" 1)" "{bug09.gif} reference to undefined identifier: error") + (test-expression "(error \"a\" \"a\")" "{bug09.gif} reference to undefined identifier: error") (test-expression "(time 1)" - #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") + "{bug09.gif} reference to undefined identifier: time") (test-expression "true" "{bug09.gif} reference to undefined identifier: true") (test-expression "mred^" "{bug09.gif} reference to undefined identifier: mred^") (test-expression "(eq? 'a 'A)" "#t") (test-expression "(set! x 1)" "{bug09.gif} set!: cannot set undefined identifier: x") - (test-expression "(cond [(= 1 2) 3])" "") + (test-expression "(cond ((= 1 2) 3))" "") (test-expression "(cons 1 2)" "(1 . 2)") (test-expression "'(1)" "(1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "(#&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 "(letrec ((x x)) 1)" "1") (test-expression "(if 1 1 1)" "1") (test-expression "(+ 1)" "1") @@ -308,13 +309,14 @@ the settings above should match r5rs (test-expression "779625/32258" "{number 779625/32258 \"24 5433/32258\" mixed}") (test-expression "(exact? 1.5)" "#f") - (test-expression "(let ([f (lambda (x) x)]) f)" "#") + (test-expression "(let ((f (lambda (x) x))) f)" "#") (test-expression ",1" "unquote: not in quasiquote in: (unquote 1)") (test-expression "(list 1)" "(1)") - (test-expression "(car (list))" "car: expects argument of type ; given ()") + (test-expression "(car (list))" + "{bug09.gif} car: expects argument of type ; given ()") - (test-expression "argv" "#0()"))) + (test-expression "argv" "{bug09.gif} reference to undefined identifier: argv"))) ;; ; ; @@ -1062,7 +1064,7 @@ the settings above should match r5rs (clear-definitions drs) (for-each fw:test:keystroke (string->list - "(define (f n)\n(cond [(zero? n) null]\n[else (cons n (f (- n 1)))]))\n(f 200)")) + "(define (f n)\n(cond ((zero? n) '())\n(else (cons n (f (- n 1))))))\n(f 200)")) (test "Constructor" #f #f (case-lambda [(x) (not (member #\newline (string->list x)))] diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index bddddda13b..787f1304c8 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -20,7 +20,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!) (define-struct loc (line col offset)) ;; loc = (make-loc number number number) - ;; numbers in loc structs start at zero. + ;; all numbers in loc structs start at zero. (define-struct test (program ;; : (union @@ -116,7 +116,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!) (make-test "(" "~aread: expected a ')'" "~aread: expected a ')'" - #t + #f (cons (make-loc 0 0 0) (make-loc 0 1 1)) 'read #f @@ -126,7 +126,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!) (make-test "." "~aread: illegal use of \".\"" "~aread: illegal use of \".\"" - #t + #f (cons (make-loc 0 0 0) (make-loc 0 1 1)) 'read #f @@ -136,7 +136,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!) (make-test "(lambda ())" "~alambda: bad syntax in: (lambda ())" "~alambda: bad syntax in: (lambda ())" - #t + #f (cons (make-loc 0 0 0) (make-loc 0 11 11)) 'expand #t @@ -512,7 +512,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!) void) (make-test "(current-namespace (make-namespace 'empty))\nif" - "~acompile: bad syntax; reference to top-level identifiers is not allowed, because no #%top syntax transformer is bound in: if" + "~acompile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: if" #f #f (cons (make-loc 1 0 44) (make-loc 1 0 46)) @@ -563,8 +563,8 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!) ;; should produce a syntax object with a turn-down triangle. (make-test "(write (list (syntax x)))" - "({syntax-snip})" - "({syntax-snip})" + "({embedded \".#\"})" + "({embedded \".#\"})" #f 'interactions #f @@ -665,8 +665,8 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!) (make-test (list "(" '("Special" "Insert λ") "())") "~aλ: bad syntax in: (λ ())" "~aλ: bad syntax in: (λ ())" - #t - (cons (make-loc 0 0 0) (make-loc 0 11 11)) + #f + (cons (make-loc 0 0 0) (make-loc 0 5 5)) 'expand #t #f @@ -765,6 +765,8 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!) (number->string (+ 1 (loc-line (car source-location)))))] [start-col (and source-location-in-message (number->string (loc-col (car source-location))))] + [start-pos (and (pair? source-location) + (number->string (+ 1 (loc-offset (car source-location)))))] [formatted-execute-answer (let* ([w/backtrace (if (and (test-has-backtrace? in-vector) @@ -782,29 +784,40 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!) [load-answer (test-load-answer in-vector)] [formatted-load-answer (and load-answer - (let* ([w/file-icon - (if raw? - (if source-location-in-message - (string-append file-image-string " " load-answer) - load-answer) - (if (or (eq? source-location 'definitions) - (pair? source-location)) - (string-append file-image-string " " load-answer) - load-answer))] - [w/backtrace - (if raw? - w/file-icon - (if (or (eq? source-location 'definitions) - (pair? source-location)) - (string-append backtrace-image-string " " w/file-icon) - w/file-icon))]) - (if source-location-in-message - (format w/file-icon - (format "~a:~a:~a: " - short-tmp-load-filename - start-line - start-col)) - w/file-icon)))] + (let ([line-col-loc-str + (and source-location-in-message + (format "~a:~a:~a: " + short-tmp-load-filename + start-line + start-col))] + [pos-col-str + (if (pair? source-location) + (format "~a::~a:" + short-tmp-load-filename + start-pos) + "")]) + (if raw? + (if source-location-in-message + (string-append file-image-string + " " + (format load-answer line-col-loc-str)) + load-answer) + (cond + [source-location-in-message + ;; syntax error or read time error, so has a back trace + ;; (the call to load) and line/col info + (string-append backtrace-image-string " " + file-image-string " " + (format load-answer line-col-loc-str))] + [(or (eq? source-location 'definitions) + (pair? source-location)) + ;; run-time error, so has a backtrace (the call to to load) + ;; but only offset info + (string-append backtrace-image-string " " + file-image-string " " + pos-col-str " " + load-answer)] + [else load-answer]))))] [breaking-test? (test-breaking-test? in-vector)]) (setup) @@ -984,5 +997,6 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!) ;(set-language-level! (list "PLT" "Graphical (MrEd)")) (kill-tests) + (run-test-in-language-level #t) (run-test-in-language-level #f) - (run-test-in-language-level #t))) + ))