...

original commit: d98524298e7fbfef7073e16205e49e649e087c0b

collects/framework/editor.ss

@@ -23,15 +23,6 @@
 
   (define basic-mixin
     (mixin (editor<%>) (basic<%>) args
-
-;      (inherit copy-self-to)
-;     (override
-;      [copy-self
-;	(lambda ()
-;	  (let ([editor (make-object (object-interface this))])
-;	   (copy-self-to editor)
-;	    editor))])
-	   
       (inherit get-filename save-file
 	       refresh-delayed? 
 	       get-canvas
@@ -53,26 +44,34 @@
       (private
 	[edit-sequence-count 0])
       (override
-	[begin-edit-sequence
-	 (case-lambda
-	  [() (begin-edit-sequence #t)]
-	  [(undoable?)
-	   (set! edit-sequence-count (+ edit-sequence-count 1))
-	   (super-begin-edit-sequence undoable?)])]
-	[end-edit-sequence
-	 (lambda ()
-	   (set! edit-sequence-count (- edit-sequence-count 1))
-	   (when (< edit-sequence-count 0)
-	     (error 'end-edit-sequence "extra end-edit-sequence"))
-	   (super-end-edit-sequence))])
+       [begin-edit-sequence
+	(case-lambda
+	 [() (begin-edit-sequence #t)]
+	 [(undoable?)
+	  (set! edit-sequence-count (+ edit-sequence-count 1))
+	  (super-begin-edit-sequence undoable?)])]
+       [end-edit-sequence
+	(lambda ()
+	  (set! edit-sequence-count (- edit-sequence-count 1))
+	  (when (< edit-sequence-count 0)
+	    (error 'end-edit-sequence "extra end-edit-sequence"))
+	  (super-end-edit-sequence))])
 
       (public
 	[on-close void]
 	[get-top-level-window
 	 (lambda ()
-	   (let ([c (get-canvas)])
-	     (and c
-		  (send c get-top-level-window))))])
+	   (let loop ([text this])
+	     (let ([editor-admin (send text get-admin)])
+	       (cond
+		[(is-a? editor-admin editor-snip-editor-admin<%>)
+		 (let* ([snip (send editor-admin get-snip)]
+			[snip-admin (send snip get-admin)])
+		   (loop (send snip-admin get-editor)))]
+		[(send text get-canvas) => (lambda (canvas)
+					     (send canvas get-top-level-window))]
+		[else
+		 #f]))))])
 
       (public [editing-this-file? (lambda () #f)])
 
@@ -97,11 +96,24 @@
 		    "expected second argument to be a symbol, got: ~s~n"
 		    sym))
 	   (if (refresh-delayed?)
-	       (cond
-		 [(symbol? sym)
-		  (hash-table-put! edit-sequence-ht sym t)]
-		 [else (set! edit-sequence-queue
-			     (cons t edit-sequence-queue))])
+	       (if in-local-edit-sequence?
+		   (cond
+		    [(symbol? sym)
+		     (hash-table-put! edit-sequence-ht sym t)]
+		    [else (set! edit-sequence-queue
+				(cons t edit-sequence-queue))])
+		   (let ([snip-admin (get-admin)])
+		     (cond
+		      [(not snip-admin)
+		       (t)] ;; refresh-delayed? is always #t when there is no admin.
+		      [(is-a? snip-admin editor-snip-editor-admin<%>)
+		       (send (send (send (send snip-admin get-snip) get-admin) get-editor)
+			     run-after-edit-sequence t sym)]
+		      [else
+		       (message-box "run-after-edit-sequence error"
+				    (format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>"
+					    snip-admin))
+		       '(t)])))
 	       (t))
 	   (void)])]
 	[extend-edit-sequence-queue
@@ -112,64 +124,62 @@
 				      k t)))
 	   (set! edit-sequence-queue (append l edit-sequence-queue)))])
       (rename
-	[super-after-edit-sequence after-edit-sequence]
-	[super-on-edit-sequence on-edit-sequence])
+       [super-after-edit-sequence after-edit-sequence]
+       [super-on-edit-sequence on-edit-sequence])
       (override
-	[on-edit-sequence
-	 (lambda ()
-	   (super-on-edit-sequence)
-	   (set! in-local-edit-sequence? #t))]
-	[after-edit-sequence
-	 (lambda ()
-	   (set! in-local-edit-sequence? #f)
-	   (super-after-edit-sequence)
-	   (let ([queue edit-sequence-queue]
-		 [ht edit-sequence-ht]
-		 [find-enclosing-edit
-		  (lambda (edit)
-		    (let ([admin (send edit get-admin)])
-		      (cond
-			[(is-a? admin editor-snip-editor-admin<%>)
-			 (send (send (send admin get-snip) get-admin) get-editor)]
-			;; assume that any non-media-snip 
-			;; administrator doesn't have embedded edits.
-			[else #f])))])
-	     (set! edit-sequence-queue null)
-	     (set! edit-sequence-ht (make-hash-table))
-	     (let loop ([edit (find-enclosing-edit this)])
-	       (cond
-		 [(and edit (not (send edit local-edit-sequence?)))
-		  (loop (find-enclosing-edit edit))]
-		 [edit (send edit extend-edit-sequence-queue queue ht)]
-		 [else
-		  (hash-table-for-each ht (lambda (k t) (t)))
-		  (for-each (lambda (t) (t)) queue)]))))])
- 
+       [on-edit-sequence
+	(lambda ()
+	  (super-on-edit-sequence)
+	  (set! in-local-edit-sequence? #t))]
+       [after-edit-sequence
+	(lambda ()
+	  (set! in-local-edit-sequence? #f)
+	  (super-after-edit-sequence)
+	  (let ([queue edit-sequence-queue]
+		[ht edit-sequence-ht]
+		[find-enclosing-edit
+		 (lambda (edit)
+		   (let ([admin (send edit get-admin)])
+		     (cond
+		      [(is-a? admin editor-snip-editor-admin<%>)
+		       (send (send (send admin get-snip) get-admin) get-editor)]
+		      [else #f])))])
+	    (set! edit-sequence-queue null)
+	    (set! edit-sequence-ht (make-hash-table))
+	    (let loop ([edit (find-enclosing-edit this)])
+	      (cond
+	       [(and edit (not (send edit local-edit-sequence?)))
+		(loop (find-enclosing-edit edit))]
+	       [edit (send edit extend-edit-sequence-queue queue ht)]
+	       [else
+		(hash-table-for-each ht (lambda (k t) (t)))
+		(for-each (lambda (t) (t)) queue)]))))])
+      
       (rename [super-lock lock])
       (private
 	[is-locked? #f])
       (public
 	[locked? (lambda () is-locked?)])
       (override
-	[lock
-	 (lambda (x)
-	   (set! is-locked? x)
-	   (super-lock x))]
-	[on-new-box
-	 (lambda (type)
-	   (cond
-	     [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
-	     [else (make-object editor-snip% (make-object pasteboard:basic%))]))])
+       [lock
+	(lambda (x)
+	  (set! is-locked? x)
+	  (super-lock x))]
+       [on-new-box
+	(lambda (type)
+	  (cond
+	   [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
+	   [else (make-object editor-snip% (make-object pasteboard:basic%))]))])
 
 
       (override
-	[get-file (lambda (d) 
-		    (parameterize ([finder:dialog-parent-parameter
-				    (get-top-level-window)])
-		      (finder:get-file d)))]
-	[put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter
-						(get-top-level-window)])
-				  (finder:put-file f d)))])
+       [get-file (lambda (d) 
+		   (parameterize ([finder:dialog-parent-parameter
+				   (get-top-level-window)])
+		     (finder:get-file d)))]
+       [put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter
+					       (get-top-level-window)])
+				 (finder:put-file f d)))])
       
       
       (sequence

collects/framework/guiutils.ss

@@ -196,7 +196,7 @@
 	   [(not snip)
 	    (set! get-next (lambda () eof))
 	    eof]
-	   [(<= end (unbox pos-box))
+	   [(not (<= (+ (unbox pos-box) (send snip get-count)) end))
 	    (set! get-next (lambda () eof))
 	    eof]
 	   [(is-a? snip sexp-snip<%>)

collects/framework/keymap.ss

@@ -24,6 +24,41 @@
 	    (lambda (edit event)
 	      (bell))]
 	   
+	   [up-out-of-editor-snip
+	    (lambda (text event)
+	      (let ([editor-admin (send text get-admin)])
+		(when (is-a? editor-admin editor-snip-editor-admin<%>)
+		  (let* ([snip (send editor-admin get-snip)]
+			 [snip-admin (send snip get-admin)])
+		    (when snip-admin
+		      (let ([editor (send snip-admin get-editor)])
+			(when (is-a? editor text%)
+			  (let ([new-pos (+ (send editor get-snip-position snip)
+					    (if (= 0 (send text get-end-position))
+						0
+						(send snip get-count)))])
+			    (send editor set-position new-pos new-pos))
+			  (send editor set-caret-owner #f 'display)))))))
+	      #t)]
+
+	   [down-into-editor-snip
+	    (lambda (dir get-pos)
+	      (lambda (text event)
+		(when (= (send text get-start-position)
+			 (send text get-end-position))
+		  (let* ([pos (send text get-start-position)]
+			 [snip (send text find-snip pos dir)])
+		    (when (and snip
+			       (is-a? snip editor-snip%))
+		      (let ([embedded-editor (send snip get-editor)])
+			(when (is-a? embedded-editor text%)
+			  (send embedded-editor set-position (get-pos embedded-editor)))
+			(send text set-caret-owner snip 'display)))))
+		#t))]
+
+	   [right-into-editor-snip (down-into-editor-snip 'after-or-none (lambda (x) 0))]
+	   [left-into-editor-snip (down-into-editor-snip 'before-or-none (lambda (x) (send x last-position)))]
+
 	   [toggle-anchor
 	    (lambda (edit event)
 	      (send edit set-anchor
@@ -554,6 +589,10 @@
 	  
 	  (add "flash-paren-match" flash-paren-match)
 	  
+	  (add "left-into-editor-snip" left-into-editor-snip)
+	  (add "right-into-editor-snip" right-into-editor-snip)
+	  (add "up-out-of-editor-snip" up-out-of-editor-snip)
+
 	  (add "toggle-anchor" toggle-anchor)
 	  (add "center-view-on-line" center-view-on-line)
 	  (add "collapse-space" collapse-space)
@@ -729,6 +768,10 @@
 	  
 	  (map "c:space" "toggle-anchor")
 	  
+	  (map-meta "c:left" "left-into-editor-snip")
+	  (map-meta "c:right" "right-into-editor-snip")
+	  (map-meta "c:up" "up-out-of-editor-snip")
+
 	  (map "insert" "toggle-overwrite")
 	  (map-meta "o" "toggle-overwrite")
 	  

collects/framework/prefs.ss

@@ -175,9 +175,8 @@
 	(with-handlers ([(lambda (x) #t)
 			 (lambda (exn)
 			   (message-box
-			    (format "Error saving preferences~n~a"
-				    (exn-message exn))
-			    "Error saving preferences"))])
+			    "Error saving preferences"
+			    (exn-message exn)))])
 	  (call-with-output-file preferences-filename
 	    (lambda (p)
 	      (mzlib:pretty-print:pretty-print

collects/tests/framework/mem.ss

@@ -2,7 +2,6 @@
 (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
@@ -31,18 +30,23 @@
          (lambda (boxl)
            (let* ([tag (first boxl)]
                   [boxes (second boxl)]
-                  [res
+                  [calc-results
                    (lambda ()
                      (foldl (lambda (b n) (if (weak-box-value b) (+ n 1) n))
                             0
                             boxes))])
-             (unless (<= (calc-results) ,mem-cutoff)
+             (when (> (calc-results) 0)
+               (collect-garbage)
+               (collect-garbage)
+               (collect-garbage)
+               (collect-garbage)
+               (collect-garbage)
                (collect-garbage))
              (let ([res (calc-results)])
-               (when (<= res ,mem-cutoff)
+               (when (> res 0)
                  (set! anything? #t)
                  (make-object message% (format "~a: ~a of ~a~n" tag res ,mem-count) f)))))
-         mem-boxes)
+         (reverse mem-boxes))
         (cond
           [anything? (make-object button% "Close" f (lambda x (send f show #f)))]
           [else (make-object button% "NOTHING!" f (lambda x (send f show #f)))])
@@ -64,6 +68,33 @@
 	       '(lambda (f) (send f show #f)))
 
 
+(define (test-editor-allocate object-name)
+  (test-allocate (symbol->string object-name)
+		 `(lambda () (make-object ,object-name))
+		 '(lambda (e) (send e on-close))))
+
+(test-editor-allocate 'text:basic%)
+(test-editor-allocate 'text:keymap%)
+(test-editor-allocate 'text:autowrap%)
+(test-editor-allocate 'text:file%)
+(test-editor-allocate 'text:clever-file-format%)
+(test-editor-allocate 'text:backup-autosave%)
+(test-editor-allocate 'text:searching%)
+(test-editor-allocate 'text:info%)
+
+(test-editor-allocate 'pasteboard:basic%)
+(test-editor-allocate 'pasteboard:keymap%)
+(test-editor-allocate 'pasteboard:file%)
+(test-editor-allocate 'pasteboard:backup-autosave%)
+(test-editor-allocate 'pasteboard:info%)
+
+(test-editor-allocate 'scheme:text%)
+
+(test-allocate "text:return%"
+	       '(lambda () (make-object text:return% void))
+	       '(lambda (t) (void)))
+
+
 (test-frame-allocate "frame:basic%" 'frame:basic%)
 (test-frame-allocate "frame:standard-menus%" 'frame:standard-menus%)
 (test-frame-allocate "frame:text%" 'frame:text%)