diff --git a/drracket-test/tests/drracket/memory-log.rkt b/drracket-test/tests/drracket/memory-log.rkt index 3aa0d567f..0e6ebbc02 100644 --- a/drracket-test/tests/drracket/memory-log.rkt +++ b/drracket-test/tests/drracket/memory-log.rkt @@ -18,57 +18,47 @@ (let loop ([cmu (current-memory-use)] [n 20]) (collect-garbage) - (let ([new-cmu (current-memory-use)]) - (cond - [(or (< n 0) - (< (abs (- cmu new-cmu)) - (* 0.01 cmu))) - new-cmu] - [else - (loop new-cmu (- n 1))])))) + (define new-cmu (current-memory-use)) + (cond + [(or (< n 0) (< (abs (- cmu new-cmu)) (* 0.01 cmu))) new-cmu] + [else (loop new-cmu (- n 1))]))) (void (putenv "PLTDRPLACEPRINT" "yes")) (define (wait-and-print) - (let ([s (make-semaphore 0)]) - ;; let two rounds of pending events be handled. - (queue-callback (λ () (queue-callback (λ () (semaphore-post s)) #f)) #f) - (yield s) - - ;; print out memory use in a fake form to be tracked by drdr - (let ([n (mem-cnt)]) - (printf "cpu time: ~a real time: ~a gc time: ~a\n" - n n n)))) + (define s (make-semaphore 0)) + ;; let two rounds of pending events be handled. + (queue-callback (λ () (queue-callback (λ () (semaphore-post s)) #f)) #f) + (yield s) + + ;; print out memory use in a fake form to be tracked by drdr + (define n (mem-cnt)) + (printf "cpu time: ~a real time: ~a gc time: ~a\n" n n n)) (fire-up-drracket-and-run-tests (λ () - (let ([drs-frame (wait-for-drracket-frame)]) - - ;; initial startup memory use - (wait-and-print) - - ;; figure out the memory use after running check syntax once (and so the docs - ;; have been loaded) - (queue-callback - (λ () (send (send drs-frame get-definitions-text) insert "#lang racket/base\n+"))) - (set-module-language!) - (test:run-one (lambda () (send (send drs-frame syncheck:get-button) command))) - (wait-for-computation drs-frame) - (wait-and-print) - - ;; figure out the memory use after letting online check syntax run once - ;; (so a place has been created and the docs loaded again (in the other place - ;; this time)) - - ; clear out the check synax results from before - (queue-callback/res (λ () (send (send drs-frame get-definitions-text) insert "\n"))) - (poll-until - (λ () - (not (send (send drs-frame get-definitions-text) syncheck:arrows-visible?)))) - - ; enable online check syntax and wait for the results to appear - (queue-callback/res (λ () (preferences:set 'drracket:online-compilation-default-on #t))) - (poll-until - (λ () - (send (send drs-frame get-definitions-text) syncheck:arrows-visible?))) - (wait-and-print)))) + (define drs-frame (wait-for-drracket-frame)) + + ;; initial startup memory use + (wait-and-print) + + ;; figure out the memory use after running check syntax once (and so the docs + ;; have been loaded) + (queue-callback (λ () (send (send drs-frame get-definitions-text) insert "#lang racket/base\n+"))) + (set-module-language!) + (test:run-one (lambda () (send (send drs-frame syncheck:get-button) command))) + (wait-for-computation drs-frame) + (wait-and-print) + + ;; figure out the memory use after letting online check syntax run once + ;; (so a place has been created and the docs loaded again (in the other place + ;; this time)) + + ; clear out the check synax results from before + (queue-callback/res (λ () (send (send drs-frame get-definitions-text) insert "\n"))) + (poll-until (λ () (not (send (send drs-frame get-definitions-text) syncheck:arrows-visible?)))) + + ; enable online check syntax and wait for the results to appear + (queue-callback/res (λ () (preferences:set 'drracket:online-compilation-default-on #t))) + (poll-until (λ () (send (send drs-frame get-definitions-text) syncheck:arrows-visible?))) + (wait-and-print))) diff --git a/drracket-test/tests/drracket/online-compilation-zo-creation.rkt b/drracket-test/tests/drracket/online-compilation-zo-creation.rkt index d31982725..56e0415e9 100644 --- a/drracket-test/tests/drracket/online-compilation-zo-creation.rkt +++ b/drracket-test/tests/drracket/online-compilation-zo-creation.rkt @@ -33,7 +33,7 @@ (fire-up-drracket-and-run-tests (λ () - (define tmp-dir (make-temporary-file "online-compilation-zo-creation~a" 'directory)) + (define tmp-dir (make-temporary-directory "online-compilation-zo-creation~a")) ;; 1. setup the files used in the test diff --git a/drracket-test/tests/drracket/snips.rkt b/drracket-test/tests/drracket/snips.rkt index 8cfb75d50..efc635b76 100644 --- a/drracket-test/tests/drracket/snips.rkt +++ b/drracket-test/tests/drracket/snips.rkt @@ -10,7 +10,7 @@ (λ () (define drs (wait-for-drracket-frame)) - (define tmpdir (make-temporary-file "drracketsniptest~a" 'directory)) + (define tmpdir (make-temporary-directory "drracketsniptest~a")) (define defs (queue-callback/res (λ () (send drs get-definitions-text)))) (for ([rfile (in-list (directory-list snip))]) (define file (build-path snip rfile)) diff --git a/drracket-test/tests/drracket/syncheck-eval-compile-time.rkt b/drracket-test/tests/drracket/syncheck-eval-compile-time.rkt index 0678db10e..44f20d6c6 100644 --- a/drracket-test/tests/drracket/syncheck-eval-compile-time.rkt +++ b/drracket-test/tests/drracket/syncheck-eval-compile-time.rkt @@ -7,15 +7,14 @@ (define (main) (fire-up-drracket-and-run-tests (λ () - (let ([drs (wait-for-drracket-frame)]) - (set-module-language!) - (do-execute drs) - (queue-callback/res - (λ () - (preferences:set 'framework:coloring-active #f) - (handler:edit-file (collection-file-path "map.rkt" "racket" "private")))) - - (click-check-syntax-and-check-errors drs "syncheck-eval-compile-time.rkt"))))) + (define drs (wait-for-drracket-frame)) + (set-module-language!) + (do-execute drs) + (queue-callback/res (λ () + (preferences:set 'framework:coloring-active #f) + (handler:edit-file (collection-file-path "map.rkt" "racket" "private")))) + + (click-check-syntax-and-check-errors drs "syncheck-eval-compile-time.rkt")))) ;; copied from syncheck-test.rkt .... @@ -25,11 +24,9 @@ (when (queue-callback/res (λ () (send (send drs get-definitions-text) in-edit-sequence?))) (error 'syncheck-test.rkt "still in edit sequence for ~s" test)) - (let ([err (queue-callback/res (λ () (send drs syncheck:get-error-report-contents)))]) - (when err - (eprintf "FAILED ~s\n error report window is visible:\n ~a\n" - test - err)))) + (define err (queue-callback/res (λ () (send drs syncheck:get-error-report-contents)))) + (when err + (eprintf "FAILED ~s\n error report window is visible:\n ~a\n" test err))) (define (click-check-syntax-button drs) (test:run-one (lambda () (send (send drs syncheck:get-button) command)))) diff --git a/drracket-test/tests/drracket/syncheck-test.rkt b/drracket-test/tests/drracket/syncheck-test.rkt index cc9cb0bc1..dca5af649 100644 --- a/drracket-test/tests/drracket/syncheck-test.rkt +++ b/drracket-test/tests/drracket/syncheck-test.rkt @@ -37,11 +37,16 @@ (define-struct prefix-test (line input pos prefix output) #:transparent) (define-struct err-test (line input expected locations) #:transparent) - (define build-test/proc - (λ (line input expected [arrow-table '()] #:tooltips [tooltips #f] - #:setup [setup void] #:teardown [teardown void] #:extra-files [extra-files (hash)] - #:extra-info? [extra-info? #f]) - (make-test line input expected arrow-table tooltips setup teardown extra-files extra-info?))) + (define (build-test/proc line + input + expected + [arrow-table '()] + #:tooltips [tooltips #f] + #:setup [setup void] + #:teardown [teardown void] + #:extra-files [extra-files (hash)] + #:extra-info? [extra-info? #f]) + (make-test line input expected arrow-table tooltips setup teardown extra-files extra-info?)) (define-syntax (build-test stx) (syntax-case stx () @@ -1754,7 +1759,7 @@ (define (main) - (define temp-dir (normalize-path (make-temporary-file "syncheck-test~a" 'directory))) + (define temp-dir (normalize-path (make-temporary-directory "syncheck-test~a"))) (dynamic-wind void (λ () diff --git a/drracket-test/tests/drracket/time-keystrokes.rkt b/drracket-test/tests/drracket/time-keystrokes.rkt index 38edf3c70..6b3471281 100644 --- a/drracket-test/tests/drracket/time-keystrokes.rkt +++ b/drracket-test/tests/drracket/time-keystrokes.rkt @@ -42,10 +42,10 @@ (let loop ([n 10]) (when (zero? n) (error 'time-keystrokes "could not find drracket frame")) - (let ([front-frame (test:get-active-top-level-window)]) - (unless (eq? front-frame frame) - (sleep 1/10) - (loop (- n 1))))) + (define front-frame (test:get-active-top-level-window)) + (unless (eq? front-frame frame) + (sleep 1/10) + (loop (- n 1)))) (let ([win (send frame get-definitions-canvas)]) (send win focus) (time (send-key-events win chars-to-test))) diff --git a/drracket-tool-lib/drracket/private/standalone-module-browser.rkt b/drracket-tool-lib/drracket/private/standalone-module-browser.rkt index 31ca6ecd4..ce7bdb865 100644 --- a/drracket-tool-lib/drracket/private/standalone-module-browser.rkt +++ b/drracket-tool-lib/drracket/private/standalone-module-browser.rkt @@ -412,13 +412,13 @@ ;; note: the preference drracket:module-browser:name-length is also used for ;; the View|Show Module Browser version of the module browser ;; here we just treat any pref value except '3' as if it were for the long names. - (let ([selection (send module-browser-name-length-choice get-selection)]) - (preferences:set 'drracket:module-browser:name-length (+ 2 selection)) - (send pasteboard - set-name-length - (case selection - [(0) 'long] - [(1) 'very-long]))))))) + (define selection (send module-browser-name-length-choice get-selection)) + (preferences:set 'drracket:module-browser:name-length (+ 2 selection)) + (send pasteboard + set-name-length + (case selection + [(0) 'long] + [(1) 'very-long])))))) (send pkg-choice set-string-selection (send pasteboard get-main-file-pkg)) (define ec (make-object overview-editor-canvas% vp pasteboard)) @@ -461,17 +461,18 @@ (set! update-label (λ (s) - (if (and s (not (null? s))) - (let* ([currently-over (car s)] - [fn (send currently-over get-filename)] - [lines (send currently-over get-lines)]) - (when (and fn lines) - (define label (format filename-constant fn lines)) - (define pkg (send currently-over get-pkg)) - (when pkg - (set! label (string-append (format pkg-constant pkg) " " label))) - (send label-message set-label label))) - (send label-message set-label "")))) + (cond + [(and s (not (null? s))) + (define currently-over (car s)) + (define fn (send currently-over get-filename)) + (define lines (send currently-over get-lines)) + (when (and fn lines) + (define label (format filename-constant fn lines)) + (define pkg (send currently-over get-pkg)) + (when pkg + (set! label (string-append (format pkg-constant pkg) " " label))) + (send label-message set-label label))] + [else (send label-message set-label "")]))) (send pasteboard set-name-length @@ -937,7 +938,7 @@ (call-with-input-file filename (λ (port) (let loop ([n 0]) - (define l (read-line port)) + (define l (read-line port 'any)) (if (eof-object? l) n (loop (+ n 1))))) @@ -1059,24 +1060,25 @@ (let loop ([snips this-level-snips] [minor-dim (/ (- max-minor this-minor) 2)]) (unless (null? snips) - (let* ([snip (car snips)] - [new-major-coord (+ major-dim - (floor (- (/ this-major 2) - (/ (if vertical? - (get-snip-height snip) - (get-snip-width snip)) - 2))))]) - (if vertical? - (move-to snip minor-dim new-major-coord) - (move-to snip new-major-coord minor-dim)) - (loop (cdr snips) - (+ minor-dim - (if vertical? - (get-snip-hspace) - (get-snip-vspace)) - (if vertical? - (get-snip-width snip) - (get-snip-height snip))))))) + (define snip (car snips)) + (define new-major-coord + (+ major-dim + (floor (- (/ this-major 2) + (/ (if vertical? + (get-snip-height snip) + (get-snip-width snip)) + 2))))) + (if vertical? + (move-to snip minor-dim new-major-coord) + (move-to snip new-major-coord minor-dim)) + (loop (cdr snips) + (+ minor-dim + (if vertical? + (get-snip-hspace) + (get-snip-vspace)) + (if vertical? + (get-snip-width snip) + (get-snip-height snip)))))) (loop (cdr levels) (+ major-dim (if vertical? @@ -1119,8 +1121,8 @@ (let loop ([snip (find-first-snip)]) (when snip (when (is-a? snip boxed-word-snip<%>) - (let ([filename (send snip get-filename)]) - (on-boxed-word-double-click filename))) + (define filename (send snip get-filename)) + (on-boxed-word-double-click filename)) (loop (send snip next)))))]) (send canvas popup-menu right-button-menu (+ (send evt get-x) 1) (+ (send evt get-y) 1))] [else (super on-event evt)])) @@ -1256,19 +1258,20 @@ "" (string (string-ref word 0)))] [(medium) - (let ([m (regexp-match #rx"^(.*)\\.[^.]*$" word)]) - (let ([short-name (if m - (cadr m) - word)]) - (if (string=? short-name "") - "" - (let ([ms (regexp-match* #rx"-[^-]*" short-name)]) - (cond - [(null? ms) (substring short-name 0 (min 2 (string-length short-name)))] - [else - (apply string-append - (cons (substring short-name 0 1) - (map (λ (x) (substring x 1 2)) ms)))])))))] + (define m (regexp-match #rx"^(.*)\\.[^.]*$" word)) + (define short-name + (if m + (cadr m) + word)) + (if (string=? short-name "") + "" + (let ([ms (regexp-match* #rx"-[^-]*" short-name)]) + (cond + [(null? ms) (substring short-name 0 (min 2 (string-length short-name)))] + [else + (apply string-append + (cons (substring short-name 0 1) + (map (λ (x) (substring x 1 2)) ms)))])))] [(long) word] [(very-long) (string-append word ": " (format "~s" require-phases))])) last-name])) @@ -1345,16 +1348,16 @@ (λ () (moddep-current-open-input-file (λ (filename) - (let* ([p (open-input-file filename)] - [wxme? (regexp-match-peek #rx#"^WXME" p)]) - (if wxme? - (let ([t (new text%)]) - (close-input-port p) - (send t load-file filename) - (let ([prt (open-input-text-editor t)]) - (port-count-lines! prt) - prt)) - p)))) + (define p (open-input-file filename)) + (define wxme? (regexp-match-peek #rx#"^WXME" p)) + (if wxme? + (let ([t (new text%)]) + (close-input-port p) + (send t load-file filename) + (let ([prt (open-input-text-editor t)]) + (port-count-lines! prt) + prt)) + p))) (current-load-relative-directory #f) (define relative? (eq? init-dir 'relative)) (unless relative? ; already there diff --git a/drracket/drracket/private/syncheck/gui.rkt b/drracket/drracket/private/syncheck/gui.rkt index f820313fa..450fd0da8 100644 --- a/drracket/drracket/private/syncheck/gui.rkt +++ b/drracket/drracket/private/syncheck/gui.rkt @@ -2259,7 +2259,7 @@ If the namespace does not, they are colored the unbound color. ;; if we've been asked to stop (because some new results are ready ;; and another trace is running). (void)] - [(and (i . > . 0) ;; check i just in case things are really strange + [(and (positive? i) ;; check i just in case things are really strange (20 . <= . (- (current-inexact-milliseconds) start-time))) (queue-callback (λ () diff --git a/drracket/drracket/private/syncheck/online-comp.rkt b/drracket/drracket/private/syncheck/online-comp.rkt index bd53d1536..b09a3a4b1 100644 --- a/drracket/drracket/private/syncheck/online-comp.rkt +++ b/drracket/drracket/private/syncheck/online-comp.rkt @@ -67,9 +67,9 @@ (make-traversal (current-namespace) (get-init-dir path))) (parameterize ([current-annotations obj]) - (for ([stx (in-list stxes)]) - (when (equal? (syntax-source stx) the-source) - (expanded-expression stx))) + (for ([stx (in-list stxes)] + #:when (equal? (syntax-source stx) the-source)) + (expanded-expression stx)) (expansion-completed)) (send obj get-trace))) diff --git a/drracket/help/bug-report.rkt b/drracket/help/bug-report.rkt index e0aef91ea..4c6964194 100644 --- a/drracket/help/bug-report.rkt +++ b/drracket/help/bug-report.rkt @@ -29,7 +29,7 @@ [s (if (<= (string-length s) 200) s (substring s 0 200))]) - (and ((string-length s) . > . 0) s))) + (and (positive? (string-length s)) s))) (preferences:set-default 'drracket:email "" string? #:aliases '(drscheme:email)) (preferences:set-default 'drracket:full-name "" string? #:aliases '(drscheme:full-name))