From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 3 Mar 1999 05:29:57 +0000 (+0000)
Subject: This version of Edwin requires microcode 11.162 or later if used under
X-Git-Tag: 20090517-FFI~4587
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9f0b6e1f94de504f92270f555765c919e3c16c2e;p=mit-scheme.git

This version of Edwin requires microcode 11.162 or later if used under
Win32.

Extensive changes to use new single input queue, and to implement
event-stream previewer.  (The single input queue was required for
proper implementation of the previewer.)  With this change, the Win32
platform has the ability to abort out of any Edwin command, as has
been true of all other platforms for years.

I also took the opportunity to considerably clean up the event code.
---

diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm
index 4eaef4d3c..639f66803 100644
--- a/v7/src/edwin/make.scm
+++ b/v7/src/edwin/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 3.98 1999/02/18 04:06:10 cph Exp $
+$Id: make.scm,v 3.99 1999/03/03 05:29:57 cph Exp $
 
 Copyright (c) 1989-1999 Massachusetts Institute of Technology
 
@@ -45,4 +45,4 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 				     ((UNIX) "edwinunx")
 				     (else "edwinunk"))))))
 	'QUERY)))))
-(add-identification! "Edwin" 3 98)
\ No newline at end of file
+(add-identification! "Edwin" 3 99)
\ No newline at end of file
diff --git a/v7/src/edwin/win32.scm b/v7/src/edwin/win32.scm
index 9f353dc33..3f884b629 100644
--- a/v7/src/edwin/win32.scm
+++ b/v7/src/edwin/win32.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: win32.scm,v 1.9 1999/01/02 06:11:34 cph Exp $
+;;; $Id: win32.scm,v 1.10 1999/03/03 05:29:31 cph Exp $
 ;;;
 ;;; Copyright (c) 1994-1999 Massachusetts Institute of Technology
 ;;;
@@ -24,11 +24,10 @@
 (declare (usual-integrations))
 
 (define-primitives
+  (win32-read-event 0)
   (win32-screen-char-dimensions 1)
   (win32-screen-clear-rectangle! 6)
   (win32-screen-create! 2)
-  (win32-screen-current-focus 0)
-  (win32-screen-get-event 1)
   (win32-screen-invalidate-rect! 5)
   (win32-screen-move-cursor! 3)
   (win32-screen-set-background-color! 2)
@@ -42,30 +41,24 @@
   (win32-screen-write-char! 5)
   (win32-screen-write-substring! 7))
 
-(define-integrable event:process-output 16)
-(define-integrable event:process-status 32)
-(define-integrable event:inferior-thread-output 64)
-
-(define win32-screens '())
-
 ;;(define (debug . details)
 ;;  (pp details console-output-port))
 
 (define-structure (win32-screen-state
 		   (constructor make-win32-screen-state (handle))
 		   (conc-name state/))
-  (handle false read-only true)
+  (handle #f read-only #t)
   (cursor-x -1) ; cached position, -1 if we dont know
   (cursor-y -1) ; ditto
   ;; This rect is the bounding box of a sequence of updates.  RECT-TOP is #F
   ;; if no box has been established, which implies that the screen needs no
   ;; update.
-  (rect-top #F)
+  (rect-top #f)
   (rect-bottom 0)
   (rect-right 0)
   (rect-left 0)
-  (redisplay-title? #F)
-  (name #F))
+  (redisplay-title? #f)
+  (name #f))
 
 (define-integrable (screen-redisplay-title? screen)
   (state/redisplay-title? (screen-state screen)))
@@ -93,7 +86,7 @@
 			win32-screen/exit!
 			win32-screen/flush!
 			win32-screen/modeline-event!
-			false
+			#f
 			win32-screen/scroll-lines-down!
 			win32-screen/scroll-lines-up!
 			win32-screen/wrap-update!
@@ -104,7 +97,6 @@
 			(car width.height)
 			(cdr width.height))))
       (set! win32-screens (cons screen win32-screens))
-      (set! input-screen #F)
       ;;(debug 'CREATE screen)
       screen)))
 
@@ -166,26 +158,24 @@
   (set! win32-screens (delq screen win32-screens)))
 
 (define (win32-screen/enter! screen)
-  (set! input-screen #F)
   (set-screen-cursor-position! screen -1 -1)
   (set-active-window (screen->handle screen))
   (win32-screen-show-cursor! (screen->handle screen) #T))
 
 (define (win32-screen/exit! screen)
-  (win32-screen-show-cursor! (screen->handle screen) #F)
-  (set! input-screen #F))
+  (win32-screen-show-cursor! (screen->handle screen) #F))
 
 (define (win32-screen/modeline-event! screen window type)
   window type				; ignored
-  (set-screen-redisplay-title?! screen true))
+  (set-screen-redisplay-title?! screen #t))
 
 (define (win32-screen/scroll-lines-down! screen xl xu yl yu amount)
-  (and #F
+  (and #f
        (win32-screen-vertical-scroll! (screen->handle screen)
 				      xl xu yl yu (fix:+ yl amount))))
 
 (define (win32-screen/scroll-lines-up! screen xl xu yl yu amount)
-  (and #F
+  (and #f
        (win32-screen-vertical-scroll! (screen->handle screen)
 				      xl xu amount yu 0)
        (win32-screen-vertical-scroll! (screen->handle screen)
@@ -197,7 +187,7 @@
   #F)
 
 (define (win32-screen/wrap-update! screen thunk)
-  (let ((finished? false))
+  (let ((finished? #f))
     (dynamic-wind
      (lambda ()
        (set-state/rect-top! (screen-state screen) #F))
@@ -211,7 +201,7 @@
        (if (and finished? (screen-redisplay-title? screen))
 	   (begin
 	     (update-win32-screen-name! screen)
-	     (set-screen-redisplay-title?! screen false)))
+	     (set-screen-redisplay-title?! screen #f)))
        (win32-screen/flush! screen)))))
 
 (define (win32-screen/write-char! screen x y char highlight)
@@ -237,10 +227,6 @@
 	  (win32-screen-move-cursor! handle x y)
 	  (set-screen-cursor-position! screen x y)))))
 
-;; Mask bits:  VK coded special keys, Edwin mode,
-;;    mouse, key, resize and close events
-(define-integrable win32-screen-features-mask #x140F)
-
 (define (screen->handle screen)
   (if (memq screen win32-screens)
       (state/handle (screen-state screen))
@@ -250,40 +236,105 @@
   (list-search-positive win32-screens
     (lambda (screen) (eqv? handle (state/handle (screen-state screen))))))
 
+(define-integrable (screen-name screen)
+  (state/name (screen-state screen)))
+
+(define-integrable (set-screen-name! screen name)
+  (set-state/name! (screen-state screen) name))
+
+(define (win32-screen/set-name! screen name)
+  (let ((name* (screen-name screen)))
+    (if (or (not name*) (not (string=? name name*)))
+	(begin
+	  (set-screen-name! screen name)
+	  (set-window-text (screen->handle screen) name)))))
+
+(define (win32-screen/set-font! screen font)
+  (let ((x-size (screen-x-size screen))
+	(y-size (screen-y-size screen)))
+    (win32-screen-set-font! (screen->handle screen) font)
+    (win32-screen/set-size! screen x-size y-size)))
+
+(define (win32-screen/set-icon! screen icon)
+  (win32-screen-set-icon! (screen->handle screen) icon))
+
+(define (win32-screen/set-foreground-color! screen color)
+  (win32-screen-set-foreground-color! (screen->handle screen) color))
+
+(define (win32-screen/set-background-color! screen color)
+  (win32-screen-set-background-color! (screen->handle screen) color))
+
+(define (win32-screen/set-size! screen width height)
+  (let ((handle (screen->handle screen)))
+    (let ((rect
+	   (let ((x.y (win32-screen-char-dimensions handle)))
+	     (make-rect 0 0 (* width (car x.y)) (* height (cdr x.y))))))
+      (adjust-window-rect rect
+			  WS_OVERLAPPEDWINDOW
+			  (not (= 0 (get-menu handle))))
+      (set-window-pos handle 0 0 0
+		      (- (rect/right rect) (rect/left rect))
+		      (- (rect/bottom rect) (rect/top rect))
+		      (+ SWP_NOMOVE SWP_NOZORDER)))))
+
+(define (win32-screen/set-position! screen x y)
+  (set-window-pos (screen->handle screen) 0 x y 0 0
+		  (+ SWP_NOSIZE SWP_NOZORDER)))
+
+(define (win32-screen/get-position screen)
+  (let ((rect (make-rect 0 0 0 0)))
+    (get-window-rect (screen->handle screen) rect)
+    (values (rect/left rect) (rect/top rect)
+	    (rect/right rect) (rect/bottom rect))))
+
+(define (win32-screen/get-client-size screen)
+  (let ((rect (make-rect 0 0 0 0)))
+    (get-client-rect (screen->handle screen) rect)
+    (values (rect/right rect) (rect/bottom rect))))
+
+(define win32-screens)
 (define win32-display-type)
+(define win32-event-queue)
+(define signal-interrupts?)
+(define reading-event?)
+(define previewer-registration)
 
 (define (win32-screen-available?)
   (implemented-primitive-procedure? win32-screen-create!))
 
 (define (initialize-package!)
+  (set! win32-screens '())
   (set! win32-display-type
 	(make-display-type 'win32
-			   true        ; multiple screens?
+			   #t		; multiple screens?
 			   win32-screen-available?
 			   (lambda geometry
 			     geometry
+			     (if (not win32-event-queue)
+				 (set! win32-event-queue (make-queue)))
 			     (make-win32-screen))
 			   get-win32-input-operations
 			   with-editor-interrupts-from-win32
 			   with-win32-interrupts-enabled
 			   with-win32-interrupts-disabled))
+  (set! win32-event-queue #f)
   (add-event-receiver! event:before-exit
-		       (lambda ()
-			 (for-each screen-discard! win32-screens)))
-  unspecific)
+		       (lambda () (for-each screen-discard! win32-screens))))
 
 (define (with-editor-interrupts-from-win32 receiver)
-  (fluid-let ((signal-interrupts? #t))
+  (fluid-let ((reading-event? #f)
+	      (signal-interrupts? #t)
+	      (previewer-registration))
     (dynamic-wind
-     (lambda () '())
+     (lambda () (preview-event-stream))
      (lambda () (receiver (lambda (thunk) (thunk)) '()))
-     (lambda () '()))))
+     (lambda () (deregister-input-thread-event previewer-registration)))))
 
 (define (with-win32-interrupts-enabled thunk)
-  (with-signal-interrupts true thunk))
+  (with-signal-interrupts #t thunk))
 
 (define (with-win32-interrupts-disabled thunk)
-  (with-signal-interrupts false thunk))
+  (with-signal-interrupts #f thunk))
 
 (define (with-signal-interrupts enabled? thunk)
   (let ((old))
@@ -301,201 +352,88 @@
   (editor-beep)
   (temporary-message "Quit")
   (^G-signal))
-
-(define signal-interrupts? #f)
-
-(define-integrable (some-bits? mask item)
-  (not (fix:= 0 (fix:and mask item))))
-
-(define (process-mouse-event screen event)
-  screen
-  (make-input-event 'BUTTON
-		    execute-button-command
-		    screen
-		    ((if (= (vector-ref event 5) 0)
-			 make-down-button
-			 make-up-button)
-		     (cond ((some-bits? #x1 (vector-ref event 4))  0)
-			   ((some-bits? #x2 (vector-ref event 4))  2)
-			   ((some-bits? #x4 (vector-ref event 4))  1)
-			   (else 0)))
-		    (vector-ref event 2)
-		    (vector-ref event 1)))
-
-(define (process-resize-event screen event)
-  event
-  (make-input-event 'SET-SCREEN-SIZE
-		    (lambda (screen)
-		      (let ((w.h (win32-screen-size (screen->handle screen))))
-			(if (not (and (= (car w.h) (screen-x-size screen))
-				      (= (cdr w.h) (screen-y-size screen))))
-			    (begin
-			      (set-screen-size! screen (car w.h) (cdr w.h))
-			      (update-screen! screen #T)))))
-		    screen))
-
-(define (process-close-event screen event)
-  event
-  (cond ((screen-deleted? screen)  #F)
-	((= (length win32-screens) 1)
-	 (make-input-event 'EXIT save-buffers-and-exit #F "Scheme"
-			   exit-scheme))
-	(else
-	 (make-input-event 'DELETE-SCREEN delete-screen! screen))))
-
-(define (process-key-event event)
-  (let* ((key        (vector-ref event 5))
-	 (cont-state (vector-ref event 4))
-	 (alt?       (some-bits? #x1 cont-state))
-	 (control?   (some-bits? #x2 cont-state))
-	 (shift?     (some-bits? #x4 cont-state)))
-    (let ((result
-	   (cond ((fix:= key -1)
-		  (let ((vk-code (vector-ref event 2))
-			(bucky-bits
-			 (+ (if alt? 1 0)     ; M-
-			    (if control? 2 0) ; C-
-			    (if shift? 4 0)   ; S-
-			    )))
-		    (win32-make-special-key vk-code bucky-bits)))
-		 ((and control? alt?)
-		  (char-control-metafy (integer->char key)))
-		 (alt?
-		  (char-metafy (integer->char key)))
-		 ;;((and control? (eq? key 32))
-		 ;; #\c-space)
-		 (control?
-		  (char-controlify (integer->char key)))
-		 (else
-		  (integer->char key)))))
-      result)))
 
 (define (get-win32-input-operations screen)
-
   screen ; ignored
+  (let ((get-next-event
+	 (lambda (block?)
+	   (let loop ()
+	     (let ((event (read-event block?)))
+	       (and event
+		    (or (process-event event)
+			(loop)))))))
+	(pending-result #f))
+    (let ((probe
+	   (lambda (block?)
+	     (let ((result (get-next-event block?)))
+	       (if result
+		   (set! pending-result result))
+	       result))))
+      (values (lambda ()		;halt-update?
+		(or pending-result
+		    (probe 'IN-UPDATE)))
+	      (lambda ()		;peek-no-hang
+		(or pending-result
+		    (probe #f)))
+	      (lambda ()		;peek
+		(or pending-result
+		    (let ((result (get-next-event #t)))
+		      (set! pending-result result)
+		      result)))
+	      (lambda ()		;read
+		(cond (pending-result
+		       => (lambda (result)
+			    (set! pending-result #f)
+			    result))
+		      (else
+		       (get-next-event #t))))))))
+
+(define (process-event event)
+  (cond ((fix:fixnum? event)
+	 (let ((flag (process-change-event event)))
+	   (and flag
+		(make-input-event (if (eq? flag 'FORCE-RETURN) 'RETURN 'UPDATE)
+				  update-screens! #f))))
+	((vector? event) (process-special-event event))
+	((input-event? event) event)
+	(else #f)))
 
-  (set! input-screen #f)
-
-  (define-integrable (win32-resize-event? event)
-    (and (vector? event) (fix:= (vector-ref event 0) 1)))
-
-  (define-integrable (win32-key-event? event)
-    (and (vector? event) (fix:= (vector-ref event 0) 2)))
-
-  (define-integrable (win32-mouse-event? event)
-    (and (vector? event) (fix:= (vector-ref event 0) 4)))
-
-  (define-integrable (win32-close-event? event)
-    (and (vector? event) (fix:= (vector-ref event 0) 8)))
-
-  (define-integrable (change-event? event)  (fix:fixnum? event))
-
-  (define (process-event event)
-    (cond ((win32-key-event? event)
-	   (let ((key (process-key-event event)))
-	     (if (and signal-interrupts?
-		      (eq? key #\BEL))
-		 (begin
-		   (signal-interrupt!)
-		   #f)
-		 key)))
-	  ((win32-mouse-event? event)
-	   (process-mouse-event input-screen event))
-	  ((win32-resize-event? event)
-	   (process-resize-event input-screen event))
-	  ((win32-close-event? event)
-	   (process-close-event input-screen event))
-	  ((input-event? event)
-	   event)
-	  (else #f)))
-
-  (define (pce-event flag)
-    (make-input-event (if (eq? flag 'FORCE-RETURN) 'RETURN 'UPDATE)
-		      update-screens!
-		      #f))
-
-  (define (get-next-event block?)
-    (let loop ()
-      (let ((event  (read-event block?)))
-	(cond ((not event)
-	       #F)
-	      ((change-event? event)
-	       (let ((flag  (process-change-event event)))
-		 (if flag
-		     (pce-event flag)
-		     (loop))))
-	      (else
-	       (or (process-event event)
-		   (loop)))))))
-
-  (define (guarantee-result)
-    (or (get-next-event #T)
-	(error "#F returned from blocking read")))
-
-  (let* ((pending-result #F)
-
-	 (probe
-	  (lambda (block?)
-	    (let ((result  (get-next-event block?)))
-	      (if result
-		  (set! pending-result result))
-	      result)))
-
-	 (halt-update?
-	  (lambda ()
-	    (or pending-result
-		(probe 'IN-UPDATE))))
-	 (peek-no-hang
-	  (lambda ()
-	    (or pending-result
-		(probe #F))))
-	 (peek
-	  (lambda ()
-	    (or pending-result
-		(let ((result  (guarantee-result)))
-		  (set! pending-result result)
-		  result))))
-	 (read
-	  (lambda ()
-	    (cond (pending-result
-		   => (lambda (result)
-			(set! pending-result #F)
-			result))
-		  (else
-		   (guarantee-result))))))
-
-    (values halt-update?
-	    peek-no-hang
-	    peek
-	    read)))
-
-;; The INPUT-SCREEN is the current screen from which we are processing
-;; input events.  When a different screen (or some window from sone
-;; other application) may have been selected, INPUT-SCREEN is set to
-;; #F.  This causes READ-EVENT-1 to hunt for a screen from which it
-;; can take input events.  This is a crock.  An improvement would be
-;; to put the input events for Edwin screens into a common queue, and
-;; invent an new `select-screen' event That in turn would require
-;; implementing the queues separately from the window but it would
-;; move the place at which the process should be suspended to a single
-;; place (WIN32-SCREEN-GET-EVENT), allowing a WIN32(C?) event and
-
-(define input-screen)
+(define (process-change-event event)
+  (cond ((fix:= event:process-output event) (accept-process-output))
+	((fix:= event:process-status event) (handle-process-status-changes))
+	((fix:= event:inferior-thread-output event) (accept-thread-output))
+	(else (error "Illegal change event:" event))))
 
-(define-integrable interrupt-mask/gc+win32
-  ;; Include INTERRUPT-BIT/GLOBAL-1 so that messages are dispatched to
-  ;; the screen by the interrupt-handler.
-  ;;(fix:or interrupt-mask/gc-ok interrupt-bit/global-1)
-  15)
+(define (process-special-event event)
+  (let ((handler (hash-table/get event-handlers (event-type event) #f))
+	(screen (handle->win32-screen (event-handle event))))
+    (and handler
+	 screen
+	 (handler screen event))))
 
-(define (read-event block?)
-  (let ((handle (and input-screen (screen->handle input-screen))))
-    (if (eq? block? 'IN-UPDATE)
-	(read-event-2 handle)
-	(read-event-1 handle block?))))
+(define event-handlers
+  (make-eq-hash-table))
+
+(define (define-event-handler event-type handler)
+  (hash-table/put! event-handlers event-type handler))
+
+;;;; Events
 
-(define (read-event-1 handle block?)
-  (or (read-event-2 handle)
+(define (read-event block?)
+  (let ((queue win32-event-queue))
+    (let loop ()
+      (set! reading-event? #t)
+      (let ((event
+	     (if (queue-empty? queue)
+		 (if (eq? 'IN-UPDATE block?)
+		     (read-event-2)
+		     (read-event-1 block?))
+		 (dequeue!/unsafe queue))))
+	(set! reading-event? #f)
+	event))))
+
+(define (read-event-1 block?)
+  (or (read-event-2)
       (let loop ()
 	(let ((mask (set-interrupt-enables! interrupt-mask/gc+win32)))
 	  (cond (inferior-thread-changes?
@@ -508,99 +446,228 @@
 		 (set-interrupt-enables! mask)
 		 event:process-status)
 		(else
-		 (let ((handle* (win32-screen-current-focus))
-		       (wait
-			(lambda ()
-			  (test-for-input-on-descriptor
-			   ;; console-channel-descriptor here
-			   ;; means "input from message queue".
-			   console-channel-descriptor block?))))
-		   (if (eqv? handle handle*)
-		       (let ((flag (wait)))
-			 (set-interrupt-enables! mask)
-			 (case flag
-			   ((#F) #f)
-			   ((PROCESS-STATUS-CHANGE) event:process-status)
-			   ((INTERRUPT) (loop))
-			   (else (read-event-1 handle block?))))
-		       (let ((screen* (handle->win32-screen handle*)))
-			 (set-interrupt-enables! mask)
-			 (if screen*
-			     (begin
-			       (set! input-screen screen*)
-			       (make-input-event 'SELECT-SCREEN
-						 select-screen
-						 screen*))
-			     (and block?
-				  (begin
-				    (wait)
-				    (read-event-1 handle block?)))))))))))))
-
-(define (read-event-2 handle)
-  (and handle
-       (let ((mask (set-interrupt-enables! interrupt-mask/gc+win32)))
-	 (let ((result (win32-screen-get-event handle)))
-	   (set-interrupt-enables! mask)
-	   result))))
-
-(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-integrable (screen-name screen)
-  (state/name (screen-state screen)))
-
-(define-integrable (set-screen-name! screen name)
-  (set-state/name! (screen-state screen) name))
+		 (let ((flag
+			(test-for-input-on-descriptor
+			 ;; console-channel-descriptor here
+			 ;; means "input from message queue".
+			 console-channel-descriptor block?)))
+		   (set-interrupt-enables! mask)
+		   (case flag
+		     ((#F) #f)
+		     ((PROCESS-STATUS-CHANGE) event:process-status)
+		     ((INTERRUPT) (loop))
+		     (else (read-event-1 block?))))))))))
+
+(define (read-event-2)
+  (let ((mask (set-interrupt-enables! interrupt-mask/gc+win32)))
+    (let ((result (win32-read-event)))
+      (set-interrupt-enables! mask)
+      result)))
 
-(define (win32-screen/set-name! screen name)
-  (let ((name* (screen-name screen)))
-    (if (or (not name*) (not (string=? name name*)))
-	(begin
-	  (set-screen-name! screen name)
-	  (set-window-text (screen->handle screen) name)))))
+(define-integrable interrupt-mask/gc+win32
+  ;; Include INTERRUPT-BIT/GLOBAL-1 so that messages are dispatched to
+  ;; the screen by the interrupt-handler.
+  ;;(fix:or interrupt-mask/gc-ok interrupt-bit/global-1)
+  15)
 
-(define (win32-screen/set-font! screen font)
-  (let ((x-size (screen-x-size screen))
-	(y-size (screen-y-size screen)))
-    (win32-screen-set-font! (screen->handle screen) font)
-    (win32-screen/set-size! screen x-size y-size)))
+(define (preview-event-stream)
+  (set! previewer-registration
+	(permanently-register-input-thread-event
+	 console-channel-descriptor
+	 (current-thread)
+	 (lambda ()
+	   (if (not reading-event?)
+	       (let ((event (read-event-2)))
+		 (if event
+		     (preview-event event)))))))
+  unspecific)
 
-(define (win32-screen/set-icon! screen icon)
-  (win32-screen-set-icon! (screen->handle screen) icon))
+(define (preview-event event)
+  (cond ((and signal-interrupts?
+	      (vector? event)
+	      (fix:= event-type:key (event-type event))
+	      (eqv? #\BEL (decode-key-event event)))
+	 (clean-event-queue win32-event-queue)
+	 (signal-interrupt!))
+	(else
+	 (enqueue!/unsafe win32-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:= event-type:mouse type)
+				      (fix:= event-type:key type))))
+			   (loop)
+			   (cons event (loop))))))
+	       (cdr events)))
+      ((null? events))
+    (enqueue!/unsafe queue (car events))))
+
+;; Mask bits:  VK coded special keys, Edwin mode,
+;;    mouse, key, resize, close, focus, and visibility events
+(define-integrable win32-screen-features-mask #x14003F)
 
-(define (win32-screen/set-foreground-color! screen color)
-  (win32-screen-set-foreground-color! (screen->handle screen) color))
+(define-integrable event:process-output 16)
+(define-integrable event:process-status 32)
+(define-integrable event:inferior-thread-output 64)
 
-(define (win32-screen/set-background-color! screen color)
-  (win32-screen-set-background-color! (screen->handle screen) color))
+(define-integrable event-type:resize		#x001)
+(define-integrable event-type:key		#x002)
+(define-integrable event-type:mouse		#x004)
+(define-integrable event-type:close		#x008)
+(define-integrable event-type:focus		#x010)
+(define-integrable event-type:visibility	#x020)
 
-(define (win32-screen/set-size! screen width height)
-  (let ((handle (screen->handle screen)))
-    (let ((rect
-	   (let ((x.y (win32-screen-char-dimensions handle)))
-	     (make-rect 0 0 (* width (car x.y)) (* height (cdr x.y))))))
-      (adjust-window-rect rect
-			  WS_OVERLAPPEDWINDOW
-			  (not (= 0 (get-menu handle))))
-      (set-window-pos handle 0 0 0
-		      (- (rect/right rect) (rect/left rect))
-		      (- (rect/bottom rect) (rect/top rect))
-		      (+ SWP_NOMOVE SWP_NOZORDER)))))
+(define-integrable control-key:alt-pressed	#x001)
+(define-integrable control-key:control-pressed	#x002)
+(define-integrable control-key:shift-pressed	#x004)
 
-(define (win32-screen/set-position! screen x y)
-  (set-window-pos (screen->handle screen) 0 x y 0 0
-		  (+ SWP_NOSIZE SWP_NOZORDER)))
+(define-integrable button-state:left-pressed	#x001)
+(define-integrable button-state:right-pressed	#x002)
+(define-integrable button-state:middle-pressed	#x004)
 
-(define (win32-screen/get-position screen)
-  (let ((rect (make-rect 0 0 0 0)))
-    (get-window-rect (screen->handle screen) rect)
-    (values (rect/left rect) (rect/top rect)
-	    (rect/right rect) (rect/bottom rect))))
+(define-integrable (some-bits? mask item)
+  (not (fix:= 0 (fix:and mask item))))
 
-(define (win32-screen/get-client-size screen)
-  (let ((rect (make-rect 0 0 0 0)))
-    (get-client-rect (screen->handle screen) rect)
-    (values (rect/right rect) (rect/bottom rect))))
\ No newline at end of file
+(define-integrable (event-type event) (vector-ref event 0))
+(define-integrable (event-handle event) (vector-ref event 1))
+
+(define-structure (resize-event (type vector)
+				(initial-offset 2)
+				(conc-name resize-event/))
+  (rows #f read-only #t)
+  (columns #f read-only #t))
+
+(define-structure (key-event (type vector)
+			     (initial-offset 2)
+			     (conc-name key-event/))
+  (repeat-count #f read-only #t)
+  (virtual-keycode #f read-only #t)
+  (virtual-scancode #f read-only #t)
+  (control-key-state #f read-only #t)
+  (character #f read-only #t)
+  (key-down? #f read-only #t))
+
+(define-structure (mouse-event (type vector)
+			       (initial-offset 2)
+			       (conc-name mouse-event/))
+  (row #f read-only #t)
+  (column #f read-only #t)
+  (control-key-state #f read-only #t)
+  (button-state #f read-only #t)
+  (up? #f read-only #t)
+  (mouse-moved? #f read-only #t)
+  (double-click? #f read-only #t))
+
+(define-structure (focus-event (type vector)
+			       (initial-offset 2)
+			       (conc-name focus-event/))
+  (gained? #f read-only #t))
+
+(define-structure (visibility-event (type vector)
+				    (initial-offset 2)
+				    (conc-name visibility-event/))
+  (show? #f read-only #t))
+
+(define-event-handler event-type:resize
+  (lambda (screen event)
+    event
+    (make-input-event 'SET-SCREEN-SIZE
+		      (lambda (screen)
+			(let ((w.h
+			       (win32-screen-size (screen->handle screen))))
+			  (if (not (and (= (car w.h) (screen-x-size screen))
+					(= (cdr w.h) (screen-y-size screen))))
+			      (begin
+				(set-screen-size! screen (car w.h) (cdr w.h))
+				(update-screen! screen #t)))))
+		      screen)))
+
+(define-event-handler event-type:key
+  (lambda (screen event)
+    screen
+    (let ((key (decode-key-event event)))
+      (if (and signal-interrupts? (eq? key #\BEL))
+	  (begin
+	    (signal-interrupt!)
+	    #f)
+	  key))))
+
+(define (decode-key-event event)
+  (let ((key (key-event/character event))
+	(cont-state (key-event/control-key-state event)))
+    (let ((alt? (some-bits? control-key:alt-pressed cont-state))
+	  (control? (some-bits? control-key:control-pressed cont-state))
+	  (shift? (some-bits? control-key:shift-pressed cont-state)))
+      (cond ((fix:= key -1)
+	     (let ((vk-code (key-event/virtual-keycode event))
+		   (bucky-bits
+		    (+ (if alt? 1 0)     ; M-
+		       (if control? 2 0) ; C-
+		       (if shift? 4 0)   ; S-
+		       )))
+	       (win32-make-special-key vk-code bucky-bits)))
+	    ((and control? alt?)
+	     (char-control-metafy (integer->char key)))
+	    (alt?
+	     (char-metafy (integer->char key)))
+	    ;;((and control? (eq? key 32))
+	    ;; #\c-space)
+	    (control?
+	     (char-controlify (integer->char key)))
+	    (else
+	     (integer->char key))))))
+
+(define-event-handler event-type:mouse
+  (lambda (screen event)
+    (make-input-event
+     'BUTTON
+     execute-button-command
+     screen
+     ((if (mouse-event/up? event)
+	  make-up-button
+	  make-down-button)
+      (let ((state (mouse-event/button-state event)))
+	(cond ((some-bits? button-state:left-pressed state) 0)
+	      ((some-bits? button-state:right-pressed state) 2)
+	      ((some-bits? button-state:middle-pressed state) 1)
+	      (else 0))))
+     (mouse-event/column event)
+     (mouse-event/row event))))
+
+(define-event-handler event-type:close
+  (lambda (screen event)
+    event
+    (cond ((screen-deleted? screen)
+	   #f)
+	  ((= (length win32-screens) 1)
+	   (make-input-event 'EXIT
+			     save-buffers-and-exit #f "Scheme" exit-scheme))
+	  (else
+	   (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:visibility
+  (lambda (screen event)
+    (and (not (screen-deleted? screen))
+	 (if (visibility-event/show? event)
+	     (begin
+	       (screen-force-update screen)
+	       (make-input-event 'UPDATE update-screen! screen #f))
+	     (and (selected-screen? screen)
+		  (let ((screen (other-screen screen 1 #f)))
+		    (and screen
+			 (make-input-event 'SELECT-SCREEN
+					   select-screen
+					   screen))))))))
\ No newline at end of file