Move OS/2 console stuff to "os2graph", and flesh it out a little.

diff --git a/v7/src/runtime/os2graph.scm b/v7/src/runtime/os2graph.scm
index c9cea0b47d66813525f10df90c00e2be71f66be2..50fb1bff960712d945a5090ca7db633a7791d619 100644 (file)
--- 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))
 \f
@@ -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. |#
 \f
 ;;;; 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)))
-
+\f
 (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)))
 \f
+;;;; 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))
+\f
 ;;;; Miscellaneous Support
 
 (define (set-window-font! window font-specifier)

diff --git a/v7/src/runtime/os2winp.scm b/v7/src/runtime/os2winp.scm
index a962d35bb061cb0d1e112b1567e21e5e7802017b..115be6534f2d1961942d8b2b0a3415b18113dc3e 100644 (file)
--- 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))
 \f
 ;;; Constants from OS/2 header file "pmwin.h":
 

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index cb608476727d99de807463d3378babb2b5cbc06c..2d9ba8b65eeb55ad1d46e71245df0d40bb1b3776 100644 (file)
--- 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 cb608476727d99de807463d3378babb2b5cbc06c..2d9ba8b65eeb55ad1d46e71245df0d40bb1b3776 100644 (file)
--- 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