From 4246217dc3a40a53a597af465325c62943c45f0a Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 20 May 1995 10:18:26 +0000
Subject: [PATCH] Move OS/2 console stuff to "os2graph", and flesh it out a
 little.

---
 v7/src/runtime/os2graph.scm | 104 +++++++++++++++++++++++++++++-------
 v7/src/runtime/os2winp.scm  |  40 +-------------
 v7/src/runtime/runtime.pkg  |  28 +++++-----
 v8/src/runtime/runtime.pkg  |  28 +++++-----
 4 files changed, 120 insertions(+), 80 deletions(-)

diff --git a/v7/src/runtime/os2graph.scm b/v7/src/runtime/os2graph.scm
index c9cea0b47..50fb1bff9 100644
--- a/v7/src/runtime/os2graph.scm
+++ b/v7/src/runtime/os2graph.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2graph.scm,v 1.8 1995/02/24 00:35:30 cph Exp $
+$Id: os2graph.scm,v 1.9 1995/05/20 10:17:55 cph Exp $
 
 Copyright (c) 1995 Massachusetts Institute of Technology
 
@@ -103,12 +103,9 @@ MIT in each case. |#
   (set! event-previewer-registration #f)
   (set! window-list (make-protection-list))
   (set! image-list (make-protection-list))
-  (set! color-table '())
   (set! user-event-mask user-event-mask:default)
   (set! user-event-queue (make-queue))
-  (for-each (lambda (entry)
-	      (os2-graphics/define-color #f (car entry) (cdr entry)))
-	    initial-color-definitions)
+  (initialize-color-table)
   (add-event-receiver! event:before-exit finalize-pm-state!)
   (add-gc-daemon! close-lost-objects-daemon))
 
@@ -117,7 +114,6 @@ MIT in each case. |#
 (define event-previewer-registration)
 (define window-list)
 (define image-list)
-(define color-table)
 (define user-event-mask)
 (define user-event-queue)
 
@@ -443,20 +439,11 @@ MIT in each case. |#
 
 (define (os2-graphics/define-color device name color)
   device
-  (if (not (and (color-name? name)
-		(not (char=? #\# (string-ref name 0)))))
-      (error:wrong-type-argument name "color name" 'DEFINE-COLOR))
-  (let ((entry (lookup-color-name name))
-	(color (->color color 'DEFINE-COLOR)))
-    (if entry
-	(set-cdr! entry color)
-	(begin
-	  (set! color-table (cons (cons name color) color-table))
-	  unspecific))))
+  (os2/define-color name color))
 
 (define (os2-graphics/find-color device specification)
   device
-  (->color specification 'FIND-COLOR))
+  (os2/find-color specification))
 
 (define (os2-graphics/set-background-color device color)
   (let ((window (graphics-device/descriptor device))
@@ -538,6 +525,21 @@ MIT in each case. |#
 
 ;;;; Color Support
 
+(define (os2/define-color name color)
+  (if (not (and (color-name? name)
+		(not (char=? #\# (string-ref name 0)))))
+      (error:wrong-type-argument name "color name" 'OS2/DEFINE-COLOR))
+  (let ((entry (lookup-color-name name))
+	(color (->color color 'OS2/DEFINE-COLOR)))
+    (if entry
+	(set-cdr! entry color)
+	(begin
+	  (set! color-table (cons (cons name color) color-table))
+	  unspecific))))
+
+(define (os2/find-color specification)
+  (->color specification 'OS2/FIND-COLOR))
+
 (define (->color specification procedure)
   (cond ((color? specification)
 	 specification)
@@ -566,7 +568,7 @@ MIT in each case. |#
   (+ (* #x10000 (car triple))
      (* #x100 (cadr triple))
      (caddr triple)))
-
+
 (define (color-name? object)
   (and (string? object)
        (not (string-null? object))))
@@ -589,6 +591,14 @@ MIT in each case. |#
 	     (car entries)
 	     (loop (cdr entries))))))
 
+(define (initialize-color-table)
+  (set! color-table '())
+  (for-each (lambda (entry)
+	      (os2/define-color (car entry) (cdr entry)))
+	    initial-color-definitions))
+
+(define color-table)
+
 (define initial-color-definitions
   `(("red"          255   0   0)
     ("green"          0 255   0)
@@ -608,6 +618,64 @@ MIT in each case. |#
     ("dark green"     0 127   0)
     ("brown"        127  63   0)))
 
+;;;; Console Window
+
+;;; This and the color support really should be in a separate file.
+
+(define (os2-console/color?)
+  (not (= 0 (os2ps-query-capability (os2win-ps (os2win-console-wid))
+				    CAPS_COLOR_TABLE_SUPPORT))))
+
+(define (os2-console/get-font-metrics)
+  (let ((metrics (os2ps-get-font-metrics (os2win-ps (os2win-console-wid)))))
+    (values (font-metrics/width metrics)
+	    (font-metrics/height metrics))))
+
+(define (os2-console/set-font! font-name)
+  (if (not (os2ps-set-font (os2win-ps (os2win-console-wid)) 1 font-name))
+      (error:bad-range-argument font-name 'OS2-CONSOLE/SET-FONT!)))
+
+(define (os2-console/set-colors! foreground background)
+  (let ((wid (os2win-console-wid)))
+    (os2ps-set-colors (os2win-ps wid)
+		      (os2/find-color foreground)
+		      (os2/find-color background))
+    (let ((w.h (os2win-get-size wid)))
+      (os2win-invalidate wid 0 (car w.h) 0 (cdr w.h)))))
+
+(define (os2-console/get-pel-size)
+  (let ((w.h (os2win-get-size (os2win-console-wid))))
+    (values (car w.h)
+	    (cdr w.h))))
+
+(define (os2-console/set-pel-size! width height)
+  (os2win-set-size (os2win-console-wid) width height))
+
+(define (os2-console/get-size)
+  (let ((wid (os2win-console-wid)))
+    (let ((w.h (os2win-get-size wid))
+	  (metrics (os2ps-get-font-metrics (os2win-ps wid))))
+      (values (quotient (car w.h) (font-metrics/width metrics))
+	      (quotient (cdr w.h) (font-metrics/height metrics))))))
+
+(define (os2-console/set-size! width height)
+  (let ((metrics (os2ps-get-font-metrics (os2win-ps (os2win-console-wid)))))
+    (os2-console/set-pel-size! (* width (font-metrics/width metrics))
+			       (* height (font-metrics/height metrics)))))
+
+(define (os2-console/get-frame-size)
+  (let ((w.h (os2win-get-frame-size (os2win-console-wid))))
+    (values (car w.h)
+	    (cdr w.h))))
+
+(define (os2-console/get-frame-position)
+  (let ((x.y (os2win-get-pos (os2win-console-wid))))
+    (values (car x.y)
+	    (cdr x.y))))
+
+(define (os2-console/set-frame-position! x y)
+  (os2win-set-pos (os2win-console-wid) x y))
+
 ;;;; Miscellaneous Support
 
 (define (set-window-font! window font-specifier)
diff --git a/v7/src/runtime/os2winp.scm b/v7/src/runtime/os2winp.scm
index a962d35bb..115be6534 100644
--- a/v7/src/runtime/os2winp.scm
+++ b/v7/src/runtime/os2winp.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2winp.scm,v 1.8 1995/05/20 03:03:14 cph Exp $
+$Id: os2winp.scm,v 1.9 1995/05/20 10:18:14 cph Exp $
 
 Copyright (c) 1995 Massachusetts Institute of Technology
 
@@ -59,6 +59,7 @@ MIT in each case. |#
   (os2ps-get-bitmap 1)
   (os2ps-get-bitmap-bits 5)
   (os2ps-get-bitmap-parameters 1)
+  (os2ps-get-font-metrics 1)
   (os2ps-line 3)
   (os2ps-move-graphics-cursor 3)
   (os2ps-poly-line 3)
@@ -142,43 +143,6 @@ MIT in each case. |#
   (width #f read-only #t)
   (height #f read-only #t)
   (descender #f read-only #t))
-
-(define (os2-console/set-font! font-name)
-  (let ((metrics
-	 (os2ps-set-font (os2win-ps (os2win-console-wid)) 1 font-name)))
-    (if (not metrics)
-	(error "Unknown font name:" font-name))
-    (values (font-metrics/width metrics)
-	    (font-metrics/height metrics))))
-
-(define (os2-console/set-colors! foreground background)
-  (let ((wid (os2win-console-wid)))
-    (os2ps-set-colors (os2win-ps wid)
-		      (->color foreground 'OS2-CONSOLE/SET-COLORS!)
-		      (->color background 'OS2-CONSOLE/SET-COLORS!))
-    (let ((w.h (os2win-get-size wid)))
-      (os2win-invalidate wid 0 (car w.h) 0 (cdr w.h)))))
-
-(define (os2-console/get-pel-size)
-  (let ((w.h (os2win-get-size (os2win-console-wid))))
-    (values (car w.h)
-	    (cdr w.h))))
-
-(define (os2-console/set-pel-size! width height)
-  (os2win-set-size (os2win-console-wid) width height))
-
-(define (os2-console/get-frame-size)
-  (let ((w.h (os2win-get-frame-size (os2win-console-wid))))
-    (values (car w.h)
-	    (cdr w.h))))
-
-(define (os2-console/get-frame-position)
-  (let ((x.y (os2win-get-pos (os2win-console-wid))))
-    (values (car x.y)
-	    (cdr x.y))))
-
-(define (os2-console/set-frame-position! x y)
-  (os2win-set-pos (os2win-console-wid) x y))
 
 ;;; Constants from OS/2 header file "pmwin.h":
 
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index cb6084767..2d9ba8b65 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.258 1995/05/20 03:03:22 cph Exp $
+$Id: runtime.pkg,v 14.259 1995/05/20 10:18:26 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -2345,10 +2345,21 @@ MIT in each case. |#
     (else))
   (parent ())
   (export ()
+	  os2-console/color?
+	  os2-console/get-font-metrics
+	  os2-console/get-frame-position
+	  os2-console/get-frame-size
+	  os2-console/get-pel-size
+	  os2-console/get-size
+	  os2-console/set-colors!
+	  os2-console/set-font!
+	  os2-console/set-frame-position!
+	  os2-console/set-pel-size!
+	  os2-console/set-size!
 	  os2-graphics-device-type
-	  os2-image/set-colormap)
-  (export (runtime os2-window-primitives)
-	  ->color)
+	  os2-image/set-colormap
+	  os2/define-color
+	  os2/find-color)
   (initialization (initialize-package!)))
 
 (define-package (runtime os2-window-primitives)
@@ -2356,14 +2367,6 @@ MIT in each case. |#
     ((os/2) "os2winp")
     (else))
   (parent ())
-  (export ()
-	  os2-console/get-frame-position
-	  os2-console/get-frame-size
-	  os2-console/get-pel-size
-	  os2-console/set-colors!
-	  os2-console/set-font!
-	  os2-console/set-frame-position!
-	  os2-console/set-pel-size!)
   (export (runtime os2-graphics)
 	  bbo_and
 	  bbo_ignore
@@ -2618,6 +2621,7 @@ MIT in each case. |#
 	  os2ps-get-bitmap
 	  os2ps-get-bitmap-bits
 	  os2ps-get-bitmap-parameters
+	  os2ps-get-font-metrics
 	  os2ps-line
 	  os2ps-move-graphics-cursor
 	  os2ps-poly-line
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index cb6084767..2d9ba8b65 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.258 1995/05/20 03:03:22 cph Exp $
+$Id: runtime.pkg,v 14.259 1995/05/20 10:18:26 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -2345,10 +2345,21 @@ MIT in each case. |#
     (else))
   (parent ())
   (export ()
+	  os2-console/color?
+	  os2-console/get-font-metrics
+	  os2-console/get-frame-position
+	  os2-console/get-frame-size
+	  os2-console/get-pel-size
+	  os2-console/get-size
+	  os2-console/set-colors!
+	  os2-console/set-font!
+	  os2-console/set-frame-position!
+	  os2-console/set-pel-size!
+	  os2-console/set-size!
 	  os2-graphics-device-type
-	  os2-image/set-colormap)
-  (export (runtime os2-window-primitives)
-	  ->color)
+	  os2-image/set-colormap
+	  os2/define-color
+	  os2/find-color)
   (initialization (initialize-package!)))
 
 (define-package (runtime os2-window-primitives)
@@ -2356,14 +2367,6 @@ MIT in each case. |#
     ((os/2) "os2winp")
     (else))
   (parent ())
-  (export ()
-	  os2-console/get-frame-position
-	  os2-console/get-frame-size
-	  os2-console/get-pel-size
-	  os2-console/set-colors!
-	  os2-console/set-font!
-	  os2-console/set-frame-position!
-	  os2-console/set-pel-size!)
   (export (runtime os2-graphics)
 	  bbo_and
 	  bbo_ignore
@@ -2618,6 +2621,7 @@ MIT in each case. |#
 	  os2ps-get-bitmap
 	  os2ps-get-bitmap-bits
 	  os2ps-get-bitmap-parameters
+	  os2ps-get-font-metrics
 	  os2ps-line
 	  os2ps-move-graphics-cursor
 	  os2ps-poly-line
-- 
2.25.1