#| -*-Scheme-*-

$Id: xterm.scm,v 1.74 2005/11/12 22:31:01 cph Exp $

Copyright 1989,1990,1991,1992,1993,1995 Massachusetts Institute of Technology
Copyright 1996,1998,1999,2000,2001,2002 Massachusetts Institute of Technology
Copyright 2003,2005 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.

|#

;;;; X Terminal
;;; Package: (edwin x-screen)

(declare (usual-integrations))

(define-primitives
  (x-change-property 7)
  (x-close-all-displays 0)
  (x-close-display 1)
  (x-close-window 1)
  (x-convert-selection 6)
  (x-delete-property 3)
  (x-display-descriptor 1)
  (x-display-flush 1)
  (x-display-get-default 3)
  (x-display-get-size 2)
  (x-display-process-events 2)
  (x-display-sync 2)
  (x-get-atom-name 2)
  (x-get-selection-owner 2)
  (x-get-window-property 7)
  (x-intern-atom 3)
  (x-max-request-size 1)
  (x-open-display 1)
  (x-select-input 3)
  (x-send-selection-notify 6)
  (x-set-selection-owner 4)
  (x-window-andc-event-mask 2)
  (x-window-beep 1)
  (x-window-display 1)
  (x-window-flush 1)
  (x-window-id 1)
  (x-window-map 1)
  (x-window-or-event-mask 2)
  (x-window-raise 1)
  (x-window-set-event-mask 2)
  (x-window-set-icon-name 2)
  (x-window-set-input-focus 2)
  (x-window-set-name 2)
  (xterm-clear-rectangle! 6)
  (xterm-draw-cursor 1)
  (xterm-dump-rectangle 5)
  (xterm-enable-cursor 2)
  (xterm-erase-cursor 1)
  (xterm-map-x-coordinate 2)
  (xterm-map-x-size 2)
  (xterm-map-y-coordinate 2)
  (xterm-map-y-size 2)
  (xterm-open-window 3)
  (xterm-reconfigure 3)
  (xterm-restore-contents 6)
  (xterm-save-contents 5)
  (xterm-scroll-lines-down 6)
  (xterm-scroll-lines-up 6)
  (xterm-set-size 3)
  (xterm-write-char! 5)
  (xterm-write-cursor! 3)
  (xterm-write-substring! 7)
  (xterm-x-size 1)
  (xterm-y-size 1))

;; These constants must match "microcode/x11base.c"
(define-integrable event:process-output -2)
(define-integrable event:process-status -3)
(define-integrable event:inferior-thread-output -4)
(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 event-type:selection-clear 15)
(define-integrable event-type:selection-notify 16)
(define-integrable event-type:selection-request 17)
(define-integrable event-type:property-notify 18)
(define-integrable number-of-event-types 19)

;; This mask contains button-down, button-up, configure, focus-in,
;; key-press, expose, destroy, map, unmap, visibility,
;; selection-clear, selection-notify, selection-request, and
;; property-notify.
(define-integrable event-mask #x7de57)

(define-structure (xterm-screen-state
		   (constructor make-xterm-screen-state (xterm display))
		   (conc-name xterm-screen-state/))
  (xterm #f read-only #t)
  (display #f read-only #t)
  (redisplay-flag #t)
  (selected? #t)
  (name #f)
  (icon-name #f)
  (x-visibility 'VISIBLE)
  (mapped? #f)
  (unexposed? #t))

(define screen-list)

(define (make-xterm-screen #!optional geometry)
  ;; Don't map the window until all of the data structures are in
  ;; place.  This guarantees that no events will be missed.
  (let ((xterm
	 (open-window (null? screen-list)
		      (if (default-object? geometry) #f geometry))))
    (x-window-set-event-mask xterm event-mask)
    (let ((screen
	   (make-screen (make-xterm-screen-state xterm
						 (x-window-display xterm))
			xterm-screen/beep
			xterm-screen/clear-line!
			xterm-screen/clear-rectangle!
			xterm-screen/clear-screen!
			xterm-screen/discard!
			xterm-screen/enter!
			xterm-screen/exit!
			xterm-screen/flush!
			xterm-screen/modeline-event!
			#f
			xterm-screen/scroll-lines-down!
			xterm-screen/scroll-lines-up!
			xterm-screen/wrap-update!
			xterm-screen/write-char!
			xterm-screen/write-cursor!
			xterm-screen/write-substring!
			8
			(xterm-x-size xterm)
			(xterm-y-size xterm))))
      (set! screen-list (cons screen screen-list))
      (update-visibility! screen)
      (x-window-map xterm)
      (x-window-flush xterm)
      screen)))

(define (open-window primary? geometry)
  (let ((display (or (get-x-display) (error "Unable to open display.")))
	(instance (if primary? "edwin" "edwinSecondary"))
	(class "Emacs"))
    (xterm-open-window display
		       (or geometry
			   (get-geometry display primary? instance class))
		       (vector #f instance class))))

(define (get-geometry display primary? instance class)
  (or (x-display-get-geometry display instance)
      (let ((geometry (x-display-get-geometry display class)))
	(and geometry
	     (if primary? geometry (strip-position-from-geometry geometry))))
      "80x40"))

(define (x-display-get-geometry display key)
  (or (x-display-get-default display key "geometry")
      (x-display-get-default display key "Geometry")))

(define (strip-position-from-geometry geometry)
  (let ((sign
	 (or (string-find-next-char geometry #\+)
	     (string-find-next-char geometry #\-))))
    (if sign
	(string-head geometry sign)
	geometry)))

(define (x-root-window-size)
  (x-display-get-size (or (get-x-display) (error "Unable to open display."))
		      0))

;;; According to the Xlib manual, we're not allowed to draw anything
;;; on the window until the first Expose event arrives.  The manual
;;; says nothing about the relationship between this event and the
;;; MapNotify event associated with that mapping.  We use the fields
;;; UNEXPOSED? and MAPPED? to track the arrival of those events.
;;; The screen's visibility remains 'UNMAPPED until both have arrived.
;;; Meanwhile, X-VISIBILITY tracks Visibility events.  When the window
;;; is both exposed and mapped, VISIBILITY reflects X-VISIBILITY.

(define (screen-x-visibility screen)
  (xterm-screen-state/x-visibility (screen-state screen)))

(define (set-screen-x-visibility! screen flag)
  (set-xterm-screen-state/x-visibility! (screen-state screen) flag)
  (update-visibility! screen))

(define (screen-mapped? screen)
  (xterm-screen-state/mapped? (screen-state screen)))

(define (set-screen-mapped?! screen flag)
  (set-xterm-screen-state/mapped?! (screen-state screen) flag)
  (update-visibility! screen))

(define (screen-unexposed? screen)
  (xterm-screen-state/unexposed? (screen-state screen)))

(define (set-screen-unexposed?! screen value)
  (set-xterm-screen-state/unexposed?! (screen-state screen) value))

(define-integrable (screen-exposed? screen)
  (not (screen-unexposed? screen)))

(define (note-xterm-exposed xterm)
  (let ((screen (xterm->screen xterm)))
    (if screen
	(let ((unexposed? (screen-unexposed? screen)))
	  (if unexposed?
	      (begin
		(set-screen-unexposed?! screen #f)
		(update-visibility! screen)
		(if (eq? 'ENTERED unexposed?)
		    (xterm-screen/enter! screen))))))))

(define (update-visibility! screen)
  (if (not (screen-deleted? screen))
      (set-screen-visibility! screen
			      (if (and (screen-mapped? screen)
				       (screen-exposed? screen))
				  (screen-x-visibility screen)
				  'UNMAPPED))))

(define (screen-xterm screen)
  (xterm-screen-state/xterm (screen-state screen)))

(define (xterm->screen xterm)
  (let loop ((screens screen-list))
    (and (not (null? screens))
	 (if (eq? xterm (screen-xterm (car screens)))
	     (car screens)
	     (loop (cdr screens))))))

(define (screen-display screen)
  (xterm-screen-state/display (screen-state screen)))

(define (screen-redisplay-flag screen)
  (xterm-screen-state/redisplay-flag (screen-state screen)))

(define (set-screen-redisplay-flag! screen flag)
  (set-xterm-screen-state/redisplay-flag! (screen-state screen) flag))

(define (screen-selected? screen)
  (xterm-screen-state/selected? (screen-state screen)))

(define (set-screen-selected?! screen selected?)
  (set-xterm-screen-state/selected?! (screen-state screen) selected?))

(define (screen-name screen)
  (xterm-screen-state/name (screen-state screen)))

(define (set-screen-name! screen name)
  (set-xterm-screen-state/name! (screen-state screen) name))

(define (xterm-screen/set-name screen name)
  (let ((name* (screen-name screen)))
    (if (or (not name*) (not (string=? name name*)))
	(begin
	  (set-screen-name! screen name)
	  (x-window-set-name (screen-xterm screen) name)))))

(define (screen-icon-name screen)
  (xterm-screen-state/icon-name (screen-state screen)))

(define (set-screen-icon-name! screen name)
  (set-xterm-screen-state/icon-name! (screen-state screen) name))

(define (xterm-screen/set-icon-name screen name)
  (let ((name* (screen-icon-name screen)))
    (if (or (not name*) (not (string=? name name*)))
	(begin
	  (set-screen-icon-name! screen name)
	  (x-window-set-icon-name (screen-xterm screen) name)))))

(define (xterm-screen/wrap-update! screen thunk)
  (let ((finished? #f))
    (dynamic-wind
     (lambda ()
       (xterm-enable-cursor (screen-xterm screen) #f))
     (lambda ()
       (let ((result (thunk)))
	 (set! finished? result)
	 result))
     (lambda ()
       (if (screen-selected? screen)
	   (let ((xterm (screen-xterm screen)))
	     (xterm-enable-cursor xterm #t)
	     (xterm-draw-cursor xterm)))
       (if (and finished? (screen-redisplay-flag screen))
	   (begin
	     (update-xterm-screen-names! screen)
	     (set-screen-redisplay-flag! screen #f)))
       (xterm-screen/flush! screen)))))

(define (xterm-screen/discard! screen)
  (set! screen-list (delq! screen screen-list))
  (x-close-window (screen-xterm screen)))

(define (xterm-screen/modeline-event! screen window type)
  window type				; ignored
  (set-screen-redisplay-flag! screen #t))

(define (xterm-screen/enter! screen)
  (if (screen-unexposed? screen)
      (set-screen-unexposed?! screen 'ENTERED)
      (begin
	(set-screen-selected?! screen #t)
	(let ((xterm (screen-xterm screen)))
	  (xterm-enable-cursor xterm #t)
	  (xterm-draw-cursor xterm))
	(xterm-screen/grab-focus! screen)
	(xterm-screen/flush! screen))))

(define (xterm-screen/grab-focus! screen)
  (and last-focus-time
       (not (screen-deleted? screen))
       (screen-mapped? screen)
       (begin
	 (x-window-set-input-focus (screen-xterm screen) last-focus-time)
	 #t)))

(define (xterm-screen/exit! screen)
  (set-screen-selected?! screen #f)
  (let ((xterm (screen-xterm screen)))
    (xterm-enable-cursor xterm #f)
    (xterm-erase-cursor xterm))
  (xterm-screen/flush! screen))

(define (xterm-screen/scroll-lines-down! screen xl xu yl yu amount)
  (xterm-scroll-lines-down (screen-xterm screen) xl xu yl yu amount)
  'UNCHANGED)

(define (xterm-screen/scroll-lines-up! screen xl xu yl yu amount)
  (xterm-scroll-lines-up (screen-xterm screen) xl xu yl yu amount)
  'UNCHANGED)

(define (xterm-screen/beep screen)
  (x-window-beep (screen-xterm screen))
  (xterm-screen/flush! screen))

(define (xterm-screen/flush! screen)
  (x-display-flush (screen-display screen)))

(define (xterm-screen/write-char! screen x y char highlight)
  (xterm-write-char! (screen-xterm screen) x y char (if highlight 1 0)))

(define (xterm-screen/write-cursor! screen x y)
  (xterm-write-cursor! (screen-xterm screen) x y))

(define (xterm-screen/write-substring! screen x y string start end highlight)
  (xterm-write-substring! (screen-xterm screen) x y string start end
			  (if highlight 1 0)))

(define (xterm-screen/clear-line! screen x y first-unused-x)
  (xterm-clear-rectangle! (screen-xterm screen)
			  x first-unused-x y (fix:1+ y) 0))

(define (xterm-screen/clear-rectangle! screen xl xu yl yu highlight)
  (xterm-clear-rectangle! (screen-xterm screen)
			  xl xu yl yu (if highlight 1 0)))

(define (xterm-screen/clear-screen! screen)
  (xterm-clear-rectangle! (screen-xterm screen)
			  0 (screen-x-size screen) 0 (screen-y-size screen) 0))

;;;; Event Handling

(define (get-xterm-input-operations)
  (let ((display x-display-data)
	(queue x-display-events)
	(pending-result #f)
	(string #f)
	(start 0)
	(end 0))
    (let ((process-key-press-event
	   (lambda (event)
	     (set! last-focus-time (vector-ref event 5))
	     (set! string (vector-ref event 2))
	     (set! end (string-length string))
	     (set! start end)
	     (cond ((fix:= end 0)
		    (x-make-special-key (vector-ref event 4)
					(vector-ref event 3)))
		   ((fix:= end 1)
		    (let ((char
			   (if (or (fix:= (vector-ref event 3) 0)
				   (fix:= (vector-ref event 3) 2))
			       (string-ref string 0)
			       (make-char (char-code (string-ref string 0))
					  (fix:andc (vector-ref event 3) 2)))))
		      (if (and signal-interrupts? (char=? char #\BEL))
			  (begin
			    (signal-interrupt!)
			    #f)
			  char)))
		   (else
		    (let ((i
			   (and signal-interrupts?
				(string-find-previous-char string #\BEL))))
		      (if i
			  (begin
			    (set! start (fix:+ i 1))
			    (signal-interrupt!)
			    (and (fix:< start end)
				 (let ((result (string-ref string start)))
				   (set! start (fix:+ start 1))
				   result)))
			  (begin
			    (set! start 1)
			    (string-ref string 0)))))))))
      (let ((process-event
	     (lambda (event)
	       (if (fix:= event-type:key-press (vector-ref event 0))
		   (process-key-press-event event)
		   (process-special-event event))))
	    (pce-event
	     (lambda (flag)
	       (make-input-event (if (eq? flag 'FORCE-RETURN) 'RETURN 'UPDATE)
				 update-screens!
				 #f))))
	(let ((get-next-event
	       (lambda (block?)
		 (let loop ()
		   (let ((event (read-event queue display block?)))
		     (cond ((or (not event) (input-event? event))
			    event)
			   ((not (vector? event))
			    (let ((flag (process-change-event event)))
			      (if flag
				  (pce-event flag)
				  (loop))))
			   (else
			    (or (process-event event)
				(loop)))))))))
	  (let ((probe
		 (lambda (block?)
		   (let ((result (get-next-event block?)))
		     (if result
			 (set! pending-result result))
		     result)))
		(guarantee-result
		 (lambda ()
		   (or (get-next-event #t)
		       (error "#F returned from blocking read")))))
	    (values
	     (lambda ()			;halt-update?
	       (or pending-result
		   (fix:< start end)
		   (probe 'IN-UPDATE)))
	     (lambda ()			;peek-no-hang
	       (or pending-result
		   (fix:< start end)
		   (probe #f)))
	     (lambda ()			;peek
	       (or pending-result
		   (if (fix:< start end)
		       (string-ref string start)
		       (let ((result (guarantee-result)))
			 (set! pending-result result)
			 result))))
	     (lambda ()			;read
	       (cond (pending-result
		      => (lambda (result)
			   (set! pending-result #f)
			   result))
		     ((fix:< start end)
		      (let ((char (string-ref string start)))
			(set! start (fix:+ start 1))
			char))
		     (else
		      (guarantee-result)))))))))))

(define (read-event queue display block?)
  (let loop ()
    (set! reading-event? #t)
    (let ((event
	   (if (queue-empty? queue)
	       (if (eq? 'IN-UPDATE block?)
		   (x-display-process-events display 2)
		   (read-event-1 display block?))
	       (dequeue!/unsafe queue))))
      (set! reading-event? #f)
      (if (and (vector? event)
	       (fix:= (vector-ref event 0) event-type:expose))
	  (begin
	    (process-expose-event event)
	    (loop))
	  (begin
	    (if (and event trace-port)
		(write-line event trace-port))
	    event)))))

(define trace-port #f)

(define (start-trace filename)
  (stop-trace)
  (set! trace-port (open-output-file filename))
  unspecific)

(define (stop-trace)
  (let ((port trace-port))
    (set! trace-port #f)
    (if port (close-port port))))

(define (process-expose-event event)
  (let ((xterm (vector-ref event 1)))
    ;; If this is the first Expose event for this window, it
    ;; requires special treatment.  Element 6 of the event
    ;; is 0 for Expose events and 1 for GraphicsExpose
    ;; events.
    (if (eq? 0 (vector-ref event 6))
	(note-xterm-exposed xterm))
    (xterm-dump-rectangle xterm
			  (vector-ref event 2)
			  (vector-ref event 3)
			  (vector-ref event 4)
			  (vector-ref event 5))))

(define (read-event-1 display block?)
  (or (x-display-process-events display 2)
      (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
			 (x-display-descriptor display)
			 block?
			 'READ)))
		   (set-interrupt-enables! interrupt-mask)
		   (case flag
		     ((#F) #f)
		     ((PROCESS-STATUS-CHANGE) event:process-status)
		     ((INTERRUPT) (loop))
		     (else (read-event-1 display block?))))))))))

(define (preview-event-stream)
  (set! previewer-registration
	(permanently-register-io-thread-event
	 (x-display-descriptor x-display-data)
	 'READ
	 (current-thread)
	 (lambda (mode)
	   mode
	   (if (not reading-event?)
	       (let ((event (x-display-process-events x-display-data 2)))
		 (if event
		     (preview-event event)))))))
  unspecific)

(define (wait-for-event interval predicate process-event)
  (let ((timeout (+ (real-time-clock) interval)))
    (fluid-let ((reading-event? #t))
      (let loop ()
	(let ((event (x-display-process-events x-display-data 2)))
	  (if event
	      (if (and (vector? event) (predicate event))
		  (or (process-event event) (loop))
		  (begin (preview-event event) (loop)))
	      (and (< (real-time-clock) timeout)
		   (loop))))))))

(define (preview-event event)
  (cond ((and signal-interrupts?
	      (vector? event)
	      (fix:= event-type:key-press (vector-ref event 0))
	      (string-find-next-char (vector-ref event 2) #\BEL))
	 (clean-event-queue x-display-events)
	 (signal-interrupt!))
	((and (vector? event)
	      (fix:= event-type:expose (vector-ref event 0)))
	 (process-expose-event event))
	((and (vector? event)
	      (or (fix:= event-type:map (vector-ref event 0))
		  (fix:= event-type:unmap (vector-ref event 0))
		  (fix:= event-type:visibility (vector-ref event 0))))
	 (let ((result (process-special-event event)))
	   (if result
	       (enqueue!/unsafe x-display-events result))))
	(else
	 (enqueue!/unsafe x-display-events 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 (vector-ref event 0)))
				  (or (fix:= type event-type:button-down)
				      (fix:= type event-type:button-up)
				      (fix:= type event-type:key-press)
				      (fix:= type event-type:motion))))
			   (loop)
			   (cons event (loop))))))
	       (cdr events)))
      ((null? events))
    (enqueue!/unsafe queue (car events))))

(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-special-event event)
  (let ((handler (vector-ref event-handlers (vector-ref event 0))))
    (and handler
	 (if (vector-ref event 1)
	     (let ((screen (xterm->screen (vector-ref event 1))))
	       (and screen
		    (handler screen event)))
	     (handler #f 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-down
  (lambda (screen event)
    (set! last-focus-time (vector-ref event 5))
    (if (eq? ignore-button-state 'IGNORE-BUTTON-DOWN)
	(begin
	  (set! ignore-button-state 'IGNORE-BUTTON-UP)
	  #f)
	(let ((xterm (screen-xterm screen)))
	  (make-input-event
	   'BUTTON
	   execute-button-command
	   screen
	   (make-down-button (vector-ref event 4))
	   (xterm-map-x-coordinate xterm (vector-ref event 2))
	   (xterm-map-y-coordinate xterm (vector-ref event 3)))))))

(define-event-handler event-type:button-up
  (lambda (screen event)
    (set! last-focus-time (vector-ref event 5))
    (if (eq? ignore-button-state 'IGNORE-BUTTON-UP)
	(begin
	  (set! ignore-button-state #f)
	  #f)
	(let ((xterm (screen-xterm screen)))
	  (make-input-event
	   'BUTTON
	   execute-button-command
	   screen
	   (make-up-button (vector-ref event 4))
	   (xterm-map-x-coordinate xterm (vector-ref event 2))
	   (xterm-map-y-coordinate xterm (vector-ref event 3)))))))

(define-event-handler event-type:configure
  (lambda (screen event)
    (make-input-event 'SET-SCREEN-SIZE
		      (lambda (screen event)
			(let ((xterm (screen-xterm screen))
			      (x-size (vector-ref event 2))
			      (y-size (vector-ref event 3)))
			  (xterm-reconfigure xterm x-size y-size)
			  (let ((x-size (xterm-map-x-size xterm x-size))
				(y-size (xterm-map-y-size xterm y-size)))
			    (if (not (and (= x-size (screen-x-size screen))
					  (= y-size (screen-y-size screen))))
				(begin
				  (set-screen-size! screen x-size y-size)
				  (update-screen! screen #t))))))
		      screen event)))

(define x-screen-ignore-focus-button? #f)

(define-event-handler event-type:focus-in
  (lambda (screen event)
    event
    (if x-screen-ignore-focus-button?
	(set! ignore-button-state 'IGNORE-BUTTON-DOWN))
    (and (not (selected-screen? screen))
	 (make-input-event 'SELECT-SCREEN
			   (lambda (screen)
			     (fluid-let ((last-focus-time #f))
			       (select-screen screen)))
			   screen))))

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

(define-event-handler event-type:map
  (lambda (screen event)
    event
    (and (not (screen-deleted? screen))
	 (begin
	   (set-screen-mapped?! screen #t)
	   (screen-force-update screen)
	   (make-input-event 'UPDATE update-screen! screen #f)))))

(define-event-handler event-type:unmap
  (lambda (screen event)
    event
    (if (not (screen-deleted? screen))
	(set-screen-mapped?! screen #f))
    #f))

(define-event-handler event-type:visibility
  (lambda (screen event)
    (and (not (screen-deleted? screen))
	 (let ((old-visibility (screen-x-visibility screen)))
	   (case (vector-ref event 2)
	     ((0) (set-screen-x-visibility! screen 'VISIBLE))
	     ((1) (set-screen-x-visibility! screen 'PARTIALLY-OBSCURED))
	     ((2) (set-screen-x-visibility! screen 'OBSCURED)))
	   (and (eq? old-visibility 'OBSCURED)
		(begin
		  (screen-force-update screen)
		  (make-input-event 'UPDATE update-screen! screen #f)))))))

(define-event-handler event-type:take-focus
  (lambda (screen event)
    (set! last-focus-time (vector-ref event 2))
    (make-input-event 'SELECT-SCREEN select-screen screen)))

;;;; Atoms

(define built-in-atoms
  '#(#F
     PRIMARY
     SECONDARY
     ARC
     ATOM
     BITMAP
     CARDINAL
     COLORMAP
     CURSOR
     CUT_BUFFER0
     CUT_BUFFER1
     CUT_BUFFER2
     CUT_BUFFER3
     CUT_BUFFER4
     CUT_BUFFER5
     CUT_BUFFER6
     CUT_BUFFER7
     DRAWABLE
     FONT
     INTEGER
     PIXMAP
     POINT
     RECTANGLE
     RESOURCE_MANAGER
     RGB_COLOR_MAP
     RGB_BEST_MAP
     RGB_BLUE_MAP
     RGB_DEFAULT_MAP
     RGB_GRAY_MAP
     RGB_GREEN_MAP
     RGB_RED_MAP
     STRING
     VISUALID
     WINDOW
     WM_COMMAND
     WM_HINTS
     WM_CLIENT_MACHINE
     WM_ICON_NAME
     WM_ICON_SIZE
     WM_NAME
     WM_NORMAL_HINTS
     WM_SIZE_HINTS
     WM_ZOOM_HINTS
     MIN_SPACE
     NORM_SPACE
     MAX_SPACE
     END_SPACE
     SUPERSCRIPT_X
     SUPERSCRIPT_Y
     SUBSCRIPT_X
     SUBSCRIPT_Y
     UNDERLINE_POSITION
     UNDERLINE_THICKNESS
     STRIKEOUT_ASCENT
     STRIKEOUT_DESCENT
     ITALIC_ANGLE
     X_HEIGHT
     QUAD_WIDTH
     WEIGHT
     POINT_SIZE
     RESOLUTION
     COPYRIGHT
     NOTICE
     FONT_NAME
     FAMILY_NAME
     FULL_NAME
     CAP_HEIGHT
     WM_CLASS
     WM_TRANSIENT_FOR))

(define (symbol->x-atom display name soft?)
  (or (hash-table/get built-in-atoms-table name #f)
      (let ((table (car (display/cached-atoms-tables display))))
	(or (hash-table/get table name #f)
	    (let ((atom
		   (x-intern-atom display
				  (string-upcase (symbol-name name))
				  soft?)))
	      (if (not (= atom 0))
		  (hash-table/put! table name atom))
	      atom)))))

(define (x-atom->symbol display atom)
  (if (< atom (vector-length built-in-atoms))
      (vector-ref built-in-atoms atom)
      (let ((table (cdr (display/cached-atoms-tables display))))
	(or (hash-table/get table atom #f)
	    (let ((symbol
		   (let ((string (x-get-atom-name display atom)))
		     (if (not (string? string))
			 (error "X error (XGetAtomName):" string atom))
		     (intern string))))
	      (hash-table/put! table atom symbol)
	      symbol)))))

(define built-in-atoms-table
  (let ((n (vector-length built-in-atoms)))
    (let ((table (make-eq-hash-table n)))
      (do ((i 0 (fix:+ i 1)))
	  ((fix:= i n))
	(hash-table/put! table (vector-ref built-in-atoms i) i))
      table)))

(define display/cached-atoms-tables
  (let ((table (make-eq-hash-table)))
    (lambda (display)
      (or (hash-table/get table display #f)
	  (let ((result (cons (make-eq-hash-table) (make-eqv-hash-table))))
	    (hash-table/put! table display result)
	    result)))))

;;;; Properties

(define (get-xterm-property xterm property type delete?)
  (get-window-property (x-window-display xterm)
		       (x-window-id xterm)
		       property
		       type
		       delete?))

(define (get-window-property display window property type delete?)
  (let ((property (symbol->x-atom display property #f))
	(type-atom (symbol->x-atom display type #f)))
    (let ((v (x-get-window-property display window property 0 0 #f type-atom)))
      (and v
	   (vector-ref v 3)
	   (let ((data
		  (get-window-property-1 display window property delete?
					 (vector-ref v 0)
					 (vector-ref v 1)
					 (vector-ref v 2))))
	     (if type
		 data
		 (cons (x-atom->symbol display (vector-ref v 0))
		       data)))))))

(define (get-window-property-1 display window property delete?
			       type format bytes)
  (let ((read-once
	 (lambda (offset bytes n delete?)
	   (let ((v
		  (x-get-window-property display window property
					 (quotient offset 4)
					 (integer-ceiling n 4)
					 delete? type)))
	     (if (not (and v
			   (= type (vector-ref v 0))
			   (= format (vector-ref v 1))
			   (= (- bytes n) (vector-ref v 2))
			   (vector-ref v 3)
			   (= n
			      (if (= format 8)
				  (string-length (vector-ref v 3))
				  (* (vector-length (vector-ref v 3))
				     (quotient format 8))))))
		 (error "Window property changed:" v))
	     (vector-ref v 3))))
	(qb (* (property-quantum display) 4)))
    (if (<= bytes qb)
	(read-once 0 bytes bytes delete?)
	(let ((b/w (quotient format 8)))
	  (let ((result
		 (if (= b/w 1)
		     (make-string bytes)
		     (make-vector (quotient bytes b/w))))
		(move!
		 (if (= b/w 1)
		     substring-move-right!
		     subvector-move-right!)))
	    (let loop ((offset 0) (bytes bytes))
	      (if (<= bytes qb)
		  (move! (read-once offset bytes bytes delete?)
			 0 (quotient bytes b/w)
			 result (quotient offset b/w))
		  (begin
		    (move! (read-once offset bytes qb #f) 0 (quotient qb b/w)
			   result (quotient offset b/w))
		    (loop (+ offset qb) (- bytes qb)))))
	    result)))))

(define (put-window-property display window property type format data)
  (let ((put-1
	 (let ((property (symbol->x-atom display property #f))
	       (type (symbol->x-atom display type #f)))
	   (lambda (mode data)
	     (let ((status
		    (x-change-property display window property type format
				       mode data)))
	       (cond ((= status x-status:success)
		      #t)
		     ((= status x-status:bad-alloc)
		      (x-delete-property display window property)
		      #f)
		     (else
		      (error "X error (XChangeProperty):" status)))))))
	(qw (property-quantum display))
	(i/w (quotient 32 format))
	(subpart (if (= format 8) substring subvector))
	(end (if (= format 8) (string-length data) (vector-length data)))
	(mode:replace 0)
	(mode:append 2))
    (let loop ((start 0) (nw (integer-ceiling end i/w)) (mode mode:replace))
      (if (<= nw qw)
	  (put-1 mode (if (= start 0) data (subpart data start end)))
	  (let ((end (+ start (* qw i/w))))
	    (and (put-1 mode (subpart data start end))
		 (loop end (- nw qw) mode:append)))))))

(define (property-quantum display)
  ;; The limit on the size of a property quantum is the maximum
  ;; request size less the size of the largest header needed.  The
  ;; relevant packets are the GetProperty reply packet (header size 8)
  ;; and the ChangeProperty request packet (header size 6).  The magic
  ;; number 8 is the larger of these two header sizes.
  (fix:- (x-max-request-size display) 8))

(define (delete-xterm-property xterm property)
  (delete-window-property (x-window-display xterm)
			  (x-window-id xterm)
			  property))

(define (delete-window-property display window property)
  (x-delete-property display window (symbol->x-atom display property #f)))

(define-integrable x-status:success		0)
(define-integrable x-status:bad-request		1)
(define-integrable x-status:bad-value		2)
(define-integrable x-status:bad-window		3)
(define-integrable x-status:bad-pixmap		4)
(define-integrable x-status:bad-atom		5)
(define-integrable x-status:bad-cursor		6)
(define-integrable x-status:bad-font		7)
(define-integrable x-status:bad-match		8)
(define-integrable x-status:bad-drawable	9)
(define-integrable x-status:bad-access		10)
(define-integrable x-status:bad-alloc		11)
(define-integrable x-status:bad-color		12)
(define-integrable x-status:bad-gc		13)
(define-integrable x-status:bad-id-choice	14)
(define-integrable x-status:bad-name		15)
(define-integrable x-status:bad-length		16)
(define-integrable x-status:bad-implementation	17)

;;;; Selection Source

(define-variable x-cut-to-clipboard
  "If true, cutting text copies to the clipboard.
In either case, it is copied to the primary selection."
  #t
  boolean?)

(define (os/interprogram-cut string context)
  (if (eq? x-display-type (current-display-type))
      (let ((xterm (screen-xterm (selected-screen))))
	(let ((own-selection
	       (lambda (selection)
		 (own-selection (x-window-display xterm)
				selection
				(x-window-id xterm)
				last-focus-time
				string))))
	  (own-selection 'PRIMARY)
	  (if (ref-variable x-cut-to-clipboard context)
	      (own-selection 'CLIPBOARD))))))

(define (own-selection display selection window time value)
  (and (eqv? window
	     (let ((selection (symbol->x-atom display selection #f)))
	       (x-set-selection-owner display selection window time)
	       (x-get-selection-owner display selection)))
       (begin
	 (hash-table/put! (display/selection-records display)
			  selection
			  (make-selection-record window time value))
	 #t)))

(define display/selection-records
  (let ((table (make-eq-hash-table)))
    (lambda (display)
      (or (hash-table/get table display #f)
	  (let ((result (make-eq-hash-table)))
	    (hash-table/put! table display result)
	    result)))))

;;; In the next two procedures, we must allow TIME to be 0, even
;;; though the ICCCM forbids this, because existing clients use that
;;; value.  An example of a broken client is GTK+ version 1.2.6.

(define (display/selection-record display name time)
  (let ((record (hash-table/get (display/selection-records display) name #f)))
    (and record
	 (or (= 0 time) (<= (selection-record/time record) time))
	 record)))

(define (display/delete-selection-record! display name time)
  (let ((records (display/selection-records display)))
    (if (let ((record (hash-table/get records name #f)))
	  (and record
	       (or (= 0 time) (<= (selection-record/time record) time))))
	(hash-table/remove! records name))))

(define-structure (selection-record (conc-name selection-record/))
  (window #f read-only #t)
  (time #f read-only #t)
  (value #f read-only #t))

(define-event-handler event-type:selection-request
  (lambda (screen event)
    screen
    (let ((display x-display-data))
      (let ((requestor (selection-request/requestor event))
	    (selection
	     (x-atom->symbol display (selection-request/selection event)))
	    (target
	     (x-atom->symbol display (selection-request/target event)))
	    (property
	     (x-atom->symbol display (selection-request/property event)))
	    (time (selection-request/time event)))
	(let ((reply
	       (lambda (property)
		 (x-send-selection-notify display
					  requestor
					  (selection-request/selection event)
					  (selection-request/target event)
					  (symbol->x-atom display property #f)
					  time)
		 (x-display-flush display))))
	  (if (let ((record (display/selection-record display selection time)))
		(and record
		     property
		     (process-selection-request display requestor property
						target time record #f)))
	      (reply property)
	      (reply #f)))))
    #f))

(define-structure (selection-request (type vector)
				     (initial-offset 2)
				     (conc-name selection-request/))
  (requestor #f read-only #t)
  (selection #f read-only #t)
  (target #f read-only #t)
  (property #f read-only #t)
  (time #f read-only #t))

(define-event-handler event-type:selection-clear
  (lambda (screen event)
    screen
    (let ((display x-display-data))
      (display/delete-selection-record!
       display
       (x-atom->symbol display (selection-clear/selection event))
       (selection-clear/time event)))
    #f))

(define-structure (selection-clear (type vector)
				   (initial-offset 2)
				   (conc-name selection-clear/))
  (selection #f read-only #t)
  (time #f read-only #t))

(define (process-selection-request display requestor property target time
				   record multiple?)
  (let ((win
	 (lambda (format data)
	   (and (put-window-property display requestor property target format
				     data)
		target))))
    (case target
      ((STRING)
       (win 8 (selection-record/value record)))
      ((TARGETS)
       (win 32 (atoms->property-data '(STRING TIMESTAMP) display)))
      ((TIMESTAMP)
       (win 32 (timestamp->property-data (selection-record/time record))))
      ((MULTIPLE)
       (and multiple?
	    (let ((alist
		   (property-data->atom-alist
		    (or (get-window-property display requestor property
					     'MULTIPLE #f)
			(error "Missing MULTIPLE property:" property))
		    display)))
	      (for-each (lambda (entry)
			  (set-car! entry
				    (process-selection-request display
							       requestor
							       (cdr entry)
							       (car entry)
							       time
							       record
							       #t)))
			alist)
	      (win 32 (atom-alist->property-data alist display)))))
      (else #f))))

(define (atoms->property-data names display)
  (list->vector (map (lambda (name) (symbol->x-atom display name #f)) names)))

(define (timestamp->property-data time)
  (vector time))

(define (property-data->atom-alist data display)
  (if (not (even? (vector-length data)))
      (error:bad-range-argument data 'PROPERTY-DATA->ATOM-ALIST))
  (let loop ((atoms
	      (map (lambda (atom) (x-atom->symbol display atom))
		   (vector->list data))))
    (if (null? atoms)
	'()
	(cons (cons (car atoms) (cadr atoms))
	      (loop (cddr atoms))))))

(define (atom-alist->property-data alist display)
  (atoms->property-data (let loop ((alist alist))
			  (if (null? alist)
			      '()
			      (cons (caar alist)
				    (cons (cdar alist)
					  (loop (cdr alist))))))
			display))

;;;; Selection Sink

(define-variable x-paste-from-clipboard
  "If true, pasting text copies from the clipboard.
Otherwise, it is copied from the primary selection."
  #t
  boolean?)

(define (os/interprogram-paste context)
  (and (eq? x-display-type (current-display-type))
       (xterm/interprogram-paste (screen-xterm (selected-screen)) context)))

(define (xterm/interprogram-paste xterm context)
  (or (and (ref-variable x-paste-from-clipboard context)
	   (xterm/interprogram-paste-1 xterm 'CLIPBOARD))
      (xterm/interprogram-paste-1 xterm 'PRIMARY)))

(define (xterm/interprogram-paste-1 xterm selection)
  (with-thread-events-blocked
   (lambda ()
     (let ((property '_EDWIN_TMP_)
	   (time last-focus-time))
       (cond ((display/selection-record (x-window-display xterm)
					selection time)
	      => selection-record/value)
	     ((request-selection xterm selection 'STRING property time)
	      (receive-selection xterm property 'STRING time))
	     ((request-selection xterm selection 'C_STRING property time)
	      (receive-selection xterm property 'C_STRING time))
	     (else #f))))))

(define (request-selection xterm selection target property time)
  (let ((display (x-window-display xterm))
	(window (x-window-id xterm)))
    (let ((selection (symbol->x-atom display selection #f))
	  (target (symbol->x-atom display target #f))
	  (property (symbol->x-atom display property #f)))
      (x-delete-property display window property)
      (x-convert-selection display selection target property window time)
      (x-display-flush display)
      (eq? 'REQUEST-GRANTED
	   (wait-for-event x-selection-timeout
	     (lambda (event)
	       (fix:= event-type:selection-notify (vector-ref event 0)))
	     (lambda (event)
	       (and (= window (selection-notify/requestor event))
		    (= selection (selection-notify/selection event))
		    (= target (selection-notify/target event))
		    (= time (selection-notify/time event))
		    (if (= property (selection-notify/property event))
			'REQUEST-GRANTED
			'REQUEST-DENIED))))))))

(define-structure (selection-notify (type vector)
				    (initial-offset 2)
				    (conc-name selection-notify/))
  (requestor #f read-only #t)
  (selection #f read-only #t)
  (target #f read-only #t)
  (property #f read-only #t)
  (time #f read-only #t))

(define (receive-selection xterm property target time)
  (let ((value (get-xterm-property xterm property #f #t)))
    (if (not value)
	(error "Missing selection value."))
    (if (eq? 'INCR (car value))
	(receive-incremental-selection xterm property target time)
	(and (eq? target (car value))
	     (cdr value)))))

(define (receive-incremental-selection xterm property target time)
  ;; I have been unable to get this to work, after a day of hacking,
  ;; and I don't have any idea why it won't work.  Given that this
  ;; will only be used for selections of size exceeding ~230kb, I'm
  ;; going to leave it broken.  -- cph
  (x-window-flush xterm)
  (let loop ((time time) (accum '()))
    (let ((time
	   (wait-for-window-property-change xterm property time
					    x-property-state:new-value)))
      (if (not time)
	  (error "Timeout waiting for PROPERTY-NOTIFY event."))
      (let ((value (get-xterm-property xterm property target #t)))
	(if (not value)
	    (error "Missing property after PROPERTY-NOTIFY event."))
	(if (string-null? value)
	    (apply string-append (reverse! accum))
	    (loop time (cons value accum)))))))

(define (wait-for-window-property-change xterm property time state)
  (wait-for-event x-selection-timeout
    (lambda (event)
      (fix:= event-type:property-notify (vector-ref event 0)))
    (let ((property (symbol->x-atom (x-window-display xterm) property #f))
	  (window (x-window-id xterm)))
      (lambda (event)
	(and (= window (property-notify/window event))
	     (= property (property-notify/property event))
	     (< time (property-notify/time event))
	     (= state (property-notify/state event))
	     (property-notify/time event))))))

(define-structure (property-notify (type vector)
				   (initial-offset 2)
				   (conc-name property-notify/))
  (window #f read-only #t)
  (property #f read-only #t)
  (time #f read-only #t)
  (state #f read-only #t))

(define-integrable x-property-state:new-value 0)
(define-integrable x-property-state:delete 1)

(define x-selection-timeout 5000)

;;;; Initialization

(define reading-event?)
(define signal-interrupts?)
(define last-focus-time)
(define previewer-registration)
(define ignore-button-state)

(define (with-editor-interrupts-from-x receiver)
  (fluid-let ((reading-event? #f)
	      (signal-interrupts? #t)
	      (last-focus-time #f)
	      (previewer-registration)
	      (ignore-button-state #f))
    (dynamic-wind
     preview-event-stream
     (lambda () (receiver (lambda (thunk) (thunk)) '()))
     (lambda ()
       (deregister-io-thread-event previewer-registration)))))

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

(define (with-x-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 (signal-interrupt!)
  (editor-beep)
  (temporary-message "Quit")
  (^G-signal))

(define x-display-type)
(define x-display-data)
(define x-display-events)
(define x-display-name #f)

(define (get-x-display)
  ;; X-OPEN-DISPLAY hangs, uninterruptibly, when the X server is
  ;; running the login loop of xdm.  Can this be fixed?
  (or x-display-data
      (and (implemented-primitive-procedure? x-open-display)
	   (or x-display-name (get-environment-variable "DISPLAY"))
	   (let ((display (x-open-display x-display-name)))
	     (set! x-display-data display)
	     (set! x-display-events (make-queue))
	     display))))

(define (initialize-package!)
  (set! screen-list '())
  (set! x-display-type
	(make-display-type 'X
			   #t
			   get-x-display
			   make-xterm-screen
			   (lambda (screen)
			     screen	;ignore
			     (get-xterm-input-operations))
			   with-editor-interrupts-from-x
			   with-x-interrupts-enabled
			   with-x-interrupts-disabled))
  (set! x-display-data #f)
  (set! x-display-events)
  unspecific)