From 22e7a9c5955454a64ee48a79ca9a81c878a60ee7 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 20 Mar 1992 05:18:31 +0000
Subject: [PATCH] This runtime system requires microcode version 11.111 or
 later.

* Allow CREATE-THREAD to accept #F as its first argument, and to use a
  default continuation in that case.  Define
  WITH-CREATE-THREAD-CONTINUATION to bind that default; change
  CMDL/START to cause the default continuation to be bound to the
  continuation of the CMDL driver.

* Add new operations to x-graphics devices: RAISE-WINDOW,
  LOWER-WINDOW, WITHDRAW-WINDOW, QUERY-POINTER.  Delete UNMAP-WINDOW
  operation which is superseded by WITHDRAW-WINDOW.

* Add new operations X-GRAPHICS/OPEN-DISPLAY and
  X-GRAPHICS/CLOSE-DISPLAY.  The value returned by
  X-GRAPHICS/OPEN-DISPLAY may be passed to MAKE-GRAPHICS-DEVICE as a
  second argument when making x-graphics devices.

* Export virtually all x-graphics operations by name as
  X-GRAPHICS/foo.

* Extensive redesign of X graphics internals.  Now events are handled
  asynchronously by a separate thread, one per display connection.
  Graphics windows now participate in the DELETE-WINDOW protocol, so
  that closing a window with the window manager has the desired effect
  rather than killing the Scheme process.  Display connections are
  memoized, and are reclaimed by garbage collection when no longer
  used.  Closing a display connection closes all of the windows
  associated with it.
---
 v7/src/runtime/rep.scm      |   8 +-
 v7/src/runtime/runtime.pkg  |  54 ++-
 v7/src/runtime/thread.scm   |  31 +-
 v7/src/runtime/version.scm  |   4 +-
 v7/src/runtime/x11graph.scm | 723 ++++++++++++++++++++++--------------
 v8/src/runtime/runtime.pkg  |  54 ++-
 6 files changed, 566 insertions(+), 308 deletions(-)

diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm
index 63733fb05..5b3570ab3 100644
--- a/v7/src/runtime/rep.scm
+++ b/v7/src/runtime/rep.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.24 1992/02/25 22:56:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.25 1992/03/20 05:17:51 cph Exp $
 
 Copyright (c) 1988-92 Massachusetts Institute of Technology
 
@@ -137,7 +137,11 @@ MIT in each case. |#
 			   interrupt-mask
 			   (unblock-thread-events)
 			   (message cmdl)
-			   ((cmdl/driver cmdl) cmdl)))))))))))))
+			   (call-with-current-continuation
+			    (lambda (continuation)
+			      (with-create-thread-continuation continuation
+				(lambda ()
+				  ((cmdl/driver cmdl) cmdl)))))))))))))))))
     (if operation
 	(operation cmdl thunk)
 	(with-thread-mutex-locked (port/thread-mutex (cmdl/port cmdl))
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 3c4ae1401..5f2601339 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.137 1992/03/08 16:22:30 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.138 1992/03/20 05:17:56 cph Exp $
 
 Copyright (c) 1988-92 Massachusetts Institute of Technology
 
@@ -2038,13 +2038,14 @@ MIT in each case. |#
   (files "x11graph")
   (parent ())
   (export ()
+	  create-x-colormap
+	  create-x-image
 	  x-character-bounds/ascent
 	  x-character-bounds/descent
 	  x-character-bounds/lbearing
 	  x-character-bounds/rbearing
 	  x-character-bounds/width
 	  x-close-all-displays
-	  x-close-display
 	  x-colormap/allocate-color
 	  x-colormap/free
 	  x-colormap/query-color
@@ -2063,6 +2064,49 @@ MIT in each case. |#
 	  x-font-structure/start-index
 	  x-geometry-string
 	  x-graphics-device-type
+	  x-graphics/available?
+	  x-graphics/clear
+	  x-graphics/close-display
+	  x-graphics/close-window
+	  x-graphics/coordinate-limits
+	  x-graphics/copy-area
+	  x-graphics/device-coordinate-limits
+	  x-graphics/drag-cursor
+	  x-graphics/draw-line
+	  x-graphics/draw-point
+	  x-graphics/draw-text
+	  x-graphics/font-structure
+	  x-graphics/get-colormap
+	  x-graphics/get-default
+	  x-graphics/flush
+	  x-graphics/iconify-window
+	  x-graphics/lower-window
+	  x-graphics/map-window
+	  x-graphics/move-cursor
+	  x-graphics/move-window
+	  x-graphics/open-display
+	  x-graphics/query-pointer
+	  x-graphics/raise-window
+	  x-graphics/reset-clip-rectangle
+	  x-graphics/resize-window
+	  x-graphics/set-background-color
+	  x-graphics/set-border-color
+	  x-graphics/set-border-width
+	  x-graphics/set-clip-rectangle
+	  x-graphics/set-colormap
+	  x-graphics/set-coordinate-limits
+	  x-graphics/set-drawing-mode
+	  x-graphics/set-font
+	  x-graphics/set-foreground-color
+	  x-graphics/set-icon-name
+	  x-graphics/set-input-hint
+	  x-graphics/set-internal-border-width
+	  x-graphics/set-line-style
+	  x-graphics/set-mouse-color
+	  x-graphics/set-mouse-shape
+	  x-graphics/set-window-name
+	  x-graphics/starbase-filename
+	  x-graphics/withdraw-window
 	  x-image/destroy
 	  x-image/draw
 	  x-image/draw-subimage
@@ -2071,9 +2115,7 @@ MIT in each case. |#
 	  x-image/height
 	  x-image/set-pixel
 	  x-image/width
-	  x-image?
-	  x-open-display
-	  )
+	  x-image?)
   (initialization (initialize-package!)))
 
 (define-package (runtime starbase-graphics)
@@ -2312,6 +2354,7 @@ MIT in each case. |#
 	  condition-type:thread-detached
 	  condition-type:thread-control-error
 	  create-thread
+	  create-thread-continuation
 	  current-thread
 	  detach-thread
 	  exit-current-thread
@@ -2334,6 +2377,7 @@ MIT in each case. |#
 	  try-lock-thread-mutex
 	  unblock-thread-events
 	  unlock-thread-mutex
+	  with-create-thread-continuation
 	  with-thread-mutex-locked
 	  yield-current-thread)
   (export (runtime interrupt-handler)
diff --git a/v7/src/runtime/thread.scm b/v7/src/runtime/thread.scm
index 8004e9647..50031731c 100644
--- a/v7/src/runtime/thread.scm
+++ b/v7/src/runtime/thread.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/thread.scm,v 1.3 1992/03/11 12:17:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/thread.scm,v 1.4 1992/03/20 05:18:00 cph Exp $
 
 Copyright (c) 1991-92 Massachusetts Institute of Technology
 
@@ -98,14 +98,12 @@ MIT in each case. |#
 (define first-running-thread)
 (define last-running-thread)
 
-(define initial-thread)
-
 (define-integrable (without-interrupts thunk)
   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
     (let ((value (thunk)))
       (set-interrupt-enables! interrupt-mask)
       value)))
-
+
 (define (initialize-package!)
   (initialize-error-conditions!)
   (set! first-running-thread false)
@@ -115,14 +113,18 @@ MIT in each case. |#
   (let ((thread (make-thread)))
     (set-thread/continuation! thread false)
     (thread-running thread)
-    (detach-thread thread)
-    (set! initial-thread thread))
+    (detach-thread thread))
   (add-event-receiver! event:before-exit stop-thread-timer))
-
+
 (define (create-thread root-continuation thunk)
+  (if (not (or (not root-continuation) (continuation? root-continuation)))
+      (error:wrong-type-argument root-continuation
+				 "continuation or #f"
+				 create-thread))
   (call-with-current-continuation
    (lambda (return)
-     (%within-continuation root-continuation true
+     (%within-continuation (or root-continuation root-continuation-default)
+			   true
        (lambda ()
 	 (fluid-let ((state-space:local (make-state-space)))
 	   (call-with-current-continuation
@@ -134,6 +136,19 @@ MIT in each case. |#
 	   (set-interrupt-enables! interrupt-mask/all)
 	   (exit-current-thread (thunk))))))))
 
+(define root-continuation-default)
+
+(define (create-thread-continuation)
+  root-continuation-default)
+
+(define (with-create-thread-continuation continuation thunk)
+  (if (not (continuation? continuation))
+      (error:wrong-type-argument continuation
+				 "continuation"
+				 with-create-thread-continuation))
+  (fluid-let ((root-continuation-default continuation))
+    (thunk)))
+
 (define-integrable (current-thread)
   (or first-running-thread (error "No current thread!")))
 
diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 022ba19b9..04f759d59 100644
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.147 1992/02/25 22:57:27 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.148 1992/03/20 05:18:31 cph Exp $
 
 Copyright (c) 1988-92 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
 		     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 147))
+  (add-identification! "Runtime" 14 148))
 
 (define microcode-system)
 
diff --git a/v7/src/runtime/x11graph.scm b/v7/src/runtime/x11graph.scm
index abba1495d..a873c3aeb 100644
--- a/v7/src/runtime/x11graph.scm
+++ b/v7/src/runtime/x11graph.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/x11graph.scm,v 1.15 1992/02/25 22:38:44 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/x11graph.scm,v 1.16 1992/03/20 05:18:02 cph Exp $
 
 Copyright (c) 1989-92 Massachusetts Institute of Technology
 
@@ -33,9 +33,10 @@ promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
 ;;;; X Graphics Interface
-;;; package: (runtime X-graphics)
+;;; package: (runtime x-graphics)
 
 (declare (usual-integrations))
+(declare (integrate-external "graphics"))
 
 (define-primitives
   (x-debug 1)
@@ -50,16 +51,20 @@ MIT in each case. |#
 
   (x-window-beep 1)
   (x-window-clear 1)
-  (x-window-display 1)
   (x-window-iconify 1)
+  (x-window-lower 1)
   (x-window-map 1)
+  (x-window-query-pointer 1)
+  (x-window-raise 1)
   (x-window-set-background-color 2)
   (x-window-set-border-color 2)
   (x-window-set-border-width 2)
   (x-window-set-cursor-color 2)
+  (x-window-set-event-mask 2)
   (x-window-set-font 2)
   (x-window-set-foreground-color 2)
   (x-window-set-icon-name 2)
+  (x-window-set-input-hint 2)
   (x-window-set-internal-border-width 2)
   (x-window-set-mouse-color 2)
   (x-window-set-mouse-shape 2)
@@ -67,7 +72,7 @@ MIT in each case. |#
   (x-window-set-position 3)
   (x-window-set-size 3)
   (x-window-starbase-filename 1)
-  (x-window-unmap 1)
+  (x-window-withdraw 1)
   (x-window-x-size 1)
   (x-window-y-size 1)
 
@@ -76,6 +81,8 @@ MIT in each case. |#
   (x-graphics-draw-line 5)
   (x-graphics-draw-point 3)
   (x-graphics-draw-string 4)
+  (x-graphics-map-x-coordinate 2)
+  (x-graphics-map-y-coordinate 2)
   (x-graphics-move-cursor 3)
   (x-graphics-open-window 3)
   (x-graphics-reset-clip-rectangle 1)
@@ -105,6 +112,27 @@ MIT in each case. |#
 
   (x-window-visual 1)
   (x-visual-deallocate 1))
+
+;; These constants must match "microcode/x11base.c"
+(define-integrable event-type:button-down 0)
+(define-integrable event-type:button-up 1)
+(define-integrable event-type:configure 2)
+(define-integrable event-type:enter 3)
+(define-integrable event-type:focus-in 4)
+(define-integrable event-type:focus-out 5)
+(define-integrable event-type:key-press 6)
+(define-integrable event-type:leave 7)
+(define-integrable event-type:motion 8)
+(define-integrable event-type:expose 9)
+(define-integrable event-type:delete-window 10)
+(define-integrable event-type:map 11)
+(define-integrable event-type:unmap 12)
+(define-integrable event-type:take-focus 13)
+(define-integrable event-type:visibility 14)
+(define-integrable number-of-event-types 15)
+
+;; This mask contains configure, delete-window, map, unmap, and visibility.
+(define-integrable event-mask #x5c04)
 
 ;;;; Protection lists
 
@@ -137,58 +165,257 @@ MIT in each case. |#
 	      (let ((next (cdr associations)))
 		(set-cdr! previous next)
 		(loop next previous)))))))
+
+(define (search-protection-list list predicate)
+  (let loop ((associations (cdr list)))
+    (and (not (null? associations))
+	 (let ((scheme-object (weak-car (car associations))))
+	   (if (and scheme-object (predicate scheme-object))
+	       scheme-object
+	       (loop (cdr associations)))))))
+
+(define (protection-list-elements list)
+  (with-absolutely-no-interrupts
+   (lambda ()
+     (let loop ((associations (cdr list)))
+       (cond ((null? associations)
+	      '())
+	     ((weak-pair/car? (car associations))
+	      (cons (weak-car (car associations))
+		    (loop (cdr associations))))
+	     (else
+	      (loop (cdr associations))))))))
 
 ;;;; X graphics device
 
 (define (initialize-package!)
   (set! x-graphics-device-type
 	(make-graphics-device-type
-	 `((available? ,operation/available?)
-	   (clear ,operation/clear)
-	   (close ,operation/close)
-	   (coordinate-limits ,operation/coordinate-limits)
-	   (copy-area ,operation/copy-area)
-	   (create-colormap ,operation/create-colormap)
-	   (create-image ,operation/create-image)
-	   (device-coordinate-limits ,operation/device-coordinate-limits)
-	   (drag-cursor ,operation/drag-cursor)
-	   (draw-line ,operation/draw-line)
-	   (draw-point ,operation/draw-point)
-	   (draw-text ,operation/draw-text)
-	   (flush ,operation/flush)
-	   (font-structure ,operation/font-structure)
-	   (get-colormap ,operation/get-colormap)
-	   (get-default ,operation/get-default)
-	   (iconify-window ,operation/iconify-window)
-	   (map-window ,operation/map-window)
-	   (move-cursor ,operation/move-cursor)
-	   (move-window ,operation/move-window)
-	   (open ,operation/open)
-	   (reset-clip-rectangle ,operation/reset-clip-rectangle)
-	   (resize-window ,operation/resize-window)
-	   (set-background-color ,operation/set-background-color)
-	   (set-border-color ,operation/set-border-color)
-	   (set-border-width ,operation/set-border-width)
-	   (set-clip-rectangle ,operation/set-clip-rectangle)
-	   (set-colormap ,operation/set-colormap)
-	   (set-coordinate-limits ,operation/set-coordinate-limits)
-	   (set-drawing-mode ,operation/set-drawing-mode)
-	   (set-font ,operation/set-font)
-	   (set-foreground-color ,operation/set-foreground-color)
-	   (set-icon-name ,operation/set-icon-name)
-	   (set-internal-border-width ,operation/set-internal-border-width)
-	   (set-line-style ,operation/set-line-style)
-	   (set-mouse-color ,operation/set-mouse-color)
-	   (set-mouse-shape ,operation/set-mouse-shape)
-	   (set-window-name ,operation/set-window-name)
-	   (starbase-filename ,operation/starbase-filename)
-	   (unmap-window ,operation/unmap-window))))
-  (set! window-list (make-protection-list))
-  (add-gc-daemon! close-lost-windows-daemon)
+	 `((available? ,x-graphics/available?)
+	   (clear ,x-graphics/clear)
+	   (close ,x-graphics/close-window)
+	   (coordinate-limits ,x-graphics/coordinate-limits)
+	   (copy-area ,x-graphics/copy-area)
+	   (create-colormap ,create-x-colormap)
+	   (create-image ,create-x-image)
+	   (device-coordinate-limits ,x-graphics/device-coordinate-limits)
+	   (drag-cursor ,x-graphics/drag-cursor)
+	   (draw-line ,x-graphics/draw-line)
+	   (draw-point ,x-graphics/draw-point)
+	   (draw-text ,x-graphics/draw-text)
+	   (flush ,x-graphics/flush)
+	   (font-structure ,x-graphics/font-structure)
+	   (get-colormap ,x-graphics/get-colormap)
+	   (get-default ,x-graphics/get-default)
+	   (iconify-window ,x-graphics/iconify-window)
+	   (lower-window ,x-graphics/lower-window)
+	   (map-window ,x-graphics/map-window)
+	   (move-cursor ,x-graphics/move-cursor)
+	   (move-window ,x-graphics/move-window)
+	   (open ,x-graphics/open)
+	   (query-pointer ,x-graphics/query-pointer)
+	   (raise-window ,x-graphics/raise-window)
+	   (reset-clip-rectangle ,x-graphics/reset-clip-rectangle)
+	   (resize-window ,x-graphics/resize-window)
+	   (set-background-color ,x-graphics/set-background-color)
+	   (set-border-color ,x-graphics/set-border-color)
+	   (set-border-width ,x-graphics/set-border-width)
+	   (set-clip-rectangle ,x-graphics/set-clip-rectangle)
+	   (set-colormap ,x-graphics/set-colormap)
+	   (set-coordinate-limits ,x-graphics/set-coordinate-limits)
+	   (set-drawing-mode ,x-graphics/set-drawing-mode)
+	   (set-font ,x-graphics/set-font)
+	   (set-foreground-color ,x-graphics/set-foreground-color)
+	   (set-icon-name ,x-graphics/set-icon-name)
+	   (set-input-hint ,x-graphics/set-input-hint)
+	   (set-internal-border-width ,x-graphics/set-internal-border-width)
+	   (set-line-style ,x-graphics/set-line-style)
+	   (set-mouse-color ,x-graphics/set-mouse-color)
+	   (set-mouse-shape ,x-graphics/set-mouse-shape)
+	   (set-window-name ,x-graphics/set-window-name)
+	   (starbase-filename ,x-graphics/starbase-filename)
+	   (withdraw-window ,x-graphics/withdraw-window))))
+  (set! display-list (make-protection-list))
+  (add-gc-daemon! close-lost-displays-daemon)
   (initialize-image-datatype)
   (initialize-colormap-datatype))
-
+
+(define (x-graphics/available?)
+  (implemented-primitive-procedure? x-graphics-open-window))
+
 (define x-graphics-device-type)
+
+;;;; Open/Close Displays
+
+(define display-list)
+
+(define-structure (x-display
+		   (conc-name x-display/)
+		   (constructor make-x-display (name xd))
+		   (print-procedure
+		    (unparser/standard-method 'X-DISPLAY
+		      (lambda (state display)
+			(unparse-object state (x-display/name display))))))
+  (name false read-only true)
+  xd
+  (window-list (make-protection-list) read-only true))
+
+(define (x-graphics/open-display name)
+  (let ((name
+	 (cond ((not name)
+		(let ((name (get-environment-variable "DISPLAY")))
+		  (if (not name)
+		      (error "No DISPLAY environment variable."))
+		  name))
+	       ((string? name)
+		name)
+	       (else
+		(error:wrong-type-argument name
+					   "string or #f"
+					   x-graphics/open-display)))))
+    (or (search-protection-list display-list
+	  (lambda (display)
+	    (string=? (x-display/name display) name)))
+	(let ((xd (x-open-display name)))
+	  (if (not xd)
+	      (error "Unable to open display:" name))
+	  (let ((display (make-x-display name xd)))
+	    (add-to-protection-list! display-list display xd)
+	    (create-thread false (make-event-previewer display))
+	    display)))))
+
+(define (x-graphics/close-display display)
+  (without-interrupts
+   (lambda ()
+     (if (x-display/xd display)
+	 (begin
+	   (do ((windows
+		 (protection-list-elements (x-display/window-list display))
+		 (cdr windows)))
+	       ((null? windows))
+	     (close-x-window (car windows)))
+	   (x-close-display (x-display/xd display))
+	   (set-x-display/xd! display false)
+	   (remove-from-protection-list! display-list display))))))
+
+(define (close-lost-displays-daemon)
+  (clean-lost-protected-objects display-list x-close-display)
+  (do ((associations (cdr display-list) (cdr associations)))
+      ((null? associations))
+    (clean-lost-protected-objects
+     (x-display/window-list (weak-car (car associations)))
+     x-close-window)))
+
+(define (make-event-previewer display)
+  (lambda ()
+    (detach-thread (current-thread))
+    (bind-condition-handler (list condition-type:bad-range-argument
+				  condition-type:wrong-type-argument)
+	(lambda (condition)
+	  ;; If x-display-process-events signals an argument error on
+	  ;; its display argument, that means the display has been
+	  ;; closed.  When that happens, kill this thread.
+	  (if (and (eq? x-display-process-events
+			(access-condition condition 'OPERATOR))
+		   (eqv? 0 (access-condition condition 'OPERAND)))
+	      (exit-current-thread unspecific)))
+      (lambda ()
+	(let ((handlers event-handlers)
+	      (interval event-previewer-interval))
+	  (do () (false)
+	    (let loop ()
+	      (let ((event
+		     (x-display-process-events (x-display/xd display) 2)))
+		(if event
+		    (begin
+		      (let ((handler
+			     (vector-ref handlers (vector-ref event 0))))
+			(if handler
+			    (let ((window
+				   (search-protection-list
+				    (x-display/window-list display)
+				    (let ((xw (vector-ref event 1)))
+				      (lambda (window)
+					(eq? (x-window/xw window) xw))))))
+			      (if window
+				  (handler window event)))))
+		      (loop)))))
+	    (sleep-current-thread interval)))))))
+
+(define event-previewer-interval
+  1000)
+
+(define event-handlers
+  (make-vector number-of-event-types false))
+
+(define-integrable (define-event-handler event-type handler)
+  (vector-set! event-handlers event-type handler))
+
+(define-event-handler event-type:delete-window
+  (lambda (window event)
+    event
+    (without-interrupts (lambda () (close-x-window window)))))
+
+(define-event-handler event-type:map
+  (lambda (window event)
+    event
+    (set-x-window/mapped?! window true)))
+
+(define-event-handler event-type:unmap
+  (lambda (window event)
+    event
+    (set-x-window/mapped?! window false)))
+
+(define-event-handler event-type:visibility
+  (lambda (window event)
+    (case (vector-ref event 2)
+      ((0) (set-x-window/visibility! window 'UNOBSCURED))
+      ((1) (set-x-window/visibility! window 'PARTIALLY-OBSCURED))
+      ((2) (set-x-window/visibility! window 'OBSCURED)))))
+
+;;;; Standard Operations
+
+(define-structure (x-window (conc-name x-window/)
+			    (constructor make-x-window (xw display)))
+  xw
+  (display false read-only true)
+  (mapped? false)
+  (visibility false))
+
+(define-integrable (x-graphics-device/xw device)
+  (x-window/xw (graphics-device/descriptor device)))
+
+(define-integrable (x-graphics-device/xd device)
+  (x-display/xd (x-window/display (graphics-device/descriptor device))))
+
+(define (x-graphics/open display geometry #!optional suppress-map?)
+  (let ((display
+	 (if (x-display? display)
+	     display
+	     (x-graphics/open-display display))))
+    (let ((xw
+	   (x-graphics-open-window (x-display/xd display)
+				   geometry
+				   (and (not (default-object? suppress-map?))
+					suppress-map?))))
+      (x-window-set-event-mask xw event-mask)
+      (let ((window (make-x-window xw display)))
+	(add-to-protection-list! (x-display/window-list display) window xw)
+	window))))
+
+(define (x-graphics/close-window device)
+  (without-interrupts
+   (lambda ()
+     (close-x-window (graphics-device/descriptor device)))))
+
+(define (close-x-window window)
+  (if (x-window/xw window)
+      (begin
+	(x-close-window (x-window/xw window))
+	(set-x-window/xw! window false)
+	(remove-from-protection-list!
+	 (x-display/window-list (x-window/display window))
+	 window))))
 
 (define (x-geometry-string x y width height)
   (string-append (if (and width height)
@@ -202,232 +429,179 @@ MIT in each case. |#
 				    (if (negative? y) "" "+")
 				    (number->string y))
 		     "")))
+
+(define (x-graphics/clear device)
+  (x-window-clear (x-graphics-device/xw device)))
 
-(define-structure (x-graphics-descriptor (conc-name x-graphics-descriptor/))
-  (window false read-only true)
-  (display false read-only true))
-
-(define (x-graphics-device/window device)
-  (x-graphics-descriptor/window (graphics-device/descriptor device)))
+(define (x-graphics/coordinate-limits device)
+  (let ((limits (x-graphics-vdc-extent (x-graphics-device/xw device))))
+    (values (vector-ref limits 0) (vector-ref limits 1)
+	    (vector-ref limits 2) (vector-ref limits 3))))
 
-(define (x-graphics-device/display device)
-  (x-graphics-descriptor/display (graphics-device/descriptor device)))
+(define (x-graphics/device-coordinate-limits device)
+  (let ((xw (x-graphics-device/xw device)))
+    (values 0 (- (x-window-y-size xw) 1) (- (x-window-x-size xw) 1) 0)))
 
-(define (x-graphics-device/process-events! device)
-  (let ((xd (x-graphics-device/display device)))
-    (let loop ()
-      (if (x-display-process-events xd 0)
-	  (loop)))))
+(define (x-graphics/drag-cursor device x y)
+  (x-graphics-drag-cursor (x-graphics-device/xw device) x y))
 
-(define (operation/available?)
-  (implemented-primitive-procedure? x-graphics-open-window))
-
-(define (operation/clear device)
-  (x-graphics-device/process-events! device)
-  (x-window-clear (x-graphics-device/window device)))
-
-(define (operation/close device)
-  (x-graphics-device/process-events! device)
-  (x-close-window (x-graphics-device/window device))
-  (remove-from-protection-list!
-   window-list
-   (graphics-device/descriptor device)))
-
-(define (close-lost-windows-daemon)
-  (clean-lost-protected-objects window-list x-close-window))
-
-(define (operation/coordinate-limits device)
-  (x-graphics-device/process-events! device)
-  (let ((limits (x-graphics-vdc-extent (x-graphics-device/window device))))
-    (values (vector-ref limits 0)
-	    (vector-ref limits 1)
-	    (vector-ref limits 2)
-	    (vector-ref limits 3))))
-
-(define (operation/copy-area device
-			     source-x-left source-y-top
-			     width height
-			     destination-x-left destination-y-top)
-  (x-graphics-device/process-events! device)
-  (x-graphics-copy-area (x-graphics-device/window device)
-			source-x-left source-y-top
-			width height
-			destination-x-left destination-y-top))
+(define (x-graphics/draw-line device x-start y-start x-end y-end)
+  (x-graphics-draw-line (x-graphics-device/xw device)
+			x-start y-start x-end y-end))
 
-(define (operation/device-coordinate-limits device)
-  (x-graphics-device/process-events! device)
-  (let ((xw (x-graphics-device/window device)))
-    (values 0 (-1+ (x-window-y-size xw)) (-1+ (x-window-x-size xw)) 0)))
+(define (x-graphics/draw-point device x y)
+  (x-graphics-draw-point (x-graphics-device/xw device) x y))
 
-(define (operation/drag-cursor device x y)
-  (x-graphics-device/process-events! device)
-  (x-graphics-drag-cursor (x-graphics-device/window device) x y))
+(define (x-graphics/draw-text device x y string)
+  (x-graphics-draw-string (x-graphics-device/xw device) x y string))
 
-(define (operation/draw-line device x-start y-start x-end y-end)
-  (x-graphics-device/process-events! device)
-  (x-graphics-draw-line (x-graphics-device/window device)
-			x-start y-start x-end y-end))
+(define (x-graphics/flush device)
+  (x-display-flush (x-graphics-device/xd device)))
 
-(define (operation/draw-point device x y)
-  (x-graphics-device/process-events! device)
-  (x-graphics-draw-point (x-graphics-device/window device) x y))
+(define (x-graphics/move-cursor device x y)
+  (x-graphics-move-cursor (x-graphics-device/xw device) x y))
 
-(define (operation/draw-text device x y string)
-  (x-graphics-device/process-events! device)
-  (x-graphics-draw-string (x-graphics-device/window device) x y string))
+(define (x-graphics/reset-clip-rectangle device)
+  (x-graphics-reset-clip-rectangle (x-graphics-device/xw device)))
 
-(define (operation/flush device)
-  (x-display-flush (x-graphics-device/display device))
-  (x-graphics-device/process-events! device))
-
-(define (operation/font-structure device string)
-  (x-graphics-device/process-events! device)
-  (x-font-structure (x-graphics-device/display device) string))
+(define (x-graphics/set-clip-rectangle device x-left y-bottom x-right y-top)
+  (x-graphics-set-clip-rectangle (x-graphics-device/xw device)
+				 x-left y-bottom x-right y-top))
 
-(define (operation/get-default device resource-name class-name)
-  (x-graphics-device/process-events! device)
-  (x-display-get-default (x-graphics-device/display device)
-			 resource-name class-name))
-
-(define (operation/map-window device)
-  (x-graphics-device/process-events! device)
-  (x-window-map (x-graphics-device/window device)))
-
-(define (operation/move-cursor device x y)
-  (x-graphics-device/process-events! device)
-  (x-graphics-move-cursor (x-graphics-device/window device) x y))
-
-(define (operation/move-window device x y)
-  (x-graphics-device/process-events! device)
-  (x-window-set-position (x-graphics-device/window device) x y))
-
-(define default-display-hash
-  false)
-
-(define window-list)
-
-(define (operation/open display geometry #!optional suppress-map?)
-  (let ((xw
-	 (x-graphics-open-window
-	  (let ((open
-		 (lambda ()
-		   (let ((d (x-open-display display)))
-		     (if (not d)
-			 (error "unable to open display" display))
-		     d))))
-	    (cond ((false? display)
-		   (or (and default-display-hash
-			    (object-unhash default-display-hash))
-		       (let ((d (open)))
-			 (set! default-display-hash (object-hash d))
-			 d)))
-		  ((string? display)
-		   (open))
-		  (else
-		   display)))
-	  geometry
-	  (and (not (default-object? suppress-map?))
-	       suppress-map?))))
-    (let ((descriptor (make-x-graphics-descriptor xw (x-window-display xw))))
-      (add-to-protection-list! window-list descriptor xw)
-      descriptor)))
-
-(define (operation/reset-clip-rectangle device)
-  (x-graphics-device/process-events! device)
-  (x-graphics-reset-clip-rectangle (x-graphics-device/window device)))
-
-(define (operation/resize-window device width height)
-  (x-graphics-device/process-events! device)
-  (x-window-set-size (x-graphics-device/window device) width height))
-
-(define (operation/set-background-color device color)
-  (x-graphics-device/process-events! device)
-  (x-window-set-background-color (x-graphics-device/window device) color))
-
-(define (operation/set-border-color device color)
-  (x-graphics-device/process-events! device)
-  (x-window-set-border-color (x-graphics-device/window device) color))
-
-(define (operation/set-border-width device width)
-  (x-graphics-device/process-events! device)
-  (x-window-set-border-width (x-graphics-device/window device) width))
-
-(define (operation/set-coordinate-limits device x-left y-bottom x-right y-top)
-  (x-graphics-device/process-events! device)
-  (x-graphics-set-vdc-extent (x-graphics-device/window device)
+(define (x-graphics/set-coordinate-limits device x-left y-bottom x-right y-top)
+  (x-graphics-set-vdc-extent (x-graphics-device/xw device)
 			     x-left y-bottom x-right y-top))
 
-(define (operation/set-clip-rectangle device x-left y-bottom x-right y-top)
-  (x-graphics-device/process-events! device)
-  (x-graphics-set-clip-rectangle (x-graphics-device/window device)
-				 x-left y-bottom x-right y-top))
-
-(define (operation/set-drawing-mode device mode)
-  (x-graphics-device/process-events! device)
-  (x-graphics-set-function (x-graphics-device/window device) mode))
-
-(define (operation/set-font device font)
-  (x-graphics-device/process-events! device)
-  (x-window-set-font (x-graphics-device/window device) font))
-
-(define (operation/set-foreground-color device color)
-  (x-graphics-device/process-events! device)
-  (x-window-set-foreground-color (x-graphics-device/window device) color))
-
-(define (operation/set-internal-border-width device width)
-  (x-graphics-device/process-events! device)
-  (x-window-set-internal-border-width (x-graphics-device/window device) width))
-
-(define (operation/set-line-style device line-style)
-  (x-graphics-device/process-events! device)
-  (if (not (and (exact-nonnegative-integer? line-style)
-		(< line-style 8)))
+(define (x-graphics/set-drawing-mode device mode)
+  (x-graphics-set-function (x-graphics-device/xw device) mode))
+
+(define (x-graphics/set-line-style device line-style)
+  (if (not (and (exact-nonnegative-integer? line-style) (< line-style 8)))
       (error:wrong-type-argument line-style "graphics line style"
 				 'SET-LINE-STYLE))
-  (let ((xw (x-graphics-device/window device)))
+  (let ((xw (x-graphics-device/xw device)))
     (if (zero? line-style)
 	(x-graphics-set-line-style xw 0)
 	(begin
 	  (x-graphics-set-line-style xw 2)
-	  (x-graphics-set-dashes
-	   xw
-	   0
-	   (vector-ref '#("\010\010"
-			  "\001\001"
-			  "\015\001\001\001"
-			  "\013\001\001\001\001\001"
-			  "\013\005"
-			  "\014\001\002\001"
-			  "\011\001\002\001\002\001")
-		       (-1+ line-style)))))))
-
-(define (operation/set-mouse-color device color)
-  (x-graphics-device/process-events! device)
-  (x-window-set-mouse-color (x-graphics-device/window device) color))
-
-(define (operation/set-mouse-shape device shape)
-  (x-graphics-device/process-events! device)
-  (x-window-set-mouse-shape (x-graphics-device/window device) shape))
-
-(define (operation/starbase-filename device)
-  (x-graphics-device/process-events! device)
-  (x-window-starbase-filename (x-graphics-device/window device)))
-
-(define (operation/unmap-window device)
-  (x-graphics-device/process-events! device)
-  (x-window-unmap (x-graphics-device/window device)))
-
-(define (operation/iconify-window device)
-  (x-graphics-device/process-events! device)
-  (x-window-iconify (x-graphics-device/window device)))
-
-(define (operation/set-icon-name device name)
-  (x-graphics-device/process-events! device)
-  (x-window-set-icon-name (x-graphics-device/window device) name))
-
-(define (operation/set-window-name device name)
-  (x-graphics-device/process-events! device)
-  (x-window-set-name (x-graphics-device/window device) name))
+	  (x-graphics-set-dashes xw
+				 0
+				 (vector-ref '#("\010\010"
+						"\001\001"
+						"\015\001\001\001"
+						"\013\001\001\001\001\001"
+						"\013\005"
+						"\014\001\002\001"
+						"\011\001\002\001\002\001")
+					     (- line-style 1)))))))
+
+;;;; Appearance Operations
+
+(define (x-graphics/set-background-color device color)
+  (x-window-set-background-color (x-graphics-device/xw device) color))
+
+(define (x-graphics/set-border-color device color)
+  (x-window-set-border-color (x-graphics-device/xw device) color))
+
+(define (x-graphics/set-border-width device width)
+  (x-window-set-border-width (x-graphics-device/xw device) width))
+
+(define (x-graphics/set-font device font)
+  (x-window-set-font (x-graphics-device/xw device) font))
+
+(define (x-graphics/set-foreground-color device color)
+  (x-window-set-foreground-color (x-graphics-device/xw device) color))
+
+(define (x-graphics/set-internal-border-width device width)
+  (x-window-set-internal-border-width (x-graphics-device/xw device) width))
+
+(define (x-graphics/set-mouse-color device color)
+  (x-window-set-mouse-color (x-graphics-device/xw device) color))
+
+(define (x-graphics/set-mouse-shape device shape)
+  (x-window-set-mouse-shape (x-graphics-device/xw device) shape))
+
+;;;; Miscellaneous Operations
+
+(define (x-graphics/copy-area device
+			      source-x-left source-y-top
+			      width height
+			      destination-x-left destination-y-top)
+  (x-graphics-copy-area (x-graphics-device/xw device)
+			source-x-left source-y-top
+			width height
+			destination-x-left destination-y-top))
+
+(define (x-graphics/get-default device resource-name class-name)
+  (x-display-get-default (x-graphics-device/xd device)
+			 resource-name class-name))
+
+(define (x-graphics/set-input-hint device input?)
+  (x-window-set-input-hint (x-graphics-device/xw device) input?))
+
+(define (x-graphics/query-pointer device)
+  (let ((result (x-window-query-pointer (x-graphics-device/xw device))))
+    (values (x-graphics-map-x-coordinate (vector-ref result 2))
+	    (x-graphics-map-y-coordinate (vector-ref result 3))
+	    (vector-ref result 4))))
+
+(define (x-graphics/starbase-filename device)
+  (x-window-starbase-filename (x-graphics-device/xw device)))
+
+;;;; Font Operations
+
+(define (x-graphics/font-structure device string)
+  (x-font-structure (x-graphics-device/xd device) string))
+
+(define-structure (x-font-structure (conc-name x-font-structure/)
+				    (type vector))
+  (name false read-only true)
+  (direction false read-only true)
+  (all-chars-exist? false read-only true)
+  (default-char false read-only true)
+  (min-bounds false read-only true)
+  (max-bounds false read-only true)
+  (start-index false read-only true)
+  (character-bounds false read-only true)
+  (max-ascent false read-only true)
+  (max-descent false read-only true))
+
+(define-structure (x-character-bounds (conc-name x-character-bounds/)
+				      (type vector))
+  (lbearing false read-only true)
+  (rbearing false read-only true)
+  (width false read-only true)
+  (ascent false read-only true)
+  (descent false read-only true))
+
+;;;; Window Management Operations
+
+(define (x-graphics/map-window device)
+  (x-window-map (x-graphics-device/xw device)))
+
+(define (x-graphics/withdraw-window device)
+  (x-window-withdraw (x-graphics-device/xw device)))
+
+(define (x-graphics/iconify-window device)
+  (x-window-iconify (x-graphics-device/xw device)))
+
+(define (x-graphics/raise-window device)
+  (x-window-raise (x-graphics-device/xw device)))
+
+(define (x-graphics/lower-window device)
+  (x-window-lower (x-graphics-device/xw device)))
+
+(define (x-graphics/set-icon-name device name)
+  (x-window-set-icon-name (x-graphics-device/xw device) name))
+
+(define (x-graphics/set-window-name device name)
+  (x-window-set-name (x-graphics-device/xw device) name))
+
+(define (x-graphics/move-window device x y)
+  (x-window-set-position (x-graphics-device/xw device) x y))
+
+(define (x-graphics/resize-window device width height)
+  (x-window-set-size (x-graphics-device/xw device) width height))
 
 ;;;; Images
 
@@ -450,8 +624,8 @@ MIT in each case. |#
   (set! image-list (make-protection-list))
   (add-gc-daemon! destroy-lost-images-daemon))
 
-(define (operation/create-image device width height)
-  (let ((window (x-graphics-device/window device)))
+(define (create-x-image device width height)
+  (let ((window (x-graphics-device/xw device)))
     (let ((descriptor (x-create-image window width height)))
       (let ((image (make-x-image descriptor window width height)))
 	(add-to-protection-list! image-list image descriptor)
@@ -503,15 +677,15 @@ MIT in each case. |#
     (add-to-protection-list! colormap-list colormap descriptor)
     colormap))
 
-(define (operation/get-colormap device)
-  (make-colormap (x-window-colormap (x-graphics-device/window device))))
+(define (x-graphics/get-colormap device)
+  (make-colormap (x-window-colormap (x-graphics-device/xw device))))
 
-(define (operation/set-colormap device colormap)
-  (x-set-window-colormap (x-graphics-device/window device)
+(define (x-graphics/set-colormap device colormap)
+  (x-set-window-colormap (x-graphics-device/xw device)
 			 (colormap/descriptor colormap)))
 
-(define (operation/create-colormap device writeable?)
-  (let ((window (x-graphics-device/window device)))
+(define (create-x-colormap device writeable?)
+  (let ((window (x-graphics-device/xw device)))
     (let ((visual (x-window-visual window)))
       (let ((descriptor (x-create-colormap window visual writeable?)))
 	(x-visual-deallocate visual)
@@ -534,27 +708,4 @@ MIT in each case. |#
   (x-store-color (colormap/descriptor colormap) position r g b))
 
 (define (x-colormap/store-colors colormap color-vector)
-  (x-store-colors (colormap/descriptor colormap) color-vector))
-
-;;;; Fonts
-
-(define-structure (x-font-structure (conc-name x-font-structure/)
-				    (type vector))
-  (name false read-only true)
-  (direction false read-only true)
-  (all-chars-exist? false read-only true)
-  (default-char false read-only true)
-  (min-bounds false read-only true)
-  (max-bounds false read-only true)
-  (start-index false read-only true)
-  (character-bounds false read-only true)
-  (max-ascent false read-only true)
-  (max-descent false read-only true))
-
-(define-structure (x-character-bounds (conc-name x-character-bounds/)
-				      (type vector))
-  (lbearing false read-only true)
-  (rbearing false read-only true)
-  (width false read-only true)
-  (ascent false read-only true)
-  (descent false read-only true))
\ No newline at end of file
+  (x-store-colors (colormap/descriptor colormap) color-vector))
\ No newline at end of file
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index b11200ca9..e3aed4834 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.137 1992/03/08 16:22:30 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.138 1992/03/20 05:17:56 cph Exp $
 
 Copyright (c) 1988-92 Massachusetts Institute of Technology
 
@@ -2038,13 +2038,14 @@ MIT in each case. |#
   (files "x11graph")
   (parent ())
   (export ()
+	  create-x-colormap
+	  create-x-image
 	  x-character-bounds/ascent
 	  x-character-bounds/descent
 	  x-character-bounds/lbearing
 	  x-character-bounds/rbearing
 	  x-character-bounds/width
 	  x-close-all-displays
-	  x-close-display
 	  x-colormap/allocate-color
 	  x-colormap/free
 	  x-colormap/query-color
@@ -2063,6 +2064,49 @@ MIT in each case. |#
 	  x-font-structure/start-index
 	  x-geometry-string
 	  x-graphics-device-type
+	  x-graphics/available?
+	  x-graphics/clear
+	  x-graphics/close-display
+	  x-graphics/close-window
+	  x-graphics/coordinate-limits
+	  x-graphics/copy-area
+	  x-graphics/device-coordinate-limits
+	  x-graphics/drag-cursor
+	  x-graphics/draw-line
+	  x-graphics/draw-point
+	  x-graphics/draw-text
+	  x-graphics/font-structure
+	  x-graphics/get-colormap
+	  x-graphics/get-default
+	  x-graphics/flush
+	  x-graphics/iconify-window
+	  x-graphics/lower-window
+	  x-graphics/map-window
+	  x-graphics/move-cursor
+	  x-graphics/move-window
+	  x-graphics/open-display
+	  x-graphics/query-pointer
+	  x-graphics/raise-window
+	  x-graphics/reset-clip-rectangle
+	  x-graphics/resize-window
+	  x-graphics/set-background-color
+	  x-graphics/set-border-color
+	  x-graphics/set-border-width
+	  x-graphics/set-clip-rectangle
+	  x-graphics/set-colormap
+	  x-graphics/set-coordinate-limits
+	  x-graphics/set-drawing-mode
+	  x-graphics/set-font
+	  x-graphics/set-foreground-color
+	  x-graphics/set-icon-name
+	  x-graphics/set-input-hint
+	  x-graphics/set-internal-border-width
+	  x-graphics/set-line-style
+	  x-graphics/set-mouse-color
+	  x-graphics/set-mouse-shape
+	  x-graphics/set-window-name
+	  x-graphics/starbase-filename
+	  x-graphics/withdraw-window
 	  x-image/destroy
 	  x-image/draw
 	  x-image/draw-subimage
@@ -2071,9 +2115,7 @@ MIT in each case. |#
 	  x-image/height
 	  x-image/set-pixel
 	  x-image/width
-	  x-image?
-	  x-open-display
-	  )
+	  x-image?)
   (initialization (initialize-package!)))
 
 (define-package (runtime starbase-graphics)
@@ -2312,6 +2354,7 @@ MIT in each case. |#
 	  condition-type:thread-detached
 	  condition-type:thread-control-error
 	  create-thread
+	  create-thread-continuation
 	  current-thread
 	  detach-thread
 	  exit-current-thread
@@ -2334,6 +2377,7 @@ MIT in each case. |#
 	  try-lock-thread-mutex
 	  unblock-thread-events
 	  unlock-thread-mutex
+	  with-create-thread-continuation
 	  with-thread-mutex-locked
 	  yield-current-thread)
   (export (runtime interrupt-handler)
-- 
2.25.1