From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 20 May 1995 10:19:57 +0000 (+0000)
Subject: Change color stuff to use global color-name database implemented in
X-Git-Tag: 20090517-FFI~6285
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d6bcbc40f292a90551a0e36e877faeea8c3ae1d5;p=mit-scheme.git

Change color stuff to use global color-name database implemented in
the runtime system.  Add M-x define-color.
---

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 22d143fba..b5753db4a 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.175 1995/05/16 09:21:12 cph Exp $
+$Id: edwin.pkg,v 1.176 1995/05/20 10:19:57 cph Exp $
 
 Copyright (c) 1989-95 Massachusetts Institute of Technology
 
@@ -1326,6 +1326,7 @@ MIT in each case. |#
     (files "os2com")
     (parent (edwin))
     (export (edwin)
+	    edwin-command$define-color-name
 	    edwin-command$set-background-color
 	    edwin-command$set-font
 	    edwin-command$set-foreground-color
diff --git a/v7/src/edwin/os2com.scm b/v7/src/edwin/os2com.scm
index aa09311a2..fbcee3854 100644
--- a/v7/src/edwin/os2com.scm
+++ b/v7/src/edwin/os2com.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: os2com.scm,v 1.1 1994/12/19 19:46:35 cph Exp $
+;;;	$Id: os2com.scm,v 1.2 1995/05/20 10:19:46 cph Exp $
 ;;;
 ;;;	Copyright (c) 1994 Massachusetts Institute of Technology
 ;;;
@@ -50,7 +50,7 @@
   "sSet foreground color"
   (lambda (name)
     (let ((screen (selected-screen)))
-      (os2-screen/set-foreground-color! screen (name->color name))
+      (os2-screen/set-foreground-color! screen (os2/find-color name))
       (update-screen! screen #t))))
 
 (define-command set-background-color
@@ -58,23 +58,16 @@
   "sSet background color"
   (lambda (name)
     (let ((screen (selected-screen)))
-      (os2-screen/set-background-color! screen (name->color name))
+      (os2-screen/set-background-color! screen (os2/find-color name))
       (update-screen! screen #t))))
 
-(define (name->color name)
-  (let ((length (string-length name)))
-    (if (and (not (fix:= 0 length))
-	     (char=? #\# (string-ref name 0)))
-	(let ((color
-	       (and (fix:= 7 length)
-		    (let ((color (substring->number name 1 length 16)))
-		      (and color
-			   (fix:>= color 0)
-			   color)))))
-	  (if (not color)
-	      (editor-error "Ill-formed RGB color name:" name))
-	  color)
-	(editor-error "Unknown color name:" name))))
+(define-command define-color-name
+  "Globally define COLOR-NAME to be COLOR.
+This does not affect any colors on the screen,
+but changes the meaning of COLOR-NAME when it is used in the future."
+  "sDefine color\nsDefine color to"
+  (lambda (name color)
+    (os2/define-color name color)))
 
 (define-command set-font
   "Set font to be used for drawing text."