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

trims the top of the stack, removing drscheme-specific frames, plus fixes to the test suites

Browse Source 
svn: r3792
This commit is contained in:
Robby Findler 2006-07-24 13:32:47 +00:00
parent 7fdf03bffd
commit 61254b02e7
3 changed files with 490 additions and 423 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -172,10 +172,11 @@ TODO
;; the highlight must be set after the error message, because inserting into the text resets ;; the highlight must be set after the error message, because inserting into the text resets
;; the highlighting. ;; the highlighting.
(define (drscheme-error-display-handler msg exn) (define (drscheme-error-display-handler msg exn)
(let* ([srclocs-stack (let* ([cut-stack (if (and (exn? exn)
(if (exn? exn) (main-user-eventspace-thread?))
(filter values (map cdr (continuation-mark-set->context (exn-continuation-marks exn)))) (cut-out-top-of-stack exn)
'())] '())]
[srclocs-stack (filter values (map cdr cut-stack))]
[stack [stack
(filter (filter
values values
@ -191,6 +192,16 @@ TODO
(if (null? stack) (if (null? stack)
'() '()
(list (car srclocs-stack))))]) (list (car srclocs-stack))))])
;; for use in debugging the stack trace stuff
#;
(when (exn? exn)
(print-struct #t)
(for-each
(λ (frame) (printf " ~s\n" frame))
(continuation-mark-set->context (exn-continuation-marks exn)))
(printf "\n"))
(unless (null? stack) (unless (null? stack)
(drscheme:debug:print-bug-to-stderr msg stack)) (drscheme:debug:print-bug-to-stderr msg stack))
(for-each drscheme:debug:display-srcloc-in-error src-locs) (for-each drscheme:debug:display-srcloc-in-error src-locs)
@ -209,27 +220,79 @@ TODO
src-locs src-locs
(filter (λ (x) (is-a? (car x) text%)) stack))))))))) (filter (λ (x) (is-a? (car x) text%)) stack)))))))))
;; drscheme-error-value->string-handler : TST number -> string (define (main-user-eventspace-thread?)
(define (drscheme-error-value->string-handler x n) (let ([rep (current-rep)])
(let ([port (open-output-string)]) (and rep
(eq? (eventspace-handler-thread (send rep get-user-eventspace))
;; using a string port here means no snips allowed, (current-thread)))))
;; even though this string may eventually end up
;; displayed in a place where snips are allowed. (define (cut-out-top-of-stack exn)
(print x port) (let ([initial-stack (continuation-mark-set->context (exn-continuation-marks exn))])
(let loop ([stack (reverse initial-stack)]
(let* ([long-string (get-output-string port)]) [hit-2? #f])
(close-output-port port) (cond
(if (<= (string-length long-string) n) [(null? stack)
long-string (unless (exn:break? exn)
(let ([short-string (substring long-string 0 n)] ;; give break exn's a free pass on this one.
[trim 3]) ;; sometimes they get raised in a funny place.
(unless (n . <= . trim) ;; (see call-with-break-parameterization below)
(let loop ([i trim]) (fprintf (current-error-port) "ACK! didn't find drscheme's stackframe when filtering\n"))
(unless (i . <= . 0) initial-stack]
(string-set! short-string (- n i) #\.) [else
(loop (sub1 i))))) (let ([top (car stack)])
short-string))))) (cond
[(is-cut? top 'cut-stacktrace-above-here1)
(if hit-2?
(reverse (cdr stack))
(begin
(fprintf (current-error-port) "ACK! found 1 without 2\n")
initial-stack))]
[(is-cut? top 'cut-stacktrace-above-here2)
(if hit-2?
(reverse (cdr stack))
(loop (cdr stack) #t))]
[else
(loop (cdr stack) hit-2?)]))]))))
;; is-cut? : any symbol -> boolean
;; determines if this stack entry is really
(define (is-cut? top sym)
(and (pair? top)
(let* ([fn-name (car top)]
[srcloc (cdr top)]
[source (and srcloc (srcloc-source srcloc))])
(and (eq? fn-name sym)
(path? source)
(let loop ([path source]
[pieces '(#"rep.ss" #"private" #"drscheme" #"collects")])
(cond
[(null? pieces) #t]
[else
(let-values ([(base name dir?) (split-path path)])
(and (equal? (path->bytes name) (car pieces))
(loop base (cdr pieces))))]))))))
;; drscheme-error-value->string-handler : TST number -> string
(define (drscheme-error-value->string-handler x n)
(let ([port (open-output-string)])
;; using a string port here means no snips allowed,
;; even though this string may eventually end up
;; displayed in a place where snips are allowed.
(print x port)
(let* ([long-string (get-output-string port)])
(close-output-port port)
(if (<= (string-length long-string) n)
long-string
(let ([short-string (substring long-string 0 n)]
[trim 3])
(unless (n . <= . trim)
(let loop ([i trim])
(unless (i . <= . 0)
(string-set! short-string (- n i) #\.)
(loop (sub1 i)))))
short-string)))))
(define drs-bindings-keymap (make-object keymap:aug-keymap%)) (define drs-bindings-keymap (make-object keymap:aug-keymap%))
@ -960,7 +1023,8 @@ TODO
(λ () ; =User=, =Handler=, =No-Breaks= (λ () ; =User=, =Handler=, =No-Breaks=
(let* ([settings (current-language-settings)] (let* ([settings (current-language-settings)]
[lang (drscheme:language-configuration:language-settings-language settings)] [lang (drscheme:language-configuration:language-settings-language settings)]
[settings (drscheme:language-configuration:language-settings-settings settings)]) [settings (drscheme:language-configuration:language-settings-settings settings)]
[dummy-value (box #f)])
(set! get-sexp/syntax/eof (set! get-sexp/syntax/eof
(if complete-program? (if complete-program?
(send lang front-end/complete-program port settings user-teachpack-cache) (send lang front-end/complete-program port settings user-teachpack-cache)
@ -981,19 +1045,33 @@ TODO
(current-error-escape-k (λ () (current-error-escape-k (λ ()
(set! cleanup? #t) (set! cleanup? #t)
(k (void))))) (k (void)))))
(λ () (λ ()
(let loop () (let loop ()
(let ([sexp/syntax/eof (get-sexp/syntax/eof)]) (let ([sexp/syntax/eof
;; this named thunk & application helps drscheme know to cut
;; off part of the stack trace. (too bad not all of it ...)
((rec cut-stacktrace-above-here1
(λ ()
(begin0 (get-sexp/syntax/eof)
(void)))))])
(unless (eof-object? sexp/syntax/eof) (unless (eof-object? sexp/syntax/eof)
(call-with-break-parameterization (call-with-break-parameterization
(get-user-break-parameterization) (get-user-break-parameterization)
;; a break exn may be raised right at this point,
;; in which case the stack won't be in a trimmable state
;; so we don't complain (above) when we find an untrimmable
;; break exn.
(λ () (λ ()
(call-with-values (call-with-values
(λ () (rec cut-stacktrace-above-here1
(eval-syntax sexp/syntax/eof)) (λ ()
(begin0 (eval-syntax sexp/syntax/eof)
(void))))
(λ x (display-results x))))) (λ x (display-results x)))))
(loop)))) (loop))))
(set! cleanup? #t)) (set! cleanup? #t))
(λ () (λ ()
(current-error-escape-k saved-error-escape-k) (current-error-escape-k saved-error-escape-k)
(when cleanup? (when cleanup?
@ -1074,10 +1152,11 @@ TODO
(current-error-escape-k (λ () (current-error-escape-k (λ ()
(set! cleanup? #t) (set! cleanup? #t)
(k (void))))) (k (void)))))
(λ () (rec cut-stacktrace-above-here2
(thunk) (λ ()
; Breaks must be off! (thunk)
(set! cleanup? #t)) ; Breaks must be off!
(set! cleanup? #t)))
(λ () (λ ()
(current-error-escape-k saved-error-escape-k) (current-error-escape-k saved-error-escape-k)
(when cleanup? (when cleanup?
@ -1312,12 +1391,12 @@ TODO
(break-enabled break-ok?) (break-enabled break-ok?)
(unless ub? (unless ub?
(set! user-break-enabled 'user))) (set! user-break-enabled 'user)))
(λ () (λ ()
(primitive-dispatch-handler eventspace)) (primitive-dispatch-handler eventspace))
(λ () (λ ()
(unless ub? (unless ub?
(set! user-break-enabled (break-enabled))) (set! user-break-enabled (break-enabled)))
(break-enabled #f)))) (break-enabled #f))))
; Cleanup after dispatch ; Cleanup after dispatch
(λ () (λ ()
;; in principle, the line below might cause ;; in principle, the line below might cause

2
collects/tests/drscheme/language-test.ss
View File

@ -1081,7 +1081,7 @@ the settings above should match r5rs
(clear-definitions drs) (clear-definitions drs)
(for-each fw:test:keystroke (for-each fw:test:keystroke
(string->list (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) (list))\n(else (cons n (f (- n 1))))))\n(f 200)"))
(test "Constructor" #f #f (test "Constructor" #f #f
(case-lambda (case-lambda
[(x) (not (member #\newline (string->list x)))] [(x) (not (member #\newline (string->list x)))]

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

File diff suppressed because it is too large Load Diff