diff --git a/drracket-core-lib/drracket/drracket.rkt b/drracket-core-lib/drracket/drracket.rkt index 6f3647f00..58fc4be1c 100644 --- a/drracket-core-lib/drracket/drracket.rkt +++ b/drracket-core-lib/drracket/drracket.rkt @@ -30,29 +30,26 @@ (define vec (sync evt)) (define str (vector-ref vec 1)) (when (regexp-match #rx"^cm: *compil(ing|ed)" str) - (display str) - (newline)) + (displayln str)) (loop)))))) (cond [debugging? (flprintf "PLTDRDEBUG: loading CM to load/create errortrace zos\n") - (let-values ([(zo-compile - make-compilation-manager-load/use-compiled-handler) - (parameterize ([current-namespace (make-base-empty-namespace)] - [use-compiled-file-paths '()]) - (values - (dynamic-require 'errortrace/zo-compile 'zo-compile) - (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)))]) - (flprintf "PLTDRDEBUG: installing CM to load/create errortrace zos\n") - (current-compile zo-compile) - (use-compiled-file-paths (list (build-path compiled-dir "errortrace"))) - (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)) - (error-display-handler (dynamic-require 'errortrace/errortrace-lib - 'errortrace-error-display-handler)) - (when cm-trace? - (flprintf "PLTDRDEBUG: enabling CM tracing\n") - (run-trace-thread)))] + (define-values (zo-compile make-compilation-manager-load/use-compiled-handler) + (parameterize ([current-namespace (make-base-empty-namespace)] + [use-compiled-file-paths '()]) + (values (dynamic-require 'errortrace/zo-compile 'zo-compile) + (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)))) + (flprintf "PLTDRDEBUG: installing CM to load/create errortrace zos\n") + (current-compile zo-compile) + (use-compiled-file-paths (list (build-path compiled-dir "errortrace"))) + (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)) + (error-display-handler (dynamic-require 'errortrace/errortrace-lib + 'errortrace-error-display-handler)) + (when cm-trace? + (flprintf "PLTDRDEBUG: enabling CM tracing\n") + (run-trace-thread))] [install-cm? (flprintf "PLTDRCM: loading compilation manager\n") (define make-compilation-manager-load/use-compiled-handler @@ -91,13 +88,12 @@ (for/list ([x (in-list (find-relevant-directories (list id)))]) (define proc (get-info/full x)) (if proc - (map (λ (dirs) - (apply build-path - x - (if (list? dirs) - dirs - (list dirs)))) - (proc id (λ () '()))) + (for/list ([dirs (in-list (proc id (λ () '())))]) + (apply build-path + x + (if (list? dirs) + dirs + (list dirs)))) '())))) (define make-compilation-manager-load/use-compiled-handler diff --git a/drracket-core-lib/drracket/sprof.rkt b/drracket-core-lib/drracket/sprof.rkt index 9cfe9e625..695dce023 100644 --- a/drracket-core-lib/drracket/sprof.rkt +++ b/drracket-core-lib/drracket/sprof.rkt @@ -16,13 +16,11 @@ (sleep pause-time) (define new-traces (map (λ (t) (continuation-mark-set->context (continuation-marks t))) (get-threads))) - (for-each (λ (trace) - (for-each (λ (line) - (hash-set! traces-table - line - (cons trace (hash-ref traces-table line '())))) - trace)) - new-traces) + (for ([trace (in-list new-traces)]) + (for-each + (λ (line) + (hash-set! traces-table line (cons trace (hash-ref traces-table line '())))) + trace)) (cond [(zero? i) (update-gui traces-table) @@ -38,8 +36,8 @@ (format "~a:~a~a" (cond [(path? (srcloc-source src)) - (let-values ([(base name dir?) (split-path (srcloc-source src))]) - name)] + (define-values (base name dir?) (split-path (srcloc-source src))) + name] [else (srcloc-source src)]) (if (srcloc-line src) (format "~a:~a" (srcloc-line src) (srcloc-column src)) @@ -108,14 +106,14 @@ [(send event button-up? 'left) (define admin (get-admin)) (when admin - (let ([dc (send admin get-dc)]) - (let-values ([(x y) (dc-location-to-editor-location (send event get-x) - (send event get-y))]) - (let* ([loc (find-position x y)] - [para (position-paragraph loc)]) - (set! clicked-srcloc-pr - (and (<= 0 para (last-paragraph)) (car (list-ref gui-display-data para)))) - (update-gui-display)))))] + (send admin get-dc) + (define-values (x y) + (dc-location-to-editor-location (send event get-x) (send event get-y))) + (define loc (find-position x y)) + (define para (position-paragraph loc)) + (set! clicked-srcloc-pr + (and (<= 0 para (last-paragraph)) (car (list-ref gui-display-data para)))) + (update-gui-display))] [else (void)])) (define/public (set-gui-display-data/refresh traces-table) @@ -138,12 +136,11 @@ (set! clear-old-pr void) (define denom-ht (make-hasheq)) (define filtered-gui-display-data - (map (λ (pr) - (let ([id (car pr)] - [stacks (filter-stacks (cdr pr))]) - (for-each (λ (stack) (hash-set! denom-ht stack #t)) stacks) - (cons id stacks))) - gui-display-data)) + (for/list ([pr (in-list gui-display-data)]) + (define id (car pr)) + (define stacks (filter-stacks (cdr pr))) + (for-each (λ (stack) (hash-set! denom-ht stack #t)) stacks) + (cons id stacks))) (define denom-count (hash-count denom-ht)) (let loop ([prs filtered-gui-display-data] [first? #t] @@ -151,22 +148,22 @@ (cond [(null? prs) (void)] [else - (let* ([pr (car prs)] - [fn (car pr)] - [count (length (cdr pr))]) - (cond - [(zero? count) (loop (cdr prs) first? i)] - [else - (unless first? - (insert "\n")) - (let ([before (last-position)]) - (hash-set! line-to-source i pr) - (insert (format-percentage (/ count denom-count))) - (insert (format " ~a" (format-fn-name fn))) - (let ([after (last-position)]) - (when (equal? (car pr) clicked-srcloc-pr) - (set! clear-old-pr (highlight-range before after "NavajoWhite"))))) - (loop (cdr prs) #f (+ i 1))]))])) + (define pr (car prs)) + (define fn (car pr)) + (define count (length (cdr pr))) + (cond + [(zero? count) (loop (cdr prs) first? i)] + [else + (unless first? + (insert "\n")) + (let ([before (last-position)]) + (hash-set! line-to-source i pr) + (insert (format-percentage (/ count denom-count))) + (insert (format " ~a" (format-fn-name fn))) + (let ([after (last-position)]) + (when (equal? (car pr) clicked-srcloc-pr) + (set! clear-old-pr (highlight-range before after "NavajoWhite"))))) + (loop (cdr prs) #f (+ i 1))])])) (lock #t) (end-edit-sequence) (update-info-editor clicked-srcloc-pr) @@ -373,11 +370,10 @@ (define/public (get-threads-to-profile) (define thds '()) (let loop ([cust (get-user-custodian)]) - (for-each (λ (obj) - (cond - [(custodian? obj) (loop obj)] - [(thread? obj) (set! thds (cons obj thds))])) - (custodian-managed-list cust system-custodian))) + (for ([obj (in-list (custodian-managed-list cust system-custodian))]) + (cond + [(custodian? obj) (loop obj)] + [(thread? obj) (set! thds (cons obj thds))]))) thds) ;; FIX diff --git a/drracket-test/tests/drracket/private/drracket-test-util.rkt b/drracket-test/tests/drracket/private/drracket-test-util.rkt index 507729b50..ec057e464 100644 --- a/drracket-test/tests/drracket/private/drracket-test-util.rkt +++ b/drracket-test/tests/drracket/private/drracket-test-util.rkt @@ -11,9 +11,8 @@ "gui.rkt" "no-fw-test-util.rkt") - (provide/contract - [use-get/put-dialog (-> (-> any) path? void?)] - [set-module-language! (->* () (boolean?) void?)]) + (provide (contract-out [use-get/put-dialog (-> (-> any) path? void?)] + [set-module-language! (->* () (boolean?) void?)])) (provide queue-callback/res fire-up-drracket-and-run-tests @@ -60,25 +59,25 @@ ;; filename is a string naming a file that should be typed into the dialog (define (use-get/put-dialog open-dialog filename) (not-on-eventspace-handler-thread 'use-get/put-dialog) - (let ([drs (wait-for-drracket-frame)]) - (with-handlers ([(lambda (x) #t) - (lambda (x) - (fw:preferences:set 'framework:file-dialogs 'std) - (raise x))]) - (fw:preferences:set 'framework:file-dialogs 'common) - (open-dialog) - (let ([dlg (wait-for-new-frame drs)]) - (send (find-labelled-window "Filename:" #f (fw:test:get-active-top-level-window)) focus) - (fw:test:keystroke #\a (list (case (system-type) - [(windows) 'control] - [(macosx macos) 'meta] - [(unix) 'control] - [else (error 'use-get/put-dialog "unknown platform: ~s\n" - (system-type))]))) - (for-each fw:test:keystroke (string->list (path->string filename))) - (fw:test:button-push "OK") - (wait-for-new-frame dlg)) - (fw:preferences:set 'framework:file-dialogs 'std)))) + (define drs (wait-for-drracket-frame)) + (with-handlers ([(lambda (x) #t) (lambda (x) + (fw:preferences:set 'framework:file-dialogs 'std) + (raise x))]) + (fw:preferences:set 'framework:file-dialogs 'common) + (open-dialog) + (let ([dlg (wait-for-new-frame drs)]) + (send (find-labelled-window "Filename:" #f (fw:test:get-active-top-level-window)) focus) + (fw:test:keystroke + #\a + (list (case (system-type) + [(windows) 'control] + [(macosx macos) 'meta] + [(unix) 'control] + [else (error 'use-get/put-dialog "unknown platform: ~s\n" (system-type))]))) + (for-each fw:test:keystroke (string->list (path->string filename))) + (fw:test:button-push "OK") + (wait-for-new-frame dlg)) + (fw:preferences:set 'framework:file-dialogs 'std))) (define (test-util-error fmt . args) (raise (make-exn (apply fmt args) (current-continuation-marks)))) @@ -90,10 +89,7 @@ (define (wait-for-drracket-frame [print-message? #f]) (define (wait-for-drracket-frame-pred) (define active (fw:test:get-active-top-level-window)) - (if (and active - (drracket-frame? active)) - active - #f)) + (and (and active (drracket-frame? active)) active)) (define drr-fr (or (wait-for-drracket-frame-pred) (begin @@ -116,10 +112,7 @@ (for/or ([eventspace (in-list extra-eventspaces)]) (parameterize ([current-eventspace eventspace]) (fw:test:get-active-top-level-window))))) - (if (and active - (not (eq? active old-frame))) - active - #f)) + (and (and active (not (eq? active old-frame))) active)) (define lab (send old-frame get-label)) (define fr (poll-until (procedure-rename wait-for-new-frame-pred @@ -167,34 +160,29 @@ (poll-until wait-for-computation-to-finish 60) (sync (system-idle-evt))) - (define do-execute - (case-lambda - [(frame) - (do-execute frame #t)] - [(frame wait-for-finish?) - (not-on-eventspace-handler-thread 'do-execute) - (queue-callback/res (λ () (verify-drracket-frame-frontmost 'do-execute frame))) - (let ([button (queue-callback/res (λ () (send frame get-execute-button)))]) - (fw:test:run-one (lambda () (send button command))) - (when wait-for-finish? - (wait-for-computation frame)))])) + (define (do-execute frame [wait-for-finish? #t]) + (not-on-eventspace-handler-thread 'do-execute) + (queue-callback/res (λ () (verify-drracket-frame-frontmost 'do-execute frame))) + (let ([button (queue-callback/res (λ () (send frame get-execute-button)))]) + (fw:test:run-one (lambda () (send button command))) + (when wait-for-finish? + (wait-for-computation frame)))) (define (verify-drracket-frame-frontmost function-name frame) (on-eventspace-handler-thread 'verify-drracket-frame-frontmost) - (let ([tl (fw:test:get-active-top-level-window)]) - (unless (and (eq? frame tl) - (drracket-frame? tl)) - (error function-name "drracket frame not frontmost: ~e (found ~e)" frame tl)))) + (define tl (fw:test:get-active-top-level-window)) + (unless (and (eq? frame tl) (drracket-frame? tl)) + (error function-name "drracket frame not frontmost: ~e (found ~e)" frame tl))) (define (clear-definitions frame) (queue-callback/res (λ () (verify-drracket-frame-frontmost 'clear-definitions frame))) (fw:test:new-window (queue-callback/res (λ () (send frame get-definitions-canvas)))) (let ([window (queue-callback/res (λ () (send frame get-edit-target-window)))]) - (let-values ([(cw ch) (queue-callback/res (λ () (send window get-client-size)))] - [(w h) (queue-callback/res (λ () (send window get-size)))]) - (fw:test:mouse-click 'left - (inexact->exact (floor (+ cw (/ (- w cw) 2)))) - (inexact->exact (floor (+ ch (/ (- h ch) 2))))))) + (define-values (cw ch) (queue-callback/res (λ () (send window get-client-size)))) + (define-values (w h) (queue-callback/res (λ () (send window get-size)))) + (fw:test:mouse-click 'left + (inexact->exact (floor (+ cw (/ (- w cw) 2)))) + (inexact->exact (floor (+ ch (/ (- h ch) 2)))))) (fw:test:menu-select "Edit" "Select All") (fw:test:menu-select "Edit" (if (eq? (system-type) 'macos) "Clear" @@ -217,38 +205,38 @@ (not-on-eventspace-handler-thread 'put-in-frame) (unless (and (object? frame) (is-a? frame top-level-window<%>)) (error who "expected a frame or a dialog as the first argument, got ~e" frame)) - (let ([str (if (string? str/sexp) - str/sexp - (let ([port (open-output-string)]) - (parameterize ([current-output-port port]) - (write str/sexp port)) - (get-output-string port)))]) - (queue-callback/res (λ () (verify-drracket-frame-frontmost who frame))) - (let ([canvas (queue-callback/res (λ () (get-canvas frame)))]) - (fw:test:new-window canvas) - (let ([editor (queue-callback/res (λ () (send canvas get-editor)))]) - (cond - [just-insert? - (let ([s (make-semaphore 0)]) - (queue-callback - (λ () - (send editor set-caret-owner #f) - (send editor insert str) - (semaphore-post s))) - (unless (sync/timeout 3 s) - (error who "callback didn't run for 3 seconds; trying to insert ~s" str/sexp)))] - [else - (queue-callback/res (λ () (send editor set-caret-owner #f))) - (type-string str)]))))) + (define str + (if (string? str/sexp) + str/sexp + (let ([port (open-output-string)]) + (parameterize ([current-output-port port]) + (write str/sexp port)) + (get-output-string port)))) + (queue-callback/res (λ () (verify-drracket-frame-frontmost who frame))) + (define canvas (queue-callback/res (λ () (get-canvas frame)))) + (fw:test:new-window canvas) + (define editor (queue-callback/res (λ () (send canvas get-editor)))) + (cond + [just-insert? + (let ([s (make-semaphore 0)]) + (queue-callback (λ () + (send editor set-caret-owner #f) + (send editor insert str) + (semaphore-post s))) + (unless (sync/timeout 3 s) + (error who "callback didn't run for 3 seconds; trying to insert ~s" str/sexp)))] + [else + (queue-callback/res (λ () (send editor set-caret-owner #f))) + (type-string str)])) (define (alt-return-in-interactions frame) (not-on-eventspace-handler-thread 'alt-return-in-interactions) (queue-callback/res (λ () (verify-drracket-frame-frontmost 'alt-return-in-interactions frame))) - (let ([canvas (send frame get-interactions-canvas)]) - (fw:test:new-window canvas) - (let ([editor (send canvas get-editor)]) - (send editor set-caret-owner #f) - (fw:test:keystroke #\return '(alt))))) + (define canvas (send frame get-interactions-canvas)) + (fw:test:new-window canvas) + (define editor (send canvas get-editor)) + (send editor set-caret-owner #f) + (fw:test:keystroke #\return '(alt))) ;; type-string : string -> void ;; to call test:keystroke repeatedly with the characters diff --git a/drracket-tool-lib/drracket/private/standalone-module-browser.rkt b/drracket-tool-lib/drracket/private/standalone-module-browser.rkt index 807be068e..fdc4494fb 100644 --- a/drracket-tool-lib/drracket/private/standalone-module-browser.rkt +++ b/drracket-tool-lib/drracket/private/standalone-module-browser.rkt @@ -1272,7 +1272,8 @@ [(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)))])])] + (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])) diff --git a/drracket/setup/plt-installer-unit.rkt b/drracket/setup/plt-installer-unit.rkt index a31eee5f8..aba9b2ca9 100644 --- a/drracket/setup/plt-installer-unit.rkt +++ b/drracket/setup/plt-installer-unit.rkt @@ -41,12 +41,10 @@ (sleep 0.2) ; kludge to allow f to appear first (end-busy-cursor) ;; do these strings ever appear? (should move to string-constants, if so) - (let ([d (get-directory - "Select the destination for unpacking" - frame)]) - (unless d - (printf ">>> Cancelled <<<\n")) - (begin-busy-cursor) - d)) + (define d (get-directory "Select the destination for unpacking" frame)) + (unless d + (printf ">>> Cancelled <<<\n")) + (begin-busy-cursor) + d) #:show-beginning-of-file? #t)) cleanup-thunk)))