/[cmucl]/src/clx/input.lisp
ViewVC logotype

Diff of /src/clx/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9.2.1 by rtoy, Sat May 22 11:54:05 2004 UTC revision 1.12 by rtoy, Wed Jun 17 18:22:46 2009 UTC
# Line 24  Line 24 
24  ;;;  Date       Author  Description  ;;;  Date       Author  Description
25  ;;; -------------------------------------------------------------------------------------  ;;; -------------------------------------------------------------------------------------
26  ;;; 12/10/87    LGO     Created  ;;; 12/10/87    LGO     Created
27    
28  #+cmu  #+cmu
29  (ext:file-comment  (ext:file-comment "$Id$")
   "$Header$")  
30    
31  (in-package :xlib)  (in-package :xlib)
32    
33  ;; Event Resource  ;; Event Resource
34  (defvar *event-free-list* nil) ;; List of unused (processed) events  (defvar *event-free-list* nil) ;; List of unused (processed) events
35    
36  (eval-when (eval compile load)  (eval-when (:compile-toplevel :load-toplevel :execute)
37  (defconstant *max-events* 64) ;; Maximum number of events supported (the X11 alpha release only has 34)    ;; Maximum number of events supported (the X11 alpha release only has 34)
38  (defvar *event-key-vector* (make-array *max-events* :initial-element nil)    (defconstant +max-events+ 64)
39    "Vector of event keys - See define-event")    (defvar *event-key-vector* (make-array +max-events+ :initial-element nil)
40  )      "Vector of event keys - See define-event"))
41  (defvar *event-macro-vector* (make-array *max-events* :initial-element nil)  
42    (defvar *event-macro-vector* (make-array +max-events+ :initial-element nil)
43    "Vector of event handler functions - See declare-event")    "Vector of event handler functions - See declare-event")
44  (defvar *event-handler-vector* (make-array *max-events* :initial-element nil)  (defvar *event-handler-vector* (make-array +max-events+ :initial-element nil)
45    "Vector of event handler functions - See declare-event")    "Vector of event handler functions - See declare-event")
46  (defvar *event-send-vector* (make-array *max-events* :initial-element nil)  (defvar *event-send-vector* (make-array +max-events+ :initial-element nil)
47    "Vector of event sending functions - See declare-event")    "Vector of event sending functions - See declare-event")
48    
49  (defun allocate-event ()  (defun allocate-event ()
50    (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer)    (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer)
51        (make-reply-buffer *replysize*)))        (make-reply-buffer +replysize+)))
52    
53  (defun deallocate-event (reply-buffer)  (defun deallocate-event (reply-buffer)
54    (declare (type reply-buffer reply-buffer))    (declare (type reply-buffer reply-buffer))
55    (setf (reply-size reply-buffer) *replysize*)    (setf (reply-size reply-buffer) +replysize+)
56    (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer))    (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer))
57    
58  ;; Extensions are handled as follows:  ;; Extensions are handled as follows:
# Line 97  Line 98 
98             (type list events errors))             (type list events errors))
99    (let ((name-symbol (kintern name)) ;; Intern name in the keyword package    (let ((name-symbol (kintern name)) ;; Intern name in the keyword package
100          (event-list (mapcar #'canonicalize-event-name events)))          (event-list (mapcar #'canonicalize-event-name events)))
101      `(eval-when (compile load eval)      `(eval-when (:compile-toplevel :load-toplevel :execute)
102         (setq *extensions* (cons (list ',name-symbol ',event-list ',errors)         (setq *extensions* (cons (list ',name-symbol ',event-list ',errors)
103                                  (delete ',name-symbol *extensions* :key #'car))))))                                  (delete ',name-symbol *extensions* :key #'car))))))
104    
105  (eval-when (compile eval load)  (eval-when (:compile-toplevel :load-toplevel :execute)
106  (defun canonicalize-event-name (event)    (defun canonicalize-event-name (event)
107    ;; Returns the event name keyword given an event name stringable      ;; Returns the event name keyword given an event name stringable
108    (declare (type stringable event))      (declare (type stringable event))
109    (declare (clx-values event-key))      (declare (clx-values event-key))
110    (kintern event))      (kintern event)))
111  ) ;; end eval-when  
112    (defun extension-event-key-p (key)
113  (eval-when (compile eval load)    (dolist (extension *extensions* nil)
114  (defun allocate-extension-event-code (name)      (when (member key (second extension))
115    ;; Allocate an event-code for an extension        (return t))))
116    ;; This is executed at COMPILE and LOAD time from DECLARE-EVENT.  
117    ;; The event-code is used at compile-time by macros to index the following vectors:  (eval-when (:compile-toplevel :load-toplevel :execute)
118    ;; *event-key-vector* *event-macro-vector* *event-handler-vector* *event-send-vector*    (defun allocate-extension-event-code (name)
119    (let ((event-code (get name 'event-code)))      ;; Allocate an event-code for an extension.  This is executed at
120      (declare (type (or null card8) event-code))      ;; COMPILE and LOAD time from DECLARE-EVENT.  The event-code is
121      (unless event-code      ;; used at compile-time by macros to index the following vectors:
122        ;; First ensure the name is for a declared extension      ;; *EVENT-KEY-VECTOR* *EVENT-MACRO-VECTOR* *EVENT-HANDLER-VECTOR*
123        (unless (dolist (extension *extensions*)      ;; *EVENT-SEND-VECTOR*
124                  (when (member name (second extension))      (let ((event-code (get name 'event-code)))
125                    (return t)))        (declare (type (or null card8) event-code))
126          (x-type-error name 'event-key))        (unless event-code
127        (setq event-code (position nil *event-key-vector*          ;; First ensure the name is for a declared extension
128                                   :start *first-extension-event-code*))          (unless (extension-event-key-p name)
129        (setf (svref *event-key-vector* event-code) name)            (x-type-error name 'event-key))
130        (setf (get name 'event-code) event-code))          (setq event-code (position nil *event-key-vector*
131      event-code))                                     :start *first-extension-event-code*))
132  ) ;; end eval-when          (setf (svref *event-key-vector* event-code) name)
133            (setf (get name 'event-code) event-code))
134          event-code)))
135    
136  (defun get-internal-event-code (display code)  (defun get-internal-event-code (display code)
137    ;; Given an X11 event-code, return the internal event-code.    ;; Given an X11 event-code, return the internal event-code.
# Line 263  Line 266 
266    
267  (defun allocate-reply-buffer (size)  (defun allocate-reply-buffer (size)
268    (declare (type array-index size))    (declare (type array-index size))
269    (if (index<= size *replysize*)    (if (index<= size +replysize+)
270        (allocate-event)        (allocate-event)
271      (let ((index (integer-length (index1- size))))      (let ((index (integer-length (index1- size))))
272        (declare (type array-index index))        (declare (type array-index index))
# Line 275  Line 278 
278    (declare (type reply-buffer reply-buffer))    (declare (type reply-buffer reply-buffer))
279    (let ((size (reply-size reply-buffer)))    (let ((size (reply-size reply-buffer)))
280      (declare (type array-index size))      (declare (type array-index size))
281      (if (index<= size *replysize*)      (if (index<= size +replysize+)
282          (deallocate-event reply-buffer)          (deallocate-event reply-buffer)
283        (let ((index (integer-length (index1- size))))        (let ((index (integer-length (index1- size))))
284          (declare (type array-index index))          (declare (type array-index index))
# Line 324  Line 327 
327             (type array-index length))             (type array-index length))
328    (unwind-protect    (unwind-protect
329        (progn        (progn
330          (when (index< *replysize* length)          (when (index< +replysize+ length)
331            (let ((repbuf nil))            (let ((repbuf nil))
332              (declare (type (or null reply-buffer) repbuf))              (declare (type (or null reply-buffer) repbuf))
333              (unwind-protect              (unwind-protect
334                  (progn                  (progn
335                    (setq repbuf (allocate-reply-buffer length))                    (setq repbuf (allocate-reply-buffer length))
336                    (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer)                    (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer)
337                                    0 *replysize*)                                    0 +replysize+)
338                    (deallocate-event (shiftf reply-buffer repbuf nil)))                    (deallocate-event (shiftf reply-buffer repbuf nil)))
339                (when repbuf                (when repbuf
340                  (deallocate-reply-buffer repbuf))))                  (deallocate-reply-buffer repbuf))))
341            (when (buffer-input display (reply-ibuf8 reply-buffer) *replysize* length)            (when (buffer-input display (reply-ibuf8 reply-buffer) +replysize+ length)
342              (return-from read-reply-input t))              (return-from read-reply-input t))
343            (setf (reply-data-size reply-buffer) length))            (setf (reply-data-size reply-buffer) length))
344          (with-event-queue-internal (display)          (with-event-queue-internal (display)
# Line 388  Line 391 
391             (type generalized-boolean force-output-p)             (type generalized-boolean force-output-p)
392             (dynamic-extent predicate-args))             (dynamic-extent predicate-args))
393    (declare (type function predicate)    (declare (type function predicate)
394             (dynamic-extent predicate))             #+clx-ansi-common-lisp
395               (dynamic-extent predicate)
396               #+(and lispm (not clx-ansi-common-lisp))
397               (sys:downward-funarg predicate))
398    (let ((reply-buffer nil)    (let ((reply-buffer nil)
399          (token (or (current-process) (cons nil nil))))          (token (or (current-process) (cons nil nil))))
400      (declare (type (or null reply-buffer) reply-buffer))      (declare (type (or null reply-buffer) reply-buffer))
# Line 406  Line 412 
412                                          (display-input-in-progress display) nil token)))                                          (display-input-in-progress display) nil token)))
413                              (null (buffer-listen display))))                              (null (buffer-listen display))))
414                 (go force-output))                 (go force-output))
415               ;; Ensure that ony one process is reading input.             ;; Ensure that only one process is reading input.
416               (unless (or (eq (display-input-in-progress display) token)             (unless (or (eq (display-input-in-progress display) token)
417                           (conditional-store (display-input-in-progress display) nil token))                         (conditional-store (display-input-in-progress display) nil token))
418                 (if (eql timeout 0)               (if (eql timeout 0)
419                     (return-from read-input :timeout)                   (return-from read-input :timeout)
420                   (apply #'process-block "CLX Input Lock"                   (apply #'process-block "CLX Input Lock"
421                          #'(lambda (display predicate &rest predicate-args)                          #'(lambda (display predicate &rest predicate-args)
422                              (declare (type display display)                              (declare (type display display)
423                                       (dynamic-extent predicate-args)                                       (dynamic-extent predicate-args)
424                                       (type function predicate)                                       (type function predicate)
425                                       (dynamic-extent predicate))                                       #+clx-ansi-common-lisp
426                                         (dynamic-extent predicate)
427                                         #+(and lispm (not clx-ansi-common-lisp))
428                                         (sys:downward-funarg predicate))
429                              (or (apply predicate predicate-args)                              (or (apply predicate predicate-args)
430                                  (null (display-input-in-progress display))                                  (null (display-input-in-progress display))
431                                  (not (null (display-dead display)))))                                  (not (null (display-dead display)))))
# Line 432  Line 441 
441                     (let ((eof-p (buffer-input-wait display timeout)))                     (let ((eof-p (buffer-input-wait display timeout)))
442                       (when eof-p (return-from read-input eof-p))))                       (when eof-p (return-from read-input eof-p))))
443                   (without-aborts                   (without-aborts
444                     (let ((eof-p (buffer-input display buffer-bbuf 0 *replysize*                     (let ((eof-p (buffer-input display buffer-bbuf 0 +replysize+
445                                                (if force-output-p 0 timeout))))                                                (if force-output-p 0 timeout))))
446                       (when eof-p                       (when eof-p
447                         (when (eq eof-p :timeout)                         (when (eq eof-p :timeout)
# Line 441  Line 450 
450                             (return-from read-input :timeout)))                             (return-from read-input :timeout)))
451                         (setf (display-dead display) t)                         (setf (display-dead display) t)
452                         (return-from read-input eof-p)))                         (return-from read-input eof-p)))
453                     (setf (reply-data-size reply-buffer) *replysize*)                     (setf (reply-data-size reply-buffer) +replysize+)
454                     (when (= (the card8 (setq type (read-card8 0))) 1)                     (when (= (the card8 (setq type (read-card8 0))) 1)
455                       ;; Normal replies can be longer than *replysize*, so we                       ;; Normal replies can be longer than +replysize+, so we
456                       ;; have to handle them while aborts are still disallowed.                       ;; have to handle them while aborts are still disallowed.
457                       (let ((value                       (let ((value
458                               (read-reply-input                               (read-reply-input
459                                 display (read-card16 2)                                 display (read-card16 2)
460                                 (index+ *replysize* (index* (read-card32 4) 4))                                 (index+ +replysize+ (index* (read-card32 4) 4))
461                                 (shiftf reply-buffer nil))))                                 (shiftf reply-buffer nil))))
462                         (when value                         (when value
463                           (return-from read-input value))                           (return-from read-input value))
# Line 606  Line 615 
615        (buffer-replace buffer        (buffer-replace buffer
616                        (display-obuf8 display)                        (display-obuf8 display)
617                        0                        0
618                        *replysize*                        +replysize+
619                        (index+ 12 (buffer-boffset display)))                        (index+ 12 (buffer-boffset display)))
620        (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code)        (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code)
621              (aref buffer 2) 0              (aref buffer 2) 0
# Line 643  Line 652 
652    
653    
654  (defmacro define-event (name code)  (defmacro define-event (name code)
655    `(eval-when (eval compile load)    `(eval-when (:compile-toplevel :load-toplevel :execute)
656       (setf (svref *event-key-vector* ,code) ',name)       (setf (svref *event-key-vector* ,code) ',name)
657       (setf (get ',name 'event-code) ,code)))       (setf (get ',name 'event-code) ,code)))
658    
# Line 757  Line 766 
766               (declare (type display display)               (declare (type display display)
767                        (type reply-buffer event))                        (type reply-buffer event))
768               (declare (type function handler)               (declare (type function handler)
769                        (dynamic-extent handler))                        #+clx-ansi-common-lisp
770                          (dynamic-extent handler)
771                          #+(and lispm (not clx-ansi-common-lisp))
772                          (sys:downward-funarg handler))
773               (reading-event (event :display display :sizes (8 16 ,@get-sizes))               (reading-event (event :display display :sizes (8 16 ,@get-sizes))
774                 (funcall handler                 (funcall handler
775                          :display display                          :display display
# Line 930  Line 942 
942  (declare-event :circulate-notify  (declare-event :circulate-notify
943    (card16 sequence)    (card16 sequence)
944    (window event-window window parent)    (window event-window window parent)
945    ((member16 :top :bottom) place))    ((member8 :top :bottom) place))
946    
947  (declare-event :circulate-request  (declare-event :circulate-request
948    (card16 sequence)    (card16 sequence)
949    (window (parent event-window) window)    (window (parent event-window) window)
950    (pad16 1 2)    (pad16 1 2)
951    ((member16 :top :bottom) place))    ((member8 :top :bottom) place))
952    
953  (declare-event :property-notify  (declare-event :property-notify
954    (card16 sequence)    (card16 sequence)
# Line 1168  Line 1180 
1180             (type (or null number) timeout)             (type (or null number) timeout)
1181             (type generalized-boolean peek-p discard-p force-output-p))             (type generalized-boolean peek-p discard-p force-output-p))
1182    (declare (type t handler)    (declare (type t handler)
1183             (dynamic-extent handler))             #+clx-ansi-common-lisp
1184               (dynamic-extent handler)
1185               #+(and lispm (not clx-ansi-common-lisp))
1186               (sys:downward-funarg #+Genera * #-Genera handler))
1187    (event-loop (display event timeout force-output-p discard-p)    (event-loop (display event timeout force-output-p discard-p)
1188      (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT      (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT
1189             (event-decoder (and (index< event-code (length *event-handler-vector*))             (event-decoder (and (index< event-code (length *event-handler-vector*))
# Line 1199  Line 1214 
1214             (type (or null function) default)             (type (or null function) default)
1215             (clx-values sequence))                       ;Default handler for initial content             (clx-values sequence))                       ;Default handler for initial content
1216    ;; Makes a handler sequence suitable for process-event    ;; Makes a handler sequence suitable for process-event
1217    (make-sequence type *max-events* :initial-element default))    (make-sequence type +max-events+ :initial-element default))
1218    
1219  (defun event-handler (handlers event-key)  (defun event-handler (handlers event-key)
1220    (declare (type sequence handlers)    (declare (type sequence handlers)
# Line 1323  Line 1338 
1338    ;; CLAUSES are of the form:    ;; CLAUSES are of the form:
1339    ;; (event-or-events binding-list test-form . body-forms)    ;; (event-or-events binding-list test-form . body-forms)
1340    (let ((event-key (gensym))    (let ((event-key (gensym))
1341          (all-events (make-array *max-events* :element-type 'bit :initial-element 0)))          (all-events (make-array +max-events+ :element-type 'bit :initial-element 0)))
1342      `(reading-event (,event)      `(reading-event (,event)
1343         (let ((,event-key (svref *event-key-vector* (event-code ,event))))         (let ((,event-key (svref *event-key-vector* (event-code ,event))))
1344           (case ,event-key           (case ,event-key
# Line 1351  Line 1366 
1366                             (let ((keys (do ((i 0 (1+ i))                             (let ((keys (do ((i 0 (1+ i))
1367                                              (key nil)                                              (key nil)
1368                                              (result nil))                                              (result nil))
1369                                             ((>= i *max-events*) result)                                             ((>= i +max-events+) result)
1370                                           (setq key (svref *event-key-vector* i))                                           (setq key (svref *event-key-vector* i))
1371                                           (when (and key (zerop (aref all-events i)))                                           (when (and key (zerop (aref all-events i)))
1372                                             (push key result)))))                                             (push key result)))))
# Line 1445  Line 1460 
1460  ;;; Error Handling  ;;; Error Handling
1461  ;;;-----------------------------------------------------------------------------  ;;;-----------------------------------------------------------------------------
1462    
1463  (eval-when (eval compile load)  (eval-when (:compile-toplevel :load-toplevel :execute)
1464  (defparameter  (defparameter
1465    *xerror-vector*    *xerror-vector*
1466    '#(unknown-error    '#(unknown-error
# Line 1521  Line 1536 
1536        (when (= code (second extension))        (when (= code (second extension))
1537          (return (first extension))))))          (return (first extension))))))
1538    
1539    #-(or clx-ansi-common-lisp excl lcl3.0 CMU)
1540    (define-condition request-error (x-error)
1541      ((display :reader request-error-display)
1542       (error-key :reader request-error-error-key)
1543       (major :reader request-error-major)
1544       (minor :reader request-error-minor)
1545       (sequence :reader request-error-sequence)
1546       (current-sequence :reader request-error-current-sequence)
1547       (asynchronous :reader request-error-asynchronous))
1548      (:report report-request-error))
1549    
1550  (defun report-request-error (condition stream)  (defun report-request-error (condition stream)
1551    (let ((error-key (request-error-error-key condition))    (let ((error-key (request-error-error-key condition))
1552          (asynchronous (request-error-asynchronous condition))          (asynchronous (request-error-asynchronous condition))
# Line 1535  Line 1561 
1561    
1562  ;; Since the :report arg is evaluated as (function report-request-error) the  ;; Since the :report arg is evaluated as (function report-request-error) the
1563  ;; define-condition must come after the function definition.  ;; define-condition must come after the function definition.
1564    #+(or clx-ansi-common-lisp excl lcl3.0 CMU)
1565  (define-condition request-error (x-error)  (define-condition request-error (x-error)
1566    ((display :reader request-error-display :initarg :display)    ((display :reader request-error-display :initarg :display)
1567     (error-key :reader request-error-error-key :initarg :error-key)     (error-key :reader request-error-error-key :initarg :error-key)
# Line 1754  Line 1780 
1780        (format stream "inconsistent-parameters:~{ ~s~}"        (format stream "inconsistent-parameters:~{ ~s~}"
1781                (inconsistent-parameters-parameters condition)))))                (inconsistent-parameters-parameters condition)))))
1782    
1783    (define-condition resource-ids-exhausted (x-error)
1784      ()
1785      (:report
1786        (lambda (condition stream)
1787          (declare (ignore condition))
1788          (format stream "All X resource IDs are in use."))))
1789    
1790  (defun get-error-key (display error-code)  (defun get-error-key (display error-code)
1791    (declare (type display display)    (declare (type display display)
1792             (type array-index error-code))             (type array-index error-code))

Legend:
Removed from v.1.9.2.1  
changed lines
  Added in v.1.12

  ViewVC Help
Powered by ViewVC 1.1.5