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

improved the error reporting in the REPL and misc other minor changes

Browse Source 
svn: r10014
This commit is contained in:
Robby Findler 2008-05-29 04:55:43 +00:00
parent 9777a6d079
commit 612f26972e
15 changed files with 6484 additions and 6158 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,24 +6,24 @@ profile todo:
|# |#
(module debug mzscheme #lang scheme/base
(require mzlib/unit
(lib "stacktrace.ss" "errortrace") (require scheme/unit
mzlib/class errortrace/stacktrace
mzlib/list scheme/class
mzlib/etc scheme/path
mzlib/file
"drsig.ss"
framework framework
mred scheme/gui/base
string-constants string-constants
(lib "bday.ss" "framework" "private") framework/private/bday
"bindings-browser.ss") "drsig.ss"
"bindings-browser.ss"
(for-syntax scheme/base))
(define orig (current-output-port)) (define orig (current-output-port))
(provide debug@) (provide debug@)
(define-unit debug@ (define-unit debug@
(import [prefix drscheme:rep: drscheme:rep^] (import [prefix drscheme:rep: drscheme:rep^]
[prefix drscheme:frame: drscheme:frame^] [prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:unit: drscheme:unit^] [prefix drscheme:unit: drscheme:unit^]
@ -36,21 +36,21 @@ profile todo:
(define (printf . args) (apply fprintf orig args)) (define (printf . args) (apply fprintf orig args))
; ;
; ;
; ; ; ;
; ; ; ; ; ;
; ; ; ;
; ; ;; ; ; ;; ; ;;; ;;;; ;;; ; ;; ; ; ;; ; ; ;; ; ;;; ;;;; ;;; ; ;;
; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ;; ; ; ; ; ;; ; ; ; ; ;; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ;; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ; ; ; ;
; ; ;; ;; ; ;; ; ; ;;;; ;;; ; ; ; ; ;; ;; ; ;; ; ; ;;;; ;;; ; ;
; ; ; ;
; ;;; ; ;;;
; ;
;; type debug-source = (union symbol (instanceof editor<%>)) ;; type debug-source = (union symbol (instanceof editor<%>))
@ -87,6 +87,7 @@ profile todo:
w-o-b w-o-b
b-o-w)))) b-o-w))))
(define arrow-cursor (make-object cursor% 'arrow))
(define (clickable-snip-mixin snip%) (define (clickable-snip-mixin snip%)
(class snip% (class snip%
(init-rest args) (init-rest args)
@ -147,6 +148,9 @@ profile todo:
(values (unbox wb) (values (unbox wb)
(unbox hb)))) (unbox hb))))
(define/override (adjust-cursor dc x y editorx editory event)
arrow-cursor)
(apply super-make-object args) (apply super-make-object args)
(set-flags (cons 'handles-events (get-flags))))) (set-flags (cons 'handles-events (get-flags)))))
@ -180,7 +184,7 @@ profile todo:
(define bug-note% (make-note% "stop-multi.png" 'png/mask)) (define bug-note% (make-note% "stop-multi.png" 'png/mask))
(define mf-note% (make-note% "mf.gif" 'gif)) (define mf-note% (make-note% "mf.gif" 'gif))
(define file-note% (make-note% "stop-32x32.png" 'gif)) (define file-note% (make-note% "stop-22x22.png" 'png/mask))
;; display-stats : (syntax -> syntax) ;; display-stats : (syntax -> syntax)
;; count the number of syntax expressions & number of with-continuation-marks in an ;; count the number of syntax expressions & number of with-continuation-marks in an
@ -214,7 +218,7 @@ profile todo:
(let loop ([exp (if (syntax? orig-exp) (let loop ([exp (if (syntax? orig-exp)
orig-exp orig-exp
(namespace-syntax-introduce (namespace-syntax-introduce
(datum->syntax-object #f orig-exp)))]) (datum->syntax #f orig-exp)))])
(let ([top-e (expand-syntax-to-top-form exp)]) (let ([top-e (expand-syntax-to-top-form exp)])
(syntax-case top-e (begin) (syntax-case top-e (begin)
[(begin expr ...) [(begin expr ...)
@ -244,29 +248,52 @@ profile todo:
(oe annotated))])))))]) (oe annotated))])))))])
debug-tool-eval-handler)) debug-tool-eval-handler))
;; make-debug-error-display-handler/text : (-> (union #f (is-a?/c text%))) ;; make-debug-error-display-handler : (string (union TST exn) -> void) -> string (union TST exn) -> void
;; ((listof (list text% number number)) -> void) ;; adds in the bug icon, if there are contexts to display
;; (string (union TST exn) -> void) (define (make-debug-error-display-handler orig-error-display-handler)
;; -> string (union TST exn)
;; -> void
(define (make-debug-error-display-handler/text get-rep highlight-errors orig-error-display-handler)
(define (debug-error-display-handler msg exn) (define (debug-error-display-handler msg exn)
(let ([rep (get-rep)]) (let ([rep (drscheme:rep:current-rep)])
(cond (cond
[rep [rep
(show-error-and-highlight (error-display-handler/stacktrace
msg msg
exn exn
(λ (srcs-to-display cms) (and (exn? exn)
(continuation-mark-set? (exn-continuation-marks exn))
(cms->srclocs (exn-continuation-marks exn))))]
[else
(orig-error-display-handler msg exn)])))
debug-error-display-handler)
;; error-display-handler/stacktrace : string any (listof srcloc) -> void
(define (error-display-handler/stacktrace msg exn [pre-stack #f])
(let* ([stack (or pre-stack
(if (exn? exn)
(map cdr (filter cdr (continuation-mark-set->context (exn-continuation-marks exn))))
'()))]
[src-locs (if (exn:srclocs? exn)
((exn:srclocs-accessor exn) exn)
(if (null? stack)
'()
(list (car stack))))])
(unless (null? stack)
(print-bug-to-stderr msg stack))
(display-srclocs-in-error src-locs)
(display msg (current-error-port))
(when (exn:fail:syntax? exn)
(show-syntax-error-context (current-error-port) exn))
(newline (current-error-port))
(flush-output (current-error-port))
(let ([rep (drscheme:rep:current-rep)])
(when (and (is-a? rep drscheme:rep:text<%>)
(eq? (current-error-port)
(send rep get-err-port)))
(parameterize ([current-eventspace drscheme:init:system-eventspace]) (parameterize ([current-eventspace drscheme:init:system-eventspace])
(queue-callback (queue-callback
(λ () (λ ()
;; need to make sure that the user's eventspace is still the same ;; need to make sure that the user's eventspace is still the same
;; and still running here? ;; and still running here?
(highlight-errors rep srcs-to-display cms))))))] (send rep highlight-errors src-locs stack))))))))
[else
(orig-error-display-handler msg exn)])))
debug-error-display-handler)
(define (print-bug-to-stderr msg cms) (define (print-bug-to-stderr msg cms)
(when (port-writes-special? (current-error-port)) (when (port-writes-special? (current-error-port))
@ -275,60 +302,60 @@ profile todo:
(let ([note (new note%)]) (let ([note (new note%)])
(send note set-callback (λ () (show-backtrace-window msg cms))) (send note set-callback (λ () (show-backtrace-window msg cms)))
(write-special note (current-error-port)) (write-special note (current-error-port))
(display #\space (current-error-port)) ))))) (display #\space (current-error-port)))))))
(define (show-error-and-highlight msg exn highlight-errors) ;; display-srclocs-in-error : (listof src-loc) -> void
(let ([cms
(and (exn? exn)
(continuation-mark-set? (exn-continuation-marks exn))
(cms->srclocs (exn-continuation-marks exn)))])
(when (and cms
(pair? cms))
(print-bug-to-stderr msg cms))
(let ([srcs-to-display (find-src-to-display exn cms)])
(for-each display-srcloc-in-error srcs-to-display)
(display msg (current-error-port))
(when (exn:fail:syntax? exn)
(show-syntax-error-context (current-error-port) exn))
(newline (current-error-port))
;; need to flush here so that error annotations inserted in next line
;; don't get erased if this output were to happen after the insertion
(flush-output (current-error-port))
(highlight-errors srcs-to-display cms))))
;; display-srcloc-in-error : text% -> src-loc -> void
;; 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-srclocs-in-error srcs-to-display)
(let* ([raw-src (srcloc-source src-to-display)] (unless (null? srcs-to-display)
[src (let ([defns-text (let ([rep (drscheme:rep:current-rep)]) (let ([src-to-display (car srcs-to-display)])
(and (is-a? rep drscheme:rep:text<%>) (let* ([src (srcloc-source src-to-display)]
(send rep get-definitions-text)))]) [line (srcloc-line src-to-display)]
(and (not (and defns-text [col (srcloc-column src-to-display)]
(send defns-text port-name-matches? raw-src))) [pos (srcloc-position src-to-display)]
raw-src))]) [do-icon
(λ ()
(when (and (path? src) file-note%) (when file-note%
(when (port-writes-special? (current-error-port)) (when (port-writes-special? (current-error-port))
(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 srcs-to-display)))
(write-special note (current-error-port)) (write-special note (current-error-port))
(display #\space (current-error-port)))) (display #\space (current-error-port))))))]
[do-src
(λ ()
(cond
[(path? src)
(display (path->string (find-relative-path (current-directory) (display (path->string (find-relative-path (current-directory)
(normalize-path src))) (normalize-path src)))
(current-error-port)) (current-error-port))]
(let ([line (srcloc-line src-to-display)] [else
[col (srcloc-column src-to-display)] (display "<unsaved editor>" (current-error-port))]))]
[pos (srcloc-position src-to-display)]) [do-line/col (λ () (fprintf (current-error-port) ":~a:~a" line col))]
[do-pos (λ () (fprintf (current-error-port) "::~a" pos))]
[src-loc-in-defs/ints?
(let ([rep (drscheme:rep:current-rep)])
(and rep
(is-a? rep drscheme:rep:text<%>)
(let ([defs (send rep get-definitions-text)])
(or (send rep port-name-matches? src)
(eq? rep src)
(send defs port-name-matches? src)
(eq? defs src)))))])
(cond (cond
[(and (number? line) (number? col)) [(and src line col)
(fprintf (current-error-port) ":~a:~a" line col)] (do-icon)
[pos (unless src-loc-in-defs/ints?
(fprintf (current-error-port) "::~a" pos)])) (do-src)
(display ": " (current-error-port))))) (do-line/col)
(display ": " (current-error-port)))]
[(and src pos)
(do-icon)
(unless src-loc-in-defs/ints?
(do-src)
(do-pos)
(display ": " (current-error-port)))])))))
;; find-src-to-display : exn (union #f (listof srcloc)) ;; find-src-to-display : exn (union #f (listof srcloc))
;; -> (listof srclocs) ;; -> (listof srclocs)
@ -350,7 +377,6 @@ profile todo:
[(pair? cms) (list (car cms))] [(pair? cms) (list (car cms))]
[else '()]))) [else '()])))
(define (show-syntax-error-context port exn) (define (show-syntax-error-context port exn)
(let ([error-text-style-delta (make-object style-delta%)] (let ([error-text-style-delta (make-object style-delta%)]
[send-out [send-out
@ -365,7 +391,7 @@ profile todo:
(let ([show-one (let ([show-one
(λ (expr) (λ (expr)
(display " " (current-error-port)) (display " " (current-error-port))
(send-out (format "~s" (syntax-object->datum expr)) (send-out (format "~s" (syntax->datum expr))
(λ (snp) (λ (snp)
(send snp set-style (send snp set-style
(send the-style-list find-or-create-style (send the-style-list find-or-create-style
@ -381,18 +407,6 @@ profile todo:
(show-one expr)) (show-one expr))
exprs)])))) exprs)]))))
;; make-debug-error-display-handler : (string (union TST exn) -> void) -> string (union TST exn) -> void
;; adds in the bug icon, if there are contexts to display
(define (make-debug-error-display-handler orig-error-display-handler)
(make-debug-error-display-handler/text
(λ ()
(let ([rep (drscheme:rep:current-rep)])
(and (is-a? rep drscheme:rep:text<%>)
(eq? (send rep get-err-port) (current-error-port))
rep)))
(λ (rep errs arrows) (send rep highlight-errors errs arrows))
orig-error-display-handler))
;; insert/clickback : (instanceof text%) (union string (instanceof snip%)) (-> void) ;; insert/clickback : (instanceof text%) (union string (instanceof snip%)) (-> void)
;; inserts `note' and a space at the end of `rep' ;; inserts `note' and a space at the end of `rep'
@ -604,7 +618,7 @@ profile todo:
(send text set-clickback (send text set-clickback
start-pos end-pos start-pos end-pos
(λ x (λ x
(open-and-highlight-in-file (make-srcloc debug-source #f #f start span))))) (open-and-highlight-in-file (list (make-srcloc debug-source #f #f start span))))))
;; make bindings hier-list ;; make bindings hier-list
(let ([bindings (st-mark-bindings di)]) (let ([bindings (st-mark-bindings di)])
@ -708,16 +722,20 @@ profile todo:
untitled)))) untitled))))
;; open-and-highlight-in-file : srcloc -> void ;; open-and-highlight-in-file : srcloc -> void
(define (open-and-highlight-in-file srcloc) (define (open-and-highlight-in-file srclocs)
(let* ([debug-source (srcloc-source srcloc)] (let ([sources (filter values (map srcloc-source srclocs))])
[position (srcloc-position srcloc)] (unless (null? sources)
[span (srcloc-span srcloc)] (let* ([debug-source (car sources)]
[same-src-srclocs
(filter (λ (x) (eq? debug-source (srcloc-source x)))
srclocs)]
[frame (cond [frame (cond
[(path? debug-source) (handler:edit-file debug-source)] [(path? debug-source) (handler:edit-file debug-source)]
[(is-a? debug-source editor<%>) [(is-a? debug-source editor<%>)
(let ([canvas (send debug-source get-canvas)]) (let ([canvas (send debug-source get-canvas)])
(and canvas (and canvas
(send canvas get-top-level-window)))])] (send canvas get-top-level-window)))]
[else #f])]
[editor (cond [editor (cond
[(path? debug-source) [(path? debug-source)
(cond (cond
@ -733,8 +751,8 @@ profile todo:
(send frame show #t)) (send frame show #t))
(when (and rep editor) (when (and rep editor)
(when (is-a? editor text:basic<%>) (when (is-a? editor text:basic<%>)
(send rep highlight-error editor position (+ position span)) (send rep highlight-errors same-src-srclocs '())
(send editor set-caret-owner #f 'global))))) (send editor set-caret-owner #f 'global)))))))
@ -761,24 +779,24 @@ profile todo:
(define current-test-coverage-info (make-thread-cell #f)) (define current-test-coverage-info (make-thread-cell #f))
(define (initialize-test-coverage-point key expr) (define (initialize-test-coverage-point key expr)
(unless (hash-table? (thread-cell-ref current-test-coverage-info)) (unless (hash? (thread-cell-ref current-test-coverage-info))
(let ([rep (drscheme:rep:current-rep)]) (let ([rep (drscheme:rep:current-rep)])
(when rep (when rep
(let ([ut (eventspace-handler-thread (send rep get-user-eventspace))]) (let ([ut (eventspace-handler-thread (send rep get-user-eventspace))])
(when (eq? ut (current-thread)) (when (eq? ut (current-thread))
(let ([ht (make-hash-table)]) (let ([ht (make-hasheq)])
(thread-cell-set! current-test-coverage-info ht) (thread-cell-set! current-test-coverage-info ht)
(send rep set-test-coverage-info ht))))))) (send rep set-test-coverage-info ht)))))))
(let ([ht (thread-cell-ref current-test-coverage-info)]) (let ([ht (thread-cell-ref current-test-coverage-info)])
(when (hash-table? ht) (when (hash? ht)
;; if rep isn't around, we don't do test coverage... ;; if rep isn't around, we don't do test coverage...
;; this can happen when check syntax expands, for example ;; this can happen when check syntax expands, for example
(hash-table-put! ht key (mcons #f expr))))) (hash-set! ht key (mcons #f expr)))))
(define (test-covered key) (define (test-covered key)
(let ([ht (thread-cell-ref current-test-coverage-info)]) (let ([ht (thread-cell-ref current-test-coverage-info)])
(when (hash-table? ht) ;; as in the `when' test in `initialize-test-coverage-point' (when (hash? ht) ;; as in the `when' test in `initialize-test-coverage-point'
(let ([v (hash-table-get ht key)]) (let ([v (hash-ref ht key)])
(set-mcar! v #t))))) (set-mcar! v #t)))))
(define test-coverage-interactions-text<%> (define test-coverage-interactions-text<%>
@ -800,7 +818,7 @@ profile todo:
[test-coverage-off-style #f] [test-coverage-off-style #f]
[ask-about-reset? #f]) [ask-about-reset? #f])
(define/public set-test-coverage-info (define/public set-test-coverage-info
(opt-lambda (ht [on-style #f] [off-style #f] [ask? #t]) (λ (ht [on-style #f] [off-style #f] [ask? #t])
(set! test-coverage-info ht) (set! test-coverage-info ht)
(set! test-coverage-on-style on-style) (set! test-coverage-on-style on-style)
(set! test-coverage-off-style off-style) (set! test-coverage-off-style off-style)
@ -903,11 +921,11 @@ profile todo:
(define/public (show-test-coverage-annotations ht on-style off-style ask?) (define/public (show-test-coverage-annotations ht on-style off-style ask?)
(set! ask-about-reset? ask?) (set! ask-about-reset? ask?)
(let* ([edit-sequence-ht (make-hash-table)] (let* ([edit-sequence-ht (make-hasheq)]
[locked-ht (make-hash-table)] [locked-ht (make-hasheq)]
[already-frozen-ht (make-hash-table)] [already-frozen-ht (make-hasheq)]
[actions-ht (make-hash-table 'equal)] [actions-ht (make-hash)]
[on/syntaxes (hash-table-map ht (λ (_ pr) pr))] [on/syntaxes (hash-map ht (λ (_ pr) pr))]
;; can-annotate : (listof (list boolean srcloc)) ;; can-annotate : (listof (list boolean srcloc))
;; boolean is #t => code was run ;; boolean is #t => code was run
@ -931,21 +949,21 @@ profile todo:
;; remove redundant expressions ;; remove redundant expressions
[filtered [filtered
(let (;; actions-ht : (list src number number) -> (list boolean syntax) (let (;; actions-ht : (list src number number) -> (list boolean syntax)
[actions-ht (make-hash-table 'equal)]) [actions-ht (make-hash)])
(for-each (for-each
(λ (pr) (λ (pr)
(let* ([on? (list-ref pr 0)] (let* ([on? (list-ref pr 0)]
[key (list-ref pr 1)] [key (list-ref pr 1)]
[old (hash-table-get actions-ht key 'nothing)]) [old (hash-ref actions-ht key 'nothing)])
(cond (cond
[(eq? old 'nothing) (hash-table-put! actions-ht key on?)] [(eq? old 'nothing) (hash-set! actions-ht key on?)]
[old ;; recorded as executed [old ;; recorded as executed
(void)] (void)]
[(not old) ;; recorded as unexected [(not old) ;; recorded as unexected
(when on? (when on?
(hash-table-put! actions-ht key #t))]))) (hash-set! actions-ht key #t))])))
can-annotate) can-annotate)
(hash-table-map actions-ht (λ (k v) (list v k))))]) (hash-map actions-ht (λ (k v) (list v k))))])
;; if everything is covered *and* no coloring has been done, do no coloring. ;; if everything is covered *and* no coloring has been done, do no coloring.
(unless (and (andmap car filtered) (unless (and (andmap car filtered)
@ -981,14 +999,14 @@ profile todo:
(for-each (for-each
(λ (pr) (λ (pr)
(let ([src (srcloc-source (list-ref pr 1))]) (let ([src (srcloc-source (list-ref pr 1))])
(hash-table-get (hash-ref
edit-sequence-ht edit-sequence-ht
src src
(λ () (λ ()
(hash-table-put! edit-sequence-ht src #f) (hash-set! edit-sequence-ht src #f)
(send src begin-edit-sequence #f) (send src begin-edit-sequence #f)
(when (send src is-locked?) (when (send src is-locked?)
(hash-table-put! locked-ht src #t) (hash-set! locked-ht src #t)
(send src lock #f)))))) (send src lock #f))))))
sorted) sorted)
@ -998,11 +1016,11 @@ profile todo:
(set! internal-clear-test-coverage-display #f)) (set! internal-clear-test-coverage-display #f))
;; freeze the colorers, but avoid a second freeze (so we can avoid a second thaw) ;; freeze the colorers, but avoid a second freeze (so we can avoid a second thaw)
(hash-table-for-each (hash-for-each
edit-sequence-ht edit-sequence-ht
(λ (src _) (λ (src _)
(if (send src is-frozen?) (if (send src is-frozen?)
(hash-table-put! already-frozen-ht src #t) (hash-set! already-frozen-ht src #t)
(send src freeze-colorer)))) (send src freeze-colorer))))
;; set new annotations ;; set new annotations
@ -1023,23 +1041,23 @@ profile todo:
sorted) sorted)
;; relock editors ;; relock editors
(hash-table-for-each (hash-for-each
locked-ht locked-ht
(λ (txt _) (send txt lock #t))) (λ (txt _) (send txt lock #t)))
;; end edit sequences ;; end edit sequences
(hash-table-for-each (hash-for-each
edit-sequence-ht edit-sequence-ht
(λ (txt _) (send txt end-edit-sequence))) (λ (txt _) (send txt end-edit-sequence)))
;; save thunk to reset these new annotations ;; save thunk to reset these new annotations
(set! internal-clear-test-coverage-display (set! internal-clear-test-coverage-display
(λ () (λ ()
(hash-table-for-each (hash-for-each
edit-sequence-ht edit-sequence-ht
(λ (txt _) (λ (txt _)
(send txt begin-edit-sequence #f))) (send txt begin-edit-sequence #f)))
(hash-table-for-each (hash-for-each
edit-sequence-ht edit-sequence-ht
(λ (txt _) (λ (txt _)
(let ([locked? (send txt is-locked?)]) (let ([locked? (send txt is-locked?)])
@ -1050,10 +1068,10 @@ profile todo:
(send txt last-position) (send txt last-position)
#f) #f)
(when locked? (send txt lock #t))))) (when locked? (send txt lock #t)))))
(hash-table-for-each (hash-for-each
edit-sequence-ht edit-sequence-ht
(λ (txt _) (λ (txt _)
(unless (hash-table-get already-frozen-ht txt #f) (unless (hash-ref already-frozen-ht txt #f)
(let ([locked? (send txt is-locked?)]) (let ([locked? (send txt is-locked?)])
(when locked? (send txt lock #f)) (when locked? (send txt lock #f))
(send txt thaw-colorer) (send txt thaw-colorer)
@ -1071,21 +1089,21 @@ profile todo:
; ;
; ;
; ;;; ;;; ; ;;; ;;;
; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ;
; ; ;; ; ;;; ;;; ;;;;;; ;;; ; ;;; ; ;; ;; ; ; ; ;; ; ;;; ;;; ;;;;;; ;;; ; ;;; ; ;; ;; ;
; ;; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ;; ; ;; ; ; ; ; ; ; ; ;; ; ; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;;
; ; ;; ; ;;; ; ; ; ; ; ; ;; ; ; ; ;; ; ;;; ; ; ; ; ; ; ;; ;
; ; ; ; ; ;
; ; ;;; ; ; ;;;
; ;
(define profile-key (gensym)) (define profile-key (gensym))
@ -1097,7 +1115,7 @@ profile todo:
;; number[time spent in all calls] ;; number[time spent in all calls]
;; (union #f symbol) ;; (union #f symbol)
;; expression) ;; expression)
(define-struct prof-info (nest num time name expr)) (define-struct prof-info (nest num time name expr) #:mutable)
;; copy-prof-info : prof-info -> prof-info ;; copy-prof-info : prof-info -> prof-info
(define (copy-prof-info prof-info) (define (copy-prof-info prof-info)
@ -1134,12 +1152,12 @@ profile todo:
(when rep (when rep
(let ([ut (eventspace-handler-thread (send rep get-user-eventspace))]) (let ([ut (eventspace-handler-thread (send rep get-user-eventspace))])
(when (eq? ut (current-thread)) (when (eq? ut (current-thread))
(let ([ht (make-hash-table)]) (let ([ht (make-hasheq)])
(thread-cell-set! current-profile-info ht) (thread-cell-set! current-profile-info ht)
(send (send rep get-context) add-profile-info ht))))))) (send (send rep get-context) add-profile-info ht)))))))
(let ([profile-info (thread-cell-ref current-profile-info)]) (let ([profile-info (thread-cell-ref current-profile-info)])
(when profile-info (when profile-info
(hash-table-put! profile-info (hash-set! profile-info
key key
(make-prof-info #f 0 0 (and (syntax? name) (syntax-e name)) expr)))) (make-prof-info #f 0 0 (and (syntax? name) (syntax-e name)) expr))))
(void)) (void))
@ -1150,7 +1168,7 @@ profile todo:
(define (register-profile-start key) (define (register-profile-start key)
(let ([ht (thread-cell-ref current-profile-info)]) (let ([ht (thread-cell-ref current-profile-info)])
(when ht (when ht
(let ([info (hash-table-get ht key)]) (let ([info (hash-ref ht key)])
(set-prof-info-num! info (+ (prof-info-num info) 1)) (set-prof-info-num! info (+ (prof-info-num info) 1))
(if (prof-info-nest info) (if (prof-info-nest info)
#f #f
@ -1165,7 +1183,7 @@ profile todo:
(when start (when start
(let ([ht (thread-cell-ref current-profile-info)]) (let ([ht (thread-cell-ref current-profile-info)])
(when ht (when ht
(let ([info (hash-table-get ht key)]) (let ([info (hash-ref ht key)])
(set-prof-info-nest! info #f) (set-prof-info-nest! info #f)
(set-prof-info-time! info (set-prof-info-time! info
(+ (- (current-process-milliseconds) start) (+ (- (current-process-milliseconds) start)
@ -1315,7 +1333,7 @@ profile todo:
(let/ec esc-k (let/ec esc-k
(for-each (for-each
(λ (ht) (λ (ht)
(hash-table-for-each (hash-for-each
ht ht
(λ (key v) (λ (key v)
(when (any-info? v) (when (any-info? v)
@ -1561,7 +1579,7 @@ profile todo:
[(null? profile-info) (void)] [(null? profile-info) (void)]
[else [else
(let ([ht (car profile-info)]) (let ([ht (car profile-info)])
(hash-table-for-each (hash-for-each
ht ht
(λ (key val) (λ (key val)
(when (any-info? val) (when (any-info? val)
@ -1571,7 +1589,7 @@ profile todo:
;; each editor that gets some highlighting is put ;; each editor that gets some highlighting is put
;; into this table and an edit sequence is begun for it. ;; into this table and an edit sequence is begun for it.
;; after all ranges are updated, the edit sequences are all closed. ;; after all ranges are updated, the edit sequences are all closed.
[in-edit-sequence (make-hash-table)] [in-edit-sequence (make-hasheq)]
[clear-highlight void] [clear-highlight void]
[max-value (extract-maximum infos)] [max-value (extract-maximum infos)]
[show-highlight [show-highlight
@ -1584,8 +1602,8 @@ profile todo:
(is-a? src text:basic<%>) (is-a? src text:basic<%>)
(number? pos) (number? pos)
(number? span)) (number? span))
(unless (hash-table-get in-edit-sequence src (λ () #f)) (unless (hash-ref in-edit-sequence src (λ () #f))
(hash-table-put! in-edit-sequence src #t) (hash-set! in-edit-sequence src #t)
(send src begin-edit-sequence)) (send src begin-edit-sequence))
(let* ([color (get-color-value (let* ([color (get-color-value
(if (eq? (preferences:get 'drscheme:profile-how-to-count) 'time) (if (eq? (preferences:get 'drscheme:profile-how-to-count) 'time)
@ -1684,17 +1702,17 @@ profile todo:
(cleanup-editor time-editor) (cleanup-editor time-editor)
(cleanup-editor src-loc-editor) (cleanup-editor src-loc-editor)
(hash-table-for-each (hash-for-each
in-edit-sequence in-edit-sequence
(λ (key val) (λ (key val)
(send key end-edit-sequence))) (send key end-edit-sequence)))
(set! clear-old-results (set! clear-old-results
(λ () (λ ()
(hash-table-for-each (hash-for-each
in-edit-sequence in-edit-sequence
(λ (key val) (send key begin-edit-sequence))) (λ (key val) (send key begin-edit-sequence)))
(clear-highlight) (clear-highlight)
(hash-table-for-each (hash-for-each
in-edit-sequence in-edit-sequence
(λ (key val) (send key end-edit-sequence))) (λ (key val) (send key end-edit-sequence)))
(set! clear-old-results void)))) (set! clear-old-results void))))
@ -1951,4 +1969,4 @@ profile todo:
(define-values/invoke-unit/infer stacktrace@))) (define-values/invoke-unit/infer stacktrace@))

16
collects/drscheme/private/drsig.ss
View File

@ -52,26 +52,26 @@
test-coverage-tab-mixin)) test-coverage-tab-mixin))
(define-signature drscheme:debug^ extends drscheme:debug-cm^ (define-signature drscheme:debug^ extends drscheme:debug-cm^
(make-debug-error-display-handler (make-debug-error-display-handler
make-debug-error-display-handler/text
make-debug-eval-handler make-debug-eval-handler
hide-backtrace-window error-display-handler/stacktrace
print-bug-to-stderr
test-coverage-enabled test-coverage-enabled
profiling-enabled profiling-enabled
add-prefs-panel add-prefs-panel
get-error-color get-error-color
show-error-and-highlight hide-backtrace-window
open-and-highlight-in-file
show-backtrace-window show-backtrace-window
open-and-highlight-in-file
get-cm-key get-cm-key
display-srcloc-in-error ;show-error-and-highlight
show-syntax-error-context)) ;print-bug-to-stderr
;display-srclocs-in-error
;show-syntax-error-context
))
(define-signature drscheme:module-langauge-cm^ (define-signature drscheme:module-langauge-cm^
(module-language<%>)) (module-language<%>))

54
collects/drscheme/private/language.ss
View File

@ -19,7 +19,8 @@
framework framework
(lib "syntax-browser.ss" "mrlib") (lib "syntax-browser.ss" "mrlib")
compiler/distribute compiler/distribute
compiler/bundle-dist) compiler/bundle-dist
"rep.ss")
(import [prefix drscheme:debug: drscheme:debug^] (import [prefix drscheme:debug: drscheme:debug^]
[prefix drscheme:tools: drscheme:tools^] [prefix drscheme:tools: drscheme:tools^]
@ -106,21 +107,6 @@
get-reader)) get-reader))
; ;;;
;
;
;;; ;;; ;;; ; ; ;;; ; ;;;
; ; ; ; ; ; ; ; ; ; ;
;;; ; ; ; ; ; ; ; ;;;;;
; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
;;; ;;;;; ;; ; ;; ;;;; ;;;;;; ;;;
;
;
;;;
(define simple-module-based-language% (define simple-module-based-language%
(class* object% (simple-module-based-language<%>) (class* object% (simple-module-based-language<%>)
(init-field module (init-field module
@ -131,7 +117,8 @@
(documentation-reference #f) (documentation-reference #f)
(reader (λ (src port) (reader (λ (src port)
(let ([v (parameterize ([read-accept-reader #t]) (let ([v (parameterize ([read-accept-reader #t])
(read-syntax src port))]) (with-stacktrace-name
(read-syntax src port)))])
(if (eof-object? v) (if (eof-object? v)
v v
(namespace-syntax-introduce v))))) (namespace-syntax-introduce v)))))
@ -149,19 +136,6 @@
;; ;;; ;; ;;
; ; ; ;
; ; ; ; ;
; ;;; ; ;;; ;;;; ;; ;; ; ;;; ;;;; ;;;; ;;; ;;; ;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
;;;;; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ;;;;; ; ; ;;;; ;;; ;;;;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;; ; ;; ;;; ;;; ; ;;; ; ;;;;;; ;;; ; ;;; ;;; ; ;;; ;;; ;;; ;
;; simple-module-based-language->module-based-language : module-based-language<%> ;; simple-module-based-language->module-based-language : module-based-language<%>
;; transforms a simple-module-based-language into a module-based-language<%> ;; transforms a simple-module-based-language into a module-based-language<%>
(define simple-module-based-language->module-based-language-mixin (define simple-module-based-language->module-based-language-mixin
@ -502,23 +476,6 @@
(read-case-sensitive ,(simple-settings-case-sensitive setting))))) (read-case-sensitive ,(simple-settings-case-sensitive setting)))))
;;;
;
; ;
; ; ;;;; ; ;;; ;;; ;;; ;; ;;;; ;;; ; ;;;
; ; ; ;; ; ; ; ; ; ; ; ; ; ;
;;;;; ; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;;;;; ;;; ;;;; ;; ;;;; ;;; ; ;;; ; ;;;; ;;;
; ;
; ;
;;; ;;;
;; module-based-language->language : module-based-language -> language<%> ;; module-based-language->language : module-based-language -> language<%>
;; given a module-based-language, implements a language ;; given a module-based-language, implements a language
(define module-based-language->language-mixin (define module-based-language->language-mixin
@ -1147,7 +1104,8 @@
(namespace-syntax-introduce (namespace-syntax-introduce
(datum->syntax (datum->syntax
#f #f
(cons '#%top-interaction s))) (cons '#%top-interaction s)
s))
s)))) s))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

3
collects/drscheme/private/module-language.ss
View File

@ -424,8 +424,7 @@
stx)) stx))
;; rewrite the module to use the scheme/base version of `module' ;; rewrite the module to use the scheme/base version of `module'
(values v-name (values v-name
#`(#,(datum->syntax #'here 'module) #`(#,(datum->syntax #'here 'module) name lang bodies ...)))]
name lang bodies ...)))]
[else [else
(raise-syntax-error 'module-language (raise-syntax-error 'module-language
"only module expressions are allowed" "only module expressions are allowed"

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

@ -1,3 +1,5 @@
#lang scheme/base
#| #|
TODO TODO
@ -17,54 +19,48 @@ TODO
;; original stdin/stdout of drscheme, instead of the ;; original stdin/stdout of drscheme, instead of the
;; user's io ports, to aid any debugging printouts. ;; user's io ports, to aid any debugging printouts.
;; (esp. useful when debugging the users's io) ;; (esp. useful when debugging the users's io)
(module rep mzscheme
(require mzlib/class (require scheme/class
mzlib/file scheme/path
mzlib/pretty scheme/pretty
mzlib/etc scheme/unit
mzlib/list scheme/list
mzlib/port
mzlib/unit
"drsig.ss" "drsig.ss"
string-constants string-constants
mred setup/xref
scheme/gui/base
framework framework
(lib "external.ss" "browser") browser/external)
(lib "default-lexer.ss" "syntax-color"))
(provide rep@) (provide rep@ with-stacktrace-name)
(define-struct unsaved-editor (editor)) (define-struct unsaved-editor (editor))
(define-syntax stacktrace-name (string->uninterned-symbol "this-is-the-funny-name")) (define stacktrace-runtime-name
(string->uninterned-symbol "this-is-the-funny-name"))
;; this macro wraps its argument expression in some code in a non-tail manner ;; this function wraps its argument expression in some code in a non-tail manner
;; so that a new name gets put onto the mzscheme stack. DrScheme's exception ;; so that a new name gets put onto the mzscheme stack. DrScheme's exception
;; handlers trims the stack starting at this point to avoid showing drscheme's ;; handlers trims the stack starting at this point to avoid showing drscheme's
;; internals on the stack in the REPL. ;; internals on the stack in the REPL.
(define-syntax (with-stacktrace-name stx) (define call-with-stacktrace-name
(syntax-case stx () (eval `(let ([,stacktrace-runtime-name
[(_ e) (lambda (thunk)
(with-syntax ([my-funny-name (syntax-local-value #'stacktrace-name)]) (begin0
(syntax (thunk)
(let ([my-funny-name (λ () (begin0 e (parameterize ([current-pseudo-random-generator (make-pseudo-random-generator)]) (void)))])
(random 1))))]) ,stacktrace-runtime-name)
((if (zero? (parameterize ([current-pseudo-random-generator (make-pseudo-random-generator)]) (make-base-namespace)))
(random 1)))
my-funny-name
values)))))]))
(define stacktrace-runtime-name (define-syntax-rule (with-stacktrace-name expr)
(let-syntax ([m (λ (x) (with-syntax ([x (syntax-local-value #'stacktrace-name)]) (call-with-stacktrace-name (lambda () expr)))
(syntax 'x)))])
(m)))
(define no-breaks-break-parameterization (define no-breaks-break-parameterization
(parameterize-break (parameterize-break
#f #f
(current-break-parameterization))) (current-break-parameterization)))
(define-unit rep@ (define-unit rep@
(import (prefix drscheme:init: drscheme:init^) (import (prefix drscheme:init: drscheme:init^)
(prefix drscheme:language-configuration: drscheme:language-configuration/internal^) (prefix drscheme:language-configuration: drscheme:language-configuration/internal^)
(prefix drscheme:language: drscheme:language^) (prefix drscheme:language: drscheme:language^)
@ -222,21 +218,7 @@ TODO
(continuation-mark-set->context (exn-continuation-marks exn))) (continuation-mark-set->context (exn-continuation-marks exn)))
(printf "\n")) (printf "\n"))
(unless (null? stack) (drscheme:debug:error-display-handler/stacktrace msg exn stack)))
(drscheme:debug:print-bug-to-stderr msg stack))
(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 src-locs stack))))))))
(define (main-user-eventspace-thread?) (define (main-user-eventspace-thread?)
(let ([rep (current-rep)]) (let ([rep (current-rep)])
@ -265,30 +247,43 @@ TODO
[else (cons top (loop (cdr stack)))]))])))) [else (cons top (loop (cdr stack)))]))]))))
;; is-cut? : any symbol -> boolean ;; is-cut? : any symbol -> boolean
;; determines if this stack entry is really ;; determines if this stack entry is drscheme's barrier in the stacktrace
(define (cut-here? top) (define (cut-here? top)
(and (pair? top) (and (pair? top)
(let* ([fn-name (car top)] (let ([fn-name (car top)])
[srcloc (cdr top)] (eq? fn-name stacktrace-runtime-name))))
[source (and srcloc (srcloc-source srcloc))])
(and (eq? fn-name stacktrace-runtime-name)
(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-element->bytes name) (car pieces))
(loop base (cdr pieces))))]))))))
(define drs-bindings-keymap (make-object keymap:aug-keymap%)) (define drs-bindings-keymap (make-object keymap:aug-keymap%))
(let ([with-drs-frame
(λ (obj f)
(when (is-a? obj editor<%>)
(let ([canvas (send obj get-canvas)])
(when canvas
(let ([frame (send canvas get-top-level-window)])
(when (is-a? frame drscheme:unit:frame%)
(f frame)))))))])
(send drs-bindings-keymap add-function (send drs-bindings-keymap add-function
"search-help-desk" "search-help-desk"
(λ (obj evt) (λ (obj evt)
(with-drs-frame
obj
(λ (frame)
(cond (cond
[(is-a? obj text%) [(is-a? obj text%)
;; this just uses the thunk argument of load-collections-xref in order
;; to ensure that there is some GUI feedback the first time the help
;; desk index is loaded.
(when frame
(let ([id 'loading-docs])
(send frame open-status-line id)
(load-collections-xref
(λ ()
(send frame update-status-line id (string-constant help-desk-loading-documentation-index))))
(send frame close-status-line id)))
(let* ([start (send obj get-start-position)] (let* ([start (send obj get-start-position)]
[end (send obj get-end-position)] [end (send obj get-end-position)]
[str (if (= start end) [str (if (= start end)
@ -304,15 +299,7 @@ TODO
get-next-settings)))))]) get-next-settings)))))])
(drscheme:help-desk:help-desk str))))] (drscheme:help-desk:help-desk str))))]
[else [else
(drscheme:help-desk:help-desk)]))) (drscheme:help-desk:help-desk)])))))
(let ([with-drs-frame
(λ (obj f)
(when (is-a? obj editor<%>)
(let ([canvas (send obj get-canvas)])
(when canvas
(let ([frame (send canvas get-top-level-window)])
(when (is-a? frame drscheme:unit:frame%)
(f frame)))))))])
(send drs-bindings-keymap add-function (send drs-bindings-keymap add-function
"execute" "execute"
@ -619,7 +606,7 @@ TODO
;; =User= (probably doesn't matter) ;; =User= (probably doesn't matter)
(define/private queue-system-callback (define/private queue-system-callback
(opt-lambda (ut thunk [always? #f]) (λ (ut thunk [always? #f])
(parameterize ([current-eventspace drscheme:init:system-eventspace]) (parameterize ([current-eventspace drscheme:init:system-eventspace])
(queue-callback (queue-callback
(λ () (λ ()
@ -790,13 +777,13 @@ TODO
;; duplicate arrows point from and to the same place -- only ;; duplicate arrows point from and to the same place -- only
;; need one arrow for each pair of locations they point to. ;; need one arrow for each pair of locations they point to.
(define/private (remove-duplicate-error-arrows error-arrows) (define/private (remove-duplicate-error-arrows error-arrows)
(let ([ht (make-hash-table 'equal)]) (let ([ht (make-hash)])
(let loop ([arrs error-arrows] (let loop ([arrs error-arrows]
[n 0]) [n 0])
(unless (null? arrs) (unless (null? arrs)
(hash-table-put! ht (car arrs) n) (hash-set! ht (car arrs) n)
(loop (cdr arrs) (+ n 1)))) (loop (cdr arrs) (+ n 1))))
(let* ([unsorted (hash-table-map ht list)] (let* ([unsorted (hash-map ht list)]
[sorted (sort unsorted (λ (x y) (<= (cadr x) (cadr y))))] [sorted (sort unsorted (λ (x y) (<= (cadr x) (cadr y))))]
[arrs (map car sorted)]) [arrs (map car sorted)])
arrs))) arrs)))
@ -999,7 +986,7 @@ TODO
(let* ([old-regions (get-regions)] (let* ([old-regions (get-regions)]
[abl (all-but-last old-regions)] [abl (all-but-last old-regions)]
[lst (car (last-pair old-regions))]) [lst (last old-regions)])
(reset-regions (append abl (list (list (list-ref lst 0) (last-position)))))) (reset-regions (append abl (list (list (list-ref lst 0) (last-position))))))
(let ([needs-execution (send context needs-execution)]) (let ([needs-execution (send context needs-execution)])
@ -1421,7 +1408,7 @@ TODO
(define/private (initialize-dispatch-handler) ;;; =User= (define/private (initialize-dispatch-handler) ;;; =User=
(let* ([primitive-dispatch-handler (event-dispatch-handler)]) (let* ([primitive-dispatch-handler (event-dispatch-handler)])
(event-dispatch-handler (event-dispatch-handler
(rec drscheme-event-dispatch-handler ; <= a name for #<...> printout (letrec ([drscheme-event-dispatch-handler ; <= a name for #<...> printout
(λ (eventspace) ; =User=, =Handler= (λ (eventspace) ; =User=, =Handler=
; Breaking is enabled if the user turned on breaks and ; Breaking is enabled if the user turned on breaks and
; is in a `yield'. If we get a break, that's ok, because ; is in a `yield'. If we get a break, that's ok, because
@ -1459,7 +1446,8 @@ TODO
(primitive-dispatch-handler eventspace)])] (primitive-dispatch-handler eventspace)])]
[else [else
; =User=, =Non-Handler=, =No-Breaks= ; =User=, =Non-Handler=, =No-Breaks=
(primitive-dispatch-handler eventspace)])))))) (primitive-dispatch-handler eventspace)]))])
drscheme-event-dispatch-handler))))
(define/public (new-empty-console) (define/public (new-empty-console)
(queue-user/wait (queue-user/wait
@ -1768,7 +1756,7 @@ TODO
(insert/delta text (format "~a" (exn-message exn)) error-delta) (insert/delta text (format "~a" (exn-message exn)) error-delta)
(when (syntax? expr) (when (syntax? expr)
(insert/delta text " in: ") (insert/delta text " in: ")
(insert/delta text (format "~s" (syntax-object->datum expr)) error-text-style-delta)) (insert/delta text (format "~s" (syntax->datum expr)) error-text-style-delta))
(insert/delta text "\n") (insert/delta text "\n")
(when (and (is-a? src text:basic%) (when (and (is-a? src text:basic%)
(number? pos) (number? pos)
@ -1849,4 +1837,4 @@ TODO
(drs-autocomplete-mixin (drs-autocomplete-mixin
(λ (txt) (send txt get-definitions-text)) (λ (txt) (send txt get-definitions-text))
(text:foreground-color-mixin (text:foreground-color-mixin
text:clever-file-format%)))))))))))))) text:clever-file-format%)))))))))))))

11
collects/drscheme/syncheck.ss
View File

@ -1124,13 +1124,10 @@ If the namespace does not, they are colored the unbound color.
(λ () ;; =drs= (λ () ;; =drs=
(show-error-report/tab)))) (show-error-report/tab))))
(drscheme:debug:show-error-and-highlight (drscheme:debug:error-display-handler/stacktrace
msg exn msg
(λ (src-to-display cms) ;; =user= exn
(parameterize ([current-eventspace drs-eventspace]) '())
(queue-callback
(λ () ;; =drs=
(send (send the-tab get-ints) highlight-errors src-to-display cms))))))
(semaphore-post error-display-semaphore))) (semaphore-post error-display-semaphore)))

32
collects/drscheme/tool-lib.ss
View File

@ -296,18 +296,20 @@ all of the names in the tools library, for use defining keybindings
; ;;;; ; ;;;;
(proc-doc/names (proc-doc/names
drscheme:debug:show-error-and-highlight drscheme:debug:error-display-handler/stacktrace
(-> string? (->* (string? any/c)
(or/c any/c exn?) ((or/c false/c (listof srcloc?)))
(-> (listof srcloc?) (or/c false/c (listof (list/c (is-a?/c text%) number? number?))) any)
any) any)
(msg exn highlight-errors) ((msg exn) ((stack #f)))
@{The first two arguments are the same as the arguments to the error-display-handler. @{Displays the error message represented by the string, adding
This function prints the error message to the current-error-port, like the default error-display-handler embellishments like those that appears in the DrScheme REPL,
and also calls @scheme[highlight-errors] to do error highlighting. It is be passed the stack trace specifically a clickable icon for the stack trace (if the srcloc location is not empty),
for the error message. and a clickable icon for the source of the error (read & syntax errors show their source
locations and otherwise the first place in the stack trace is shown).
This function should be called on the same thread/eventspace where the error happened.}) If @scheme[stack] is false, then the stack trace embedded in the @scheme[exn] argument (if any) is used.
This should be called in the same eventspace and on the same thread as the error.})
(proc-doc/names (proc-doc/names
drscheme:debug:make-debug-error-display-handler drscheme:debug:make-debug-error-display-handler
@ -323,7 +325,7 @@ all of the names in the tools library, for use defining keybindings
@scheme[drscheme:debug:make-debug-eval-handler]. @scheme[drscheme:debug:make-debug-eval-handler].
See also MzScheme's See also MzScheme's
MzLink{mz:p:error-display-handler}{error-display-handler} @scheme[error-display-handler]
parameter. parameter.
If the current-error-port is the definitions window in If the current-error-port is the definitions window in
@ -345,7 +347,7 @@ all of the names in the tools library, for use defining keybindings
This function is designed to work in conjunction with This function is designed to work in conjunction with
@scheme[drscheme:debug:make-debug-error-display-handler]. @scheme[drscheme:debug:make-debug-error-display-handler].
See also MzScheme's MzLink{mz:p:eval-handler}{eval-handler} See also MzScheme's @scheme[eval-handler]
parameter. parameter.
The resulting eval-handler expands and annotates the input The resulting eval-handler expands and annotates the input
@ -384,10 +386,8 @@ all of the names in the tools library, for use defining keybindings
(srcloc? . -> . void?) (srcloc? . -> . void?)
(debug-info) (debug-info)
@{This function opens a DrScheme to display @{This function opens a DrScheme to display
@scheme[debug-info]. The first element in @scheme[debug-info]. Only the src the position
the cons indicates where the file is and the span fields of the srcloc are considered.
and the two number indicate a range of
text to show.
See also See also
@scheme[drscheme:debug:get-cm-key].}) @scheme[drscheme:debug:get-cm-key].})

BIN
collects/icons/stop-16x16.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 836 B

BIN
collects/icons/stop-multi.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.8 KiB

After

Width:  |  Height:  |  Size: 1.1 KiB

5
collects/string-constants/english-string-constants.ss
View File

@ -329,6 +329,11 @@ please adhere to these guidelines:
(help-desk-this-is-just-example-text (help-desk-this-is-just-example-text
"This is just example text for setting the font size. Open Help Desk proper (from Help menu) to follow these links.") "This is just example text for setting the font size. Open Help Desk proper (from Help menu) to follow these links.")
;; this appears in the bottom part of the frame the first time the user hits `f1'
;; (assuming nothing else has loaded the documentation index first)
;; see also: cs-status-loading-docs-index
(help-desk-loading-documentation-index "Help Desk: loading documentation index")
;; Help desk htty proxy ;; Help desk htty proxy
(http-proxy "HTTP Proxy") (http-proxy "HTTP Proxy")
(proxy-direct-connection "Direct connection") (proxy-direct-connection "Direct connection")

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

File diff suppressed because it is too large Load Diff

12
collects/tests/drscheme/module-lang-test.ss
View File

@ -45,7 +45,7 @@
(regexp "first>")) (regexp "first>"))
(make-test "(module m mzscheme (require (all-except (lib \"list.ss\") foldl)))" (make-test "(module m mzscheme (require (all-except (lib \"list.ss\") foldl)))"
"foldl" "foldl"
". reference to an identifier before its definition: foldl") ". . reference to an identifier before its definition: foldl")
(make-test "(module m mzscheme (require (prefix mz: mzscheme)))" "mz:+" #rx"procedure:+") (make-test "(module m mzscheme (require (prefix mz: mzscheme)))" "mz:+" #rx"procedure:+")
@ -72,7 +72,7 @@
`(module m (file ,(path->string (build-path this-dir "module-lang-test-tmp.ss"))) `(module m (file ,(path->string (build-path this-dir "module-lang-test-tmp.ss")))
x)) x))
"+" "+"
". reference to an identifier before its definition: +") ". . reference to an identifier before its definition: +")
(make-test (format "~s" '(module m mzscheme (provide lambda))) (make-test (format "~s" '(module m mzscheme (provide lambda)))
"(lambda (x) x)" "(lambda (x) x)"
@ -83,14 +83,14 @@
"1") "1")
(make-test (format "~s" '(module m mzscheme (define-syntax s (syntax 1)) (provide s))) (make-test (format "~s" '(module m mzscheme (define-syntax s (syntax 1)) (provide s)))
"s" "s"
"s: illegal use of syntax in: s") ". s: illegal use of syntax in: s")
(make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define a 10)) x x)) (make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define a 10)) x x))
"a" "a"
". reference to an identifier before its definition: a") ". . reference to an identifier before its definition: a")
(make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define-syntax (a stx) #'10)) x x)) (make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define-syntax (a stx) #'10)) x x))
"a" "a"
". reference to an identifier before its definition: a") ". . reference to an identifier before its definition: a")
(make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define a 10)) x x (define a 77))) (make-test (format "~s" '(module m mzscheme (define-syntax (x stx) #'(define a 10)) x x (define a 77)))
"a" "a"
"77") "77")
@ -210,7 +210,7 @@
[(regexp? (test-result test)) [(regexp? (test-result test))
(regexp-match (test-result test) after-int-output)])]) (regexp-match (test-result test) after-int-output)])])
(unless passed? (unless passed?
(printf "FAILED: ~a\n ~a\n expected: ~a\n got: ~a\n" (printf "FAILED: ~a\n ~a\n expected: ~s\n got: ~s\n"
(test-definitions test) (test-definitions test)
(or (test-interactions test) 'no-interactions) (or (test-interactions test) 'no-interactions)
(test-result test) (test-result test)

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

File diff suppressed because it is too large Load Diff

4
doc/release-notes/drscheme/HISTORY.txt
View File

@ -18,6 +18,10 @@
. removed help-desk:help-desk from the tools interface. . removed help-desk:help-desk from the tools interface.
Use the help collection instead. Use the help collection instead.
. removed drscheme:debug:show-error-and-highlight from
the tools interface. Use drscheme:debug:error-display-handler/stacktrace
instead.
------------------------------ ------------------------------
Version 372 Version 372
------------------------------ ------------------------------