#| -*-Scheme-*-

$Id: os2term.scm,v 1.25 2003/02/14 18:28:12 cph Exp $

Copyright 1994,1995,1996,1997,2000,2003 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; OS/2 Presentation Manager Interface
;;; Package: (edwin screen os2-screen)

(declare (usual-integrations))
(declare (integrate-external "../runtime/os2winp"))

(define os2-display-type)
(define screen-list)
(define event-queue)
(define event-descriptor)
(define virtual-key-table)
(define signal-interrupts?)
(define previewer-registration)
(define reading-event?)
(define desktop-width)
(define desktop-height)
(define hide-console?)
(define edwin-screen-icon)

(define (initialize-package!)
  (set! os2-display-type
	(make-display-type 'PM
			   #t
			   (lambda () (initialize-pm-state) #t)
			   make-os2-screen
			   get-os2-input-operations
			   with-editor-interrupts-from-os2
			   with-os2-interrupts-enabled
			   with-os2-interrupts-disabled))
  (set! virtual-key-table (make-virtual-key-table))
  (set! event-descriptor #f)
  (add-event-receiver! event:before-exit finalize-pm-state))

(define (initialize-pm-state)
  (if (not event-descriptor)
      (begin
	(set! screen-list '())
	(set! event-queue (make-queue))
	(set! event-descriptor (os2win-open-event-qid))
	(set! desktop-width (os2win-desktop-width))
	(set! desktop-height (os2win-desktop-height))
	(set! hide-console? #t)
	(set! edwin-screen-icon
	      (os2win-load-pointer HWND_DESKTOP NULLHANDLE IDI_EDWIN))
	unspecific)))

(define (finalize-pm-state)
  (if event-descriptor
      (begin
	(os2win-destroy-pointer edwin-screen-icon)
	(set! edwin-screen-icon)
	(do () ((null? screen-list)) (os2-screen/discard! (car screen-list)))
	(set! event-queue)
	(os2win-close-event-qid event-descriptor)
	(set! event-descriptor #f)
	unspecific)))

(define (with-editor-interrupts-from-os2 receiver)
  (fluid-let ((reading-event? #f)
	      (signal-interrupts? #t)
	      (previewer-registration))
    (dynamic-wind (lambda ()
		    (preview-event-stream)
		    (if hide-console?
			(begin
			  (set! hide-console? #f)
			  (os2win-set-state (os2win-console-wid)
					    window-state:hide))))
		  (lambda ()
		    (receiver (lambda (thunk) (thunk)) '()))
		  (lambda ()
		    (deregister-io-thread-event previewer-registration)))))

(define (with-os2-interrupts-enabled thunk)
  (with-signal-interrupts #t thunk))

(define (with-os2-interrupts-disabled thunk)
  (with-signal-interrupts #f thunk))

(define (with-signal-interrupts enabled? thunk)
  (let ((old))
    (dynamic-wind (lambda ()
		    (set! old signal-interrupts?)
		    (set! signal-interrupts? enabled?)
		    unspecific)
		  thunk
		  (lambda ()
		    (set! enabled? signal-interrupts?)
		    (set! signal-interrupts? old)
		    unspecific))))

(define (make-os2-screen)
  (call-with-values open-window
    (lambda (state x-size y-size)
      (let ((screen
	     (make-screen state
			  os2-screen/beep
			  os2-screen/clear-line!
			  os2-screen/clear-rectangle!
			  os2-screen/clear-screen!
			  os2-screen/discard!
			  os2-screen/enter!
			  os2-screen/exit!
			  os2-screen/flush!
			  os2-screen/modeline-event!
			  #f
			  os2-screen/scroll-lines-down!
			  os2-screen/scroll-lines-up!
			  os2-screen/wrap-update!
			  os2-screen/write-char!
			  os2-screen/write-cursor!
			  os2-screen/write-substring!
			  8
			  x-size
			  y-size)))
	(set! screen-list (cons screen screen-list))
	screen))))

(define (open-window)
  (let ((wid (os2win-open event-descriptor "Edwin")))
    (os2win-set-icon wid edwin-screen-icon)
    (let ((metrics
	   (if current-font
	       (let ((metrics (set-normal-font! wid current-font)))
		 (if (not metrics)
		     (error "Unknown font name:" current-font))
		 metrics)
	       (let loop ((fonts initial-font-list))
		 (if (null? fonts)
		     (error "Unable to find usable font:" initial-font-list))
		 (let ((metrics (set-normal-font! wid (car fonts))))
		   (if metrics
		       (begin
			 (set! current-font (car fonts))
			 metrics)
		       (loop (cdr fonts))))))))
      (os2ps-set-colors (os2win-ps wid)
			(face-foreground-color normal-face)
			(face-background-color normal-face))
      (os2win-show-cursor wid #t)
      (os2win-show wid #t)
      (os2win-activate wid)
      (let ((w.h (os2win-get-size wid)))
	(let ((x-size (fix:quotient (car w.h) (font-metrics/width metrics)))
	      (y-size (fix:quotient (cdr w.h) (font-metrics/height metrics))))
	  (let ((size (fix:* x-size y-size)))
	    (values (make-screen-state wid
				       metrics
				       (car w.h)
				       (cdr w.h)
				       (make-string size #\space)
				       (make-vector size normal-face))
		    x-size
		    y-size)))))))

(define (os2-screen/beep screen)
  screen
  (os2win-alarm WA_ERROR))

(define (os2-screen/clear-line! screen x y first-unused-x)
  (let ((start (screen-char-index screen x y))
	(end (screen-char-index screen first-unused-x y))
	(face (screen-normal-face screen)))
    (substring-fill! (screen-char-map screen) start end #\space)
    (subvector-fill! (screen-face-map screen) start end face)
    (set-screen-face! screen face))
  (os2ps-clear (screen-psid screen)
	       (cxl->xl screen x)
	       (cxh->xh screen first-unused-x)
	       (cyh->yl screen (fix:+ y 1))
	       (cyl->yh screen y)))

(define (os2-screen/clear-rectangle! screen xl xu yl yu highlight)
  (if (fix:< xl xu)
      (let ((char-map (screen-char-map screen))
	    (face-map (screen-face-map screen))
	    (face (screen-face screen highlight))
	    (x-size (screen-x-size screen))
	    (width (fix:- xu xl)))
	(do ((y yl (fix:+ y 1))
	     (start (screen-char-index screen xl yl) (fix:+ start x-size)))
	    ((fix:= y yu))
	  (let ((end (fix:+ start width)))
	    (substring-fill! char-map start end #\space)
	    (subvector-fill! face-map start end face)))
	(set-screen-face! screen face)
	(os2ps-clear (screen-psid screen)
		     (cxl->xl screen xl) (cxh->xh screen xu)
		     (cyh->yl screen yu) (cyl->yh screen yl)))))

(define (os2-screen/clear-screen! screen)
  (let ((face (screen-normal-face screen)))
    (string-fill! (screen-char-map screen) #\space)
    (vector-fill! (screen-face-map screen) face)
    (set-screen-face! screen face))
  (os2ps-clear (screen-psid screen)
	       0 (screen-pel-width screen)
	       0 (screen-pel-height screen)))

(define (os2-screen/discard! screen)
  (set! screen-list (delq! screen screen-list))
  (os2win-close (screen-wid screen)))

(define (os2-screen/enter! screen)
  (os2win-activate (screen-wid screen)))

(define (os2-screen/exit! screen)
  screen
  unspecific)

(define (os2-screen/flush! screen)
  screen
  unspecific)

(define (os2-screen/modeline-event! screen window type)
  screen window type
  unspecific)

(define (os2-screen/wrap-update! screen thunk)
  (let ((finished? #f))
    (dynamic-wind (lambda () unspecific)
		  (lambda ()
		    (let ((result (thunk)))
		      (set! finished? result)
		      result))
		  (lambda ()
		    (set-screen-face! screen (screen-normal-face screen))
		    (if finished?
			(update-os2-screen-names! screen))))))

(define (os2-screen/write-cursor! screen x y)
  (os2win-move-cursor (screen-wid screen) (cx->x screen x) (cy->y screen y)))

(define (os2-screen/write-char! screen x y char highlight)
  (let ((char-map (screen-char-map screen))
	(index (screen-char-index screen x y))
	(face (screen-face screen highlight)))
    (string-set! char-map index char)
    (vector-set! (screen-face-map screen) index face)
    (set-screen-face! screen face)
    (os2ps-write (screen-psid screen)
		 (cx->x screen x)
		 (fix:+ (cy->y screen y) (screen-char-descender screen))
		 char-map
		 index
		 (fix:+ index 1))))

(define (os2-screen/write-substring! screen x y string start end highlight)
  (let ((start* (screen-char-index screen x y))
	(face (screen-face screen highlight)))
    (%substring-move! string start end (screen-char-map screen) start*)
    (subvector-fill! (screen-face-map screen)
		     start*
		     (fix:+ start* (fix:- end start))
		     face)
    (set-screen-face! screen face)
    (os2ps-write (screen-psid screen)
		 (cx->x screen x)
		 (fix:+ (cy->y screen y) (screen-char-descender screen))
		 string start end)))

(define use-scrolling? #t)

(define (os2-screen/scroll-lines-down! screen xl xu yl yu amount)
  (and use-scrolling?
       (begin
	 (let ((char-map (screen-char-map screen))
	       (face-map (screen-face-map screen))
	       (x-size (screen-x-size screen))
	       (width (fix:- xu xl))
	       (y-from (fix:- yu amount)))
	   (if (fix:= x-size width)
	       (let ((start (fix:* x-size yl))
		     (end (fix:* x-size y-from))
		     (start* (fix:* x-size (fix:+ yl amount))))
		 (%substring-move! char-map start end char-map start*)
		 (subvector-move-right! face-map start end face-map start*))
	       (let ((delta (fix:* x-size amount))
		     (end (screen-char-index screen xl (fix:- yl 1))))
		 (do ((from (screen-char-index screen xl (fix:- y-from 1))
			    (fix:- from x-size)))
		     ((fix:= from end))
		   (let ((from-end (fix:+ from width))
			 (to (fix:+ from delta)))
		     (%substring-move! char-map from from-end char-map to)
		     (subvector-move-right! face-map from from-end
					    face-map to))))))
	 (os2win-scroll (screen-wid screen)
			(cxl->xl screen xl)
			(cxh->xh screen xu)
			(cyh->yl screen (fix:- yu amount))
			(cyl->yh screen yl)
			0
			(fix:- 0 (fix:* amount (screen-char-height screen))))
	 'CLOBBERED-CURSOR)))

(define (os2-screen/scroll-lines-up! screen xl xu yl yu amount)
  (and use-scrolling?
       (begin
	 (let ((char-map (screen-char-map screen))
	       (face-map (screen-face-map screen))
	       (x-size (screen-x-size screen))
	       (width (fix:- xu xl))
	       (y-from (fix:+ yl amount)))
	   (if (fix:= x-size width)
	       (let ((start (fix:* x-size y-from))
		     (end (fix:* x-size yu))
		     (start* (fix:* x-size yl)))
		 (%substring-move! char-map start end char-map start*)
		 (subvector-move-left! face-map start end face-map start*))
	       (let ((delta (fix:* x-size amount))
		     (end (screen-char-index screen xl yu)))
		 (do ((from (screen-char-index screen xl y-from)
			    (fix:+ from x-size)))
		     ((fix:= from end))
		   (let ((from-end (fix:+ from width))
			 (to (fix:- from delta)))
		     (%substring-move! char-map from from-end char-map to)
		     (subvector-move-left! face-map from from-end
					   face-map to))))))
	 (os2win-scroll (screen-wid screen)
			(cxl->xl screen xl)
			(cxh->xh screen xu)
			(cyh->yl screen yu)
			(cyl->yh screen (fix:+ yl amount))
			0
			(fix:* amount (screen-char-height screen)))
	 'CLOBBERED-CURSOR)))

(define-integrable (screen-face screen highlight)
  (if highlight
      (screen-highlight-face screen)
      (screen-normal-face screen)))

(define (set-screen-face! screen face)
  (if (not (eq? face (screen-current-face screen)))
      (begin
	(os2ps-set-colors (screen-psid screen)
			  (face-foreground-color face)
			  (face-background-color face))
	(set-screen-current-face! screen face))))

(define-structure face
  (foreground-color #f read-only #t)
  (background-color #f read-only #t))

(define current-font #f)
(define initial-font-list
  '("4.System VIO" "8.Courier" "10.Courier" "12.Courier"
		   "10.System Monospaced"))
(define normal-face (make-face #x000000 #xFFFFFF))
(define highlight-face (make-face #xFFFFFF #x000000))

(define-integrable (screen-normal-face screen) screen normal-face)
(define-integrable (screen-highlight-face screen) screen highlight-face)

(define (os2-screen/set-foreground-color! screen color)
  screen
  (set! normal-face
	(make-face color (face-background-color normal-face)))
  (set! highlight-face
	(make-face (face-foreground-color highlight-face) color))
  unspecific)

(define (os2-screen/set-background-color! screen color)
  screen
  (set! normal-face
	(make-face (face-foreground-color normal-face) color))
  (set! highlight-face
	(make-face color (face-background-color highlight-face)))
  unspecific)

(define (os2-screen/set-font! screen font)
  (let ((metrics (set-normal-font! (screen-wid screen) font)))
    (if (not metrics)
	(error "Unknown font name:" font))
    (set-screen-font-metrics! screen metrics))
  (set! current-font font)
  (let ((resize (screen-resize-thunk screen)))
    (if resize
	(resize))))

(define (set-normal-font! wid font)
  (let ((metrics (os2ps-set-font (os2win-ps wid) 1 font)))
    (if metrics
	(let ((width (font-metrics/width metrics))
	      (height (font-metrics/height metrics)))
	  (os2win-set-grid wid width height)
	  (os2win-shape-cursor wid width height
			       (fix:or CURSOR_SOLID CURSOR_FLASH))))
    metrics))

(define (os2-screen/set-size! screen x-size y-size)
  (os2win-set-size (screen-wid screen)
		   (fix:* x-size (screen-char-width screen))
		   (fix:* y-size (screen-char-height screen))))

(define (os2-screen/get-frame-size screen)
  (let ((w.h (os2win-get-frame-size (screen-wid screen))))
    (values (car w.h)
	    (cdr w.h))))

(define (os2-screen/get-position screen)
  (let ((x.y (os2win-get-pos (screen-wid screen))))
    (values (car x.y)
	    (cdr x.y))))

(define (os2-screen/set-position! screen x y)
  (os2win-set-pos (screen-wid screen) x y))

(define (os2-screen/set-title! screen title)
  (let ((title* (screen-current-title screen)))
    (if (not (and title* (string=? title title*)))
	(begin
	  (set-screen-current-title! screen #f)
	  (os2win-set-title (screen-wid screen) title)
	  (set-screen-current-title! screen title)))))

(define (os2-screen/raise! screen)
  (os2win-set-state (screen-wid screen) window-state:top))

(define (os2-screen/lower! screen)
  (os2win-set-state (screen-wid screen) window-state:bottom))

(define (os2-screen/show! screen)
  (os2win-set-state (screen-wid screen) window-state:show))

(define (os2-screen/hide! screen)
  (os2win-set-state (screen-wid screen) window-state:hide))

(define (os2-screen/activate! screen)
  (os2win-set-state (screen-wid screen) window-state:activate))

(define (os2-screen/deactivate! screen)
  (os2win-set-state (screen-wid screen) window-state:deactivate))

(define (os2-screen/minimize! screen)
  (os2win-set-state (screen-wid screen) window-state:minimize))

(define (os2-screen/maximize! screen)
  (os2win-set-state (screen-wid screen) window-state:maximize))

(define (os2-screen/restore! screen)
  (os2win-set-state (screen-wid screen) window-state:restore))

(define (os2/desktop-width)
  desktop-width)

(define (os2/desktop-height)
  desktop-height)

(define-integrable (cx->x screen cx)
  ;; Returns leftmost pel of cell.
  (fix:* cx (screen-char-width screen)))

(define-integrable (cy->y screen cy)
  ;; Returns bottommost pel of cell.
  (cyl->yh screen (fix:+ cy 1)))

(define-integrable (cyl->yh screen cy)
  ;; Returns bottommost pel of cell above.
  (fix:* (fix:- (screen-y-size screen) cy) (screen-char-height screen)))

(define-integrable cxl->xl cx->x)
(define-integrable cxh->xh cx->x)
(define-integrable cyh->yl cyl->yh)

(define (x->cx screen x)
  (let ((cx (fix:quotient x (screen-char-width screen)))
	(xs (screen-x-size screen)))
    (if (fix:> cx xs)
	xs
	cx)))

(define (y->cy screen y)
  (let ((cy
	 (fix:- (fix:- (screen-y-size screen) 1)
		(fix:quotient y (screen-char-height screen)))))
    (if (fix:< cy 0)
	0
	cy)))

(define (xl->cxl screen xl)
  (let ((cx (fix:quotient xl (screen-char-width screen)))
	(xs (screen-x-size screen)))
    (if (fix:> cx xs)
	xs
	cx)))

(define (xh->cxh screen xh)
  (let ((cx
	 (let ((cw (screen-char-width screen)))
	   (let ((cx (fix:quotient xh cw)))
	     (if (fix:= 0 (fix:remainder xh cw))
		 cx
		 (fix:+ cx 1)))))
	(xs (screen-x-size screen)))
    (if (fix:> cx xs)
	xs
	cx)))

(define (yl->cyh screen yl)
  (let ((cy
	 (fix:- (screen-y-size screen)
		(fix:quotient yl (screen-char-height screen)))))
    (if (fix:< cy 0)
	0
	cy)))

(define (yh->cyl screen yh)
  (let ((cy
	 (let ((ch (screen-char-height screen)))
	   (let ((cy (fix:- (screen-y-size screen) (fix:quotient yh ch))))
	     (if (fix:= 0 (fix:remainder yh ch))
		 cy
		 (fix:- cy 1))))))
    (if (fix:< cy 0)
	0
	cy)))

(define-integrable (width->x-size screen width)
  (fix:quotient width (screen-char-width screen)))

(define-integrable (height->y-size screen height)
  (fix:quotient height (screen-char-height screen)))

(define-structure (os2-screen-state
		   (constructor
		    make-screen-state
		    (wid font-metrics pel-width pel-height char-map face-map))
		   (predicate screen-state?)
		   (conc-name screen-state/))
  (wid #f read-only #t)
  font-metrics
  (pel-width 0)
  (pel-height 0)
  (char-map "")
  (face-map '#())
  (current-face normal-face)
  (current-title #f))

(define-integrable (screen-wid screen)
  (screen-state/wid (screen-state screen)))

(define-integrable (screen-font-metrics screen)
  (screen-state/font-metrics (screen-state screen)))

(define-integrable (set-screen-font-metrics! screen metrics)
  (set-screen-state/font-metrics! (screen-state screen) metrics))

(define-integrable (screen-pel-width screen)
  (screen-state/pel-width (screen-state screen)))

(define-integrable (set-screen-pel-width! screen width)
  (set-screen-state/pel-width! (screen-state screen) width))

(define-integrable (screen-pel-height screen)
  (screen-state/pel-height (screen-state screen)))

(define-integrable (set-screen-pel-height! screen height)
  (set-screen-state/pel-height! (screen-state screen) height))

(define-integrable (screen-char-map screen)
  (screen-state/char-map (screen-state screen)))

(define-integrable (set-screen-char-map! screen char-map)
  (set-screen-state/char-map! (screen-state screen) char-map))

(define-integrable (screen-face-map screen)
  (screen-state/face-map (screen-state screen)))

(define-integrable (set-screen-face-map! screen face-map)
  (set-screen-state/face-map! (screen-state screen) face-map))

(define-integrable (screen-current-face screen)
  (screen-state/current-face (screen-state screen)))

(define-integrable (set-screen-current-face! screen face)
  (set-screen-state/current-face! (screen-state screen) face))

(define-integrable (screen-current-title screen)
  (screen-state/current-title (screen-state screen)))

(define-integrable (set-screen-current-title! screen title)
  (set-screen-state/current-title! (screen-state screen) title))

(define-integrable (screen-psid screen)
  (os2win-ps (screen-wid screen)))

(define-integrable (screen-char-width screen)
  (font-metrics/width (screen-font-metrics screen)))

(define-integrable (screen-char-height screen)
  (font-metrics/height (screen-font-metrics screen)))

(define-integrable (screen-char-descender screen)
  (font-metrics/descender (screen-font-metrics screen)))

(define-integrable (screen-char-index screen x y)
  (fix:+ (fix:* y (screen-x-size screen)) x))

(define (wid->screen wid)
  (let loop ((screens screen-list))
    (and (not (null? screens))
	 (if (fix:= wid (screen-wid (car screens)))
	     (car screens)
	     (loop (cdr screens))))))

(define (get-os2-input-operations screen)
  screen
  (let ((pending #f)
	(repeat 0))

    (define (halt-update?)
      (setup-pending 'IN-UPDATE)
      pending)

    (define (peek-no-hang)
      (setup-pending #f)
      pending)

    (define (peek)
      (setup-pending #t)
      pending)

    (define (read)
      (setup-pending #t)
      (let ((result pending))
	(if (fix:> repeat 1)
	    (set! repeat (fix:- repeat 1))
	    (set! pending #f))
	result))

    (define (setup-pending block?)
      (if (not pending)
	  (let loop ()
	    (let ((event (read-event block?)))
	      (cond ((not event)
		     (set! pending #f))
		    ((input-event? event)
		     (set! pending event)
		     (set! repeat 1))
		    ((not (vector? event))
		     (let ((flag (process-change-event event)))
		       (if flag
			   (begin
			     (set! pending
				   (make-input-event
				    (if (eq? flag 'FORCE-RETURN)
					'RETURN
					'UPDATE)
				    update-screens!
				    #f))
			     (set! repeat 1))
			   (loop))))
		    ((fix:= event-type:key (event-type event))
		     (set! pending (translate-key-event event))
		     (set! repeat (key-event/repeat event))
		     (cond ((fix:= 0 repeat)
			    (set! pending #f))
			   ((and (char? pending)
				 (or (char=? pending #\BEL)
				     (char=? pending #\C-g))
				 signal-interrupts?)
			    (set! pending #f)
			    (signal-interrupt!)))
		     (if (not pending)
			 (loop)))
		    (else
		     (set! pending (process-special-event event))
		     (if pending
			 (set! repeat 1)
			 (loop))))))))

    (values halt-update? peek-no-hang peek read)))

(define (read-event block?)
  (let loop ()
    (set! reading-event? #t)
    (let ((event
	   (if (queue-empty? event-queue)
	       (if (eq? 'IN-UPDATE block?)
		   (os2win-get-event event-descriptor #f)
		   (read-event-1 block?))
	       (dequeue!/unsafe event-queue))))
      (set! reading-event? #f)
      (if (and (vector? event) (fix:= (event-type event) event-type:paint))
	  (begin
	    (process-paint-event event)
	    (loop))
	  event))))

(define (read-event-1 block?)
  (or (os2win-get-event event-descriptor #f)
      (let loop ()
	(let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
	  (cond (inferior-thread-changes?
		 (set-interrupt-enables! interrupt-mask)
		 event:inferior-thread-output)
		((process-output-available?)
		 (set-interrupt-enables! interrupt-mask)
		 event:process-output)
		((process-status-changes?)
		 (set-interrupt-enables! interrupt-mask)
		 event:process-status)
		(else
		 (let ((flag
			(test-for-io-on-descriptor event-descriptor
						   block?
						   'READ)))
		   (set-interrupt-enables! interrupt-mask)
		   (case flag
		     ((#F) #f)
		     ((PROCESS-STATUS-CHANGE) event:process-status)
		     ((INTERRUPT) (loop))
		     (else (read-event-1 block?))))))))))

(define-integrable event:process-output -2)
(define-integrable event:process-status -3)
(define-integrable event:inferior-thread-output -4)

(define (preview-event-stream)
  (set! previewer-registration
	(permanently-register-io-thread-event
	 event-descriptor
	 'READ
	 (current-thread)
	 (lambda (mode)
	   mode
	   (if (not reading-event?)
	       (let ((event (os2win-get-event event-descriptor #f)))
		 (if event
		     (preview-event event)))))))
  unspecific)

(define (preview-event event)
  (cond ((not (vector? event))
	 (enqueue!/unsafe event-queue event))
	((and signal-interrupts?
	      (fix:= event-type:key (event-type event))
	      ;; This tests for CTRL on, ALT off, and
	      ;; not a virtual key:
	      (fix:= #x10 (fix:and #x32 (key-event/flags event)))
	      (let ((code (key-event/code event)))
		(or (fix:= code (char->integer #\G))
		    (fix:= code (char->integer #\g)))))
	 (clean-event-queue event-queue)
	 (signal-interrupt!))
	((fix:= (event-type event) event-type:visibility)
	 (let ((result (process-special-event event)))
	   (if result
	       (enqueue!/unsafe event-queue result))))
	((fix:= (event-type event) event-type:paint)
	 (process-paint-event event))
	(else
	 (enqueue!/unsafe event-queue event))))

(define (clean-event-queue queue)
  ;; Flush keyboard and mouse events from the input queue.  Other
  ;; events are harmless and must be processed regardless.
  (do ((events (let loop ()
		 (if (queue-empty? queue)
		     '()
		     (let ((event (dequeue!/unsafe queue)))
		       (if (and (vector? event)
				(let ((type (event-type event)))
				  (or (fix:= type event-type:button)
				      (fix:= type event-type:key))))
			   (loop)
			   (cons event (loop))))))
	       (cdr events)))
      ((null? events))
    (enqueue!/unsafe queue (car events))))

(define (signal-interrupt!)
  (editor-beep)
  (temporary-message "Quit")
  (^G-signal))

(define (translate-key-event event)
  (let ((code (key-event/code event))
	(flags (key-event/flags event)))
    (let ((control (if (fix:= 0 (fix:and flags KC_CTRL)) 0 2))
	  (meta (if (fix:= 0 (fix:and flags KC_ALT)) 0 1)))
      (let ((process-code
	     (lambda (code)
	       (if (and (fix:<= #o100 code) (fix:< code #o140)
			(not (fix:= 0 control)))
		   (make-char (fix:and code #o037) meta)
		   (make-char code (fix:or meta control))))))
	(if (fix:= 0 (fix:and flags KC_VIRTUALKEY))
	    (and (fix:< code #o200)
		 (process-code code))
	    (let ((key
		   (and (fix:< code (vector-length virtual-key-table))
			(vector-ref virtual-key-table code))))
	      (and key
		   (if (fix:fixnum? key)
		       (process-code key)
		       (make-special-key key (fix:or meta control))))))))))

(define (process-change-event event)
  (cond ((fix:= event event:process-output) (accept-process-output))
	((fix:= event event:process-status) (handle-process-status-changes))
	((fix:= event event:inferior-thread-output) (accept-thread-output))
	(else (error "Illegal change event:" event))))

(define (process-paint-event event)
  (let ((wid (event-wid event))
	(xl (paint-event/xl event))
	(xh (paint-event/xh event))
	(yl (paint-event/yl event))
	(yh (paint-event/yh event)))
    (os2ps-clear (os2win-ps wid) xl xh yl yh)
    (let ((screen (wid->screen wid)))
      (if screen
	  (let ((cxl (xl->cxl screen xl))
		(cxh (xh->cxh screen xh))
		(cyl (yh->cyl screen yh))
		(cyh (yl->cyh screen yl))
		(char-map (screen-char-map screen))
		(face-map (screen-face-map screen))
		(x-size (screen-x-size screen))
		(char-height (screen-char-height screen)))
	    (if (fix:< cxl cxh)
		(let ((size (fix:- cxh cxl)))
		  (do ((cy cyl (fix:+ cy 1))
		       (y (fix:+ (cy->y screen cyl)
				 (screen-char-descender screen))
			  (fix:- y char-height))
		       (start (screen-char-index screen cxl cyl)
			      (fix:+ start x-size)))
		      ((fix:= cy cyh))
		    (let ((end (fix:+ start size)))
		      (let outer ((start start) (cxl cxl))
			(let ((face (vector-ref face-map start)))
			  (let inner ((index (fix:+ start 1)))
			    (if (or (fix:= index end)
				    (not (eq? face
					      (vector-ref face-map index))))
				(begin
				  (set-screen-face! screen face)
				  (os2ps-write (os2win-ps wid)
					       (cx->x screen cxl) y
					       char-map start end)
				  (if (not (fix:= index end))
				      (outer index
					     (fix:+ cxl (fix:- index start)))))
				(inner (fix:+ index 1)))))))))))))))

(define (process-special-event event)
  (let ((handler
	 (let ((type (event-type event)))
	   (and (fix:fixnum? type)
		(fix:>= type 0)
		(fix:< type (vector-length event-handlers))
		(vector-ref event-handlers type))))
	(screen (wid->screen (event-wid event))))
    (and handler
	 screen
	 (handler screen event))))

(define event-handlers
  (make-vector number-of-event-types #f))

(define (define-event-handler event-type handler)
  (vector-set! event-handlers event-type handler))

(define-event-handler event-type:button
  (lambda (screen event)
    (and (eq? button-event-type:down (button-event/type event))
	 (if (os2win-focus? (screen-wid screen))
	     (make-input-event 'BUTTON
			       execute-button-command
			       screen
			       (make-down-button (button-event/number event))
			       (x->cx screen (button-event/x event))
			       (y->cy screen (button-event/y event)))
	     (begin
	       (os2win-activate (screen-wid screen))
	       #f)))))

(define-event-handler event-type:close
  (lambda (screen event)
    event
    (and (not (screen-deleted? screen))
	 (make-input-event 'DELETE-SCREEN delete-screen! screen))))

(define-event-handler event-type:focus
  (lambda (screen event)
    (and (focus-event/gained? event)
	 (not (selected-screen? screen))
	 (make-input-event 'SELECT-SCREEN select-screen screen))))

(define-event-handler event-type:resize
  (lambda (screen event)
    (set-screen-pel-width! screen (resize-event/width event))
    (set-screen-pel-height! screen (resize-event/height event))
    (let ((thunk (screen-resize-thunk screen)))
      (and thunk
	   (make-input-event 'SET-SCREEN-SIZE
			     (lambda (screen)
			       (thunk)
			       (update-screen! screen #t))
			     screen)))))

(define (screen-resize-thunk screen)
  (let ((width (screen-pel-width screen))
	(height (screen-pel-height screen)))
    (let ((x-size (width->x-size screen width))
	  (y-size (height->y-size screen height)))
      (and (not (and (= x-size (screen-x-size screen))
		     (= y-size (screen-y-size screen))))
	   (lambda ()
	     (let ((size (fix:* x-size y-size)))
	       (let ((char-map (make-string size #\space))
		     (face-map
		      (make-vector size (screen-current-face screen))))
		 (without-interrupts
		  (lambda ()
		    (set-screen-char-map! screen char-map)
		    (set-screen-face-map! screen face-map)
		    (set-screen-size! screen x-size y-size))))))))))

(define-event-handler event-type:visibility
  (lambda (screen event)
    (and (not (screen-deleted? screen))
	 (if (visibility-event/shown? event)
	     (begin
	       (set-screen-visibility! screen 'VISIBLE)	;don't really know
	       (screen-force-update screen)
	       (make-input-event 'UPDATE update-screen! screen #f))
	     (begin
	       (set-screen-visibility! screen 'UNMAPPED)
	       (and (selected-screen? screen)
		    (let ((screen (other-screen screen)))
		      (and screen
			   (make-input-event 'SELECT-SCREEN
					     select-screen
					     screen)))))))))

(define (make-virtual-key-table)
  ;; Shift keys are commented out, causing them to be ignored.
  (let ((table (make-vector virtual-key-supremum #f)))
    (vector-set! table VK_BUTTON1	'BUTTON1)
    (vector-set! table VK_BUTTON2	'BUTTON2)
    (vector-set! table VK_BUTTON3	'BUTTON3)
    (vector-set! table VK_BREAK		'BREAK)
    (vector-set! table VK_BACKSPACE	(char-code #\rubout))
    (vector-set! table VK_TAB		(char-code #\tab))
    (vector-set! table VK_BACKTAB	'BACKTAB)
    (vector-set! table VK_NEWLINE	(char-code #\return))
    ;;(vector-set! table VK_SHIFT		'SHIFT)
    ;;(vector-set! table VK_CTRL		'CTRL)
    ;;(vector-set! table VK_ALT		'ALT)
    ;;(vector-set! table VK_ALTGRAF	'ALTGRAF)
    (vector-set! table VK_PAUSE		'PAUSE)
    ;;(vector-set! table VK_CAPSLOCK	'CAPS-LOCK)
    (vector-set! table VK_ESC		(char-code #\escape))
    (vector-set! table VK_SPACE		(char-code #\space))
    (vector-set! table VK_PAGEUP	'PAGE-UP)
    (vector-set! table VK_PAGEDOWN	'PAGE-DOWN)
    (vector-set! table VK_END		'END)
    (vector-set! table VK_HOME		'HOME)
    (vector-set! table VK_LEFT		'LEFT)
    (vector-set! table VK_UP		'UP)
    (vector-set! table VK_RIGHT		'RIGHT)
    (vector-set! table VK_DOWN		'DOWN)
    (vector-set! table VK_PRINTSCRN	'PRINT-SCREEN)
    (vector-set! table VK_INSERT	'INSERT)
    (vector-set! table VK_DELETE	'DELETE)
    ;;(vector-set! table VK_SCRLLOCK	'SCRL-LOCK)
    ;;(vector-set! table VK_NUMLOCK	'NUM-LOCK)
    (vector-set! table VK_ENTER		(char-code #\return))
    (vector-set! table VK_SYSRQ		'SYSRQ)
    (vector-set! table VK_F1		'F1)
    (vector-set! table VK_F2		'F2)
    (vector-set! table VK_F3		'F3)
    (vector-set! table VK_F4		'F4)
    (vector-set! table VK_F5		'F5)
    (vector-set! table VK_F6		'F6)
    (vector-set! table VK_F7		'F7)
    (vector-set! table VK_F8		'F8)
    (vector-set! table VK_F9		'F9)
    (vector-set! table VK_F10		'F10)
    (vector-set! table VK_F11		'F11)
    (vector-set! table VK_F12		'F12)
    (vector-set! table VK_F13		'F13)
    (vector-set! table VK_F14		'F14)
    (vector-set! table VK_F15		'F15)
    (vector-set! table VK_F16		'F16)
    (vector-set! table VK_F17		'F17)
    (vector-set! table VK_F18		'F18)
    (vector-set! table VK_F19		'F19)
    (vector-set! table VK_F20		'F20)
    (vector-set! table VK_F21		'F21)
    (vector-set! table VK_F22		'F22)
    (vector-set! table VK_F23		'F23)
    (vector-set! table VK_F24		'F24)
    (vector-set! table VK_ENDDRAG	'END-DRAG)
    (vector-set! table VK_CLEAR		'CLEAR)
    (vector-set! table VK_EREOF		'EREOF)
    (vector-set! table VK_PA1		'PA1)
    table))