diff --git a/collects/drscheme/drscheme.ss b/collects/drscheme/drscheme.ss index f4358ea541..e5c5207b8f 100644 --- a/collects/drscheme/drscheme.ss +++ b/collects/drscheme/drscheme.ss @@ -1,6 +1,5 @@ #lang scheme/base - -(require "private/key.ss") +(require scheme/gui/base "private/key.ss") (define debugging? (getenv "PLTDRDEBUG")) (define profiling? (getenv "PLTDRPROFILE")) @@ -55,7 +54,12 @@ (when profiling? (flprintf "PLTDRPROFILE: installing profiler\n") + ;; NOTE that this might not always work. + ;; it creates a new custodian and installs it, but the + ;; original eventspace was created on the original custodian + ;; and this code does not create a new eventspace. (let ([orig-cust (current-custodian)] + [orig-eventspace (current-eventspace)] [new-cust (make-custodian)]) (current-custodian new-cust) ((dynamic-require 'drscheme/private/profile-drs 'start-profile) orig-cust))) diff --git a/collects/drscheme/private/profile-drs.ss b/collects/drscheme/private/profile-drs.ss index a195369a46..78e0131d1f 100644 --- a/collects/drscheme/private/profile-drs.ss +++ b/collects/drscheme/private/profile-drs.ss @@ -18,6 +18,7 @@ itself. (define (start-profile super-custodian) (define drs-custodian (current-custodian)) + (define drs-main-thread (current-thread)) (define profile-eventspace (parameterize ([current-custodian super-custodian]) (make-eventspace))) @@ -32,6 +33,22 @@ itself. (define resume-b (new button% [label "Resume"] [parent bp] [callback (λ (a b) (resume))] [stretchable-width #t])) (define start-stop-b (new button% [label "Stop"] [parent bp] [callback (λ (a b) (start-stop))] [stretchable-width #t])) (define choice (new choice% [label #f] [choices '("9" "10" "12")] [parent bp] [callback (λ (a b) (font-size))])) + + + (define mb (new menu-bar% [parent frame])) + (define edit-menu (new menu% [label "&Edit"] [parent mb])) + (define sa (new menu-item% + [parent edit-menu] + [label "Select al&l"] + [shortcut #\a] + [callback (λ (x y) + (send ec focus) + (send t set-position 0 (send t last-position)))])) + (define copy (new menu-item% + [parent edit-menu] + [label "&Copy"] + [shortcut #\c] + [callback (λ (x y) (send t copy))])) (define (font-size) (let ([n (send choice get-string-selection)]) @@ -49,7 +66,7 @@ itself. (define running? #f) (define current-sampler #f) (define (start-sampler) - (let ([s (create-sampler drs-custodian 1/2 super-custodian)]) + (let ([s (create-sampler (list drs-custodian drs-main-thread) 1/2 super-custodian)]) (set! current-sampler s))) (define (stop-sampler) (current-sampler 'stop) @@ -101,4 +118,5 @@ itself. (update-buttons)) (update-buttons) + (send ec focus) (send frame show #t))