From 041de65d2e94eb26db1d083d6a3e53d34bc073d9 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 21 Oct 1999 18:14:33 +0000 Subject: [PATCH] ... original commit: a090a6dda85922e90ea7043307e76e98051583e4 --- collects/framework/scheme.ss | 41 +++++++++--------- collects/tests/framework/README | 13 +++--- collects/tests/framework/mem.ss | 77 +++++++++++++++++++++++++++++++++ 3 files changed, 105 insertions(+), 26 deletions(-) create mode 100644 collects/tests/framework/mem.ss diff --git a/collects/framework/scheme.ss b/collects/framework/scheme.ss index c2e7d9d5..f7d50e34 100644 --- a/collects/framework/scheme.ss +++ b/collects/framework/scheme.ss @@ -562,38 +562,39 @@ (opt-lambda ([start-pos (get-start-position)] [end-pos (get-end-position)]) (begin-edit-sequence) - (let* ([first-para (position-paragraph start-pos)] - [last-para (position-paragraph end-pos)]) - (let para-loop ([curr-para first-para]) - (if (<= curr-para last-para) - (let ([first-on-para (paragraph-start-position curr-para)]) - (if (not - (char=? #\; (get-character first-on-para))) - (insert ";" first-on-para)) - (para-loop (add1 curr-para)))))) + (let ([first-pos-is-first-para-pos? + (= (paragraph-start-position (position-paragraph start-pos)) + start-pos)]) + (let* ([first-para (position-paragraph start-pos)] + [last-para (position-paragraph end-pos)]) + (let para-loop ([curr-para first-para]) + (if (<= curr-para last-para) + (let ([first-on-para (paragraph-start-position curr-para)]) + (insert #\; first-on-para) + (para-loop (add1 curr-para)))))) + (when first-pos-is-first-para-pos? + (set-position + (paragraph-start-position (position-paragraph (get-start-position))) + (get-end-position)))) (end-edit-sequence) #t)] [uncomment-selection (opt-lambda ([start-pos (get-start-position)] [end-pos (get-end-position)]) (begin-edit-sequence) - (let* ([first-para (position-paragraph start-pos)] - [last-para (position-paragraph end-pos)]) + (let ([last-pos (last-position)] + [first-para (position-paragraph start-pos)] + [last-para (position-paragraph end-pos)]) (let para-loop ([curr-para first-para]) (if (<= curr-para last-para) - (let ([first-on-para + (let ([first-on-para (paren:skip-whitespace this (paragraph-start-position curr-para) 'forward)]) - (delete first-on-para - (+ first-on-para - (let char-loop ([n 0]) - (if (char=? #\; - (get-character - (+ n first-on-para))) - (char-loop (add1 n)) - n)))) + (when (and (< first-on-para last-pos) + (char=? #\; (get-character first-on-para))) + (delete first-on-para (+ first-on-para 1))) (para-loop (add1 curr-para)))))) (end-edit-sequence) #t)] diff --git a/collects/tests/framework/README b/collects/tests/framework/README index 654eab3f..076179fa 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -17,7 +17,7 @@ To run a test use: where or is the name of one of the tests below. Alternatively, pass no command-line arguments to run the same -test as last time. +test as last time, or `all' to run all of the tests. - load: |# load.ss #| @@ -55,11 +55,6 @@ test as last time. - edits to frames: |# edit-frame.ss #| - handler |# handler-test.ss #| -- garbage collection: |# gc.ss #| - - | These tests will create objects in various configurations and - | make sure that they are garbage collected - - keybindings: |# keys.ss #| | This tests all of the misc (non-scheme) keybindings @@ -111,5 +106,11 @@ test as last time. | these tests require intervention by people. Clicking and whatnot - panel:single |# panel.ss #| + + - garbage collection: |# mem.ss #| + + | These tests will create objects in various configurations and + | make sure that they are garbage collected + |#) \ No newline at end of file diff --git a/collects/tests/framework/mem.ss b/collects/tests/framework/mem.ss new file mode 100644 index 00000000..84b7c503 --- /dev/null +++ b/collects/tests/framework/mem.ss @@ -0,0 +1,77 @@ +;; (list-of (list string (list-of (weak-box TST)))) +(send-sexp-to-mred '(define mem-boxes null)) + +(define mem-count 10) +(define mem-cutoff 1) + +(define (test-allocate tag open close) + (send-sexp-to-mred + `(let ([new-boxes + (let loop ([n ,mem-count]) + (cond + [(zero? n) null] + [else + (let* ([o (,open)] + [b (make-weak-box o)]) + (,close o) + (cons b (loop (- n 1))))]))]) + (collect-garbage) + (set! mem-boxes (cons (list ,tag new-boxes) mem-boxes))))) + +(define (done) + (send-sexp-to-mred + `(begin + (collect-garbage) + (collect-garbage) + (collect-garbage) + (collect-garbage) + (let ([f (make-object dialog% "Results")] + [anything? #f]) + (for-each + (lambda (boxl) + (let* ([tag (first boxl)] + [boxes (second boxl)] + [calc-results + (lambda () + (foldl (lambda (b n) (if (weak-box-value b) (+ n 1) n)) + 0 + boxes))]) + (unless (<= (calc-results) ,mem-cutoff) + (collect-garbage)) + (let ([res (calc-results)]) + (when (<= res ,mem-cutoff) + (set! anything #t) + (make-object message% (format "~a: ~a of ~a~n" tag res ,mem-count) f))))) + mem-boxes) + (cond + [anything? (make-object button% "Close" (lambda x (send f show #f)) f)] + [else (make-object button% "NOTHING!" (lambda x (send f show #f)) f)]) + (send f show #t))))) + +(define (test-frame-allocate name %) + (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f)) + (test-allocate name + `(lambda () (let ([f (make-object ,% ,name)]) + (send f show #t) + f)) + `(lambda (f) (send f close))) + (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))) + +(test-allocate "frame%" + '(lambda () (let ([f (make-object frame% "test frame")]) + (send f show #t) + f)) + '(lambda (f) (send f show #f))) + + +(test-frame-allocate "frame:basic%" 'frame:basic%) +(test-frame-allocate "frame:standard-menus%" 'frame:standard-menus%) +(test-frame-allocate "frame:text%" 'frame:text%) +(test-frame-allocate "frame:searchable%" 'frame:searchable%) +(test-frame-allocate "frame:text-info%" 'frame:text-info%) +(test-frame-allocate "frame:text-info-file%" 'frame:text-info-file%) +(test-frame-allocate "frame:pasteboard%" 'frame:pasteboard%) +(test-frame-allocate "frame:pasteboard-info%" 'frame:pasteboard-info%) +(test-frame-allocate "frame:pasteboard-info-file%" 'frame:pasteboard-info-file%) +(done) +