Skip to content
Snippets Groups Projects
input.lisp 72.5 KiB
Newer Older
dan's avatar
dan committed
(defun event-loop-setup (display)
  (declare (type display display)
	   (clx-values progv-vars progv-vals
		   current-event-symbol current-event-discarded-p-symbol))
  (let* ((progv-vars (display-current-event-symbol display))
	 (current-event-symbol (first progv-vars))
	 (current-event-discarded-p-symbol (second progv-vars)))
    (declare (type list progv-vars)
	     (type symbol current-event-symbol current-event-discarded-p-symbol))
    (values
      progv-vars 
      (list (if (boundp current-event-symbol)
		;; The current event is already bound, so bind it to the next
		;; event.
		(let ((event (symbol-value current-event-symbol)))
		  (declare (type (or null reply-buffer) event))
		  (and event (reply-next (the reply-buffer event))))
	      ;; The current event isn't bound, so bind it to the head of the
	      ;; event queue.
	      (display-event-queue-head display))
	    nil)
      current-event-symbol
      current-event-discarded-p-symbol)))

(defun event-loop-step-before (display timeout force-output-p current-event-symbol)
  (declare (type display display)
	   (type (or null number) timeout)
	   (type generalized-boolean force-output-p)
	   (type symbol current-event-symbol)
	   (clx-values event eof-or-timeout))
  (unless (symbol-value current-event-symbol)
    (let ((eof-or-timeout (wait-for-event display timeout force-output-p)))
      (when eof-or-timeout
	(return-from event-loop-step-before (values nil eof-or-timeout))))
    (setf (symbol-value current-event-symbol) (display-new-events display)))
  (let ((event (symbol-value current-event-symbol)))
    (declare (type reply-buffer event))
    (with-event-queue-internal (display)
      (when (eq event (display-new-events display))
	(setf (display-new-events display) (reply-next event))))
    (values event nil)))

(defun dequeue-event (display event)
  (declare (type display display)
	   (type reply-buffer event)
	   (clx-values next))
  ;; Remove the current event from the event queue
  (with-event-queue-internal (display)
    (let ((next (reply-next event))
	  (head (display-event-queue-head display)))
      (declare (type (or null reply-buffer) next head))
      (when (eq event (display-new-events display))
	(setf (display-new-events display) next))
      (cond ((eq event head)
	     (threaded-dequeue (display-event-queue-head display)
			       (display-event-queue-tail display)
			       reply-next reply-buffer))
	    ((null head)
	     (setq next nil))
	    (t
	     (do* ((previous head current)
		   (current (reply-next previous) (reply-next previous)))
		  ((or (null current) (eq event current))
		   (when (eq event current)
		     (when (eq current (display-event-queue-tail display))
		       (setf (display-event-queue-tail display) previous))
		     (setf (reply-next previous) next)))
	       (declare (type reply-buffer previous)
			(type (or null reply-buffer) current)))))
      next)))

(defun event-loop-step-after
       (display event discard-p current-event-symbol current-event-discarded-p-symbol
	&optional aborted)
  (declare (type display display)
	   (type reply-buffer event)
	   (type generalized-boolean discard-p aborted)
	   (type symbol current-event-symbol current-event-discarded-p-symbol))
  (when (and discard-p
	     (not aborted)
	     (not (symbol-value current-event-discarded-p-symbol)))
    (discard-current-event display))
  (let ((next (reply-next event)))
    (declare (type (or null reply-buffer) next))
    (when (symbol-value current-event-discarded-p-symbol)
      (setf (symbol-value current-event-discarded-p-symbol) nil)
      (setq next (dequeue-event display event))
      (deallocate-event event))
    (setf (symbol-value current-event-symbol) next)))

(defmacro event-loop ((display event timeout force-output-p discard-p) &body body)
  ;; Bind EVENT to the events for DISPLAY.
  ;; This is the "GUTS" of process-event and event-case.
  `(let ((.display. ,display)
	 (.timeout. ,timeout)
	 (.force-output-p. ,force-output-p)
	 (.discard-p. ,discard-p))
     (declare (type display .display.)
	      (type (or null number) .timeout.)
	      (type generalized-boolean .force-output-p. .discard-p.))
     (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.)))
       (multiple-value-bind (.progv-vars. .progv-vals.
			     .current-event-symbol. .current-event-discarded-p-symbol.)
	   (event-loop-setup .display.)
	 (declare (type list .progv-vars. .progv-vals.)
		  (type symbol .current-event-symbol. .current-event-discarded-p-symbol.))
	 (progv .progv-vars. .progv-vals.
	   (loop
	     (multiple-value-bind (.event. .eof-or-timeout.)
		 (event-loop-step-before
		   .display. .timeout. .force-output-p.
		   .current-event-symbol.)
	       (declare (type (or null reply-buffer) .event.))
	       (when (null .event.) (return (values nil .eof-or-timeout.)))
	       (let ((.aborted. t))
		 (unwind-protect 
		     (progn
		       (let ((,event .event.))
			 (declare (type reply-buffer ,event))
			 ,@body)
		       (setq .aborted. nil))
		   (event-loop-step-after
		     .display. .event. .discard-p.
		     .current-event-symbol. .current-event-discarded-p-symbol.
		     .aborted.))))))))))

(defun discard-current-event (display)
  ;; Discard the current event for DISPLAY.
  ;; Returns NIL when the event queue is empty, else T.
  ;; To ensure events aren't ignored, application code should only call
  ;; this when throwing out of event-case or process-next-event, or from
  ;; inside even-case, event-cond or process-event when :peek-p is T and
  ;; :discard-p is NIL.
  (declare (type display display)
	   (clx-values generalized-boolean))
  (let* ((symbols (display-current-event-symbol display))
	 (event
	   (let ((current-event-symbol (first symbols)))
	     (declare (type symbol current-event-symbol))
	     (when (boundp current-event-symbol)
	       (symbol-value current-event-symbol)))))
    (declare (type list symbols)
	     (type (or null reply-buffer) event))
    (unless (null event)
      ;; Set the discarded-p flag
      (let ((current-event-discarded-p-symbol (second symbols)))
	(declare (type symbol current-event-discarded-p-symbol))
	(when (boundp current-event-discarded-p-symbol)
	  (setf (symbol-value current-event-discarded-p-symbol) t)))
      ;; Return whether the event queue is empty
      (not (null (reply-next (the reply-buffer event)))))))

;;
;; PROCESS-EVENT
;;
(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t))
  ;; If force-output-p is true, first invokes display-force-output.  Invokes handler
  ;; on each queued event until handler returns non-nil, and that returned object is
  ;; then returned by process-event.  If peek-p is true, then the event is not
  ;; removed from the queue.  If discard-p is true, then events for which handler
  ;; returns nil are removed from the queue, otherwise they are left in place.  Hangs
  ;; until non-nil is generated for some event, or for the specified timeout (in
  ;; seconds, if given); however, it is acceptable for an implementation to wait only
  ;; once on network data, and therefore timeout prematurely.  Returns nil on
  ;; timeout.  If handler is a sequence, it is expected to contain handler functions
  ;; specific to each event class; the event code is used to index the sequence,
  ;; fetching the appropriate handler.  Handler is called with raw resource-ids, not
  ;; with resource objects.  The arguments to the handler are described using declare-event.
  ;;
  ;; T for peek-p means the event (for which the handler returns non-nil) is not removed
  ;; from the queue (it is left in place), NIL means the event is removed.
  
  (declare (type display display)
	   (type (or null number) timeout)
	   (type generalized-boolean peek-p discard-p force-output-p))
  (declare (type t handler)
	   #+clx-ansi-common-lisp
	   (dynamic-extent handler)
	   #+(and lispm (not clx-ansi-common-lisp))
	   (sys:downward-funarg #+Genera * #-Genera handler))
  (event-loop (display event timeout force-output-p discard-p)
    (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT
	   (event-decoder (and (index< event-code (length *event-handler-vector*))
			       (svref *event-handler-vector* event-code))))
      (declare (type array-index event-code)
	       (type (or null function) event-decoder))
      (if event-decoder
	  (let ((event-handler (if (functionp handler)
				   handler
				   (and (type? handler 'sequence)
					(< event-code (length handler))
					(elt handler event-code)))))
	    (if event-handler
		(let ((result (funcall event-decoder display event event-handler)))
		  (when result
		    (unless peek-p
		      (discard-current-event display))
		    (return result)))
	      (cerror "Ignore this event"
		      "No handler for ~s event"
		      (svref *event-key-vector* event-code))))
	(cerror "Ignore this event"
		"Server Error: event with unknown event code ~d received."
		event-code)))))

(defun make-event-handlers (&key (type 'array) default)
  (declare (type t type)			;Sequence type specifier
	   (type (or null function) default)
dan's avatar
dan committed
	   (clx-values sequence))			;Default handler for initial content
  ;; Makes a handler sequence suitable for process-event
csr21's avatar
csr21 committed
  (make-sequence type +max-events+ :initial-element default))
dan's avatar
dan committed
   
(defun event-handler (handlers event-key)
  (declare (type sequence handlers)
	   (type event-key event-key)
	   (clx-values function))
  ;; Accessor for a handler sequence
  (elt handlers (position event-key *event-key-vector* :test #'eq)))

(defun set-event-handler (handlers event-key handler)
  (declare (type sequence handlers)
	   (type event-key event-key)
	   (type function handler)
	   (clx-values handler))
  (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler))

(defsetf event-handler set-event-handler)

;;
;; EVENT-CASE
;; 

(defmacro event-case ((&rest args) &body clauses)
  ;; If force-output-p is true, first invokes display-force-output.  Executes the
  ;; matching clause for each queued event until a clause returns non-nil, and that
  ;; returned object is then returned by event-case.  If peek-p is true, then the
  ;; event is not removed from the queue.  If discard-p is true, then events for
  ;; which the clause returns nil are removed from the queue, otherwise they are left
  ;; in place.  Hangs until non-nil is generated for some event, or for the specified
  ;; timeout (in seconds, if given); however, it is acceptable for an implementation
  ;; to wait only once on network data, and therefore timeout prematurely.  Returns
  ;; nil on timeout.  In each clause, event-or-events is an event-key or a list of
  ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise
  ;; (but only in the last clause).  The keys are not evaluated, and it is an error
  ;; for the same key to appear in more than one clause.  Args is the list of event
  ;; components of interest; corresponding values (if any) are bound to variables
  ;; with these names (i.e., the args are variable names, not keywords, the keywords
  ;; are derived from the variable names).  An arg can also be a (keyword var) form,
  ;; as for keyword args in a lambda lists.  If no t/otherwise clause appears, it is
  ;; equivalent to having one that returns nil.
  (declare (arglist (display &key timeout peek-p discard-p (force-output-p t))
		   (event-or-events ((&rest args) |...|) &body body) |...|))
  ;; Event-case is just event-cond with the whole body in the test-form
  `(event-cond ,args
	       ,@(mapcar
		   #'(lambda (clause)
		       `(,(car clause) ,(cadr clause) (progn ,@(cddr clause))))
		   clauses)))

;;
;; EVENT-COND
;; 

(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t))
		      &body clauses)
  ;; The clauses of event-cond are of the form:
  ;; (event-or-events binding-list test-form . body-forms)
  ;;
  ;; EVENT-OR-EVENTS	event-key or a list of event-keys (but they
  ;;			need not be typed as keywords) or the symbol t
  ;;			or otherwise (but only in the last clause).  If
  ;;			no t/otherwise clause appears, it is equivalent
  ;;			to having one that returns nil.  The keys are
  ;;			not evaluated, and it is an error for the same
  ;;			key to appear in more than one clause.
  ;;
  ;; BINDING-LIST	The list of event components of interest.
  ;;			corresponding values (if any) are bound to
  ;;			variables with these names (i.e., the binding-list
  ;;			has variable names, not keywords, the keywords are
  ;;			derived from the variable names).  An arg can also
  ;;			be a (keyword var) form, as for keyword args in a
  ;;			lambda list.
  ;;
  ;; The matching TEST-FORM for each queued event is executed until a
  ;; clause's test-form returns non-nil.  Then the BODY-FORMS are
  ;; evaluated, returning the (possibly multiple) values of the last
  ;; form from event-cond.  If there are no body-forms then, if the
  ;; test-form is non-nil, the value of the test-form is returned as a
  ;; single value.
  ;;
  ;; Options:
  ;; FORCE-OUTPUT-P	When true, first invoke display-force-output if no
  ;;		  	input is pending.
  ;;
  ;; PEEK-P		When true, then the event is not removed from the queue.
  ;;
  ;; DISCARD-P		When true, then events for which the clause returns nil
  ;; 			are removed from the queue, otherwise they are left in place.
  ;;
  ;; TIMEOUT		If NIL, hang until non-nil is generated for some event's
  ;;			test-form. Otherwise return NIL after TIMEOUT seconds have
  ;;			elapsed.
  ;;
  (declare (arglist (display &key timeout peek-p discard-p force-output-p)
		   (event-or-events (&rest args) test-form &body body) |...|))
  (let ((event (gensym))
	(disp (gensym))
	(peek (gensym)))
    `(let ((,disp ,display)
	   (,peek ,peek-p))
       (declare (type display ,disp))
       (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p)
	 (event-dispatch (,disp ,event ,peek) ,@clauses)))))

(defun get-event-code (event)
  ;; Returns the event code given an event-key
  (declare (type event-key event))
  (declare (clx-values card8))
  (or (get event 'event-code)
      (x-type-error event 'event-key)))

(defun universal-event-get-macro (display event-key variable)
  (getf
    `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code
	       (the card8 (logand 127 (read-card8 0))) :send-event-p
	       (logbitp 7 (read-card8 0)))
    variable))

(defmacro event-dispatch ((display event peek-p) &body clauses)
  ;; Helper macro for event-case
  ;; CLAUSES are of the form:
  ;; (event-or-events binding-list test-form . body-forms)
  (let ((event-key (gensym))
csr21's avatar
csr21 committed
	(all-events (make-array +max-events+ :element-type 'bit :initial-element 0)))
dan's avatar
dan committed
    `(reading-event (,event)
       (let ((,event-key (svref *event-key-vector* (event-code ,event))))
	 (case ,event-key
	   ,@(mapcar
	       #'(lambda (clause)		; Translate event-cond clause to case clause
		   (let* ((events (first clause))
			  (arglist (second clause))
			  (test-form (third clause))
			  (body-forms (cdddr clause)))
		     (flet ((event-clause (display peek-p first-form rest-of-forms)
			      (if rest-of-forms
				  `(when ,first-form
				     (unless ,peek-p (discard-current-event ,display))
				     (return (progn ,@rest-of-forms)))
				;; No body forms, return the result of the test form
				(let ((result (gensym)))
				  `(let ((,result ,first-form))
				     (when ,result
				       (unless ,peek-p (discard-current-event ,display))
				       (return ,result)))))))

		       (if (member events '(otherwise t))
			   ;; code for OTHERWISE clause.
			   ;; Find all events NOT used by other clauses
			   (let ((keys (do ((i 0 (1+ i))
					    (key nil)
					    (result nil))
csr21's avatar
csr21 committed
					   ((>= i +max-events+) result)
dan's avatar
dan committed
					 (setq key (svref *event-key-vector* i))
					 (when (and key (zerop (aref all-events i)))
					   (push key result)))))
			     `(otherwise
				(binding-event-values
				  (,display ,event-key ,(or keys :universal) ,@arglist)
				  ,(event-clause display peek-p test-form body-forms))))

			 ;; Code for normal clauses
			 (let (true-events) ;; canonicalize event-names
			   (if (consp events)
			       (progn
				 (setq true-events (mapcar #'canonicalize-event-name events))
				 (dolist (event true-events)
				   (setf (aref all-events (get-event-code event)) 1)))
			     (setf true-events (canonicalize-event-name events)
				   (aref all-events (get-event-code true-events)) 1))
			   `(,true-events
			     (binding-event-values
			       (,display ,event-key ,true-events ,@arglist)
			       ,(event-clause display peek-p test-form body-forms))))))))
	       clauses))))))

(defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body)
  ;; Execute BODY with the variables in VALUE-LIST bound to components of the
  ;; EVENT-KEYS events.
  (unless (consp event-keys) (setq event-keys (list event-keys)))
  (flet ((var-key (var) (kintern (if (consp var) (first var) var)))
	 (var-symbol (var) (if (consp var) (second var) var)))
    ;; VARS is an alist of:
    ;;  (component-key ((event-key event-key ...) . extraction-code)
    ;;		       ((event-key event-key ...) . extraction-code) ...)
    ;; There should probably be accessor macros for this, instead of things like cdadr.
    (let ((vars (mapcar #'list value-list))
	  (multiple-p nil))
      ;; Fill in the VARS alist with event-keys and extraction-code
      (do ((keys event-keys (cdr keys))
	   (temp nil))
	  ((endp keys))
	(let* ((key (car keys))
	       (binder (case key
			 (:universal #'universal-event-get-macro)
			 (otherwise (svref *event-macro-vector* (get-event-code key))))))
	  (dolist (var vars)
	    (let ((code (funcall binder display event-key (var-key (car var)))))
	      (unless code (warn "~a isn't a component of the ~s event"
				 (var-key (car var)) key))
	      (if (setq temp (member code (cdr var) :key #'cdr :test #'equal))
		  (push key (caar temp))
		(push `((,key) . ,code) (cdr var)))))))
      ;; Bind all the values
      `(let ,(mapcar #'(lambda (var)
			 (if (cddr var) ;; if more than one binding form
			     (progn (setq multiple-p t)
				    (var-symbol (car var)))
			   (list (var-symbol (car var)) (cdadr var))))
		     vars)
	 ;; When some values come from different places, generate code to set them
	 ,(when multiple-p
	    `(case ,event-key
	       ,@(do ((keys event-keys (cdr keys))
		      (clauses nil) ;; alist of (event-keys bindings)
		      (clause nil nil)
		      (temp))
		     ((endp keys)
		      (dolist (clause clauses)
			(unless (cdar clause) ;; Atomize single element lists
			  (setf (car clause) (caar clause))))
		      clauses)
		   ;; Gather up all the bindings associated with (car keys)
		   (dolist (var vars)
		     (when (cddr var) ;; when more than one binding form
		       (dolist (events (cdr var))
			 (when (member (car keys) (car events))
			   ;; Optimize for event-window being the same as some other binding
			   (if (setq temp (member (cdr events) clause
						  :key #'caddr
						  :test #'equal))
			       (setq clause
				     (nconc clause `((setq ,(car var) ,(second (car temp))))))
			     (push `(setq ,(car var) ,(cdr events)) clause))))))
		   ;; Merge bindings for (car keys) with other bindings
		   (when clause
		     (if (setq temp (member clause clauses :key #'cdr :test #'equal))
			 (push (car keys) (caar temp))
		       (push `((,(car keys)) . ,clause) clauses))))))
	 ,@body))))


;;;-----------------------------------------------------------------------------
;;; Error Handling
;;;-----------------------------------------------------------------------------

csr21's avatar
csr21 committed
(eval-when (:compile-toplevel :load-toplevel :execute)
dan's avatar
dan committed
1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887
(defparameter
  *xerror-vector*
  '#(unknown-error
     request-error				; 1  bad request code
     value-error				; 2  integer parameter out of range
     window-error				; 3  parameter not a Window
     pixmap-error				; 4  parameter not a Pixmap
     atom-error					; 5  parameter not an Atom
     cursor-error				; 6  parameter not a Cursor
     font-error					; 7  parameter not a Font
     match-error				; 8  parameter mismatch
     drawable-error				; 9  parameter not a Pixmap or Window
     access-error				; 10 attempt to access private resource"
     alloc-error				; 11 insufficient resources
     colormap-error				; 12 no such colormap
     gcontext-error				; 13 parameter not a GContext
     id-choice-error				; 14 invalid resource ID for this connection
     name-error					; 15 font or color name does not exist
     length-error				; 16 request length incorrect;
						;    internal Xlib error
     implementation-error			; 17 server is defective
     ))
)

(defun make-error (display event asynchronous)
  (declare (type display display)
	   (type reply-buffer event)
	   (type generalized-boolean asynchronous))
  (reading-event (event)
    (let* ((error-code (read-card8 1))
	   (error-key (get-error-key display error-code))
	   (error-decode-function (get error-key 'error-decode-function))
	   (params (funcall error-decode-function display event)))
      (list* error-code error-key
	     :asynchronous asynchronous :current-sequence (display-request-number display)
	     params))))

(defun report-error (display error-code error-key &rest params)
  (declare (type display display)
	   (dynamic-extent params))
  ;; All errors (synchronous and asynchronous) are processed by calling
  ;; an error handler in the display.  The handler is called with the display
  ;; as the first argument and the error-key as its second argument. If handler is
  ;; an array it is expected to contain handler functions specific to
  ;; each error; the error code is used to index the array, fetching the
  ;; appropriate handler. Any results returned by the handler are ignored;;
  ;; it is assumed the handler either takes care of the error completely,
  ;; or else signals. For all core errors, additional keyword/value argument
  ;; pairs are:
  ;;    :major integer
  ;;    :minor integer
  ;;    :sequence integer
  ;;    :current-sequence integer
  ;;    :asynchronous (member t nil)
  ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window
  ;; errors another pair is:
  ;;    :resource-id integer
  ;; For :atom errors, another pair is:
  ;;    :atom-id integer
  ;; For :value errors, another pair is:
  ;;    :value integer
  (let* ((handler (display-error-handler display))
	 (handler-function
	   (if (type? handler 'sequence)
	       (elt handler error-code)
	     handler)))
    (apply handler-function display error-key params)))

(defun request-name (code &optional display)
  (if (< code (length *request-names*))
      (svref *request-names* code)
    (dolist (extension (and display (display-extension-alist display)) "unknown")
      (when (= code (second extension))
	(return (first extension))))))

#-(or clx-ansi-common-lisp excl lcl3.0 CMU)
(define-condition request-error (x-error)
  ((display :reader request-error-display)
   (error-key :reader request-error-error-key)
   (major :reader request-error-major)
   (minor :reader request-error-minor)
   (sequence :reader request-error-sequence)
   (current-sequence :reader request-error-current-sequence)
   (asynchronous :reader request-error-asynchronous))
  (:report report-request-error))

(defun report-request-error (condition stream)
  (let ((error-key (request-error-error-key condition))
	(asynchronous (request-error-asynchronous condition))
	(major (request-error-major condition))
	(minor (request-error-minor condition))
	(sequence (request-error-sequence condition))
	(current-sequence (request-error-current-sequence condition)))		   
    (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]"
	    asynchronous error-key (= sequence current-sequence)
	    sequence current-sequence major minor
	    (request-name major (request-error-display condition)))))

;; Since the :report arg is evaluated as (function report-request-error) the
;; define-condition must come after the function definition.
#+(or clx-ansi-common-lisp excl lcl3.0 CMU)
(define-condition request-error (x-error)
  ((display :reader request-error-display :initarg :display)
   (error-key :reader request-error-error-key :initarg :error-key)
   (major :reader request-error-major :initarg :major)
   (minor :reader request-error-minor :initarg :minor)
   (sequence :reader request-error-sequence :initarg :sequence)
   (current-sequence :reader request-error-current-sequence :initarg :current-sequence)
   (asynchronous :reader request-error-asynchronous :initarg :asynchronous))
  (:report report-request-error))

(define-condition resource-error (request-error)
  ((resource-id :reader resource-error-resource-id :initarg :resource-id))
  (:report
    (lambda (condition stream)
      (report-request-error condition stream)
      (format stream " ID #x~x" (resource-error-resource-id condition)))))  

(define-condition unknown-error (request-error)
  ((error-code :reader unknown-error-error-code :initarg :error-code))
  (:report
    (lambda (condition stream)
      (report-request-error condition stream)
      (format stream " Error Code ~d." (unknown-error-error-code condition)))))

(define-condition access-error (request-error) ())

(define-condition alloc-error (request-error) ())

(define-condition atom-error (request-error)
  ((atom-id :reader atom-error-atom-id :initarg :atom-id))
  (:report
    (lambda (condition stream)
      (report-request-error condition stream)
      (format stream " Atom-ID #x~x" (atom-error-atom-id condition)))))

(define-condition colormap-error (resource-error) ())

(define-condition cursor-error (resource-error) ())

(define-condition drawable-error (resource-error) ())

(define-condition font-error (resource-error) ())

(define-condition gcontext-error (resource-error) ())

(define-condition id-choice-error (resource-error) ())

(define-condition illegal-request-error (request-error) ())

(define-condition length-error (request-error) ())

(define-condition match-error (request-error) ())

(define-condition name-error (request-error) ())

(define-condition pixmap-error (resource-error) ())

(define-condition value-error (request-error)
  ((value :reader value-error-value :initarg :value))
  (:report
    (lambda (condition stream)
      (report-request-error condition stream)
      (format stream " Value ~d." (value-error-value condition)))))

(define-condition window-error (resource-error)())

(define-condition implementation-error (request-error) ())

;;-----------------------------------------------------------------------------
;; Internal error conditions signaled by CLX

(define-condition x-type-error (type-error x-error)
  ((type-string :reader x-type-error-type-string :initarg :type-string))
  (:report
    (lambda (condition stream)
      (format stream "~s isn't a ~a"
	      (type-error-datum condition)
	      (or (x-type-error-type-string condition)
		  (type-error-expected-type condition))))))

(define-condition closed-display (x-error)
  ((display :reader closed-display-display :initarg :display))
  (:report
    (lambda (condition stream)
      (format stream "Attempt to use closed display ~s"
	      (closed-display-display condition)))))

(define-condition lookup-error (x-error)
  ((id :reader lookup-error-id :initarg :id)
   (display :reader lookup-error-display :initarg :display)
   (type :reader lookup-error-type :initarg :type)
   (object :reader lookup-error-object :initarg :object))
  (:report
    (lambda (condition stream)
      (format stream "ID ~d from display ~s should have been a ~s, but was ~s"
	      (lookup-error-id condition)
	      (lookup-error-display condition)
	      (lookup-error-type condition)
	      (lookup-error-object condition)))))  

(define-condition connection-failure (x-error)
  ((major-version :reader connection-failure-major-version :initarg :major-version)
   (minor-version :reader connection-failure-minor-version :initarg :minor-version)
   (host :reader connection-failure-host :initarg :host)
   (display :reader connection-failure-display :initarg :display)
   (reason :reader connection-failure-reason :initarg :reason))
  (:report
    (lambda (condition stream)
      (format stream "Connection failure to X~d.~d server ~a display ~d: ~a"
	      (connection-failure-major-version condition)
	      (connection-failure-minor-version condition)
	      (connection-failure-host condition)
	      (connection-failure-display condition)
	      (connection-failure-reason condition)))))
  
(define-condition reply-length-error (x-error)
  ((reply-length :reader reply-length-error-reply-length :initarg :reply-length)
   (expected-length :reader reply-length-error-expected-length :initarg :expected-length)
   (display :reader reply-length-error-display :initarg :display))
  (:report
    (lambda (condition stream)
      (format stream "Reply length was ~d when ~d words were expected for display ~s"
	      (reply-length-error-reply-length condition)
	      (reply-length-error-expected-length condition)
	      (reply-length-error-display condition)))))  

(define-condition reply-timeout (x-error)
  ((timeout :reader reply-timeout-timeout :initarg :timeout)
   (display :reader reply-timeout-display :initarg :display))
  (:report
    (lambda (condition stream)
      (format stream "Timeout after waiting ~d seconds for a reply for display ~s"
	      (reply-timeout-timeout condition)
	      (reply-timeout-display condition)))))  

(define-condition sequence-error (x-error)
  ((display :reader sequence-error-display :initarg :display)
   (req-sequence :reader sequence-error-req-sequence :initarg :req-sequence)
   (msg-sequence :reader sequence-error-msg-sequence :initarg :msg-sequence))
  (:report
    (lambda (condition stream)
      (format stream "Reply out of sequence for display ~s.~%  Expected ~d, Got ~d"
	      (sequence-error-display condition)
	      (sequence-error-req-sequence condition)
	      (sequence-error-msg-sequence condition)))))  

(define-condition unexpected-reply (x-error)
  ((display :reader unexpected-reply-display :initarg :display)
   (msg-sequence :reader unexpected-reply-msg-sequence :initarg :msg-sequence)
   (req-sequence :reader unexpected-reply-req-sequence :initarg :req-sequence)
   (length :reader unexpected-reply-length :initarg :length))
  (:report
    (lambda (condition stream)
      (format stream "Display ~s received a server reply when none was expected.~@
		      Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes."
	      (unexpected-reply-display condition)
	      (unexpected-reply-req-sequence condition)
	      (unexpected-reply-msg-sequence condition)
	      (unexpected-reply-length condition)))))

(define-condition missing-parameter (x-error)
  ((parameter :reader missing-parameter-parameter :initarg :parameter))
  (:report
    (lambda (condition stream)
      (let ((parm (missing-parameter-parameter condition)))
	(if (consp parm)
	    (format stream "One or more of the required parameters ~a is missing."
		    parm)
	  (format stream "Required parameter ~a is missing or null." parm))))))

;; This can be signalled anywhere a pseudo font access fails.
(define-condition invalid-font (x-error)
  ((font :reader invalid-font-font :initarg :font))
  (:report
    (lambda (condition stream)
      (format stream "Can't access font ~s" (invalid-font-font condition)))))

(define-condition device-busy (x-error)
  ((display :reader device-busy-display :initarg :display))
  (:report
    (lambda (condition stream)
      (format stream "Device busy for display ~s"
	      (device-busy-display condition)))))

(define-condition unimplemented-event (x-error)
  ((display :reader unimplemented-event-display :initarg :display)
   (event-code :reader unimplemented-event-event-code :initarg :event-code))
  (:report
    (lambda (condition stream)
      (format stream "Event code ~d not implemented for display ~s"
	      (unimplemented-event-event-code condition)
	      (unimplemented-event-display condition)))))

(define-condition undefined-event (x-error)
  ((display :reader undefined-event-display :initarg :display)
   (event-name :reader undefined-event-event-name :initarg :event-name))
  (:report
    (lambda (condition stream)
      (format stream "Event code ~d undefined for display ~s"
	      (undefined-event-event-name condition)
	      (undefined-event-display condition)))))

(define-condition absent-extension (x-error)
  ((name :reader absent-extension-name :initarg :name)
   (display :reader absent-extension-display :initarg :display))
  (:report
    (lambda (condition stream)
      (format stream "Extension ~a isn't defined for display ~s"
	      (absent-extension-name condition)
	      (absent-extension-display condition)))))

(define-condition inconsistent-parameters (x-error)
  ((parameters :reader inconsistent-parameters-parameters :initarg :parameters))
  (:report
    (lambda (condition stream)
      (format stream "inconsistent-parameters:~{ ~s~}"
	      (inconsistent-parameters-parameters condition)))))

(defun get-error-key (display error-code)
  (declare (type display display)
	   (type array-index error-code))
  ;; Return the error-key associated with error-code
  (if (< error-code (length *xerror-vector*))
      (svref *xerror-vector* error-code)
    ;; Search the extensions for the error
    (dolist (entry (display-extension-alist display) 'unknown-error)
      (let* ((event-name (first entry))
	     (first-error (fourth entry))
	     (errors (third (assoc event-name *extensions*))))
	(declare (type keyword event-name)
		 (type array-index first-error)
		 (type list errors))
	(when (and errors
		   (index<= first-error error-code
			    (index+ first-error (index- (length errors) 1))))
	  (return (nth (index- error-code first-error) errors)))))))

(defmacro define-error (error-key function)
  ;; Associate a function with ERROR-KEY which will be called with
  ;; parameters DISPLAY and REPLY-BUFFER and
  ;; returns a plist of keyword/value pairs which will be passed on
  ;; to the error handler.  A compiler warning is printed when
  ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION.
  ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type
  ;;       macros for getting error fields. See DECODE-CORE-ERROR for
  ;;       an example.
  (declare (type symbol error-key)
	   (type (or symbol list) function))
  ;; First ensure the name is for a declared extension
  (unless (or (find error-key *xerror-vector*)
	      (dolist (extension *extensions*)
		(when (member error-key (third extension))
		  (return t))))
    (x-type-error error-key 'error-key))
  `(setf (get ',error-key 'error-decode-function) (function ,function)))

;; All core errors use this, so we make it available to extensions.
(defun decode-core-error (display event &optional arg)
  ;; All core errors have the following keyword/argument pairs:
  ;;    :major integer
  ;;    :minor integer
  ;;    :sequence integer
  ;; In addition, many have an additional argument that comes from the
  ;; same place in the event, but is named differently.  When the ARG
  ;; argument is specified, the keyword ARG with card32 value starting
  ;; at byte 4 of the event is returned with the other keyword/argument
  ;; pairs.
  (declare (type display display)
	   (type reply-buffer event)
	   (type (or null keyword) arg))
  (declare (clx-values keyword/arg-plist))
  display
  (reading-event (event)
    (let* ((sequence (read-card16 2))
	   (minor-code (read-card16 8))
	   (major-code (read-card8 10))
	   (result (list :major major-code
			 :minor minor-code
			 :sequence sequence)))
      (when arg
	(setq result (list* arg (read-card32 4) result)))
      result)))

(defun decode-resource-error (display event)
  (decode-core-error display event :resource-id))

(define-error unknown-error
  (lambda (display event)
    (list* :error-code (aref (reply-ibuf8 event) 1)
	   (decode-core-error display event))))

(define-error request-error decode-core-error)		; 1  bad request code

(define-error value-error				; 2  integer parameter out of range
  (lambda (display event)
    (decode-core-error display event :value)))

(define-error window-error decode-resource-error)	; 3  parameter not a Window

(define-error pixmap-error decode-resource-error)	; 4  parameter not a Pixmap

(define-error atom-error				; 5  parameter not an Atom
  (lambda (display event)
    (decode-core-error display event :atom-id)))

(define-error cursor-error decode-resource-error)	; 6  parameter not a Cursor

(define-error font-error decode-resource-error)		; 7  parameter not a Font

(define-error match-error decode-core-error)		; 8  parameter mismatch

(define-error drawable-error decode-resource-error)	; 9  parameter not a Pixmap or Window

(define-error access-error decode-core-error)		; 10 attempt to access private resource"

(define-error alloc-error decode-core-error)		; 11 insufficient resources

(define-error colormap-error decode-resource-error)	; 12 no such colormap

(define-error gcontext-error decode-resource-error)	; 13 parameter not a GContext

(define-error id-choice-error decode-resource-error)	; 14 invalid resource ID for this connection

(define-error name-error decode-core-error)		; 15 font or color name does not exist

(define-error length-error decode-core-error)		; 16 request length incorrect;
							;    internal Xlib error

(define-error implementation-error decode-core-error)	; 17 server is defective