...

original commit: a090a6dda85922e90ea7043307e76e98051583e4

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)]
+	   (let ([first-pos-is-first-para-pos?
-		  [last-para (position-paragraph end-pos)])
+		  (= (paragraph-start-position (position-paragraph start-pos))
-	     (let para-loop ([curr-para first-para])
+		     start-pos)])
-	       (if (<= curr-para last-para)
+	     (let* ([first-para (position-paragraph start-pos)]
-		   (let ([first-on-para (paragraph-start-position curr-para)])
+		    [last-para (position-paragraph end-pos)])
-		     (if (not
+	       (let para-loop ([curr-para first-para])
-			  (char=? #\; (get-character first-on-para)))
+		 (if (<= curr-para last-para)
-			 (insert ";" first-on-para))
+		     (let ([first-on-para (paragraph-start-position curr-para)])
-		     (para-loop (add1 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)]
+	   (let ([last-pos (last-position)]
-		  [last-para (position-paragraph end-pos)])
+		 [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
+		     (when (and (< first-on-para last-pos)
-			   (+ first-on-para
+				(char=? #\; (get-character first-on-para)))
-			      (let char-loop ([n 0])
+		       (delete first-on-para (+ first-on-para 1)))
-				(if (char=? #\; 
-					    (get-character 
-						  (+  n first-on-para)))
-				    (char-loop (add1 n))
-				    n))))
 		     (para-loop (add1 curr-para))))))
 	   (end-edit-sequence)
 	   #t)]

collects/tests/framework/README

@@ -17,7 +17,7 @@ To run a test use:
 
 where or <test.ss> 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
+
 	
 |#)

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)
+