Skip to content
Snippets Groups Projects
input.lisp 72.5 KiB
Newer Older
dan's avatar
dan committed
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-

;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11

;;;
;;;			 TEXAS INSTRUMENTS INCORPORATED
;;;				  P.O. BOX 2909
;;;			       AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;

;;;
;;; Change history:
;;;
;;;  Date	Author	Description
;;; -------------------------------------------------------------------------------------
;;; 12/10/87	LGO	Created

(in-package :xlib)

;; Event Resource
(defvar *event-free-list* nil) ;; List of unused (processed) events

csr21's avatar
csr21 committed
(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; Maximum number of events supported (the X11 alpha release only has 34)
  (defconstant +max-events+ 64) 
  (defvar *event-key-vector* (make-array +max-events+ :initial-element nil)
    "Vector of event keys - See define-event"))

csr21's avatar
csr21 committed
(defvar *event-macro-vector* (make-array +max-events+ :initial-element nil)
dan's avatar
dan committed
  "Vector of event handler functions - See declare-event")
csr21's avatar
csr21 committed
(defvar *event-handler-vector* (make-array +max-events+ :initial-element nil)
dan's avatar
dan committed
  "Vector of event handler functions - See declare-event")
csr21's avatar
csr21 committed
(defvar *event-send-vector* (make-array +max-events+ :initial-element nil)
dan's avatar
dan committed
  "Vector of event sending functions - See declare-event")

(defun allocate-event ()
  (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer)
csr21's avatar
csr21 committed
      (make-reply-buffer +replysize+)))
dan's avatar
dan committed

(defun deallocate-event (reply-buffer)
  (declare (type reply-buffer reply-buffer))
csr21's avatar
csr21 committed
  (setf (reply-size reply-buffer) +replysize+)
dan's avatar
dan committed
  (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer))

;; Extensions are handled as follows:
;; DEFINITION:	Use DEFINE-EXTENSION
;;
;; CODE:	Use EXTENSION-CODE to get the X11 opcode for an extension.
;;		This looks up the code on the display-extension-alist.
;;
;; EVENTS:	Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE
;;		at LOAD time to define an internal event-code number
;;		(stored in the 'event-code property of the event-name)
;;		used to index the following vectors:
;;		*event-key-vector* 	Used for getting the event-key
;;		*event-macro-vector*	Used for getting the event-parameter getting macros
;;
;;		The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert
;;		a server event-code into an internal event-code used to index the following
;;		vectors:
;;		*event-handler-vector*	Used for getting the event-handler function
;;		*event-send-vector*	Used for getting the event-sending function
;;
;;		The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert
;;		internal event-codes to external (server) codes.
;;
;; ERRORS:	Use DEFINE-ERROR to define new error decodings.
;;


;; Any event-code greater than 34 is for an extension
(defparameter *first-extension-event-code* 35)

(defvar *extensions* nil) ;; alist of (extension-name-symbol events errors)

(defmacro define-extension (name &key events errors)
  ;; Define extension NAME with EVENTS and ERRORS.
  ;; Note: The case of NAME is important.
  ;; To define the request, Use:
  ;;     (with-buffer-request (display (extension-opcode ,name)) ,@body)
  ;;     See the REQUESTS file for lots of examples.
  ;; To define event handlers, use declare-event.
  ;; To define error handlers, use declare-error and define-condition.
  (declare (type stringable name)
	   (type list events errors))
  (let ((name-symbol (kintern name)) ;; Intern name in the keyword package
	(event-list (mapcar #'canonicalize-event-name events)))
csr21's avatar
csr21 committed
    `(eval-when (:compile-toplevel :load-toplevel :execute)
dan's avatar
dan committed
       (setq *extensions* (cons (list ',name-symbol ',event-list ',errors)
				(delete ',name-symbol *extensions* :key #'car))))))

csr21's avatar
csr21 committed
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun canonicalize-event-name (event)
    ;; Returns the event name keyword given an event name stringable
    (declare (type stringable event))
    (declare (clx-values event-key))
    (kintern event)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun allocate-extension-event-code (name)
    ;; Allocate an event-code for an extension.  This is executed at
    ;; COMPILE and LOAD time from DECLARE-EVENT.  The event-code is
    ;; used at compile-time by macros to index the following vectors:
    ;; *EVENT-KEY-VECTOR* *EVENT-MACRO-VECTOR* *EVENT-HANDLER-VECTOR*
    ;; *EVENT-SEND-VECTOR*
    (let ((event-code (get name 'event-code)))
      (declare (type (or null card8) event-code))
      (unless event-code
	;; First ensure the name is for a declared extension
	(unless (dolist (extension *extensions*)
		  (when (member name (second extension))
		    (return t)))
	  (x-type-error name 'event-key))
	(setq event-code (position nil *event-key-vector*
				   :start *first-extension-event-code*))
	(setf (svref *event-key-vector* event-code) name)
	(setf (get name 'event-code) event-code))
      event-code)))
dan's avatar
dan committed

(defun get-internal-event-code (display code)
  ;; Given an X11 event-code, return the internal event-code.
  ;; The internal event-code is used for indexing into the following vectors:
  ;; *event-key-vector* *event-handler-vector* *event-send-vector*
  ;; Returns NIL when the event-code is for an extension that isn't handled.
  (declare (type display display)
	   (type card8 code))
  (declare (clx-values (or null card8)))
  (setq code (logand #x7f code))
  (if (< code *first-extension-event-code*)
      code
    (let* ((code-offset (- code *first-extension-event-code*))
	   (event-extensions (display-event-extensions display))
	   (code (if (< code-offset (length event-extensions))
		     (aref event-extensions code-offset)
		   0)))
      (declare (type card8 code-offset code))
      (when (zerop code)
	(x-cerror "Ignore the event"
		  'unimplemented-event :event-code code :display display))
      code)))

(defun get-external-event-code (display event)
  ;; Given an X11 event name, return the event-code
  (declare (type display display)
	   (type event-key event))
  (declare (clx-values card8))
  (let ((code (get-event-code event)))
    (declare (type (or null card8) code))
    (when (>= code *first-extension-event-code*)
      (setq code (+ *first-extension-event-code*
		    (or (position code (display-event-extensions display))
			(x-error 'undefined-event :display display :event-name event)))))
    code))

(defmacro extension-opcode (display name)
  ;; Returns the major opcode for extension NAME.
  ;; This is a macro to enable NAME to be interned for fast run-time
  ;; retrieval. 
  ;; Note: The case of NAME is important.
  (let ((name-symbol (kintern name))) ;; Intern name in the keyword package
    `(or (second (assoc ',name-symbol (display-extension-alist ,display)))
	 (x-error 'absent-extension :name ',name-symbol :display ,display))))

(defun initialize-extensions (display)
  ;; Initialize extensions for DISPLAY
  (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0))
	(extension-alist nil))
    (declare (type vector event-extensions)
	     (type list extension-alist))
    (dolist (extension *extensions*)
      (let ((name (first extension))
	    (events (second extension)))
	(declare (type keyword name)
		 (type list events))
	(multiple-value-bind (major-opcode first-event first-error)
	    (query-extension display name)
	  (declare (type (or null card8) major-opcode first-event first-error))
	  (when (and major-opcode (plusp major-opcode))
	    (push (list name major-opcode first-event first-error)
		  extension-alist)
	    (when (plusp first-event) ;; When there are extension events
	      ;; Grow extension vector when needed
	      (let ((max-event (- (+ first-event (length events))
				  *first-extension-event-code*)))
		(declare (type card8 max-event))
		(when (>= max-event (length event-extensions))
		  (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8
						    :initial-element 0)))
		    (declare (type vector new-extensions))
		    (replace new-extensions event-extensions)
		    (setq event-extensions new-extensions))))
	      (dolist (event events)
		(declare (type symbol event))
		(setf (aref event-extensions (- first-event *first-extension-event-code*))
		      (get-event-code event))
		(incf first-event)))))))
    (setf (display-event-extensions display) event-extensions)
    (setf (display-extension-alist display) extension-alist)))

;;
;; Reply handlers
;;

(defvar *pending-command-free-list* nil)

(defun start-pending-command (display)
  (declare (type display display))
  (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list*
						  pending-command-next pending-command)
			     (make-pending-command))))
    (declare (type pending-command pending-command))
    (setf (pending-command-reply-buffer pending-command) nil)
    (setf (pending-command-process pending-command) (current-process))
    (setf (pending-command-sequence pending-command)
	  (ldb (byte 16 0) (1+ (buffer-request-number display))))
    ;; Add the pending command to the end of the threaded list of pending
    ;; commands for the display.
    (with-event-queue-internal (display)
      (threaded-nconc pending-command (display-pending-commands display)
		      pending-command-next pending-command))
    pending-command))

(defun stop-pending-command (display pending-command)
  (declare (type display display)
	   (type pending-command pending-command))
  (with-event-queue-internal (display)
    ;; Remove the pending command from the threaded list of pending commands
    ;; for the display.
    (threaded-delete pending-command (display-pending-commands display)
		     pending-command-next pending-command)
    ;; Deallocate any reply buffers in this pending command
    (loop
      (let ((reply-buffer
	      (threaded-pop (pending-command-reply-buffer pending-command)
			    reply-next reply-buffer)))
	(declare (type (or null reply-buffer) reply-buffer))
	(if reply-buffer
	    (deallocate-reply-buffer reply-buffer)
	  (return nil)))))
  ;; Clear pointers to help the Garbage Collector
  (setf (pending-command-process pending-command) nil)
  ;; Deallocate this pending-command
  (threaded-atomic-push pending-command *pending-command-free-list*
			pending-command-next pending-command)
  nil)

;;;

(defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil))

(defun allocate-reply-buffer (size)
  (declare (type array-index size))
csr21's avatar
csr21 committed
  (if (index<= size +replysize+)
dan's avatar
dan committed
      (allocate-event)
    (let ((index (integer-length (index1- size))))
      (declare (type array-index index))
      (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index)
			       reply-next reply-buffer)
	  (make-reply-buffer (index-ash 1 index))))))

(defun deallocate-reply-buffer (reply-buffer)
  (declare (type reply-buffer reply-buffer))
  (let ((size (reply-size reply-buffer)))
    (declare (type array-index size))
csr21's avatar
csr21 committed
    (if (index<= size +replysize+)
dan's avatar
dan committed
	(deallocate-event reply-buffer)
      (let ((index (integer-length (index1- size))))
	(declare (type array-index index))
	(threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index)
			      reply-next reply-buffer)))))

;;;

(defun read-error-input (display sequence reply-buffer token)
  (declare (type display display)
	   (type reply-buffer reply-buffer)
	   (type card16 sequence))
  (tagbody
    start
       (with-event-queue-internal (display)
	 (let ((command 
		 ;; Find any pending command with this sequence number.
		 (threaded-dolist (pending-command (display-pending-commands display)
						   pending-command-next pending-command)
		   (when (= (pending-command-sequence pending-command) sequence)
		     (return pending-command)))))
	   (declare (type (or null pending-command) command))
	   (cond ((not (null command))
		  ;; Give this reply to the pending command
		  (threaded-nconc reply-buffer (pending-command-reply-buffer command)
				  reply-next reply-buffer)
		  (process-wakeup (pending-command-process command)))
		 ((member :immediately (display-report-asynchronous-errors display))
		  ;; No pending command and we should report the error immediately
		  (go report-error))
		 (t
		  ;; No pending command found, count this as an asynchronous error
		  (threaded-nconc reply-buffer (display-asynchronous-errors display)
				  reply-next reply-buffer)))))
       (return-from read-error-input nil)
    report-error
       (note-input-complete display token)
       (apply #'report-error display
	      (prog1 (make-error display reply-buffer t)
		     (deallocate-event reply-buffer)))))

(defun read-reply-input (display sequence length reply-buffer)
  (declare (type display display)
	   (type (or null reply-buffer) reply-buffer)
	   (type card16 sequence)
	   (type array-index length))
  (unwind-protect 
      (progn
csr21's avatar
csr21 committed
	(when (index< +replysize+ length)
dan's avatar
dan committed
	  (let ((repbuf nil))
	    (declare (type (or null reply-buffer) repbuf))
	    (unwind-protect
		(progn
		  (setq repbuf (allocate-reply-buffer length))
		  (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer)
csr21's avatar
csr21 committed
				  0 +replysize+)
dan's avatar
dan committed
		  (deallocate-event (shiftf reply-buffer repbuf nil)))
	      (when repbuf
		(deallocate-reply-buffer repbuf))))
csr21's avatar
csr21 committed
	  (when (buffer-input display (reply-ibuf8 reply-buffer) +replysize+ length)
dan's avatar
dan committed
	    (return-from read-reply-input t))
	  (setf (reply-data-size reply-buffer) length))
	(with-event-queue-internal (display)
	  ;; Find any pending command with this sequence number.
	  (let ((command 
		  (threaded-dolist (pending-command (display-pending-commands display)
						    pending-command-next pending-command)
		    (when (= (pending-command-sequence pending-command) sequence)
		      (return pending-command)))))
	    (declare (type (or null pending-command) command))
	    (when command 
	      ;; Give this reply to the pending command
	      (threaded-nconc (shiftf reply-buffer nil)
			      (pending-command-reply-buffer command)
			      reply-next reply-buffer)
	      (process-wakeup (pending-command-process command)))))
	nil)
    (when reply-buffer
      (deallocate-reply-buffer reply-buffer))))

(defun read-event-input (display code reply-buffer)
  (declare (type display display)
	   (type card8 code)
	   (type reply-buffer reply-buffer))
  ;; Push the event in the input buffer on the display's event queue
  (setf (event-code reply-buffer)
	(get-internal-event-code display code))
  (enqueue-event reply-buffer display)
  nil)

(defun note-input-complete (display token)
  (declare (type display display))
  (when (eq (display-input-in-progress display) token)
    ;; Indicate that input is no longer in progress
    (setf (display-input-in-progress display) nil)
    ;; Let the event process get the first chance to do input
    (let ((process (display-event-process display)))
      (when (not (null process))
	(process-wakeup process)))
    ;; Then give processes waiting for command responses a chance
    (unless (display-input-in-progress display)
      (with-event-queue-internal (display)
	(threaded-dolist (command (display-pending-commands display)
				  pending-command-next pending-command)
	  (process-wakeup (pending-command-process command)))))))

(defun read-input (display timeout force-output-p predicate &rest predicate-args)
  (declare (type display display)
	   (type (or null number) timeout)
	   (type generalized-boolean force-output-p)
	   (dynamic-extent predicate-args))
  (declare (type function predicate)
	   #+clx-ansi-common-lisp
	   (dynamic-extent predicate)
	   #+(and lispm (not clx-ansi-common-lisp))
	   (sys:downward-funarg predicate))
  (let ((reply-buffer nil)
	(token (or (current-process) (cons nil nil))))
    (declare (type (or null reply-buffer) reply-buffer))
    (unwind-protect 
	(tagbody
	  loop
	     (when (display-dead display)
	       (x-error 'closed-display :display display))
	     (when (apply predicate predicate-args)
	       (return-from read-input nil))
	     ;; Check and see if we have to force output
	     (when (and force-output-p
			(or (and (not (eq (display-input-in-progress display) token))
				 (not (conditional-store
					(display-input-in-progress display) nil token)))
			    (null (buffer-listen display))))
	       (go force-output))
	   ;; Ensure that only one process is reading input.
	   (unless (or (eq (display-input-in-progress display) token)
		       (conditional-store (display-input-in-progress display) nil token))
	     (if (eql timeout 0)
		 (return-from read-input :timeout)
dan's avatar
dan committed
		 (apply #'process-block "CLX Input Lock"
			#'(lambda (display predicate &rest predicate-args)
			    (declare (type display display)
				     (dynamic-extent predicate-args)
				     (type function predicate)
				     #+clx-ansi-common-lisp
				     (dynamic-extent predicate)
				     #+(and lispm (not clx-ansi-common-lisp))
				     (sys:downward-funarg predicate))
			    (or (apply predicate predicate-args)
				(null (display-input-in-progress display))
				(not (null (display-dead display)))))
			display predicate predicate-args))
	       (go loop))
	     ;; Now start gobbling.
	     (setq reply-buffer (allocate-event))
	     (with-buffer-input (reply-buffer :sizes (8 16 32))
	       (let ((type 0))
		 (declare (type card8 type))
		 ;; Wait for input before we disallow aborts.
		 (unless (eql timeout 0)
		   (let ((eof-p (buffer-input-wait display timeout)))
		     (when eof-p (return-from read-input eof-p))))
		 (without-aborts
csr21's avatar
csr21 committed
		   (let ((eof-p (buffer-input display buffer-bbuf 0 +replysize+
dan's avatar
dan committed
					      (if force-output-p 0 timeout))))
		     (when eof-p
		       (when (eq eof-p :timeout)
			 (if force-output-p
			     (go force-output)
			   (return-from read-input :timeout)))
		       (setf (display-dead display) t)
		       (return-from read-input eof-p)))
csr21's avatar
csr21 committed
		   (setf (reply-data-size reply-buffer) +replysize+)
dan's avatar
dan committed
		   (when (= (the card8 (setq type (read-card8 0))) 1)
csr21's avatar
csr21 committed
		     ;; Normal replies can be longer than +replysize+, so we
dan's avatar
dan committed
		     ;; have to handle them while aborts are still disallowed.
		     (let ((value
			     (read-reply-input
			       display (read-card16 2)
csr21's avatar
csr21 committed
			       (index+ +replysize+ (index* (read-card32 4) 4))
dan's avatar
dan committed
			       (shiftf reply-buffer nil))))
		       (when value
			 (return-from read-input value))
		       (go loop))))
		 (if (zerop type)
		     (read-error-input
		       display (read-card16 2) (shiftf reply-buffer nil) token)
		   (read-event-input
		     display (read-card8 0) (shiftf reply-buffer nil)))))
	     (go loop)
	  force-output 
	     (note-input-complete display token)
	     (display-force-output display)
	     (setq force-output-p nil)
	     (go loop))
      (when (not (null reply-buffer))
	(deallocate-reply-buffer reply-buffer))
      (note-input-complete display token))))

(defun report-asynchronous-errors (display mode)
  (when (and (display-asynchronous-errors display)
	     (member mode (display-report-asynchronous-errors display)))
    (let ((aborted t))
      (unwind-protect 
	  (loop
	    (let ((error
		    (with-event-queue-internal (display)
		      (threaded-pop (display-asynchronous-errors display)
				    reply-next reply-buffer))))
	      (declare (type (or null reply-buffer) error))
	      (if error
		  (apply #'report-error display
			 (prog1 (make-error display error t)
				(deallocate-event error)))
		(return (setq aborted nil)))))
	;; If we get aborted out of this, deallocate all outstanding asynchronous
	;; errors.
	(when aborted 
	  (with-event-queue-internal (display)
	    (loop
	      (let ((reply-buffer
		      (threaded-pop (display-asynchronous-errors display)
				    reply-next reply-buffer)))
		(declare (type (or null reply-buffer) reply-buffer))
		(if reply-buffer
		    (deallocate-event reply-buffer)
		  (return nil))))))))))

(defun wait-for-event (display timeout force-output-p)
  (declare (type display display)
	   (type (or null number) timeout)
	   (type generalized-boolean force-output-p))
  (let ((event-process-p (not (eql timeout 0))))
    (declare (type generalized-boolean event-process-p))
    (unwind-protect
	(loop
	  (when event-process-p
	    (conditional-store (display-event-process display) nil (current-process)))
	  (let ((eof (read-input
		       display timeout force-output-p 
		       #'(lambda (display)
			   (declare (type display display))
			   (or (not (null (display-new-events display)))
			       (and (display-asynchronous-errors display)
				    (member :before-event-handling
					    (display-report-asynchronous-errors display))
				    t)))
		       display)))
	    (when eof (return eof)))
	  ;; Report asynchronous errors here if the user wants us to.
	  (when event-process-p
	    (report-asynchronous-errors display :before-event-handling))
	  (when (not (null (display-new-events display)))
	    (return nil)))
      (when (and event-process-p
		 (eq (display-event-process display) (current-process)))
	(setf (display-event-process display) nil)))))

(defun read-reply (display pending-command)
  (declare (type display display)
	   (type pending-command pending-command))
  (loop
    (when (read-input display nil nil
		      #'(lambda (pending-command)
			  (declare (type pending-command pending-command))
			  (not (null (pending-command-reply-buffer pending-command))))
		      pending-command)
      (x-error 'closed-display :display display))
    (let ((reply-buffer
	    (with-event-queue-internal (display)
	      (threaded-pop (pending-command-reply-buffer pending-command)
			    reply-next reply-buffer))))
      (declare (type reply-buffer reply-buffer))
      ;; Check for error.
      (with-buffer-input (reply-buffer)
	(ecase (read-card8 0)
	  (0 (apply #'report-error display
		    (prog1 (make-error display reply-buffer nil)
			   (deallocate-reply-buffer reply-buffer))))
	  (1 (return reply-buffer)))))))

;;;

(defun event-listen (display &optional (timeout 0))
  (declare (type display display)
	   (type (or null number) timeout)
	   (clx-values number-of-events-queued eof-or-timeout))
  ;; Returns the number of events queued locally, if any, else nil.  Hangs
  ;; waiting for events, forever if timeout is nil, else for the specified
  ;; number of seconds.
  (let* ((current-event-symbol (car (display-current-event-symbol display)))
	 (current-event (and (boundp current-event-symbol)
			     (symbol-value current-event-symbol)))
	 (queue (if current-event
		    (reply-next (the reply-buffer current-event))
		  (display-event-queue-head display))))
    (declare (type symbol current-event-symbol)
	     (type (or null reply-buffer) current-event queue))
    (if queue
	(values
	  (with-event-queue-internal (display :timeout timeout)
	    (threaded-length queue reply-next reply-buffer))
	  nil)
      (with-event-queue (display :timeout timeout :inline t)
	(let ((eof-or-timeout (wait-for-event display timeout nil)))
	  (if eof-or-timeout
	      (values nil eof-or-timeout)
	    (values 
	      (with-event-queue-internal (display :timeout timeout)
		(threaded-length (display-new-events display)
				 reply-next reply-buffer))
	      nil)))))))

(defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys)
  ;; The event is put at the head of the queue if append-p is nil, else the tail.
  ;; Additional arguments depend on event-key, and are as specified above with
  ;; declare-event, except that both resource-ids and resource objects are accepted
  ;; in the event components.
  (declare (type display display)
	   (type event-key event-key)
	   (type generalized-boolean append-p send-event-p)
	   (dynamic-extent args))
  (unless (get event-key 'event-code)
    (x-type-error event-key 'event-key))
  (let* ((event (allocate-event))
	 (buffer (reply-ibuf8 event))
	 (event-code (get event-key 'event-code)))
    (declare (type reply-buffer event)
	     (type buffer-bytes buffer)
	     (type (or null card8) event-code))
    (unless event-code (x-type-error event-key 'event-key))
    (setf (event-code event) event-code)
    (with-display (display)
      (apply (svref *event-send-vector* event-code) display args)
      (buffer-replace buffer
		      (display-obuf8 display)
		      0
csr21's avatar
csr21 committed
		      +replysize+
dan's avatar
dan committed
		      (index+ 12 (buffer-boffset display)))
      (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code)
	    (aref buffer 2) 0
	    (aref buffer 3) 0))
    (with-event-queue (display)
      (if append-p
	  (enqueue-event event display)
	(with-event-queue-internal (display)
	  (threaded-requeue event
			    (display-event-queue-head display)
			    (display-event-queue-tail display)
			    reply-next reply-buffer))))))

(defun enqueue-event (new-event display)
  (declare (type reply-buffer new-event)
	   (type display display))
  ;; Place EVENT at the end of the event queue for DISPLAY
  (let* ((event-code (event-code new-event))
	 (event-key (and (index< event-code (length *event-key-vector*))
			 (svref *event-key-vector* event-code))))
    (declare (type array-index event-code)
	     (type (or null keyword) event-key))
    (if (null event-key)
	(unwind-protect
	    (cerror "Ignore this event" "No handler for ~s event" event-key)
	  (deallocate-event new-event))
      (with-event-queue-internal (display)
	(threaded-enqueue new-event
			  (display-event-queue-head display)
			  (display-event-queue-tail display)
			  reply-next reply-buffer)
	(unless (display-new-events display)
	  (setf (display-new-events display) new-event))))))


(defmacro define-event (name code)
csr21's avatar
csr21 committed
  `(eval-when (:compile-toplevel :load-toplevel :execute)
dan's avatar
dan committed
     (setf (svref *event-key-vector* ,code) ',name)
     (setf (get ',name 'event-code) ,code)))

;; Event names.  Used in "type" field in XEvent structures.  Not to be
;; confused with event masks above.  They start from 2 because 0 and 1
;; are reserved in the protocol for errors and replies. */

(define-event :key-press 2)
(define-event :key-release 3)
(define-event :button-press 4)
(define-event :button-release 5)
(define-event :motion-notify 6)
(define-event :enter-notify 7)
(define-event :leave-notify 8)
(define-event :focus-in 9)
(define-event :focus-out 10)
(define-event :keymap-notify 11)
(define-event :exposure 12)
(define-event :graphics-exposure 13)
(define-event :no-exposure 14)
(define-event :visibility-notify 15)
(define-event :create-notify 16)
(define-event :destroy-notify 17)
(define-event :unmap-notify 18)
(define-event :map-notify 19)
(define-event :map-request 20)
(define-event :reparent-notify 21)
(define-event :configure-notify 22)
(define-event :configure-request 23)
(define-event :gravity-notify 24)
(define-event :resize-request 25)
(define-event :circulate-notify 26)
(define-event :circulate-request 27)
(define-event :property-notify 28)
(define-event :selection-clear 29)
(define-event :selection-request 30)
(define-event :selection-notify 31)
(define-event :colormap-notify 32)
(define-event :client-message 33)
(define-event :mapping-notify 34)


(defmacro declare-event (event-codes &body declares &environment env)
  ;; Used to indicate the keyword arguments for handler functions in
  ;; process-event and event-case.
  ;; Generates the functions used in SEND-EVENT.
  ;; A compiler warning is printed when all of EVENT-CODES are not
  ;; defined by a preceding DEFINE-EXTENSION.
  ;; The body is a list of declarations, each of which has the form:
  ;; (type . items)  Where type is a data-type, and items is a list of
  ;; symbol names.  The item order corresponds to the order of fields
  ;; in the event sent by the server.  An item may be a list of items.
  ;; In this case, each item is aliased to the same event field.
  ;; This is used to give all events an EVENT-WINDOW item.
  ;; See the INPUT file for lots of examples.
  (declare (type (or keyword list) event-codes)
	   (type (alist (field-type symbol) (field-names list))
                 declares))
  (when (atom event-codes) (setq event-codes (list event-codes)))
  (setq event-codes (mapcar #'canonicalize-event-name event-codes))
  (let* ((keywords nil)
	 (name (first event-codes))
	 (get-macro (xintern name '-event-get-macro))
	 (get-function (xintern name '-event-get))
	 (put-function (xintern name '-event-put)))
    (multiple-value-bind (get-code get-index get-sizes)
	(get-put-items
	  2 declares nil
	  #'(lambda (type index item args)
	      (flet ((event-get (type index item args)
		       (unless (member type '(pad8 pad16))
			 `(,(kintern item)
			   (,(getify type) ,index ,@args)))))
		(if (atom item)
		    (event-get type index item args)
		  (mapcan #'(lambda (item)
			      (event-get type index item args))
			  item)))))
      (declare (ignore get-index))
      (multiple-value-bind (put-code put-index put-sizes)
	  (get-put-items
	    2 declares t
	    #'(lambda (type index item args)
		(unless (member type '(pad8 pad16))
		  (if (atom item)
		      (progn
			(push item keywords)
			`((,(putify type) ,index ,item ,@args)))
		    (let ((names (mapcar #'(lambda (name) (kintern name))
					 item)))
		      (setq keywords (append item keywords))
		      `((,(putify type) ,index
			 (check-consistency ',names ,@item) ,@args)))))))
	(declare (ignore put-index))
	`(within-definition (,name declare-event)
	   (defun ,get-macro (display event-key variable)
	     ;; Note: we take pains to macroexpand the get-code here to enable application
	     ;; code to be compiled without having the CLX macros file loaded.
	     `(let ((%buffer ,display))
		(declare (ignorable %buffer))
		,(getf `(:display (the display ,display)
			 :event-key (the keyword ,event-key)
			 :event-code (the card8 (logand #x7f (read-card8 0)))
			 :send-event-p (logbitp 7 (read-card8 0))
			 ,@',(mapcar #'(lambda (form)
					 (clx-macroexpand form env))
				     get-code))
		       variable)))

	   (defun ,get-function (display event handler)
	     (declare (type display display)
		      (type reply-buffer event))
	     (declare (type function handler)
		      #+clx-ansi-common-lisp
		      (dynamic-extent handler)
		      #+(and lispm (not clx-ansi-common-lisp))
		      (sys:downward-funarg handler))
	     (reading-event (event :display display :sizes (8 16 ,@get-sizes))
	       (funcall handler
			:display display
			:event-key (svref *event-key-vector* (event-code event))
			:event-code (logand #x7f (card8-get 0))
			:send-event-p (logbitp 7 (card8-get 0))
			,@get-code)))

	   (defun ,put-function (display &key ,@(setq keywords (nreverse keywords))
				 &allow-other-keys)
	     (declare (type display display))
	     ,(when (member 'sequence keywords)
		`(unless sequence (setq sequence (display-request-number display))))
	     (with-buffer-output (display :sizes ,put-sizes
					  :index (index+ (buffer-boffset display) 12))
	       ,@put-code))
       
	   ,@(mapcar #'(lambda (name)
			 (allocate-extension-event-code name)
			 `(let ((event-code (or (get ',name 'event-code)
						(allocate-extension-event-code ',name))))
			    (setf (svref *event-macro-vector* event-code)
				  (function ,get-macro))
			    (setf (svref *event-handler-vector* event-code)
				  (function ,get-function))
			    (setf (svref *event-send-vector* event-code)
				  (function ,put-function))))
		     event-codes)
	   ',name)))))

(defun check-consistency (names &rest args)
  ;; Ensure all args are nil or have the same value.
  ;; Returns the consistent non-nil value.
  (let ((value (car args)))
    (dolist (arg (cdr args))
      (if value
	  (when (and arg (not (eq arg value)))
	    (x-error 'inconsistent-parameters
		     :parameters (mapcan #'list names args)))
	(setq value arg)))
    value))

(declare-event (:key-press :key-release :button-press :button-release)
  ;; for key-press and key-release, code is the keycode
  ;; for button-press and button-release, code is the button number
  (data code)
  (card16 sequence)
  ((or null card32) time)
  (window root (window event-window))
  ((or null window) child)
  (int16 root-x root-y x y)
  (card16 state)
  (boolean same-screen-p)
  )

(declare-event :motion-notify
  ((data boolean) hint-p)
  (card16 sequence)
  ((or null card32) time)
  (window root (window event-window))
  ((or null window) child)
  (int16 root-x root-y x y)
  (card16 state)
  (boolean same-screen-p))

(declare-event (:enter-notify :leave-notify)
  ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind)
  (card16 sequence)
  ((or null card32) time)
  (window root (window event-window))
  ((or null window) child)
  (int16 root-x root-y x y)
  (card16 state)
  ((member8 :normal :grab :ungrab) mode)
  ((bit 0) focus-p)
  ((bit 1) same-screen-p))

(declare-event (:focus-in :focus-out)
  ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
		  :pointer :pointer-root :none))
   kind)
  (card16 sequence)
  (window (window event-window))
  ((member8 :normal :while-grabbed :grab :ungrab) mode))

(declare-event :keymap-notify
  ((bit-vector256 0) keymap))

(declare-event :exposure
  (card16 sequence)
  (window (window event-window))
  (card16 x y width height count))

(declare-event :graphics-exposure
  (card16 sequence)
  (drawable (drawable event-window))
  (card16 x y width height)
  (card16 minor)  ;; Minor opcode
  (card16 count)
  (card8 major))

(declare-event :no-exposure
  (card16 sequence)
  (drawable (drawable event-window))
  (card16 minor)
  (card8  major))

(declare-event :visibility-notify
  (card16 sequence)
  (window (window event-window))
  ((member8 :unobscured :partially-obscured :fully-obscured) state))

(declare-event :create-notify
  (card16 sequence)
  (window (parent event-window) window)
  (int16 x y)
  (card16 width height border-width)
  (boolean override-redirect-p))

(declare-event :destroy-notify
  (card16 sequence)
  (window event-window window))

(declare-event :unmap-notify
  (card16 sequence)
  (window event-window window)
  (boolean configure-p))

(declare-event :map-notify
  (card16 sequence)
  (window event-window window)
  (boolean override-redirect-p))

(declare-event :map-request
  (card16 sequence)
  (window (parent event-window) window))

(declare-event :reparent-notify
  (card16 sequence)
  (window event-window window parent)
  (int16 x y)
  (boolean override-redirect-p))

(declare-event :configure-notify
  (card16 sequence)
  (window event-window window)
  ((or null window) above-sibling)
  (int16 x y)
  (card16 width height border-width)
  (boolean override-redirect-p))

(declare-event :configure-request
  ((data (member8 :above :below :top-if :bottom-if :opposite)) stack-mode)
dan's avatar
dan committed
  (card16 sequence)
  (window (parent event-window) window)
  ((or null window) above-sibling)
  (int16 x y)
  (card16 width height border-width value-mask))

(declare-event :gravity-notify
  (card16 sequence)
  (window event-window window)
  (int16 x y))

(declare-event :resize-request
  (card16 sequence)
  (window (window event-window))
  (card16 width height))

(declare-event :circulate-notify
  (card16 sequence)
  (window event-window window parent)
csr21's avatar
csr21 committed
  ((member8 :top :bottom) place))
dan's avatar
dan committed

(declare-event :circulate-request
  (card16 sequence)
  (window (parent event-window) window)
  (pad16 1 2)
csr21's avatar
csr21 committed
  ((member8 :top :bottom) place))
dan's avatar
dan committed

(declare-event :property-notify
  (card16 sequence)
  (window (window event-window))
  (keyword atom) ;; keyword
  ((or null card32) time)
csr21's avatar
csr21 committed
  ((member8 :new-value :deleted) state))
dan's avatar
dan committed

(declare-event :selection-clear
  (card16 sequence)
  ((or null card32) time)
  (window (window event-window)) 
  (keyword selection) ;; keyword
  )

(declare-event :selection-request
  (card16 sequence)
  ((or null card32) time)
  (window (window event-window) requestor)
  (keyword selection target)
  ((or null keyword) property)
  )

(declare-event :selection-notify
  (card16 sequence)
  ((or null card32) time)
  (window (window event-window))
  (keyword selection target)
  ((or null keyword) property)
  )

(declare-event :colormap-notify
  (card16 sequence)
  (window (window event-window))
  ((or null colormap) colormap)
  (boolean new-p installed-p))

(declare-event :client-message
  (data format)
  (card16 sequence)
  (window (window event-window))
  (keyword type)
  ((client-message-sequence format) data))

(declare-event :mapping-notify
  (card16 sequence)
  ((member8 :modifier :keyboard :pointer) request)
  (card8 start) ;; first key-code
  (card8 count))


;;
;; EVENT-LOOP
;;