From a774016b57d07c5a1d4632f302c5e1b9db111e99 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 30 Jul 2009 05:17:40 +0000
Subject: [PATCH] added automatic compilation to the module language, plus
 various other tweaks (contract library enhancement, bug fixes here and there)

svn: r15635

original commit: b5b32d1d8eb78bb54155666b77188073682ef1b7
---
 collects/framework/main.ss         | 31 ++++++++++++++++++++++++++++++
 collects/framework/private/sig.ss  |  9 ++++++++-
 collects/framework/private/text.ss | 28 +++++++++++++--------------
 collects/framework/splash.ss       |  2 +-
 4 files changed, 54 insertions(+), 16 deletions(-)

diff --git a/collects/framework/main.ss b/collects/framework/main.ss
index aa0a4b68..78c30cac 100644
--- a/collects/framework/main.ss
+++ b/collects/framework/main.ss
@@ -54,6 +54,37 @@
   (link standard-mred@ framework@))
 
 (provide/doc
+ 
+ (proc-doc/names 
+  text:range? (-> any/c boolean?) (arg)
+  @{Determines if @scheme[arg] is an instance of the @tt{range} struct.})
+ 
+ (proc-doc/names
+  text:range-start
+  (-> text:range? exact-nonnegative-integer?)
+  (range)
+  @{Returns the start position of the range.})
+ (proc-doc/names
+  text:range-end
+  (-> text:range? exact-nonnegative-integer?)
+  (range)
+  @{Returns the end position of the range.})
+ (proc-doc/names
+  text:range-caret-space?
+  (-> text:range? boolean?)
+  (range)
+  @{Returns a boolean indicating where the caret-space in the range goes. See also @method[text:basic<%> highlight-range].})
+ (proc-doc/names
+  text:range-style
+  (-> text:range? exact-nonnegative-integer?)
+  (range)
+  @{Returns the style of the range. See also @method[text:basic<%> highlight-range].})
+ (proc-doc/names
+  text:range-color
+  (-> text:range? (or/c string? (is-a?/c color%)))
+  (range)
+  @{Returns the color of the highlighted range.})
+    
  (parameter-doc
   text:autocomplete-append-after
   (parameter/c string?)
diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss
index ec23b69f..ea446f8f 100644
--- a/collects/framework/private/sig.ss
+++ b/collects/framework/private/sig.ss
@@ -217,7 +217,14 @@
     (autocomplete-append-after
      autocomplete-limit
      get-completions/manuals
-     lookup-port-name))
+     lookup-port-name
+     
+     range?
+     range-start
+     range-end
+     range-caret-space? 
+     range-style 
+     range-color))
   
   (define-signature canvas-class^
     (basic<%>
diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss
index b626e2d0..d0b1e2fd 100644
--- a/collects/framework/private/text.ss
+++ b/collects/framework/private/text.ss
@@ -7,17 +7,16 @@ WARNING: printf is rebound in the body of the unit to always
 |#
 
 (require string-constants
-         mzlib/class
-         mzlib/match
+         scheme/unit
+         scheme/class
+         scheme/match
          scheme/path
          "sig.ss"
          "../gui-utils.ss"
          "../preferences.ss"
          mred/mred-sig
          mrlib/interactive-value-port
-         mzlib/list
          setup/dirs
-         mzlib/string
          (prefix-in srfi1: srfi/1))
 (require setup/xref
          scribble/xref
@@ -41,6 +40,7 @@ WARNING: printf is rebound in the body of the unit to always
   (apply fprintf original-output-port args)
   (void))
 
+
 (define-struct range (start end caret-space? style color) #:inspector #f)
 (define-struct rectangle (left top right bottom style color) #:inspector #f)
 
@@ -2674,12 +2674,12 @@ WARNING: printf is rebound in the body of the unit to always
              (map
               (λ (a-committer)
                 (match a-committer
-                  [($ committer 
-                      kr
-                      commit-peeker-evt
-                      done-evt
-                      resp-chan
-                      resp-nack)
+                  [(struct committer 
+                           (kr
+                            commit-peeker-evt
+                            done-evt
+                            resp-chan
+                            resp-nack))
                    (choice-evt
                     (handle-evt 
                      commit-peeker-evt
@@ -2737,9 +2737,9 @@ WARNING: printf is rebound in the body of the unit to always
        ;; does the dumping. otherwise, return #f
        (define ((service-committer data peeker-evt) a-committer)
          (match a-committer
-           [($ committer
-               kr commit-peeker-evt
-               done-evt resp-chan resp-nack)
+           [(struct committer
+                    (kr commit-peeker-evt
+                        done-evt resp-chan resp-nack))
             (let ([size (queue-size data)])
               (cond
                 [(not (eq? peeker-evt commit-peeker-evt))
@@ -2758,7 +2758,7 @@ WARNING: printf is rebound in the body of the unit to always
        ;; otherwise return #f
        (define (service-waiter a-peeker)
          (match a-peeker
-           [($ peeker bytes skip-count pe resp-chan nack-evt polling?)
+           [(struct peeker (bytes skip-count pe resp-chan nack-evt polling?))
             (cond
               [(and pe (not (eq? pe peeker-evt)))
                (choice-evt (channel-put-evt resp-chan #f)
diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss
index 240059e0..47802f3d 100644
--- a/collects/framework/splash.ss
+++ b/collects/framework/splash.ss
@@ -299,7 +299,7 @@
   (class canvas%
     (inherit get-client-size get-dc)
     (define/override (on-char evt) (char-observer evt))
-    (define/override (on-paint) (send (get-dc) draw-bitmap splash-cache-bitmap 0 0))
+    (define/override (on-paint) (when splash-cache-bitmap (send (get-dc) draw-bitmap splash-cache-bitmap 0 0)))
     (define/override (on-event evt) (splash-event-callback evt))
     (super-new)))