.

original commit: f47c89e286bb105ef694c23f58a0d4dedaa62946

collects/framework/private/color.ss

@@ -46,9 +46,7 @@
           backward-containing-sexp
           forward-match
           insert-close-paren
-	  classify-position
-          
-          get-colorer-blank-style))
+	  classify-position))
 
       (define text-mixin
         (mixin (text:basic<%>) (-text<%>)
@@ -334,8 +332,6 @@
               (set! token-sym->style #f)
               (set! get-token #f)))
           
-          (define/public (get-colorer-blank-style) (send (get-style-list) find-named-style "Standard"))
-          
           (define/public (is-frozen?) frozen?)
           
           ;; See docs

collects/framework/private/editor.ss

@@ -293,6 +293,9 @@
       (define standard-style-list (new style-list%))
       (define (get-standard-style-list) standard-style-list)
       
+      (define default-color-style-name "framework:default-color")
+      (define (get-default-color-style-name) default-color-style-name)
+      
       (let ([delta (make-object style-delta% 'change-normal)])
         (send delta set-delta 'change-family 'modern)
         (let ([style (send standard-style-list find-named-style "Standard")])
@@ -301,8 +304,23 @@
               (send standard-style-list new-named-style "Standard"
                     (send standard-style-list find-or-create-style
                           (send standard-style-list find-named-style "Basic")
+                          delta))))
+        
+        (let ([style (send standard-style-list find-named-style default-color-style-name)])
+          (if style
+              (send style set-delta delta)
+              (send standard-style-list new-named-style default-color-style-name
+                    (send standard-style-list find-or-create-style
+                          (send standard-style-list find-named-style "Standard")
                           delta)))))
       
+      (define (set-default-font-color color)
+        (let* ([scheme-standard (send standard-style-list find-named-style default-color-style-name)]
+               [scheme-delta (make-object style-delta%)])
+          (send scheme-standard get-delta scheme-delta)
+          (send scheme-delta set-delta-foreground color)
+          (send scheme-standard set-delta scheme-delta)))
+      
       (define (set-font-size size)
         (update-standard-style
          (lambda (scheme-delta)

collects/framework/private/main.ss

@@ -251,9 +251,7 @@
                                      (make-object color% (car lst) (cadr lst) (caddr lst))))
       (preferences:add-callback 'framework:default-text-color
                                 (lambda (p v)
-                                  (editor:update-standard-style
-                                   (lambda (style-delta)
-                                     (send style-delta set-delta-foreground v)))))
+                                  (editor:set-default-font-color v)))
       
       ;; groups
       

collects/framework/private/sig.ss

@@ -275,7 +275,8 @@
     (get-standard-style-list
      set-standard-style-list-pref-callbacks
      set-standard-style-list-delta
-     update-standard-style))
+     set-default-font-color
+     get-default-color-style-name))
   (define-signature framework:editor^
     ((open framework:editor-class^)
      (open framework:editor-fun^)))
@@ -295,6 +296,7 @@
 
   (define-signature framework:text-class^
     (basic<%>
+     foreground-color<%>
      hide-caret/selection<%>
      nbsp->space<%>
      delegate<%>
@@ -322,6 +324,7 @@
      info%
 
      basic-mixin
+     foreground-color-mixin
      hide-caret/selection-mixin
      nbsp->space-mixin
      delegate-mixin

collects/framework/private/text.ss

@@ -53,6 +53,7 @@ WARNING: printf is rebound in the body of the unit to always
           highlight-range
           get-highlighted-ranges
           get-styles-fixed
+          get-fixed-style
           set-styles-fixed
           move/copy-to-edit
           initial-autowrap-bitmap))
@@ -74,6 +75,8 @@ WARNING: printf is rebound in the body of the unit to always
           (define ranges null)
           
           (define/public-final (get-highlighted-ranges) ranges)
+          (define/public (get-fixed-style)
+            (send (get-style-list) find-named-style "Standard"))
           
           (define (invalidate-rectangles rectangles)
             (let ([b1 (box 0)]
@@ -328,10 +331,7 @@ WARNING: printf is rebound in the body of the unit to always
             (begin-edit-sequence))
           (define/augment (after-insert start len)
             (when styles-fixed?
-              (change-style (send (get-style-list) find-named-style "Standard")
-                            start
-                            (+ start len)
-                            #f))
+              (change-style (get-fixed-style) start (+ start len) #f))
             (end-edit-sequence)
             (inner (void) after-insert start len))
           
@@ -361,12 +361,22 @@ WARNING: printf is rebound in the body of the unit to always
           (super-instantiate ())
           (set-autowrap-bitmap (initial-autowrap-bitmap))))
       
+      (define foreground-color<%>
+        (interface (basic<%> editor:standard-style-list<%>)
+          ))
+          
+      (define foreground-color-mixin
+        (mixin (basic<%> editor:standard-style-list<%>) (foreground-color<%>)
+          (inherit begin-edit-sequence end-edit-sequence change-style)
+          (define/override (get-fixed-style)
+            (send (editor:get-standard-style-list) find-named-style (editor:get-default-color-style-name)))
+          (super-new)))
+      
       (define hide-caret/selection<%> (interface (basic<%>)))
       (define hide-caret/selection-mixin
         (mixin (basic<%>) (hide-caret/selection<%>)
           (inherit get-start-position get-end-position hide-caret)
           (define/augment (after-set-position)
-	    ;; >>> super was not here <<<
             (hide-caret (= (get-start-position) (get-end-position)))
 	    (inner (void) after-set-position))
           (super-instantiate ())))