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

misc changes: flush io in make.ss, remove unused require in world.ss, improved test suite, made drscheme use new built-in srcloc debugging info provided by mzscheme

Browse Source 
svn: r1708
This commit is contained in:
Robby Findler 2005-12-29 14:10:47 +00:00
parent 67ad8cee68
commit 26c844adc6
8 changed files with 73 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -227,14 +227,7 @@ profile todo:
(orig-error-display-handler msg exn)])))
debug-error-display-handler)
(define (show-error-and-highlight msg exn highlight-errors)
(let* ([cms (and (exn? exn)
(continuation-mark-set? (exn-continuation-marks exn))
(continuation-mark-set->list
(exn-continuation-marks exn)
cm-key))])
(when (and cms
(pair? cms))
(define (print-bug-to-stderr msg cms)
(let ([note% (if (mf-bday?) mf-note% bug-note%)])
(when note%
(let ([note (new note%)])
@ -242,6 +235,17 @@ profile todo:
(write-special note (current-error-port))
(display #\space (current-error-port))))))
(define (show-error-and-highlight msg exn highlight-errors)
(let ([cms
(and (exn? exn)
(continuation-mark-set? (exn-continuation-marks exn))
(continuation-mark-set->list
(exn-continuation-marks exn)
cm-key))])
(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)

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

@ -46,6 +46,7 @@
make-debug-error-display-handler/text
make-debug-eval-handler
hide-backtrace-window
print-bug-to-stderr
profile-definitions-text-mixin
profile-tab-mixin

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

@ -172,9 +172,25 @@ 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)
(let ([src-locs (if (exn:srclocs? exn)
(let* ([srclocs-stack
(filter values (map cdr (continuation-mark-set->context (exn-continuation-marks exn))))]
[stack
(filter
values
(map (λ (srcloc)
(let ([source (srcloc-source srcloc)]
[pos (srcloc-position srcloc)]
[span (srcloc-span srcloc)])
(and source pos span
(cons source (cons pos span)))))
srclocs-stack))]
[src-locs (if (exn:srclocs? exn)
((exn:srclocs-accessor exn) exn)
'())])
(if (null? stack)
'()
(list (car srclocs-stack))))])
(unless (null? 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)
@ -187,7 +203,9 @@ TODO
(parameterize ([current-eventspace drscheme:init:system-eventspace])
(queue-callback
(λ ()
(send rep highlight-errors/exn exn))))))))
(send rep highlight-errors
src-locs
(filter (λ (x) (is-a? (car x) text%)) stack)))))))))
;; drscheme-error-value->string-handler : TST number -> string
(define (drscheme-error-value->string-handler x n)

3
collects/htdp/world.ss
View File

@ -2,8 +2,7 @@
;; Fri Dec 9 21:39:03 EST 2005: remoevd (update ... produce ...); added on-redraw
;; Thu Dec 1 17:03:03 EST 2005: fixed place-image; all coordinates okay now
(module world mzscheme
(require ; (lib "unitsig.ss")
(lib "etc.ss")
(require
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "error.ss" "htdp")

7
collects/make/make-unit.ss
View File

@ -99,7 +99,8 @@
(when (and (make-print-checking)
(or line
(make-print-dep-no-line)))
(printf "make: ~achecking ~a~n" indent s))
(printf "make: ~achecking ~a~n" indent s)
(flush-output))
(if line
(let ([deps (cadr line)])
@ -134,6 +135,7 @@
(format " because (reason: ~a date: ~a)"
reason date))])
""))
(flush-output)
(with-handlers ([exn:fail?
(lambda (exn)
(raise (make-exn:fail:make
@ -161,7 +163,8 @@
(for-each (lambda (item)
(printf "make: made ~a~n" (path-string->string item)))
(reverse made))))
(reverse made))
(flush-output)))
(define make/proc
(case-lambda

8
collects/tests/drscheme/io.ss
View File

@ -29,14 +29,16 @@ add this test:
(clear-definitions drs-frame)
(type-in-definitions drs-frame expression)
(do-execute drs-frame)
(let* ([got (get-annotated-output)])
(unless (andmap (λ (exp got)
(let ([got (get-annotated-output)])
(unless (and (= (length expected)
(length got))
(andmap (λ (exp got)
(and (string=? (car exp) (car got))
(or (equal? (cadr exp) (cadr got))
(and (procedure? (cadr exp))
((cadr exp) (cadr got))))))
expected
got)
got))
(fprintf (current-error-port)
"expected ~s, got ~s for ~s\n\n"
expected

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

@ -1183,14 +1183,17 @@ the settings above should match r5rs
(printf (make-err-msg defs-expected)
'definitions (language) expression defs-expected got)))
(let ([s (make-semaphore 0)])
(queue-callback
(λ ()
(send definitions-text select-all)
(send definitions-text copy)
(send interactions-text set-position
(send interactions-text last-position)
(send interactions-text last-position))
(send interactions-text paste)
(semaphore-post s)))
(semaphore-wait s))
(let ([last-para (send interactions-text last-paragraph)])
(type-in-interactions drs (string #\newline))
@ -1220,11 +1223,11 @@ the settings above should match r5rs
(let ([drs (wait-for-drscheme-frame)])
(fw:test:menu-select "Language" "Clear All Teachpacks"))
(go mred)
(go mzscheme)
(go beginner)
(go beginner/abbrev)
(go intermediate)
(go intermediate/lambda)
(go advanced)
(go r5rs)
(go mred)
(go mzscheme)))
(go r5rs)))

9
collects/tests/drscheme/teachpack.ss
View File

@ -193,9 +193,9 @@
(let* ([test-teachpack
(lambda (dir)
(lambda (teachpack)
(when (or (equal? "ss" (filename-extension teachpack))
(equal? "scm" (filename-extension teachpack)))
(unless (equal? "graphing.ss" teachpack)
(when (or (equal? #"ss" (filename-extension teachpack))
(equal? #"scm" (filename-extension teachpack)))
(unless (equal? "graphing.ss" (path->string teachpack))
(printf " testing ~a~n" (build-path dir teachpack))
(let ([filename (normal-case-path (build-path dir teachpack))])
(fw:test:menu-select "Language" "Clear All Teachpacks")
@ -212,7 +212,8 @@
(printf " got: ~s~n expected: ~s~n" got expected))))))))]
[test-teachpacks
(lambda (dir)
(for-each (test-teachpack dir) (directory-list dir)))]
(for-each (test-teachpack dir)
(directory-list dir)))]
[teachpack-dir (normalize-path (build-path (collection-path "mzlib") 'up 'up "teachpack"))])
(set-language-level! '("How to Design Programs" "Advanced Student"))
(test-teachpacks teachpack-dir)