suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed some bugs revealed by the test suite (and in the test suite ...)

Browse Source 
svn: r3336
This commit is contained in:
Robby Findler 2006-06-11 23:08:04 +00:00
parent 70d764c941
commit 1cd117bd2c
3 changed files with 100 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/drscheme/private/debug.ss
View File

@ -273,13 +273,20 @@ profile todo:
;; prints out the src location information for src-to-display ;; prints out the src location information for src-to-display
;; as it would appear in an error message ;; as it would appear in an error message
(define (display-srcloc-in-error src-to-display) (define (display-srcloc-in-error src-to-display)
(let ([src (srcloc-source src-to-display)]) (let* ([raw-src (srcloc-source src-to-display)]
[src (if (and (is-a? raw-src editor<%>)
(not (is-a? raw-src drscheme:unit:definitions-text<%>)))
(let* ([b (box #f)]
[fn (send raw-src get-filename b)])
(and (not (unbox b))
fn))
raw-src)])
(when (and (path? src) file-note%) (when (and (path? src) file-note%)
(let ([note (new file-note%)]) (let ([note (new file-note%)])
(send note set-callback (send note set-callback
(λ () (open-and-highlight-in-file src-to-display))) (λ () (open-and-highlight-in-file src-to-display)))
(write-special note (current-error-port)) (write-special note (current-error-port))
(display #\space (current-error-port)) (display #\space (current-error-port))
(display (path->string (find-relative-path (current-directory) src)) (display (path->string (find-relative-path (current-directory) src))
(current-error-port)) (current-error-port))
(let ([line (srcloc-line src-to-display)] (let ([line (srcloc-line src-to-display)]
@ -296,19 +303,27 @@ profile todo:
;; -> (listof srclocs) ;; -> (listof srclocs)
;; finds the source location to display, choosing between ;; finds the source location to display, choosing between
;; the stack trace and the exception record. ;; the stack trace and the exception record.
;; returns #f if the source isn't a string.
(define (find-src-to-display exn cms) (define (find-src-to-display exn cms)
(cond (let ([has-info?
[(exn:srclocs? exn) (λ (srcloc)
((exn:srclocs-accessor exn) exn)] (ormap (λ (f) (f srcloc))
[(pair? cms) (list srcloc-column
(let ([fst (car cms)]) srcloc-line
(list (make-srcloc (car fst) srcloc-position
#f srcloc-source
#f #;srcloc-span)))]) ;; don't consider span alone to count as `info'
(cadr fst) (cond
(cddr fst))))] [(and (exn:srclocs? exn)
[else '()])) (ormap has-info? ((exn:srclocs-accessor exn) 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) (define (show-syntax-error-context port exn)

4
collects/drscheme/private/rep.ss
View File

@ -173,7 +173,9 @@ TODO
;; the highlighting. ;; the highlighting.
(define (drscheme-error-display-handler msg exn) (define (drscheme-error-display-handler msg exn)
(let* ([srclocs-stack (let* ([srclocs-stack
(filter values (map cdr (continuation-mark-set->context (exn-continuation-marks exn))))] (if (exn? exn)
(filter values (map cdr (continuation-mark-set->context (exn-continuation-marks exn))))
'())]
[stack [stack
(filter (filter
values values

187
collects/tests/drscheme/repl-test.ss
View File

@ -56,9 +56,6 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
;; if this field is not #f, the execute-answer and load-answer fields ;; if this field is not #f, the execute-answer and load-answer fields
;; are expected to be `format'able strings with one ~a in them. ;; are expected to be `format'able strings with one ~a in them.
docs-icon? ;; : boolean
;; true if this should have a docs icon in front of the response.
breaking-test? ;; : boolean breaking-test? ;; : boolean
;; setup is called before the test case is run. ;; setup is called before the test case is run.
@ -76,8 +73,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
(make-test "\"a\"" (make-test "\"a\""
@ -86,8 +82,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -97,8 +92,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -108,8 +102,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -119,8 +112,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
(cons (make-loc 0 0 0) (make-loc 0 1 1)) (cons (make-loc 0 0 0) (make-loc 0 1 1))
'read 'read
#f #f
#f
void void
void) void)
(make-test "." (make-test "."
@ -129,8 +121,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
(cons (make-loc 0 0 0) (make-loc 0 1 1)) (cons (make-loc 0 0 0) (make-loc 0 1 1))
'read 'read
#f #f
#f
void void
void) void)
(make-test "(lambda ())" (make-test "(lambda ())"
@ -139,8 +130,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
(cons (make-loc 0 0 0) (make-loc 0 11 11)) (cons (make-loc 0 0 0) (make-loc 0 11 11))
'expand 'expand
#t #f
#f
void void
void) void)
(make-test "xx" (make-test "xx"
@ -149,8 +139,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#t #t
(cons (make-loc 0 0 0) (make-loc 0 2 2)) (cons (make-loc 0 0 0) (make-loc 0 2 2))
#f #f
#f #f
#f
void void
void) void)
(make-test "(raise 1)" (make-test "(raise 1)"
@ -159,8 +148,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
(make-test "(raise #f)" (make-test "(raise #f)"
@ -169,8 +157,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -180,8 +167,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
(make-test "(list 1 2)" (make-test "(list 1 2)"
@ -190,8 +176,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -201,8 +186,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -213,8 +197,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -225,7 +208,6 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -236,7 +218,6 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -245,13 +226,12 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
"(module n mzscheme (require-for-syntax m) (provide s) (define-syntax (s stx) e))\n" "(module n mzscheme (require-for-syntax m) (provide s) (define-syntax (s stx) e))\n"
"(require n)\n" "(require n)\n"
"s") "s")
"compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1" "~acompile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
"compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1" "~acompile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1"
#f
(cons (make-loc 1 43 43) (make-loc 1 44 44))
#f
#f
#f #f
(cons (make-loc 0 43 43) (make-loc 0 44 44))
'expand
#f
void void
void) void)
@ -262,8 +242,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -273,8 +252,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#t #t
(cons (make-loc 1 0 10) (make-loc 1 2 12)) (cons (make-loc 1 0 10) (make-loc 1 2 12))
#f #f
#f #f
#f
void void
void) void)
@ -287,8 +265,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -301,8 +278,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -316,8 +292,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -331,8 +306,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -346,8 +320,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#t #t
'definitions 'definitions
#f #f
#f #f
#f
void void
void) void)
|# |#
@ -360,8 +333,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
(make-test " (eval '(list 1 2))" (make-test " (eval '(list 1 2))"
@ -370,8 +342,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
(make-test " (eval '(lambda ()))" (make-test " (eval '(lambda ()))"
@ -380,8 +351,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
2 2
(cons (make-loc 0 4 4) (make-loc 0 23 23)) (cons (make-loc 0 4 4) (make-loc 0 23 23))
#f #f
#f #f
#f
void void
void) void)
(make-test " (eval 'x)" (make-test " (eval 'x)"
@ -390,8 +360,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
2 2
(cons (make-loc 0 4 4) (make-loc 0 13 13)) (cons (make-loc 0 4 4) (make-loc 0 13 13))
#f #f
#f #f
#f
void void
void) void)
@ -401,7 +370,6 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f
#f #f
void void
void) void)
@ -412,7 +380,6 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f
#f #f
void void
void) void)
@ -424,8 +391,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
2 2
(cons (make-loc 0 0 0) (make-loc 0 12 12)) (cons (make-loc 0 0 0) (make-loc 0 12 12))
#f #f
#f #f
#f
void void
void) void)
@ -436,8 +402,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
(cons (make-loc 0 4 4) (make-loc 0 9 9)) (cons (make-loc 0 4 4) (make-loc 0 9 9))
'read 'read
#f #f
#f
void void
void) void)
(make-test "1 2 . 3 4" (make-test "1 2 . 3 4"
@ -446,8 +411,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
(cons (make-loc 0 4 4) (make-loc 0 5 5)) (cons (make-loc 0 4 4) (make-loc 0 5 5))
'read 'read
#f #f
#f
void void
void) void)
(make-test "1 2 (lambda ()) 3 4" (make-test "1 2 (lambda ()) 3 4"
@ -456,8 +420,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
(cons (make-loc 0 4 4) (make-loc 0 15 15)) (cons (make-loc 0 4 4) (make-loc 0 15 15))
'expand 'expand
#t #f
#f
void void
void) void)
(make-test "1 2 x 3 4" (make-test "1 2 x 3 4"
@ -466,8 +429,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#t #t
(cons (make-loc 0 4 4) (make-loc 0 5 5)) (cons (make-loc 0 4 4) (make-loc 0 5 5))
#f #f
#f #f
#f
void void
void) void)
(make-test "1 2 (raise 1) 3 4" (make-test "1 2 (raise 1) 3 4"
@ -476,8 +438,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
(make-test "1 2 (raise #f) 3 4" (make-test "1 2 (raise #f) 3 4"
@ -486,8 +447,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -501,8 +461,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
(cons (make-loc -1 -1 (+ (string-length (path->string tmp-filename)) 29)) (cons (make-loc -1 -1 (+ (string-length (path->string tmp-filename)) 29))
(make-loc -1 -1 (+ (string-length (path->string tmp-filename)) 36))) (make-loc -1 -1 (+ (string-length (path->string tmp-filename)) 36)))
#f #f
#f #f
#f
(lambda () (lambda ()
(call-with-output-file tmp-filename (call-with-output-file tmp-filename
(lambda (port) (lambda (port)
@ -519,8 +478,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
(cons (make-loc 1 0 37) (make-loc 1 2 39)) (cons (make-loc 1 0 37) (make-loc 1 2 39))
'expand 'expand
#t #f
#f
void void
void) void)
@ -530,8 +488,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
(cons (make-loc 1 0 44) (make-loc 1 0 46)) (cons (make-loc 1 0 44) (make-loc 1 0 46))
'expand 'expand
#t #f
#f
void void
void) void)
@ -542,7 +499,6 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f
#f #f
void void
void) void)
@ -558,19 +514,19 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
'definitions 'definitions
#f #f
#f #f
#f
void void
void) void)
; fraction snip test ; fraction snip test
;; this test depends on the state of the 'framework:fraction-snip-style preference
;; make sure this preference is set to the default when running this test.
(make-test 'fraction-sum (make-test 'fraction-sum
"{number 5/6 \"5/6\" mixed}" "{number 5/6 \"5/6\" improper}"
"{number 5/6 \"5/6\" mixed}" "{number 5/6 \"5/6\" improper}"
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -581,8 +537,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -593,8 +548,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -605,19 +559,17 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
(make-test "(parameterize ([current-output-port (open-output-string)]) (fprintf (current-error-port) \"~e\" #'foot))" (make-test "(parameterize ([current-output-port (open-output-string)]) (fprintf (current-error-port) \"~e\" #'foot))"
"#<syntax::79>" "#<syntax:1:96>"
"#<syntax::79>" "#<syntax:/Users/robby/svn/plt/collects/tests/drscheme/repl-test-tmp.ss:1:96>"
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -627,8 +579,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -642,7 +593,6 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
(cons (make-loc 0 99 99) (make-loc 0 104 104)) (cons (make-loc 0 99 99) (make-loc 0 104 104))
#f #f
#f #f
#f
void void
void) void)
@ -653,8 +603,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
2 2
(cons (make-loc 0 0 0) (make-loc 0 35 35)) (cons (make-loc 0 0 0) (make-loc 0 35 35))
#f #f
#f #t
#t
void void
void) void)
@ -664,8 +613,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
2 2
(cons (make-loc 0 8 8) (make-loc 0 11 11)) (cons (make-loc 0 8 8) (make-loc 0 11 11))
#f #f
#f #t
#t
void void
void) void)
@ -675,7 +623,6 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f
#f #f
void void
void) void)
@ -684,8 +631,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
(make-test "(define v (vector (eval '(call/cc (lambda (x) x)))))\n((vector-ref v 0) 2)\nv" (make-test "(define v (vector (eval '(call/cc (lambda (x) x)))))\n((vector-ref v 0) 2)\nv"
@ -693,8 +639,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -704,8 +649,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#t #t
(cons (make-loc 3 7 61) (make-loc 3 12 66)) (cons (make-loc 3 7 61) (make-loc 3 12 66))
#f #f
#f #f
#f
void void
void) void)
@ -716,8 +660,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
'interactions 'interactions
#f #f
#f #f
#f
void void
void) void)
@ -727,8 +670,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#f #f
(cons (make-loc 0 0 0) (make-loc 0 5 5)) (cons (make-loc 0 0 0) (make-loc 0 5 5))
'expand 'expand
#t #f
#f
void void
void) void)
@ -739,8 +681,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
#t #t
(cons (make-loc 0 26 26) (make-loc 0 27 27)) (cons (make-loc 0 26 26) (make-loc 0 27 27))
#f #f
#f #f
#f
void void
void))) void)))
@ -961,6 +902,14 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
(- (send interactions-text last-position) 1)))) (- (send interactions-text last-position) 1))))
(test:keystroke #\return)) (test:keystroke #\return))
; in order to erase the state in the namespace already, we clear (but don't save!)
; the definitions and click execute with the empty buffer
(test:new-window definitions-canvas)
(test:menu-select "Edit" "Select All")
(test:menu-select "Edit" "Delete")
(do-execute drscheme-frame #f)
(wait-for-execute)
; stuff the load command into the REPL ; stuff the load command into the REPL
(for-each test:keystroke (for-each test:keystroke
(string->list (format "(load ~s)" tmp-load-short-filename))) (string->list (format "(load ~s)" tmp-load-short-filename)))