home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / X / mit / lib / CLX / input.l < prev    next >
Encoding:
Text File  |  1991-08-18  |  72.2 KB  |  1,885 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. ;;;
  22. ;;; Change history:
  23. ;;;
  24. ;;;  Date    Author    Description
  25. ;;; -------------------------------------------------------------------------------------
  26. ;;; 12/10/87    LGO    Created
  27.  
  28. (in-package :xlib)
  29.  
  30. ;; Event Resource
  31. (defvar *event-free-list* nil) ;; List of unused (processed) events
  32.  
  33. (eval-when (eval compile load)
  34. (defconstant *max-events* 64) ;; Maximum number of events supported (the X11 alpha release only has 34)
  35. (defvar *event-key-vector* (make-array *max-events* :initial-element nil)
  36.   "Vector of event keys - See define-event")
  37. )
  38. (defvar *event-macro-vector* (make-array *max-events* :initial-element nil)
  39.   "Vector of event handler functions - See declare-event")
  40. (defvar *event-handler-vector* (make-array *max-events* :initial-element nil)
  41.   "Vector of event handler functions - See declare-event")
  42. (defvar *event-send-vector* (make-array *max-events* :initial-element nil)
  43.   "Vector of event sending functions - See declare-event")
  44.  
  45. (defun allocate-event ()
  46.   (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer)
  47.       (make-reply-buffer *replysize*)))
  48.  
  49. (defun deallocate-event (reply-buffer)
  50.   (declare (type reply-buffer reply-buffer))
  51.   (setf (reply-size reply-buffer) *replysize*)
  52.   (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer))
  53.  
  54. ;; Extensions are handled as follows:
  55. ;; DEFINITION:    Use DEFINE-EXTENSION
  56. ;;
  57. ;; CODE:    Use EXTENSION-CODE to get the X11 opcode for an extension.
  58. ;;        This looks up the code on the display-extension-alist.
  59. ;;
  60. ;; EVENTS:    Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE
  61. ;;        at LOAD time to define an internal event-code number
  62. ;;        (stored in the 'event-code property of the event-name)
  63. ;;        used to index the following vectors:
  64. ;;        *event-key-vector*     Used for getting the event-key
  65. ;;        *event-macro-vector*    Used for getting the event-parameter getting macros
  66. ;;
  67. ;;        The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert
  68. ;;        a server event-code into an internal event-code used to index the following
  69. ;;        vectors:
  70. ;;        *event-handler-vector*    Used for getting the event-handler function
  71. ;;        *event-send-vector*    Used for getting the event-sending function
  72. ;;
  73. ;;        The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert
  74. ;;        internal event-codes to external (server) codes.
  75. ;;
  76. ;; ERRORS:    Use DEFINE-ERROR to define new error decodings.
  77. ;;
  78.  
  79.  
  80. ;; Any event-code greater than 34 is for an extension
  81. (defparameter *first-extension-event-code* 35)
  82.  
  83. (defvar *extensions* nil) ;; alist of (extension-name-symbol events errors)
  84.  
  85. (defmacro define-extension (name &key events errors)
  86.   ;; Define extension NAME with EVENTS and ERRORS.
  87.   ;; Note: The case of NAME is important.
  88.   ;; To define the request, Use:
  89.   ;;     (with-buffer-request (display (extension-opcode ,name)) ,@body)
  90.   ;;     See the REQUESTS file for lots of examples.
  91.   ;; To define event handlers, use declare-event.
  92.   ;; To define error handlers, use declare-error and define-condition.
  93.   (declare (type stringable name)
  94.        (type list events errors))
  95.   (let ((name-symbol (kintern name)) ;; Intern name in the keyword package
  96.     (event-list (mapcar #'canonicalize-event-name events)))
  97.     `(eval-when (compile load eval)
  98.        (setq *extensions* (cons (list ',name-symbol ',event-list ',errors)
  99.                 (delete ',name-symbol *extensions* :key #'car))))))
  100.  
  101. (eval-when (compile eval load)
  102. (defun canonicalize-event-name (event)
  103.   ;; Returns the event name keyword given an event name stringable
  104.   (declare (type stringable event))
  105.   (declare (values event-key))
  106.   (kintern event))
  107. ) ;; end eval-when
  108.  
  109. (eval-when (compile eval load)
  110. (defun allocate-extension-event-code (name)
  111.   ;; Allocate an event-code for an extension
  112.   ;; This is executed at COMPILE and LOAD time from DECLARE-EVENT.
  113.   ;; The event-code is used at compile-time by macros to index the following vectors:
  114.   ;; *event-key-vector* *event-macro-vector* *event-handler-vector* *event-send-vector*
  115.   (let ((event-code (get name 'event-code)))
  116.     (declare (type (or null card8) event-code))
  117.     (unless event-code
  118.       ;; First ensure the name is for a declared extension
  119.       (unless (dolist (extension *extensions*)
  120.         (when (member name (second extension))
  121.           (return t)))
  122.     (x-type-error name 'event-key))
  123.       (setq event-code (position nil *event-key-vector*
  124.                  :start *first-extension-event-code*))
  125.       (setf (svref *event-key-vector* event-code) name)
  126.       (setf (get name 'event-code) event-code))
  127.     event-code))
  128. ) ;; end eval-when
  129.  
  130. (defun get-internal-event-code (display code)
  131.   ;; Given an X11 event-code, return the internal event-code.
  132.   ;; The internal event-code is used for indexing into the following vectors:
  133.   ;; *event-key-vector* *event-handler-vector* *event-send-vector*
  134.   ;; Returns NIL when the event-code is for an extension that isn't handled.
  135.   (declare (type display display)
  136.        (type card8 code))
  137.   (declare (values (or null card8)))
  138.   (setq code (logand #x7f code))
  139.   (if (< code *first-extension-event-code*)
  140.       code
  141.     (let* ((code-offset (- code *first-extension-event-code*))
  142.        (event-extensions (display-event-extensions display))
  143.        (code (if (< code-offset (length event-extensions))
  144.              (aref event-extensions code-offset)
  145.            0)))
  146.       (declare (type card8 code-offset code))
  147.       (when (zerop code)
  148.     (x-cerror "Ignore the event"
  149.           'unimplemented-event :event-code code :display display))
  150.       code)))
  151.  
  152. (defun get-external-event-code (display event)
  153.   ;; Given an X11 event name, return the event-code
  154.   (declare (type display display)
  155.        (type event-key event))
  156.   (declare (values card8))
  157.   (let ((code (get-event-code event)))
  158.     (declare (type (or null card8) code))
  159.     (when (>= code *first-extension-event-code*)
  160.       (setq code (+ *first-extension-event-code*
  161.             (or (position code (display-event-extensions display))
  162.             (x-error 'undefined-event :display display :event-name event)))))
  163.     code))
  164.  
  165. (defmacro extension-opcode (display name)
  166.   ;; Returns the major opcode for extension NAME.
  167.   ;; This is a macro to enable NAME to be interned for fast run-time
  168.   ;; retrieval. 
  169.   ;; Note: The case of NAME is important.
  170.   (let ((name-symbol (kintern name))) ;; Intern name in the keyword package
  171.     `(or (second (assoc ',name-symbol (display-extension-alist ,display)))
  172.      (x-error 'absent-extension :name ',name-symbol :display ,display))))
  173.  
  174. (defun initialize-extensions (display)
  175.   ;; Initialize extensions for DISPLAY
  176.   (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0))
  177.     (extension-alist nil))
  178.     (declare (type vector event-extensions)
  179.          (type list extension-alist))
  180.     (dolist (extension *extensions*)
  181.       (let ((name (first extension))
  182.         (events (second extension)))
  183.     (declare (type keyword name)
  184.          (type list events))
  185.     (multiple-value-bind (major-opcode first-event first-error)
  186.         (query-extension display name)
  187.       (declare (type (or null card8) major-opcode first-event first-error))
  188.       (when (and major-opcode (plusp major-opcode))
  189.         (push (list name major-opcode first-event first-error)
  190.           extension-alist)
  191.         (when (plusp first-event) ;; When there are extension events
  192.           ;; Grow extension vector when needed
  193.           (let ((max-event (- (+ first-event (length events))
  194.                   *first-extension-event-code*)))
  195.         (declare (type card8 max-event))
  196.         (when (>= max-event (length event-extensions))
  197.           (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8
  198.                             :initial-element 0)))
  199.             (declare (type vector new-extensions))
  200.             (replace new-extensions event-extensions)
  201.             (setq event-extensions new-extensions))))
  202.           (dolist (event events)
  203.         (declare (type symbol event))
  204.         (setf (aref event-extensions (- first-event *first-extension-event-code*))
  205.               (get-event-code event))
  206.         (incf first-event)))))))
  207.     (setf (display-event-extensions display) event-extensions)
  208.     (setf (display-extension-alist display) extension-alist)))
  209.  
  210. ;;
  211. ;; Reply handlers
  212. ;;
  213.  
  214. (defvar *pending-command-free-list* nil)
  215.  
  216. (defun start-pending-command (display)
  217.   (declare (type display display))
  218.   (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list*
  219.                           pending-command-next pending-command)
  220.                  (make-pending-command))))
  221.     (declare (type pending-command pending-command))
  222.     (setf (pending-command-reply-buffer pending-command) nil)
  223.     (setf (pending-command-process pending-command) (current-process))
  224.     (setf (pending-command-sequence pending-command)
  225.       (ldb (byte 16 0) (1+ (buffer-request-number display))))
  226.     ;; Add the pending command to the end of the threaded list of pending
  227.     ;; commands for the display.
  228.     (with-event-queue-internal (display)
  229.       (threaded-nconc pending-command (display-pending-commands display)
  230.               pending-command-next pending-command))
  231.     pending-command))
  232.  
  233. (defun stop-pending-command (display pending-command)
  234.   (declare (type display display)
  235.        (type pending-command pending-command))
  236.   (with-event-queue-internal (display)
  237.     ;; Remove the pending command from the threaded list of pending commands
  238.     ;; for the display.
  239.     (threaded-delete pending-command (display-pending-commands display)
  240.              pending-command-next pending-command)
  241.     ;; Deallocate any reply buffers in this pending command
  242.     (loop
  243.       (let ((reply-buffer
  244.           (threaded-pop (pending-command-reply-buffer pending-command)
  245.                 reply-next reply-buffer)))
  246.     (declare (type (or null reply-buffer) reply-buffer))
  247.     (if reply-buffer
  248.         (deallocate-reply-buffer reply-buffer)
  249.       (return nil)))))
  250.   ;; Clear pointers to help the Garbage Collector
  251.   (setf (pending-command-process pending-command) nil)
  252.   ;; Deallocate this pending-command
  253.   (threaded-atomic-push pending-command *pending-command-free-list*
  254.             pending-command-next pending-command)
  255.   nil)
  256.  
  257. ;;;
  258.  
  259. (defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil))
  260.  
  261. (defun allocate-reply-buffer (size)
  262.   (declare (type array-index size))
  263.   (if (index<= size *replysize*)
  264.       (allocate-event)
  265.     (let ((index (integer-length (index1- size))))
  266.       (declare (type array-index index))
  267.       (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index)
  268.                    reply-next reply-buffer)
  269.       (make-reply-buffer (index-ash 1 index))))))
  270.  
  271. (defun deallocate-reply-buffer (reply-buffer)
  272.   (declare (type reply-buffer reply-buffer))
  273.   (let ((size (reply-size reply-buffer)))
  274.     (declare (type array-index size))
  275.     (if (index<= size *replysize*)
  276.     (deallocate-event reply-buffer)
  277.       (let ((index (integer-length (index1- size))))
  278.     (declare (type array-index index))
  279.     (threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index)
  280.                   reply-next reply-buffer)))))
  281.  
  282. ;;;
  283.  
  284. (defun read-error-input (display sequence reply-buffer token)
  285.   (declare (type display display)
  286.        (type reply-buffer reply-buffer)
  287.        (type card16 sequence))
  288.   (tagbody
  289.     start
  290.        (with-event-queue-internal (display)
  291.      (let ((command 
  292.          ;; Find any pending command with this sequence number.
  293.          (threaded-dolist (pending-command (display-pending-commands display)
  294.                            pending-command-next pending-command)
  295.            (when (= (pending-command-sequence pending-command) sequence)
  296.              (return pending-command)))))
  297.        (declare (type (or null pending-command) command))
  298.        (cond ((not (null command))
  299.           ;; Give this reply to the pending command
  300.           (threaded-nconc reply-buffer (pending-command-reply-buffer command)
  301.                   reply-next reply-buffer)
  302.           (process-wakeup (pending-command-process command)))
  303.          ((member :immediately (display-report-asynchronous-errors display))
  304.           ;; No pending command and we should report the error immediately
  305.           (go report-error))
  306.          (t
  307.           ;; No pending command found, count this as an asynchronous error
  308.           (threaded-nconc reply-buffer (display-asynchronous-errors display)
  309.                   reply-next reply-buffer)))))
  310.        (return-from read-error-input nil)
  311.     report-error
  312.        (note-input-complete display token)
  313.        (apply #'report-error display
  314.           (prog1 (make-error display reply-buffer t)
  315.              (deallocate-event reply-buffer)))))
  316.  
  317. (defun read-reply-input (display sequence length reply-buffer)
  318.   (declare (type display display)
  319.        (type (or null reply-buffer) reply-buffer)
  320.        (type card16 sequence)
  321.        (type array-index length))
  322.   (unwind-protect 
  323.       (progn
  324.     (when (index< *replysize* length)
  325.       (let ((repbuf nil))
  326.         (declare (type (or null reply-buffer) repbuf))
  327.         (unwind-protect
  328.         (progn
  329.           (setq repbuf (allocate-reply-buffer length))
  330.           (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer)
  331.                   0 *replysize*)
  332.           (deallocate-event (shiftf reply-buffer repbuf nil)))
  333.           (when repbuf
  334.         (deallocate-reply-buffer repbuf))))
  335.       (when (buffer-input display (reply-ibuf8 reply-buffer) *replysize* length)
  336.         (return-from read-reply-input t))
  337.       (setf (reply-data-size reply-buffer) length))
  338.     (with-event-queue-internal (display)
  339.       ;; Find any pending command with this sequence number.
  340.       (let ((command 
  341.           (threaded-dolist (pending-command (display-pending-commands display)
  342.                             pending-command-next pending-command)
  343.             (when (= (pending-command-sequence pending-command) sequence)
  344.               (return pending-command)))))
  345.         (declare (type (or null pending-command) command))
  346.         (when command 
  347.           ;; Give this reply to the pending command
  348.           (threaded-nconc (shiftf reply-buffer nil)
  349.                   (pending-command-reply-buffer command)
  350.                   reply-next reply-buffer)
  351.           (process-wakeup (pending-command-process command)))))
  352.     nil)
  353.     (when reply-buffer
  354.       (deallocate-reply-buffer reply-buffer))))
  355.  
  356. (defun read-event-input (display code reply-buffer)
  357.   (declare (type display display)
  358.        (type card8 code)
  359.        (type reply-buffer reply-buffer))
  360.   ;; Push the event in the input buffer on the display's event queue
  361.   (setf (event-code reply-buffer)
  362.     (get-internal-event-code display code))
  363.   (enqueue-event reply-buffer display)
  364.   nil)
  365.  
  366. (defun note-input-complete (display token)
  367.   (declare (type display display))
  368.   (when (eq (display-input-in-progress display) token)
  369.     ;; Indicate that input is no longer in progress
  370.     (setf (display-input-in-progress display) nil)
  371.     ;; Let the event process get the first chance to do input
  372.     (let ((process (display-event-process display)))
  373.       (when (not (null process))
  374.     (process-wakeup process)))
  375.     ;; Then give processes waiting for command responses a chance
  376.     (unless (display-input-in-progress display)
  377.       (with-event-queue-internal (display)
  378.     (threaded-dolist (command (display-pending-commands display)
  379.                   pending-command-next pending-command)
  380.       (process-wakeup (pending-command-process command)))))))
  381.  
  382. (defun read-input (display timeout force-output-p predicate &rest predicate-args)
  383.   (declare (type display display)
  384.        (type (or null number) timeout)
  385.        (type boolean force-output-p)
  386.        (dynamic-extent predicate-args))
  387.   (declare (type function predicate)
  388.        #+clx-ansi-common-lisp
  389.        (dynamic-extent predicate)
  390.        #+(and lispm (not clx-ansi-common-lisp))
  391.        (sys:downward-funarg predicate))
  392.   (let ((reply-buffer nil)
  393.     (token (or (current-process) (cons nil nil))))
  394.     (declare (type (or null reply-buffer) reply-buffer))
  395.     (unwind-protect 
  396.     (tagbody
  397.       loop
  398.          (when (display-dead display)
  399.            (x-error 'closed-display :display display))
  400.          (when (apply predicate predicate-args)
  401.            (return-from read-input nil))
  402.          ;; Check and see if we have to force output
  403.          (when (and force-output-p
  404.             (or (and (not (eq (display-input-in-progress display) token))
  405.                  (not (conditional-store
  406.                     (display-input-in-progress display) nil token)))
  407.                 (null (buffer-listen display))))
  408.            (go force-output))
  409.          ;; Ensure that ony one process is reading input.
  410.          (unless (or (eq (display-input-in-progress display) token)
  411.              (conditional-store (display-input-in-progress display) nil token))
  412.            (if (eql timeout 0)
  413.            (return-from read-input :timeout)
  414.          (apply #'process-block "CLX Input Lock"
  415.             #'(lambda (display predicate &rest predicate-args)
  416.                 (declare (type display display)
  417.                      (dynamic-extent predicate-args)
  418.                      (type function predicate)
  419.                      #+clx-ansi-common-lisp
  420.                      (dynamic-extent predicate)
  421.                      #+(and lispm (not clx-ansi-common-lisp))
  422.                      (sys:downward-funarg predicate))
  423.                 (or (apply predicate predicate-args)
  424.                 (null (display-input-in-progress display))
  425.                 (not (null (display-dead display)))))
  426.             display predicate predicate-args))
  427.            (go loop))
  428.          ;; Now start gobbling.
  429.          (setq reply-buffer (allocate-event))
  430.          (with-buffer-input (reply-buffer :sizes (8 16 32))
  431.            (let ((type 0))
  432.          (declare (type card8 type))
  433.          ;; Wait for input before we disallow aborts.
  434.          (unless (eql timeout 0)
  435.            (let ((eof-p (buffer-input-wait display timeout)))
  436.              (when eof-p (return-from read-input eof-p))))
  437.          (without-aborts
  438.            (let ((eof-p (buffer-input display buffer-bbuf 0 *replysize*
  439.                           (if force-output-p 0 timeout))))
  440.              (when eof-p
  441.                (when (eq eof-p :timeout)
  442.              (if force-output-p
  443.                  (go force-output)
  444.                (return-from read-input :timeout)))
  445.                (setf (display-dead display) t)
  446.                (return-from read-input eof-p)))
  447.            (setf (reply-data-size reply-buffer) *replysize*)
  448.            (when (= (the card8 (setq type (read-card8 0))) 1)
  449.              ;; Normal replies can be longer than *replysize*, so we
  450.              ;; have to handle them while aborts are still disallowed.
  451.              (let ((value
  452.                  (read-reply-input
  453.                    display (read-card16 2)
  454.                    (index+ *replysize* (index* (read-card32 4) 4))
  455.                    (shiftf reply-buffer nil))))
  456.                (when value
  457.              (return-from read-input value))
  458.                (go loop))))
  459.          (if (zerop type)
  460.              (read-error-input
  461.                display (read-card16 2) (shiftf reply-buffer nil) token)
  462.            (read-event-input
  463.              display (read-card8 0) (shiftf reply-buffer nil)))))
  464.          (go loop)
  465.       force-output 
  466.          (note-input-complete display token)
  467.          (display-force-output display)
  468.          (setq force-output-p nil)
  469.          (go loop))
  470.       (when (not (null reply-buffer))
  471.     (deallocate-reply-buffer reply-buffer))
  472.       (note-input-complete display token))))
  473.  
  474. (defun report-asynchronous-errors (display mode)
  475.   (when (and (display-asynchronous-errors display)
  476.          (member mode (display-report-asynchronous-errors display)))
  477.     (let ((aborted t))
  478.       (unwind-protect 
  479.       (loop
  480.         (let ((error
  481.             (with-event-queue-internal (display)
  482.               (threaded-pop (display-asynchronous-errors display)
  483.                     reply-next reply-buffer))))
  484.           (declare (type (or null reply-buffer) error))
  485.           (if error
  486.           (apply #'report-error display
  487.              (prog1 (make-error display error t)
  488.                 (deallocate-event error)))
  489.         (return (setq aborted nil)))))
  490.     ;; If we get aborted out of this, deallocate all outstanding asynchronous
  491.     ;; errors.
  492.     (when aborted 
  493.       (with-event-queue-internal (display)
  494.         (loop
  495.           (let ((reply-buffer
  496.               (threaded-pop (display-asynchronous-errors display)
  497.                     reply-next reply-buffer)))
  498.         (declare (type (or null reply-buffer) reply-buffer))
  499.         (if reply-buffer
  500.             (deallocate-event reply-buffer)
  501.           (return nil))))))))))
  502.  
  503. (defun wait-for-event (display timeout force-output-p)
  504.   (declare (type display display)
  505.        (type (or null number) timeout)
  506.        (type boolean force-output-p))
  507.   (let ((event-process-p (not (eql timeout 0))))
  508.     (declare (type boolean event-process-p))
  509.     (unwind-protect
  510.     (loop
  511.       (when event-process-p
  512.         (conditional-store (display-event-process display) nil (current-process)))
  513.       (let ((eof (read-input
  514.                display timeout force-output-p 
  515.                #'(lambda (display)
  516.                (declare (type display display))
  517.                (or (not (null (display-new-events display)))
  518.                    (and (display-asynchronous-errors display)
  519.                     (member :before-event-handling
  520.                         (display-report-asynchronous-errors display))
  521.                     t)))
  522.                display)))
  523.         (when eof (return eof)))
  524.       ;; Report asynchronous errors here if the user wants us to.
  525.       (when event-process-p
  526.         (report-asynchronous-errors display :before-event-handling))
  527.       (when (not (null (display-new-events display)))
  528.         (return nil)))
  529.       (when (and event-process-p
  530.          (eq (display-event-process display) (current-process)))
  531.     (setf (display-event-process display) nil)))))
  532.  
  533. (defun read-reply (display pending-command)
  534.   (declare (type display display)
  535.        (type pending-command pending-command))
  536.   (loop
  537.     (when (read-input display nil nil
  538.               #'(lambda (pending-command)
  539.               (declare (type pending-command pending-command))
  540.               (not (null (pending-command-reply-buffer pending-command))))
  541.               pending-command)
  542.       (x-error 'closed-display :display display))
  543.     (let ((reply-buffer
  544.         (with-event-queue-internal (display)
  545.           (threaded-pop (pending-command-reply-buffer pending-command)
  546.                 reply-next reply-buffer))))
  547.       (declare (type reply-buffer reply-buffer))
  548.       ;; Check for error.
  549.       (with-buffer-input (reply-buffer)
  550.     (ecase (read-card8 0)
  551.       (0 (apply #'report-error display
  552.             (prog1 (make-error display reply-buffer nil)
  553.                (deallocate-reply-buffer reply-buffer))))
  554.       (1 (return reply-buffer)))))))
  555.  
  556. ;;;
  557.  
  558. (defun event-listen (display &optional (timeout 0))
  559.   (declare (type display display)
  560.        (type (or null number) timeout)
  561.        (values number-of-events-queued eof-or-timeout))
  562.   ;; Returns the number of events queued locally, if any, else nil.  Hangs
  563.   ;; waiting for events, forever if timeout is nil, else for the specified
  564.   ;; number of seconds.
  565.   (let* ((current-event-symbol (car (display-current-event-symbol display)))
  566.      (current-event (and (boundp current-event-symbol)
  567.                  (symbol-value current-event-symbol)))
  568.      (queue (if current-event
  569.             (reply-next (the reply-buffer current-event))
  570.           (display-event-queue-head display))))
  571.     (declare (type symbol current-event-symbol)
  572.          (type (or null reply-buffer) current-event queue))
  573.     (if queue
  574.     (values
  575.       (with-event-queue-internal (display :timeout timeout)
  576.         (threaded-length queue reply-next reply-buffer))
  577.       nil)
  578.       (with-event-queue (display :timeout timeout :inline t)
  579.     (let ((eof-or-timeout (wait-for-event display timeout nil)))
  580.       (if eof-or-timeout
  581.           (values nil eof-or-timeout)
  582.         (values 
  583.           (with-event-queue-internal (display :timeout timeout)
  584.         (threaded-length (display-new-events display)
  585.                  reply-next reply-buffer))
  586.           nil)))))))
  587.  
  588. (defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys)
  589.   ;; The event is put at the head of the queue if append-p is nil, else the tail.
  590.   ;; Additional arguments depend on event-key, and are as specified above with
  591.   ;; declare-event, except that both resource-ids and resource objects are accepted
  592.   ;; in the event components.
  593.   (declare (type display display)
  594.        (type event-key event-key)
  595.        (type boolean append-p send-event-p)
  596.        (dynamic-extent args))
  597.   (unless (get event-key 'event-code)
  598.     (x-type-error event-key 'event-key))
  599.   (let* ((event (allocate-event))
  600.      (buffer (reply-ibuf8 event))
  601.      (event-code (get event-key 'event-code)))
  602.     (declare (type reply-buffer event)
  603.          (type buffer-bytes buffer)
  604.          (type (or null card8) event-code))
  605.     (unless event-code (x-type-error event-key 'event-key))
  606.     (setf (event-code event) event-code)
  607.     (with-display (display)
  608.       (apply (svref *event-send-vector* event-code) display args)
  609.       (buffer-replace buffer
  610.               (display-obuf8 display)
  611.               0
  612.               *replysize*
  613.               (index+ 12 (buffer-boffset display)))
  614.       (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code)
  615.         (aref buffer 2) 0
  616.         (aref buffer 3) 0))
  617.     (with-event-queue (display)
  618.       (if append-p
  619.       (enqueue-event event display)
  620.     (with-event-queue-internal (display)
  621.       (threaded-requeue event
  622.                 (display-event-queue-head display)
  623.                 (display-event-queue-tail display)
  624.                 reply-next reply-buffer))))))
  625.  
  626. (defun enqueue-event (new-event display)
  627.   (declare (type reply-buffer new-event)
  628.        (type display display))
  629.   ;; Place EVENT at the end of the event queue for DISPLAY
  630.   (let* ((event-code (event-code new-event))
  631.      (event-key (and (index< event-code (length *event-key-vector*))
  632.              (svref *event-key-vector* event-code))))
  633.     (declare (type array-index event-code)
  634.          (type (or null keyword) event-key))
  635.     (if (null event-key)
  636.     (unwind-protect
  637.         (cerror "Ignore this event" "No handler for ~s event" event-key)
  638.       (deallocate-event new-event))
  639.       (with-event-queue-internal (display)
  640.     (threaded-enqueue new-event
  641.               (display-event-queue-head display)
  642.               (display-event-queue-tail display)
  643.               reply-next reply-buffer)
  644.     (unless (display-new-events display)
  645.       (setf (display-new-events display) new-event))))))
  646.  
  647.  
  648. (defmacro define-event (name code)
  649.   `(eval-when (eval compile load)
  650.      (setf (svref *event-key-vector* ,code) ',name)
  651.      (setf (get ',name 'event-code) ,code)))
  652.  
  653. ;; Event names.  Used in "type" field in XEvent structures.  Not to be
  654. ;; confused with event masks above.  They start from 2 because 0 and 1
  655. ;; are reserved in the protocol for errors and replies. */
  656.  
  657. (define-event :key-press 2)
  658. (define-event :key-release 3)
  659. (define-event :button-press 4)
  660. (define-event :button-release 5)
  661. (define-event :motion-notify 6)
  662. (define-event :enter-notify 7)
  663. (define-event :leave-notify 8)
  664. (define-event :focus-in 9)
  665. (define-event :focus-out 10)
  666. (define-event :keymap-notify 11)
  667. (define-event :exposure 12)
  668. (define-event :graphics-exposure 13)
  669. (define-event :no-exposure 14)
  670. (define-event :visibility-notify 15)
  671. (define-event :create-notify 16)
  672. (define-event :destroy-notify 17)
  673. (define-event :unmap-notify 18)
  674. (define-event :map-notify 19)
  675. (define-event :map-request 20)
  676. (define-event :reparent-notify 21)
  677. (define-event :configure-notify 22)
  678. (define-event :configure-request 23)
  679. (define-event :gravity-notify 24)
  680. (define-event :resize-request 25)
  681. (define-event :circulate-notify 26)
  682. (define-event :circulate-request 27)
  683. (define-event :property-notify 28)
  684. (define-event :selection-clear 29)
  685. (define-event :selection-request 30)
  686. (define-event :selection-notify 31)
  687. (define-event :colormap-notify 32)
  688. (define-event :client-message 33)
  689. (define-event :mapping-notify 34)
  690.  
  691.  
  692. (defmacro declare-event (event-codes &body declares)
  693.   ;; Used to indicate the keyword arguments for handler functions in
  694.   ;; process-event and event-case.
  695.   ;; Generates the functions used in SEND-EVENT.
  696.   ;; A compiler warning is printed when all of EVENT-CODES are not
  697.   ;; defined by a preceding DEFINE-EXTENSION.
  698.   ;; The body is a list of declarations, each of which has the form:
  699.   ;; (type . items)  Where type is a data-type, and items is a list of
  700.   ;; symbol names.  The item order corresponds to the order of fields
  701.   ;; in the event sent by the server.  An item may be a list of items.
  702.   ;; In this case, each item is aliased to the same event field.
  703.   ;; This is used to give all events an EVENT-WINDOW item.
  704.   ;; See the INPUT file for lots of examples.
  705.   (declare (type (or keyword list) event-codes)
  706.        (type (alist (field-type symbol) (field-names list))
  707.                  declares))
  708.   (when (atom event-codes) (setq event-codes (list event-codes)))
  709.   (setq event-codes (mapcar #'canonicalize-event-name event-codes))
  710.   (let* ((keywords nil)
  711.      (name (first event-codes))
  712.      (get-macro (xintern name '-event-get-macro))
  713.      (get-function (xintern name '-event-get))
  714.      (put-function (xintern name '-event-put)))
  715.     (multiple-value-bind (get-code get-index get-sizes)
  716.     (get-put-items
  717.       2 declares nil
  718.       #'(lambda (type index item args)
  719.           (flet ((event-get (type index item args)
  720.                (unless (member type '(pad8 pad16))
  721.              `(,(kintern item)
  722.                (,(getify type) ,index ,@args)))))
  723.         (if (atom item)
  724.             (event-get type index item args)
  725.           (mapcan #'(lambda (item)
  726.                   (event-get type index item args))
  727.               item)))))
  728.       (declare (ignore get-index))
  729.       (multiple-value-bind (put-code put-index put-sizes)
  730.       (get-put-items
  731.         2 declares t
  732.         #'(lambda (type index item args)
  733.         (unless (member type '(pad8 pad16))
  734.           (if (atom item)
  735.               (progn
  736.             (push item keywords)
  737.             `((,(putify type) ,index ,item ,@args)))
  738.             (let ((names (mapcar #'(lambda (name) (kintern name))
  739.                      item)))
  740.               (setq keywords (append item keywords))
  741.               `((,(putify type) ,index
  742.              (check-consistency ',names ,@item) ,@args)))))))
  743.     (declare (ignore put-index))
  744.     `(within-definition (,name declare-event)
  745.        (defun ,get-macro (display event-key variable)
  746.          ;; Note: we take pains to macroexpand the get-code here to enable application
  747.          ;; code to be compiled without having the CLX macros file loaded.
  748.          (subst display '%buffer
  749.             (getf `(:display (the display ,display)
  750.                 :event-key (the keyword ,event-key)
  751.                 :event-code (the card8 (logand #x7f (read-card8 0)))
  752.                 :send-event-p (the boolean (logbitp 7 (read-card8 0)))
  753.                 ,@',(mapcar #'macroexpand get-code))
  754.               variable)))
  755.  
  756.        (defun ,get-function (display event handler)
  757.          (declare (type display display)
  758.               (type reply-buffer event))
  759.          (declare (type function handler)
  760.               #+clx-ansi-common-lisp
  761.               (dynamic-extent handler)
  762.               #+(and lispm (not clx-ansi-common-lisp))
  763.               (sys:downward-funarg handler))
  764.          (reading-event (event :display display :sizes (8 16 ,@get-sizes))
  765.            (funcall handler
  766.             :display display
  767.             :event-key (svref *event-key-vector* (event-code event))
  768.             :event-code (logand #x7f (card8-get 0))
  769.             :send-event-p (logbitp 7 (card8-get 0))
  770.             ,@get-code)))
  771.  
  772.        (defun ,put-function (display &key ,@(setq keywords (nreverse keywords))
  773.                  &allow-other-keys)
  774.          (declare (type display display))
  775.          ,(when (member 'sequence keywords)
  776.         `(unless sequence (setq sequence (display-request-number display))))
  777.          (with-buffer-output (display :sizes ,put-sizes
  778.                       :index (index+ (buffer-boffset display) 12))
  779.            ,@put-code))
  780.        
  781.        ,@(mapcar #'(lambda (name)
  782.              (allocate-extension-event-code name)
  783.              `(let ((event-code (or (get ',name 'event-code)
  784.                         (allocate-extension-event-code ',name))))
  785.                 (setf (svref *event-macro-vector* event-code)
  786.                   (function ,get-macro))
  787.                 (setf (svref *event-handler-vector* event-code)
  788.                   (function ,get-function))
  789.                 (setf (svref *event-send-vector* event-code)
  790.                   (function ,put-function))))
  791.              event-codes)
  792.        ',name)))))
  793.  
  794. (defun check-consistency (names &rest args)
  795.   ;; Ensure all args are nil or have the same value.
  796.   ;; Returns the consistent non-nil value.
  797.   (let ((value (car args)))
  798.     (dolist (arg (cdr args))
  799.       (if value
  800.       (when (and arg (not (eq arg value)))
  801.         (x-error 'inconsistent-parameters
  802.              :parameters (mapcan #'list names args)))
  803.     (setq value arg)))
  804.     value))
  805.  
  806. (declare-event (:key-press :key-release :button-press :button-release)
  807.   ;; for key-press and key-release, code is the keycode
  808.   ;; for button-press and button-release, code is the button number
  809.   (data code)
  810.   (card16 sequence)
  811.   ((or null card32) time)
  812.   (window root (window event-window))
  813.   ((or null window) child)
  814.   (int16 root-x root-y x y)
  815.   (card16 state)
  816.   (boolean same-screen-p)
  817.   )
  818.  
  819. (declare-event :motion-notify
  820.   ((data boolean) hint-p)
  821.   (card16 sequence)
  822.   ((or null card32) time)
  823.   (window root (window event-window))
  824.   ((or null window) child)
  825.   (int16 root-x root-y x y)
  826.   (card16 state)
  827.   (boolean same-screen-p))
  828.  
  829. (declare-event (:enter-notify :leave-notify)
  830.   ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind)
  831.   (card16 sequence)
  832.   ((or null card32) time)
  833.   (window root (window event-window))
  834.   ((or null window) child)
  835.   (int16 root-x root-y x y)
  836.   (card16 state)
  837.   ((member8 :normal :grab :ungrab) mode)
  838.   ((bit 0) focus-p)
  839.   ((bit 1) same-screen-p))
  840.  
  841. (declare-event (:focus-in :focus-out)
  842.   ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
  843.           :pointer :pointer-root :none))
  844.    kind)
  845.   (card16 sequence)
  846.   (window (window event-window))
  847.   ((member8 :normal :while-grabbed :grab :ungrab) mode))
  848.  
  849. (declare-event :keymap-notify
  850.   ((bit-vector256 0) keymap))
  851.  
  852. (declare-event :exposure
  853.   (card16 sequence)
  854.   (window (window event-window))
  855.   (card16 x y width height count))
  856.  
  857. (declare-event :graphics-exposure
  858.   (card16 sequence)
  859.   (drawable (drawable event-window))
  860.   (card16 x y width height)
  861.   (card16 minor)  ;; Minor opcode
  862.   (card16 count)
  863.   (card8 major))
  864.  
  865. (declare-event :no-exposure
  866.   (card16 sequence)
  867.   (drawable (drawable event-window))
  868.   (card16 minor)
  869.   (card8  major))
  870.  
  871. (declare-event :visibility-notify
  872.   (card16 sequence)
  873.   (window (window event-window))
  874.   ((member8 :unobscured :partially-obscured :fully-obscured) state))
  875.  
  876. (declare-event :create-notify
  877.   (card16 sequence)
  878.   (window (parent event-window) window)
  879.   (int16 x y)
  880.   (card16 width height border-width)
  881.   (boolean override-redirect-p))
  882.  
  883. (declare-event :destroy-notify
  884.   (card16 sequence)
  885.   (window event-window window))
  886.  
  887. (declare-event :unmap-notify
  888.   (card16 sequence)
  889.   (window event-window window)
  890.   (boolean configure-p))
  891.  
  892. (declare-event :map-notify
  893.   (card16 sequence)
  894.   (window event-window window)
  895.   (boolean override-redirect-p))
  896.  
  897. (declare-event :map-request
  898.   (card16 sequence)
  899.   (window (parent event-window) window))
  900.  
  901. (declare-event :reparent-notify
  902.   (card16 sequence)
  903.   (window event-window window parent)
  904.   (int16 x y)
  905.   (boolean override-redirect-p))
  906.  
  907. (declare-event :configure-notify
  908.   (card16 sequence)
  909.   (window event-window window)
  910.   ((or null window) above-sibling)
  911.   (int16 x y)
  912.   (card16 width height border-width)
  913.   (boolean override-redirect-p))
  914.  
  915. (declare-event :configure-request
  916.   ((data (member :above :below :top-if :bottom-if :opposite)) stack-mode)
  917.   (card16 sequence)
  918.   (window (parent event-window) window)
  919.   ((or null window) above-sibling)
  920.   (int16 x y)
  921.   (card16 width height border-width value-mask))
  922.  
  923. (declare-event :gravity-notify
  924.   (card16 sequence)
  925.   (window event-window window)
  926.   (int16 x y))
  927.  
  928. (declare-event :resize-request
  929.   (card16 sequence)
  930.   (window (window event-window))
  931.   (card16 width height))
  932.  
  933. (declare-event :circulate-notify
  934.   (card16 sequence)
  935.   (window event-window window parent)
  936.   ((member16 :top :bottom) place))
  937.  
  938. (declare-event :circulate-request
  939.   (card16 sequence)
  940.   (window (parent event-window) window)
  941.   (pad16 1 2)
  942.   ((member16 :top :bottom) place))
  943.  
  944. (declare-event :property-notify
  945.   (card16 sequence)
  946.   (window (window event-window))
  947.   (keyword atom) ;; keyword
  948.   ((or null card32) time)
  949.   ((member16 :new-value :deleted) state))
  950.  
  951. (declare-event :selection-clear
  952.   (card16 sequence)
  953.   ((or null card32) time)
  954.   (window (window event-window)) 
  955.   (keyword selection) ;; keyword
  956.   )
  957.  
  958. (declare-event :selection-request
  959.   (card16 sequence)
  960.   ((or null card32) time)
  961.   (window (window event-window) requestor)
  962.   (keyword selection target)
  963.   ((or null keyword) property)
  964.   )
  965.  
  966. (declare-event :selection-notify
  967.   (card16 sequence)
  968.   ((or null card32) time)
  969.   (window (window event-window))
  970.   (keyword selection target)
  971.   ((or null keyword) property)
  972.   )
  973.  
  974. (declare-event :colormap-notify
  975.   (card16 sequence)
  976.   (window (window event-window))
  977.   ((or null colormap) colormap)
  978.   (boolean new-p installed-p))
  979.  
  980. (declare-event :client-message
  981.   (data format)
  982.   (card16 sequence)
  983.   (window (window event-window))
  984.   (keyword type)
  985.   ((client-message-sequence format) data))
  986.  
  987. (declare-event :mapping-notify
  988.   (card16 sequence)
  989.   ((member8 :modifier :keyboard :pointer) request)
  990.   (card8 start) ;; first key-code
  991.   (card8 count))
  992.  
  993.  
  994. ;;
  995. ;; EVENT-LOOP
  996. ;;
  997.  
  998. (defun event-loop-setup (display)
  999.   (declare (type display display)
  1000.        (values progv-vars progv-vals
  1001.            current-event-symbol current-event-discarded-p-symbol))
  1002.   (let* ((progv-vars (display-current-event-symbol display))
  1003.      (current-event-symbol (first progv-vars))
  1004.      (current-event-discarded-p-symbol (second progv-vars)))
  1005.     (declare (type list progv-vars)
  1006.          (type symbol current-event-symbol current-event-discarded-p-symbol))
  1007.     (values
  1008.       progv-vars 
  1009.       (list (if (boundp current-event-symbol)
  1010.         ;; The current event is already bound, so bind it to the next
  1011.         ;; event.
  1012.         (let ((event (symbol-value current-event-symbol)))
  1013.           (declare (type (or null reply-buffer) event))
  1014.           (and event (reply-next (the reply-buffer event))))
  1015.           ;; The current event isn't bound, so bind it to the head of the
  1016.           ;; event queue.
  1017.           (display-event-queue-head display))
  1018.         nil)
  1019.       current-event-symbol
  1020.       current-event-discarded-p-symbol)))
  1021.  
  1022. (defun event-loop-step-before (display timeout force-output-p current-event-symbol)
  1023.   (declare (type display display)
  1024.        (type (or null number) timeout)
  1025.        (type boolean force-output-p)
  1026.        (type symbol current-event-symbol)
  1027.        (values event eof-or-timeout))
  1028.   (unless (symbol-value current-event-symbol)
  1029.     (let ((eof-or-timeout (wait-for-event display timeout force-output-p)))
  1030.       (when eof-or-timeout
  1031.     (return-from event-loop-step-before (values nil eof-or-timeout))))
  1032.     (setf (symbol-value current-event-symbol) (display-new-events display)))
  1033.   (let ((event (symbol-value current-event-symbol)))
  1034.     (declare (type reply-buffer event))
  1035.     (with-event-queue-internal (display)
  1036.       (when (eq event (display-new-events display))
  1037.     (setf (display-new-events display) (reply-next event))))
  1038.     (values event nil)))
  1039.  
  1040. (defun dequeue-event (display event)
  1041.   (declare (type display display)
  1042.        (type reply-buffer event)
  1043.        (values next))
  1044.   ;; Remove the current event from the event queue
  1045.   (with-event-queue-internal (display)
  1046.     (let ((next (reply-next event))
  1047.       (head (display-event-queue-head display)))
  1048.       (declare (type (or null reply-buffer) next head))
  1049.       (when (eq event (display-new-events display))
  1050.     (setf (display-new-events display) next))
  1051.       (cond ((eq event head)
  1052.          (threaded-dequeue (display-event-queue-head display)
  1053.                    (display-event-queue-tail display)
  1054.                    reply-next reply-buffer))
  1055.         ((null head)
  1056.          (setq next nil))
  1057.         (t
  1058.          (do* ((previous head current)
  1059.            (current (reply-next previous) (reply-next previous)))
  1060.           ((or (null current) (eq event current))
  1061.            (when (eq event current)
  1062.              (when (eq current (display-event-queue-tail display))
  1063.                (setf (display-event-queue-tail display) previous))
  1064.              (setf (reply-next previous) next)))
  1065.            (declare (type reply-buffer previous)
  1066.             (type (or null reply-buffer) current)))))
  1067.       next)))
  1068.  
  1069. (defun event-loop-step-after
  1070.        (display event discard-p current-event-symbol current-event-discarded-p-symbol
  1071.     &optional aborted)
  1072.   (declare (type display display)
  1073.        (type reply-buffer event)
  1074.        (type boolean discard-p aborted)
  1075.        (type symbol current-event-symbol current-event-discarded-p-symbol))
  1076.   (when (and discard-p
  1077.          (not aborted)
  1078.          (not (symbol-value current-event-discarded-p-symbol)))
  1079.     (discard-current-event display))
  1080.   (let ((next (reply-next event)))
  1081.     (declare (type (or null reply-buffer) next))
  1082.     (when (symbol-value current-event-discarded-p-symbol)
  1083.       (setf (symbol-value current-event-discarded-p-symbol) nil)
  1084.       (setq next (dequeue-event display event))
  1085.       (deallocate-event event))
  1086.     (setf (symbol-value current-event-symbol) next)))
  1087.  
  1088. (defmacro event-loop ((display event timeout force-output-p discard-p) &body body)
  1089.   ;; Bind EVENT to the events for DISPLAY.
  1090.   ;; This is the "GUTS" of process-event and event-case.
  1091.   `(let ((.display. ,display)
  1092.      (.timeout. ,timeout)
  1093.      (.force-output-p. ,force-output-p)
  1094.      (.discard-p. ,discard-p))
  1095.      (declare (type display .display.)
  1096.           (type (or null number) .timeout.)
  1097.           (type boolean .force-output-p. .discard-p.))
  1098.      (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.)))
  1099.        (multiple-value-bind (.progv-vars. .progv-vals.
  1100.                  .current-event-symbol. .current-event-discarded-p-symbol.)
  1101.        (event-loop-setup .display.)
  1102.      (declare (type list .progv-vars. .progv-vals.)
  1103.           (type symbol .current-event-symbol. .current-event-discarded-p-symbol.))
  1104.      (progv .progv-vars. .progv-vals.
  1105.        (loop
  1106.          (multiple-value-bind (.event. .eof-or-timeout.)
  1107.          (event-loop-step-before
  1108.            .display. .timeout. .force-output-p.
  1109.            .current-event-symbol.)
  1110.            (declare (type (or null reply-buffer) .event.))
  1111.            (when (null .event.) (return (values nil .eof-or-timeout.)))
  1112.            (let ((.aborted. t))
  1113.          (unwind-protect 
  1114.              (progn
  1115.                (let ((,event .event.))
  1116.              (declare (type reply-buffer ,event))
  1117.              ,@body)
  1118.                (setq .aborted. nil))
  1119.            (event-loop-step-after
  1120.              .display. .event. .discard-p.
  1121.              .current-event-symbol. .current-event-discarded-p-symbol.
  1122.              .aborted.))))))))))
  1123.  
  1124. (defun discard-current-event (display)
  1125.   ;; Discard the current event for DISPLAY.
  1126.   ;; Returns NIL when the event queue is empty, else T.
  1127.   ;; To ensure events aren't ignored, application code should only call
  1128.   ;; this when throwing out of event-case or process-next-event, or from
  1129.   ;; inside even-case, event-cond or process-event when :peek-p is T and
  1130.   ;; :discard-p is NIL.
  1131.   (declare (type display display)
  1132.        (values boolean))
  1133.   (let* ((symbols (display-current-event-symbol display))
  1134.      (event
  1135.        (let ((current-event-symbol (first symbols)))
  1136.          (declare (type symbol current-event-symbol))
  1137.          (when (boundp current-event-symbol)
  1138.            (symbol-value current-event-symbol)))))
  1139.     (declare (type list symbols)
  1140.          (type (or null reply-buffer) event))
  1141.     (unless (null event)
  1142.       ;; Set the discarded-p flag
  1143.       (let ((current-event-discarded-p-symbol (second symbols)))
  1144.     (declare (type symbol current-event-discarded-p-symbol))
  1145.     (when (boundp current-event-discarded-p-symbol)
  1146.       (setf (symbol-value current-event-discarded-p-symbol) t)))
  1147.       ;; Return whether the event queue is empty
  1148.       (not (null (reply-next (the reply-buffer event)))))))
  1149.  
  1150. ;;
  1151. ;; PROCESS-EVENT
  1152. ;;
  1153. (defun process-event (display &key handler timeout peek-p discard-p (force-output-p t))
  1154.   ;; If force-output-p is true, first invokes display-force-output.  Invokes handler
  1155.   ;; on each queued event until handler returns non-nil, and that returned object is
  1156.   ;; then returned by process-event.  If peek-p is true, then the event is not
  1157.   ;; removed from the queue.  If discard-p is true, then events for which handler
  1158.   ;; returns nil are removed from the queue, otherwise they are left in place.  Hangs
  1159.   ;; until non-nil is generated for some event, or for the specified timeout (in
  1160.   ;; seconds, if given); however, it is acceptable for an implementation to wait only
  1161.   ;; once on network data, and therefore timeout prematurely.  Returns nil on
  1162.   ;; timeout.  If handler is a sequence, it is expected to contain handler functions
  1163.   ;; specific to each event class; the event code is used to index the sequence,
  1164.   ;; fetching the appropriate handler.  Handler is called with raw resource-ids, not
  1165.   ;; with resource objects.  The arguments to the handler are described using declare-event.
  1166.   ;;
  1167.   ;; T for peek-p means the event (for which the handler returns non-nil) is not removed
  1168.   ;; from the queue (it is left in place), NIL means the event is removed.
  1169.   
  1170.   (declare (type display display)
  1171.        (type (or null number) timeout)
  1172.        (type boolean peek-p discard-p force-output-p))
  1173.   (declare (type t handler)
  1174.        #+clx-ansi-common-lisp
  1175.        (dynamic-extent handler)
  1176.        #+(and lispm (not clx-ansi-common-lisp))
  1177.        (sys:downward-funarg #+Genera * #-Genera handler))
  1178.   (event-loop (display event timeout force-output-p discard-p)
  1179.     (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT
  1180.        (event-decoder (and (index< event-code (length *event-handler-vector*))
  1181.                    (svref *event-handler-vector* event-code))))
  1182.       (declare (type array-index event-code)
  1183.            (type (or null function) event-decoder))
  1184.       (if event-decoder
  1185.       (let ((event-handler (if (functionp handler)
  1186.                    handler
  1187.                    (and (type? handler 'sequence)
  1188.                     (< event-code (length handler))
  1189.                     (elt handler event-code)))))
  1190.         (if event-handler
  1191.         (let ((result (funcall event-decoder display event event-handler)))
  1192.           (when result
  1193.             (unless peek-p
  1194.               (discard-current-event display))
  1195.             (return result)))
  1196.           (cerror "Ignore this event"
  1197.               "No handler for ~s event"
  1198.               (svref *event-key-vector* event-code))))
  1199.     (cerror "Ignore this event"
  1200.         "Server Error: event with unknown event code ~d received."
  1201.         event-code)))))
  1202.  
  1203. (defun make-event-handlers (&key (type 'array) default)
  1204.   (declare (type t type)            ;Sequence type specifier
  1205.        (type function default)
  1206.        (values sequence))            ;Default handler for initial content
  1207.   ;; Makes a handler sequence suitable for process-event
  1208.   (make-sequence type *max-events* :initial-element default))
  1209.    
  1210. (defun event-handler (handlers event-key)
  1211.   (declare (type sequence handlers)
  1212.        (type event-key event-key)
  1213.        (values function))
  1214.   ;; Accessor for a handler sequence
  1215.   (elt handlers (position event-key *event-key-vector* :test #'eq)))
  1216.  
  1217. (defun set-event-handler (handlers event-key handler)
  1218.   (declare (type sequence handlers)
  1219.        (type event-key event-key)
  1220.        (type function handler)
  1221.        (values handler))
  1222.   (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler))
  1223.  
  1224. (defsetf event-handler set-event-handler)
  1225.  
  1226. ;;
  1227. ;; EVENT-CASE
  1228. ;; 
  1229.  
  1230. (defmacro event-case ((&rest args) &body clauses)
  1231.   ;; If force-output-p is true, first invokes display-force-output.  Executes the
  1232.   ;; matching clause for each queued event until a clause returns non-nil, and that
  1233.   ;; returned object is then returned by event-case.  If peek-p is true, then the
  1234.   ;; event is not removed from the queue.  If discard-p is true, then events for
  1235.   ;; which the clause returns nil are removed from the queue, otherwise they are left
  1236.   ;; in place.  Hangs until non-nil is generated for some event, or for the specified
  1237.   ;; timeout (in seconds, if given); however, it is acceptable for an implementation
  1238.   ;; to wait only once on network data, and therefore timeout prematurely.  Returns
  1239.   ;; nil on timeout.  In each clause, event-or-events is an event-key or a list of
  1240.   ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise
  1241.   ;; (but only in the last clause).  The keys are not evaluated, and it is an error
  1242.   ;; for the same key to appear in more than one clause.  Args is the list of event
  1243.   ;; components of interest; corresponding values (if any) are bound to variables
  1244.   ;; with these names (i.e., the args are variable names, not keywords, the keywords
  1245.   ;; are derived from the variable names).  An arg can also be a (keyword var) form,
  1246.   ;; as for keyword args in a lambda lists.  If no t/otherwise clause appears, it is
  1247.   ;; equivalent to having one that returns nil.
  1248.   (declare (arglist (display &key timeout peek-p discard-p (force-output-p t))
  1249.            (event-or-events ((&rest args) |...|) &body body) |...|))
  1250.   ;; Event-case is just event-cond with the whole body in the test-form
  1251.   `(event-cond ,args
  1252.            ,@(mapcar
  1253.            #'(lambda (clause)
  1254.                `(,(car clause) ,(cadr clause) (progn ,@(cddr clause))))
  1255.            clauses)))
  1256.  
  1257. ;;
  1258. ;; EVENT-COND
  1259. ;; 
  1260.  
  1261. (defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t))
  1262.               &body clauses)
  1263.   ;; The clauses of event-cond are of the form:
  1264.   ;; (event-or-events binding-list test-form . body-forms)
  1265.   ;;
  1266.   ;; EVENT-OR-EVENTS    event-key or a list of event-keys (but they
  1267.   ;;            need not be typed as keywords) or the symbol t
  1268.   ;;            or otherwise (but only in the last clause).  If
  1269.   ;;            no t/otherwise clause appears, it is equivalent
  1270.   ;;            to having one that returns nil.  The keys are
  1271.   ;;            not evaluated, and it is an error for the same
  1272.   ;;            key to appear in more than one clause.
  1273.   ;;
  1274.   ;; BINDING-LIST    The list of event components of interest.
  1275.   ;;            corresponding values (if any) are bound to
  1276.   ;;            variables with these names (i.e., the binding-list
  1277.   ;;            has variable names, not keywords, the keywords are
  1278.   ;;            derived from the variable names).  An arg can also
  1279.   ;;            be a (keyword var) form, as for keyword args in a
  1280.   ;;            lambda list.
  1281.   ;;
  1282.   ;; The matching TEST-FORM for each queued event is executed until a
  1283.   ;; clause's test-form returns non-nil.  Then the BODY-FORMS are
  1284.   ;; evaluated, returning the (possibly multiple) values of the last
  1285.   ;; form from event-cond.  If there are no body-forms then, if the
  1286.   ;; test-form is non-nil, the value of the test-form is returned as a
  1287.   ;; single value.
  1288.   ;;
  1289.   ;; Options:
  1290.   ;; FORCE-OUTPUT-P    When true, first invoke display-force-output if no
  1291.   ;;              input is pending.
  1292.   ;;
  1293.   ;; PEEK-P        When true, then the event is not removed from the queue.
  1294.   ;;
  1295.   ;; DISCARD-P        When true, then events for which the clause returns nil
  1296.   ;;             are removed from the queue, otherwise they are left in place.
  1297.   ;;
  1298.   ;; TIMEOUT        If NIL, hang until non-nil is generated for some event's
  1299.   ;;            test-form. Otherwise return NIL after TIMEOUT seconds have
  1300.   ;;            elapsed.
  1301.   ;;
  1302.   (declare (arglist (display &key timeout peek-p discard-p force-output-p)
  1303.            (event-or-events (&rest args) test-form &body body) |...|))
  1304.   (let ((event (gensym))
  1305.     (disp (gensym))
  1306.     (peek (gensym)))
  1307.     `(let ((,disp ,display)
  1308.        (,peek ,peek-p))
  1309.        (declare (type display ,disp))
  1310.        (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p)
  1311.      (event-dispatch (,disp ,event ,peek) ,@clauses)))))
  1312.  
  1313. (defun get-event-code (event)
  1314.   ;; Returns the event code given an event-key
  1315.   (declare (type event-key event))
  1316.   (declare (values card8))
  1317.   (or (get event 'event-code)
  1318.       (x-type-error event 'event-key)))
  1319.  
  1320. (defun universal-event-get-macro (display event-key variable)
  1321.   (getf
  1322.     `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code
  1323.            (the card8 (logand 127 (read-card8 0))) :send-event-p
  1324.            (the boolean (logbitp 7 (read-card8 0))))
  1325.     variable))
  1326.  
  1327. (defmacro event-dispatch ((display event peek-p) &body clauses)
  1328.   ;; Helper macro for event-case
  1329.   ;; CLAUSES are of the form:
  1330.   ;; (event-or-events binding-list test-form . body-forms)
  1331.   (let ((event-key (gensym))
  1332.     (all-events (make-array *max-events* :element-type 'bit :initial-element 0)))
  1333.     `(reading-event (,event)
  1334.        (let ((,event-key (svref *event-key-vector* (event-code ,event))))
  1335.      (case ,event-key
  1336.        ,@(mapcar
  1337.            #'(lambda (clause)        ; Translate event-cond clause to case clause
  1338.            (let* ((events (first clause))
  1339.               (arglist (second clause))
  1340.               (test-form (third clause))
  1341.               (body-forms (cdddr clause)))
  1342.              (flet ((event-clause (display peek-p first-form rest-of-forms)
  1343.                   (if rest-of-forms
  1344.                   `(when ,first-form
  1345.                      (unless ,peek-p (discard-current-event ,display))
  1346.                      (return (progn ,@rest-of-forms)))
  1347.                 ;; No body forms, return the result of the test form
  1348.                 (let ((result (gensym)))
  1349.                   `(let ((,result ,first-form))
  1350.                      (when ,result
  1351.                        (unless ,peek-p (discard-current-event ,display))
  1352.                        (return ,result)))))))
  1353.  
  1354.                (if (member events '(otherwise t))
  1355.                ;; code for OTHERWISE clause.
  1356.                ;; Find all events NOT used by other clauses
  1357.                (let ((keys (do ((i 0 (1+ i))
  1358.                         (key nil)
  1359.                         (result nil))
  1360.                        ((>= i *max-events*) result)
  1361.                      (setq key (svref *event-key-vector* i))
  1362.                      (when (and key (zerop (aref all-events i)))
  1363.                        (push key result)))))
  1364.                  `(otherwise
  1365.                 (binding-event-values
  1366.                   (,display ,event-key ,(or keys :universal) ,@arglist)
  1367.                   ,(event-clause display peek-p test-form body-forms))))
  1368.  
  1369.              ;; Code for normal clauses
  1370.              (let (true-events) ;; canonicalize event-names
  1371.                (if (consp events)
  1372.                    (progn
  1373.                  (setq true-events (mapcar #'canonicalize-event-name events))
  1374.                  (dolist (event true-events)
  1375.                    (setf (aref all-events (get-event-code event)) 1)))
  1376.                  (setf true-events (canonicalize-event-name events)
  1377.                    (aref all-events (get-event-code true-events)) 1))
  1378.                `(,true-events
  1379.                  (binding-event-values
  1380.                    (,display ,event-key ,true-events ,@arglist)
  1381.                    ,(event-clause display peek-p test-form body-forms))))))))
  1382.            clauses))))))
  1383.  
  1384. (defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body)
  1385.   ;; Execute BODY with the variables in VALUE-LIST bound to components of the
  1386.   ;; EVENT-KEYS events.
  1387.   (unless (consp event-keys) (setq event-keys (list event-keys)))
  1388.   (flet ((var-key (var) (kintern (if (consp var) (first var) var)))
  1389.      (var-symbol (var) (if (consp var) (second var) var)))
  1390.     ;; VARS is an alist of:
  1391.     ;;  (component-key ((event-key event-key ...) . extraction-code)
  1392.     ;;               ((event-key event-key ...) . extraction-code) ...)
  1393.     ;; There should probably be accessor macros for this, instead of things like cdadr.
  1394.     (let ((vars (mapcar #'(lambda (var) (list var)) value-list))
  1395.       (multiple-p nil))
  1396.       ;; Fill in the VARS alist with event-keys and extraction-code
  1397.       (do ((keys event-keys (cdr keys))
  1398.        (temp nil))
  1399.       ((endp keys))
  1400.     (let* ((key (car keys))
  1401.            (binder (case key
  1402.              (:universal #'universal-event-get-macro)
  1403.              (otherwise (svref *event-macro-vector* (get-event-code key))))))
  1404.       (dolist (var vars)
  1405.         (let ((code (funcall binder display event-key (var-key (car var)))))
  1406.           (unless code (warn "~a isn't a component of the ~s event"
  1407.                  (var-key (car var)) key))
  1408.           (if (setq temp (member code (cdr var) :key #'cdr :test #'equal))
  1409.           (push key (caar temp))
  1410.         (push `((,key) . ,code) (cdr var)))))))
  1411.       ;; Bind all the values
  1412.       `(let ,(mapcar #'(lambda (var)
  1413.              (if (cddr var) ;; if more than one binding form
  1414.                  (progn (setq multiple-p t)
  1415.                     (var-symbol (car var)))
  1416.                (list (var-symbol (car var)) (cdadr var))))
  1417.              vars)
  1418.      ;; When some values come from different places, generate code to set them
  1419.      ,(when multiple-p
  1420.         `(case ,event-key
  1421.            ,@(do ((keys event-keys (cdr keys))
  1422.               (clauses nil) ;; alist of (event-keys bindings)
  1423.               (clause nil nil)
  1424.               (temp))
  1425.              ((endp keys)
  1426.               (dolist (clause clauses)
  1427.             (unless (cdar clause) ;; Atomize single element lists
  1428.               (setf (car clause) (caar clause))))
  1429.               clauses)
  1430.            ;; Gather up all the bindings associated with (car keys)
  1431.            (dolist (var vars)
  1432.              (when (cddr var) ;; when more than one binding form
  1433.                (dolist (events (cdr var))
  1434.              (when (member (car keys) (car events))
  1435.                ;; Optimize for event-window being the same as some other binding
  1436.                (if (setq temp (member (cdr events) clause
  1437.                           :key #'caddr
  1438.                           :test #'equal))
  1439.                    (setq clause
  1440.                      (nconc clause `((setq ,(car var) ,(second (car temp))))))
  1441.                  (push `(setq ,(car var) ,(cdr events)) clause))))))
  1442.            ;; Merge bindings for (car keys) with other bindings
  1443.            (when clause
  1444.              (if (setq temp (member clause clauses :key #'cdr :test #'equal))
  1445.              (push (car keys) (caar temp))
  1446.                (push `((,(car keys)) . ,clause) clauses))))))
  1447.      ,@body))))
  1448.  
  1449.  
  1450. ;;;-----------------------------------------------------------------------------
  1451. ;;; Error Handling
  1452. ;;;-----------------------------------------------------------------------------
  1453.  
  1454. (eval-when (eval compile load)
  1455. (defparameter
  1456.   *xerror-vector*
  1457.   '#(unknown-error
  1458.      request-error                ; 1  bad request code
  1459.      value-error                ; 2  integer parameter out of range
  1460.      window-error                ; 3  parameter not a Window
  1461.      pixmap-error                ; 4  parameter not a Pixmap
  1462.      atom-error                    ; 5  parameter not an Atom
  1463.      cursor-error                ; 6  parameter not a Cursor
  1464.      font-error                    ; 7  parameter not a Font
  1465.      match-error                ; 8  parameter mismatch
  1466.      drawable-error                ; 9  parameter not a Pixmap or Window
  1467.      access-error                ; 10 attempt to access private resource"
  1468.      alloc-error                ; 11 insufficient resources
  1469.      colormap-error                ; 12 no such colormap
  1470.      gcontext-error                ; 13 parameter not a GContext
  1471.      id-choice-error                ; 14 invalid resource ID for this connection
  1472.      name-error                    ; 15 font or color name does not exist
  1473.      length-error                ; 16 request length incorrect;
  1474.                         ;    internal Xlib error
  1475.      implementation-error            ; 17 server is defective
  1476.      ))
  1477. )
  1478.  
  1479. (defun make-error (display event asynchronous)
  1480.   (declare (type display display)
  1481.        (type reply-buffer event)
  1482.        (type boolean asynchronous))
  1483.   (reading-event (event)
  1484.     (let* ((error-code (read-card8 1))
  1485.        (error-key (get-error-key display error-code))
  1486.        (error-decode-function (get error-key 'error-decode-function))
  1487.        (params (funcall error-decode-function display event)))
  1488.       (list* error-code error-key
  1489.          :asynchronous asynchronous :current-sequence (display-request-number display)
  1490.          params))))
  1491.  
  1492. (defun report-error (display error-code error-key &rest params)
  1493.   (declare (type display display)
  1494.        (dynamic-extent params))
  1495.   ;; All errors (synchronous and asynchronous) are processed by calling
  1496.   ;; an error handler in the display.  The handler is called with the display
  1497.   ;; as the first argument and the error-key as its second argument. If handler is
  1498.   ;; an array it is expected to contain handler functions specific to
  1499.   ;; each error; the error code is used to index the array, fetching the
  1500.   ;; appropriate handler. Any results returned by the handler are ignored;;
  1501.   ;; it is assumed the handler either takes care of the error completely,
  1502.   ;; or else signals. For all core errors, additional keyword/value argument
  1503.   ;; pairs are:
  1504.   ;;    :major integer
  1505.   ;;    :minor integer
  1506.   ;;    :sequence integer
  1507.   ;;    :current-sequence integer
  1508.   ;;    :asynchronous (member t nil)
  1509.   ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window
  1510.   ;; errors another pair is:
  1511.   ;;    :resource-id integer
  1512.   ;; For :atom errors, another pair is:
  1513.   ;;    :atom-id integer
  1514.   ;; For :value errors, another pair is:
  1515.   ;;    :value integer
  1516.   (let* ((handler (display-error-handler display))
  1517.      (handler-function
  1518.        (if (type? handler 'sequence)
  1519.            (elt handler error-code)
  1520.          handler)))
  1521.     (apply handler-function display error-key params)))
  1522.  
  1523. (defun request-name (code &optional display)
  1524.   (if (< code (length *request-names*))
  1525.       (svref *request-names* code)
  1526.     (dolist (extension (and display (display-extension-alist display)) "unknown")
  1527.       (when (= code (second extension))
  1528.     (return (first extension))))))
  1529.  
  1530. #-(or clx-ansi-common-lisp excl lcl3.0)
  1531. (define-condition request-error (x-error)
  1532.   ((display :reader request-error-display)
  1533.    (error-key :reader request-error-error-key)
  1534.    (major :reader request-error-major)
  1535.    (minor :reader request-error-minor)
  1536.    (sequence :reader request-error-sequence)
  1537.    (current-sequence :reader request-error-current-sequence)
  1538.    (asynchronous :reader request-error-asynchronous))
  1539.   (:report report-request-error))
  1540.  
  1541. (defun report-request-error (condition stream)
  1542.   (let ((error-key (request-error-error-key condition))
  1543.     (asynchronous (request-error-asynchronous condition))
  1544.     (major (request-error-major condition))
  1545.     (minor (request-error-minor condition))
  1546.     (sequence (request-error-sequence condition))
  1547.     (current-sequence (request-error-current-sequence condition)))           
  1548.     (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]"
  1549.         asynchronous error-key (= sequence current-sequence)
  1550.         sequence current-sequence major minor
  1551.         (request-name major (request-error-display condition)))))
  1552.  
  1553. ;; Since the :report arg is evaluated as (function report-request-error) the
  1554. ;; define-condition must come after the function definition.
  1555. #+(or clx-ansi-common-lisp excl lcl3.0)
  1556. (define-condition request-error (x-error)
  1557.   ((display :reader request-error-display :initarg :display)
  1558.    (error-key :reader request-error-error-key :initarg :error-key)
  1559.    (major :reader request-error-major :initarg :major)
  1560.    (minor :reader request-error-minor :initarg :minor)
  1561.    (sequence :reader request-error-sequence :initarg :sequence)
  1562.    (current-sequence :reader request-error-current-sequence :initarg :current-sequence)
  1563.    (asynchronous :reader request-error-asynchronous :initarg :asynchronous))
  1564.   (:report report-request-error))
  1565.  
  1566. (define-condition resource-error (request-error)
  1567.   ((resource-id :reader resource-error-resource-id :initarg :resource-id))
  1568.   (:report
  1569.     (lambda (condition stream)
  1570.       (report-request-error condition stream)
  1571.       (format stream " ID #x~x" (resource-error-resource-id condition)))))  
  1572.  
  1573. (define-condition unknown-error (request-error)
  1574.   ((error-code :reader unknown-error-error-code :initarg :error-code))
  1575.   (:report
  1576.     (lambda (condition stream)
  1577.       (report-request-error condition stream)
  1578.       (format stream " Error Code ~d." (unknown-error-error-code condition)))))
  1579.  
  1580. (define-condition access-error (request-error) ())
  1581.  
  1582. (define-condition alloc-error (request-error) ())
  1583.  
  1584. (define-condition atom-error (request-error)
  1585.   ((atom-id :reader atom-error-atom-id :initarg :atom-id))
  1586.   (:report
  1587.     (lambda (condition stream)
  1588.       (report-request-error condition stream)
  1589.       (format stream " Atom-ID #x~x" (atom-error-atom-id condition)))))
  1590.  
  1591. (define-condition colormap-error (resource-error) ())
  1592.  
  1593. (define-condition cursor-error (resource-error) ())
  1594.  
  1595. (define-condition drawable-error (resource-error) ())
  1596.  
  1597. (define-condition font-error (resource-error) ())
  1598.  
  1599. (define-condition gcontext-error (resource-error) ())
  1600.  
  1601. (define-condition id-choice-error (resource-error) ())
  1602.  
  1603. (define-condition illegal-request-error (request-error) ())
  1604.  
  1605. (define-condition length-error (request-error) ())
  1606.  
  1607. (define-condition match-error (request-error) ())
  1608.  
  1609. (define-condition name-error (request-error) ())
  1610.  
  1611. (define-condition pixmap-error (resource-error) ())
  1612.  
  1613. (define-condition value-error (request-error)
  1614.   ((value :reader value-error-value :initarg :value))
  1615.   (:report
  1616.     (lambda (condition stream)
  1617.       (report-request-error condition stream)
  1618.       (format stream " Value ~d." (value-error-value condition)))))
  1619.  
  1620. (define-condition window-error (resource-error)())
  1621.  
  1622. (define-condition implementation-error (request-error) ())
  1623.  
  1624. ;;-----------------------------------------------------------------------------
  1625. ;; Internal error conditions signaled by CLX
  1626.  
  1627. (define-condition x-type-error (type-error x-error)
  1628.   ((type-string :reader x-type-error-type-string :initarg :type-string))
  1629.   (:report
  1630.     (lambda (condition stream)
  1631.       (format stream "~s isn't a ~a"
  1632.           (type-error-datum condition)
  1633.           (or (x-type-error-type-string condition)
  1634.           (type-error-expected-type condition))))))
  1635.  
  1636. (define-condition closed-display (x-error)
  1637.   ((display :reader closed-display-display :initarg :display))
  1638.   (:report
  1639.     (lambda (condition stream)
  1640.       (format stream "Attempt to use closed display ~s"
  1641.           (closed-display-display condition)))))
  1642.  
  1643. (define-condition lookup-error (x-error)
  1644.   ((id :reader lookup-error-id :initarg :id)
  1645.    (display :reader lookup-error-display :initarg :display)
  1646.    (type :reader lookup-error-type :initarg :type)
  1647.    (object :reader lookup-error-object :initarg :object))
  1648.   (:report
  1649.     (lambda (condition stream)
  1650.       (format stream "ID ~d from display ~s should have been a ~s, but was ~s"
  1651.           (lookup-error-id condition)
  1652.           (lookup-error-display condition)
  1653.           (lookup-error-type condition)
  1654.           (lookup-error-object condition)))))  
  1655.  
  1656. (define-condition connection-failure (x-error)
  1657.   ((major-version :reader connection-failure-major-version :initarg :major-version)
  1658.    (minor-version :reader connection-failure-minor-version :initarg :minor-version)
  1659.    (host :reader connection-failure-host :initarg :host)
  1660.    (display :reader connection-failure-display :initarg :display)
  1661.    (reason :reader connection-failure-reason :initarg :reason))
  1662.   (:report
  1663.     (lambda (condition stream)
  1664.       (format stream "Connection failure to X~d.~d server ~a display ~d: ~a"
  1665.           (connection-failure-major-version condition)
  1666.           (connection-failure-minor-version condition)
  1667.           (connection-failure-host condition)
  1668.           (connection-failure-display condition)
  1669.           (connection-failure-reason condition)))))
  1670.   
  1671. (define-condition reply-length-error (x-error)
  1672.   ((reply-length :reader reply-length-error-reply-length :initarg :reply-length)
  1673.    (expected-length :reader reply-length-error-expected-length :initarg :expected-length)
  1674.    (display :reader reply-length-error-display :initarg :display))
  1675.   (:report
  1676.     (lambda (condition stream)
  1677.       (format stream "Reply length was ~d when ~d words were expected for display ~s"
  1678.           (reply-length-error-reply-length condition)
  1679.           (reply-length-error-expected-length condition)
  1680.           (reply-length-error-display condition)))))  
  1681.  
  1682. (define-condition reply-timeout (x-error)
  1683.   ((timeout :reader reply-timeout-timeout :initarg :timeout)
  1684.    (display :reader reply-timeout-display :initarg :display))
  1685.   (:report
  1686.     (lambda (condition stream)
  1687.       (format stream "Timeout after waiting ~d seconds for a reply for display ~s"
  1688.           (reply-timeout-timeout condition)
  1689.           (reply-timeout-display condition)))))  
  1690.  
  1691. (define-condition sequence-error (x-error)
  1692.   ((display :reader sequence-error-display :initarg :display)
  1693.    (req-sequence :reader sequence-error-req-sequence :initarg :req-sequence)
  1694.    (msg-sequence :reader sequence-error-msg-sequence :initarg :msg-sequence))
  1695.   (:report
  1696.     (lambda (condition stream)
  1697.       (format stream "Reply out of sequence for display ~s.~%  Expected ~d, Got ~d"
  1698.           (sequence-error-display condition)
  1699.           (sequence-error-req-sequence condition)
  1700.           (sequence-error-msg-sequence condition)))))  
  1701.  
  1702. (define-condition unexpected-reply (x-error)
  1703.   ((display :reader unexpected-reply-display :initarg :display)
  1704.    (msg-sequence :reader unexpected-reply-msg-sequence :initarg :msg-sequence)
  1705.    (req-sequence :reader unexpected-reply-req-sequence :initarg :req-sequence)
  1706.    (length :reader unexpected-reply-length :initarg :length))
  1707.   (:report
  1708.     (lambda (condition stream)
  1709.       (format stream "Display ~s received a server reply when none was expected.~@
  1710.               Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes."
  1711.           (unexpected-reply-display condition)
  1712.           (unexpected-reply-req-sequence condition)
  1713.           (unexpected-reply-msg-sequence condition)
  1714.           (unexpected-reply-length condition)))))
  1715.  
  1716. (define-condition missing-parameter (x-error)
  1717.   ((parameter :reader missing-parameter-parameter :initarg :parameter))
  1718.   (:report
  1719.     (lambda (condition stream)
  1720.       (let ((parm (missing-parameter-parameter condition)))
  1721.     (if (consp parm)
  1722.         (format stream "One or more of the required parameters ~a is missing."
  1723.             parm)
  1724.       (format stream "Required parameter ~a is missing or null." parm))))))
  1725.  
  1726. ;; This can be signalled anywhere a pseudo font access fails.
  1727. (define-condition invalid-font (x-error)
  1728.   ((font :reader invalid-font-font :initarg :font))
  1729.   (:report
  1730.     (lambda (condition stream)
  1731.       (format stream "Can't access font ~s" (invalid-font-font condition)))))
  1732.  
  1733. (define-condition device-busy (x-error)
  1734.   ((display :reader device-busy-display :initarg :display))
  1735.   (:report
  1736.     (lambda (condition stream)
  1737.       (format stream "Device busy for display ~s"
  1738.           (device-busy-display condition)))))
  1739.  
  1740. (define-condition unimplemented-event (x-error)
  1741.   ((display :reader unimplemented-event-display :initarg :display)
  1742.    (event-code :reader unimplemented-event-event-code :initarg :event-code))
  1743.   (:report
  1744.     (lambda (condition stream)
  1745.       (format stream "Event code ~d not implemented for display ~s"
  1746.           (unimplemented-event-event-code condition)
  1747.           (unimplemented-event-display condition)))))
  1748.  
  1749. (define-condition undefined-event (x-error)
  1750.   ((display :reader undefined-event-display :initarg :display)
  1751.    (event-name :reader undefined-event-event-name :initarg :event-name))
  1752.   (:report
  1753.     (lambda (condition stream)
  1754.       (format stream "Event code ~d undefined for display ~s"
  1755.           (undefined-event-event-name condition)
  1756.           (undefined-event-display condition)))))
  1757.  
  1758. (define-condition absent-extension (x-error)
  1759.   ((name :reader absent-extension-name :initarg :name)
  1760.    (display :reader absent-extension-display :initarg :display))
  1761.   (:report
  1762.     (lambda (condition stream)
  1763.       (format stream "Extension ~a isn't defined for display ~s"
  1764.           (absent-extension-name condition)
  1765.           (absent-extension-display condition)))))
  1766.  
  1767. (define-condition inconsistent-parameters (x-error)
  1768.   ((parameters :reader inconsistent-parameters-parameters :initarg :parameters))
  1769.   (:report
  1770.     (lambda (condition stream)
  1771.       (format stream "inconsistent-parameters:~{ ~s~}"
  1772.           (inconsistent-parameters-parameters condition)))))
  1773.  
  1774. (defun get-error-key (display error-code)
  1775.   (declare (type display display)
  1776.        (type array-index error-code))
  1777.   ;; Return the error-key associated with error-code
  1778.   (if (< error-code (length *xerror-vector*))
  1779.       (svref *xerror-vector* error-code)
  1780.     ;; Search the extensions for the error
  1781.     (dolist (entry (display-extension-alist display) 'unknown-error)
  1782.       (let* ((event-name (first entry))
  1783.          (first-error (fourth entry))
  1784.          (errors (third (assoc event-name *extensions*))))
  1785.     (declare (type keyword event-name)
  1786.          (type array-index first-error)
  1787.          (type list errors))
  1788.     (when (and errors
  1789.            (index<= first-error error-code
  1790.                 (index+ first-error (index- (length errors) 1))))
  1791.       (return (nth (index- error-code first-error) errors)))))))
  1792.  
  1793. (defmacro define-error (error-key function)
  1794.   ;; Associate a function with ERROR-KEY which will be called with
  1795.   ;; parameters DISPLAY and REPLY-BUFFER and
  1796.   ;; returns a plist of keyword/value pairs which will be passed on
  1797.   ;; to the error handler.  A compiler warning is printed when
  1798.   ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION.
  1799.   ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type
  1800.   ;;       macros for getting error fields. See DECODE-CORE-ERROR for
  1801.   ;;       an example.
  1802.   (declare (type symbol error-key)
  1803.        (type function function))
  1804.   ;; First ensure the name is for a declared extension
  1805.   (unless (or (find error-key *xerror-vector*)
  1806.           (dolist (extension *extensions*)
  1807.         (when (member error-key (third extension))
  1808.           (return t))))
  1809.     (x-type-error error-key 'error-key))
  1810.   `(setf (get ',error-key 'error-decode-function) (function ,function)))
  1811.  
  1812. ;; All core errors use this, so we make it available to extensions.
  1813. (defun decode-core-error (display event &optional arg)
  1814.   ;; All core errors have the following keyword/argument pairs:
  1815.   ;;    :major integer
  1816.   ;;    :minor integer
  1817.   ;;    :sequence integer
  1818.   ;; In addition, many have an additional argument that comes from the
  1819.   ;; same place in the event, but is named differently.  When the ARG
  1820.   ;; argument is specified, the keyword ARG with card32 value starting
  1821.   ;; at byte 4 of the event is returned with the other keyword/argument
  1822.   ;; pairs.
  1823.   (declare (type display display)
  1824.        (type reply-buffer event)
  1825.        (type (or null keyword) arg))
  1826.   (declare (values keyword/arg-plist))
  1827.   display
  1828.   (reading-event (event)
  1829.     (let* ((sequence (read-card16 2))
  1830.        (minor-code (read-card16 8))
  1831.        (major-code (read-card8 10))
  1832.        (result (list :major major-code
  1833.              :minor minor-code
  1834.              :sequence sequence)))
  1835.       (when arg
  1836.     (setq result (list* arg (read-card32 4) result)))
  1837.       result)))
  1838.  
  1839. (defun decode-resource-error (display event)
  1840.   (decode-core-error display event :resource-id))
  1841.  
  1842. (define-error unknown-error
  1843.   (lambda (display event)
  1844.     (list* :error-code (aref (reply-ibuf8 event) 1)
  1845.        (decode-core-error display event))))
  1846.  
  1847. (define-error request-error decode-core-error)        ; 1  bad request code
  1848.  
  1849. (define-error value-error                ; 2  integer parameter out of range
  1850.   (lambda (display event)
  1851.     (decode-core-error display event :value)))
  1852.  
  1853. (define-error window-error decode-resource-error)    ; 3  parameter not a Window
  1854.  
  1855. (define-error pixmap-error decode-resource-error)    ; 4  parameter not a Pixmap
  1856.  
  1857. (define-error atom-error                ; 5  parameter not an Atom
  1858.   (lambda (display event)
  1859.     (decode-core-error display event :atom-id)))
  1860.  
  1861. (define-error cursor-error decode-resource-error)    ; 6  parameter not a Cursor
  1862.  
  1863. (define-error font-error decode-resource-error)        ; 7  parameter not a Font
  1864.  
  1865. (define-error match-error decode-core-error)        ; 8  parameter mismatch
  1866.  
  1867. (define-error drawable-error decode-resource-error)    ; 9  parameter not a Pixmap or Window
  1868.  
  1869. (define-error access-error decode-core-error)        ; 10 attempt to access private resource"
  1870.  
  1871. (define-error alloc-error decode-core-error)        ; 11 insufficient resources
  1872.  
  1873. (define-error colormap-error decode-resource-error)    ; 12 no such colormap
  1874.  
  1875. (define-error gcontext-error decode-resource-error)    ; 13 parameter not a GContext
  1876.  
  1877. (define-error id-choice-error decode-resource-error)    ; 14 invalid resource ID for this connection
  1878.  
  1879. (define-error name-error decode-core-error)        ; 15 font or color name does not exist
  1880.  
  1881. (define-error length-error decode-core-error)        ; 16 request length incorrect;
  1882.                             ;    internal Xlib error
  1883.  
  1884. (define-error implementation-error decode-core-error)    ; 17 server is defective
  1885.