.

original commit: 6335f47ae93ffdf03a6a65e5143128d695149a37

collects/framework/framework.ss

@@ -858,6 +858,14 @@
     "This returns the parenthesis highlight "
     "@link bitmap %"
     ". It is only used on black and white screens.")
+   (icon:get-eof-bitmap
+    (-> (is-a?/c bitmap%))
+    ()
+    "This returns the"
+    "@link bitmap %"
+    "used for the clickable ``eof'' icon from"
+    "@ilink text:ports %"
+    ".")
    (icon:get-autowrap-bitmap
     (-> (is-a?/c bitmap%))
     ()
@@ -1499,5 +1507,16 @@
      "@flink editor:get-standard-style-list"
      "and \\var{example-text} is shown in the panel so users can see"
      "the results of their configuration.")
+
+    (color-prefs:marshall-style
+     (-> (is-a?/c style-delta%) printable/c)
+     (style-delta)
+     "Builds a printed representation for a style-delta.")
+    
+    (color-prefs:unmarshall-style
+     (-> printable/c (union false/c (is-a?/c style-delta%)))
+     (marshalled-style-delta)
+     "Builds a style delta from its printed representation."
+     "Returns \\scheme|#f| if the printed form cannot be parsed.")
     
     ))

collects/framework/private/editor.ss

@@ -41,7 +41,8 @@
           load-file/gui-error
           on-close
           can-close?
-          close))
+          close
+          get-filename/untitled-name))
 
       (define basic-mixin
 	(mixin (editor<%>) (basic<%>)
@@ -52,6 +53,19 @@
                                      (begin (on-close) #t)
                                      #f))
           
+          ;; get-filename/untitled-name : -> string
+          ;; returns a string representing the visible name for this file,
+          ;; or "Untitled <n>" for some n.
+          (define untitled-name #f)
+          (define/public (get-filename/untitled-name)
+            (let ([filename (get-filename)])
+              (if filename
+                  (path->string filename)
+                  (begin
+                    (unless untitled-name
+                      (set! untitled-name (gui-utils:next-untitled-name)))
+                    untitled-name))))
+          
 	  (inherit get-filename save-file)
 	  (define/public save-file/gui-error
 	    (opt-lambda ([input-filename #f]
@@ -402,7 +416,6 @@
       
       (define file<%> 
         (interface (-keymap<%>)
-          get-filename/untitled-name
           get-can-close-parent
           update-frame-filename
           allow-close-with-no-filename?))
@@ -413,7 +426,7 @@
                    is-modified? set-modified 
                    get-top-level-window)
 
-          (inherit get-canvases)
+          (inherit get-canvases get-filename/untitled-name)
           (define/public (update-frame-filename)
             (let* ([filename (get-filename)]
                    [name (if filename
@@ -426,19 +439,6 @@
                               (send tlw set-label name))))
                         (get-canvases))))
           
-          ;; get-filename/untitled-name : -> string
-          ;; returns a string representing the visible name for this file,
-          ;; or "Untitled <n>" for some n.
-          (define untitled-name #f)
-          (define/public (get-filename/untitled-name)
-            (let ([filename (get-filename)])
-              (if filename
-                  (path->string filename)
-                  (begin
-                    (unless untitled-name
-                      (set! untitled-name (gui-utils:next-untitled-name)))
-                    untitled-name))))
-
           (define/override set-filename
 	    (case-lambda
 	     [(name) (set-filename name #f)]

collects/framework/private/frame.ss

@@ -995,22 +995,21 @@
                 (set! label t)
                 (do-label)))]
 
-          (public get-canvas% get-canvas<%> make-canvas get-editor% get-editor<%> make-editor)
-          [define get-canvas% (λ () editor-canvas%)]
-          [define get-canvas<%> (λ () (class->interface editor-canvas%))]
-          [define make-canvas (λ ()
-                                (let ([% (get-canvas%)]
-                                      [<%> (get-canvas<%>)])
-                                  (unless (implementation? % <%>)
-                                    (error 'frame:editor%
-                                           "result of get-canvas% method must match ~e interface; got: ~e"
-                                           <%> %))
-                                  (instantiate % () (parent (get-area-container)))))]
-          (define (get-editor%)
+          (define/public (get-canvas%) editor-canvas%)
+          (define/public (get-canvas<%>) (class->interface editor-canvas%))
+          (define/public (make-canvas)
+            (let ([% (get-canvas%)]
+                  [<%> (get-canvas<%>)])
+              (unless (implementation? % <%>)
+                (error 'frame:editor%
+                       "result of get-canvas% method must match ~e interface; got: ~e"
+                       <%> %))
+              (instantiate % () (parent (get-area-container)))))
+          (define/public (get-editor%)
 	    (error 'editor-frame% "abstract method: no editor% class specified"))
-          (define (get-editor<%>)
-	    editor<%>)
-          (define (make-editor)
+          (define/public (get-editor<%>)
+	    editor:basic<%>)
+          (define/public (make-editor)
 	    (let ([% (get-editor%)]
 		  [<%> (get-editor<%>)])
 	      (unless (implementation? % <%>)
@@ -1296,13 +1295,13 @@
                     [(cancel)
                      #f]))))
             
-	  (super-instantiate ())))
+	  (super-new)))
 
       (define text<%> (interface (-editor<%>)))
       (define text-mixin
         (mixin (-editor<%>) (text<%>)
-          [define/override get-editor<%> (λ () (class->interface text%))]
-          [define/override get-editor% (λ () text:keymap%)]
+          (define/override (get-editor<%>) (class->interface text%))
+          (define/override (get-editor%) text:keymap%)
           (super-new)))
       
       (define pasteboard<%> (interface (-editor<%>)))

collects/framework/private/sig.ss

@@ -314,6 +314,7 @@
      1-pixel-string-snip%
      1-pixel-tab-snip%
      delegate%
+     wide-snip%
      standard-style-list%
      keymap%
      return%

collects/framework/private/text.ss

@@ -995,7 +995,8 @@ WARNING: printf is rebound in the body of the unit to always
           
           (define/public-final (get-insertion-point) insertion-point)
           (define/public-final (set-insertion-point ip) (set! insertion-point ip))
-          (define/public-final (get-unread-start-point) unread-start-point)
+          (define/public-final (get-unread-start-point)
+            unread-start-point)
           (define/public-final (set-unread-start-point u) 
             (unless (<= u (last-position))
               (error 'set-unread-start-point "~e is too large, last-position is ~e"
@@ -1076,7 +1077,7 @@ WARNING: printf is rebound in the body of the unit to always
           ;;
           
           (define/augment (can-insert? start len)
-            (and (or allow-edits?
+            (and (or allow-edits? 
                      (start . >= . unread-start-point))
                  (inner #t can-insert? start len)))
           
@@ -1929,7 +1930,8 @@ WARNING: printf is rebound in the body of the unit to always
       (define hide-caret/selection% (hide-caret/selection-mixin basic%))
       (define nbsp->space% (nbsp->space-mixin basic%))
       (define delegate% (delegate-mixin basic%))
-      (define standard-style-list% (editor:standard-style-list-mixin (wide-snip-mixin basic%)))
+      (define wide-snip% (wide-snip-mixin basic%))
+      (define standard-style-list% (editor:standard-style-list-mixin wide-snip%))
       (define input-box% (input-box-mixin standard-style-list%))
       (define -keymap% (editor:keymap-mixin standard-style-list%))
       (define return% (return-mixin -keymap%))

collects/tests/framework/canvas.ss

@@ -9,7 +9,7 @@
      (send-sexp-to-mred
       `(let* ([f (make-object frame:basic% "test canvas" #f 300 300)]
 	      [c (make-object ,class (send f get-area-container))])
-	 (send c set-editor (make-object text:basic%))
+	 (send c set-editor (make-object text:wide-snip%))
 	 (send f show #t)))
       (wait-for-frame "test canvas")
       (send-sexp-to-mred

collects/tests/framework/exit.ss

@@ -22,7 +22,7 @@
 	(with-handlers ([eof-result? (lambda (x) 'passed)])
 	  (send-sexp-to-mred
 	   `(begin
-	      (exit:insert-can?-callback (lambda () (call-with-output-file ,tmp-file void) #t))
+	      (exit:insert-can?-callback (lambda () (call-with-output-file (bytes->path ,(path->bytes tmp-file)) void) #t))
 	      (begin (exit:exit) (sleep/yield 1)))))))
 
 (test 'exit-callback-removed

collects/tests/framework/frame.ss

@@ -85,10 +85,6 @@
    'searchable-mixin
    '(frame:searchable-mixin frame:text%))
   
-  (test-creation
-   'text-info-file%-creation
-   'frame:text-info-file%)
-  
   (test-creation
    'pasteboard-mixin-creation
    '(frame:pasteboard-mixin frame:editor%))
@@ -99,10 +95,6 @@
    'pasteboard%-creation
    'frame:pasteboard%)
   
-  (test-creation
-   'pasteboard-info-file%-creation
-   'frame:pasteboard-info-file%)
-  
   (define (test-open name class-expression)
     (let* ([test-file-contents "test"]
            [tmp-file-name "framework-tmp"]
@@ -117,7 +109,7 @@
        (lambda ()
          (let ([frame-name 
                 (send-sexp-to-mred
-                 `(let ([frame (instantiate ,class-expression ())])
+                 `(let ([frame (new ,class-expression)])
                     (preferences:set 'framework:file-dialogs 'common)
                     (send frame show #t)
                     (send frame get-label)))])
@@ -137,7 +129,7 @@
                        [(windows) `(test:keystroke #\a '(control))]
                        [else (error 'file-open-dialog "unknown system type: ~a" (system-type))])
                     (for-each test:keystroke
-                              (string->list ,tmp-file))
+                              (string->list ,(path->string tmp-file)))
                     (test:keystroke #\return)))
            (wait-for-frame tmp-file-name)
            (begin0
@@ -150,6 +142,5 @@
              (queue-sexp-to-mred
               `(send (get-top-level-focus-window) close))))))))
   
-  (test-open "frame:editor open" 'frame:text%)
   (test-open "frame:searchable open" 'frame:searchable%)
-  (test-open "frame:text-info open" 'frame:text-info-file%))
+  (test-open "frame:text open" 'frame:text%))

collects/tests/framework/load.ss

@@ -25,15 +25,13 @@
  
   (test/load "gui-utils.ss" 'gui-utils:next-untitled-name)
   (test/load "test.ss" 'test:run-interval)
-  (test/load "macro.ss" '(mixin () () ()))
   (test/load "splash.ss" 'start-splash)
   (test/load "framework-sig.ss" '(begin (eval '(require (lib "unitsig.ss")))
                                         (eval '(define-signature dummy-signature^ framework^))))
   (test/load "framework-unit.ss" 'framework@)
   (test/load "framework.ss" '(list test:button-push
 				   gui-utils:next-untitled-name
-				   frame:basic-mixin
-                                   (mixin () () ())))
+				   frame:basic-mixin))
   
   ;; ensures that all of the names in the signature are provided
   ;; by (require (lib "framework.ss" "framework"))

collects/tests/framework/mem.ss

@@ -111,7 +111,7 @@
           (send f show #t)))))
   
   (define (test-frame-allocate %)
-    (let ([name (symbol->string %)])
+    (let ([name (format "~s" %)])
       (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
       (test-allocate name
                      `(lambda () (let ([f (make-object ,% ,name)])
@@ -159,6 +159,7 @@
                  '(lambda () (make-object text:return% void))
                  '(lambda (t) (void)))
   
+  (test-frame-allocate '(class frame% (inherit show) (define/public (close) (show #f)) (super-new)))
   (test-frame-allocate 'frame:basic%)
   (test-frame-allocate 'frame:info%)
   (test-frame-allocate 'frame:text-info%)
@@ -166,9 +167,7 @@
   (test-frame-allocate 'frame:standard-menus%)
   
   (test-frame-allocate 'frame:text%)
-  (test-frame-allocate 'frame:text-info-file%)
   (test-frame-allocate 'frame:searchable%)
   
   (test-frame-allocate 'frame:pasteboard%)
-  (test-frame-allocate 'frame:pasteboard-info-file%)
   (done))

collects/tests/framework/panel.ss

@@ -7,9 +7,8 @@
  `(let* ([semaphore (make-semaphore 0)]
 	 [semaphore-frame%
 	  (class frame% 
-	    (override on-close)
-	    [define on-close (lambda () (semaphore-post semaphore))]
-	    (super-instantiate ()))]
+	    (define/augment (on-close) (semaphore-post semaphore))
+	    (super-new))]
 	 [f (make-object semaphore-frame% "Single Panel Test")]
 	 [blue-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)]
 	 [green-brush (send the-brush-list find-or-create-brush "FOREST GREEN" 'solid)]

collects/tests/framework/text.ss

@@ -23,8 +23,12 @@
          (send-sexp-to-mred `(test:keystroke #\a))
          (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
          (send-sexp-to-mred
-          `(begin (send (send (get-top-level-focus-window) get-editor) lock #t)
-                  (send (send (get-top-level-focus-window) get-editor) lock #f)))
+          `(begin 
+             ;; remove the `a' to avoid save dialog boxes (and test them, I suppose)
+             (send (send (get-top-level-focus-window) get-editor) undo) 
+
+             (send (send (get-top-level-focus-window) get-editor) lock #t)
+             (send (send (get-top-level-focus-window) get-editor) lock #f)))
          (queue-sexp-to-mred
           `(send (get-top-level-focus-window) close))
          (send-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))