-
Notifications
You must be signed in to change notification settings - Fork 1
/
input.cl
1885 lines (1717 loc) · 72.2 KB
/
input.cl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;;
;;; Change history:
;;;
;;; Date Author Description
;;; -------------------------------------------------------------------------------------
;;; 12/10/87 LGO Created
(in-package :xlib)
;; Event Resource
#-allegro-pre-smp
(defvar *event-free-list* nil) ;; List of unused (processed) events
(eval-when (eval compile load)
(defconstant *max-events* 64) ;; Maximum number of events supported (the X11 alpha release only has 34)
(defvar *event-key-vector* (make-array *max-events* :initial-element nil)
"Vector of event keys - See define-event")
)
(defvar *event-macro-vector* (make-array *max-events* :initial-element nil)
"Vector of event handler functions - See declare-event")
(defvar *event-handler-vector* (make-array *max-events* :initial-element nil)
"Vector of event handler functions - See declare-event")
(defvar *event-send-vector* (make-array *max-events* :initial-element nil)
"Vector of event sending functions - See declare-event")
(defun allocate-event ()
(or (threaded-atomic-pop *event-free-list* reply-next reply-buffer)
(make-reply-buffer *replysize*)))
(defun deallocate-event (reply-buffer)
(declare (type reply-buffer reply-buffer))
(setf (reply-size reply-buffer) *replysize*)
(threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer))
;; Extensions are handled as follows:
;; DEFINITION: Use DEFINE-EXTENSION
;;
;; CODE: Use EXTENSION-CODE to get the X11 opcode for an extension.
;; This looks up the code on the display-extension-alist.
;;
;; EVENTS: Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE
;; at LOAD time to define an internal event-code number
;; (stored in the 'event-code property of the event-name)
;; used to index the following vectors:
;; *event-key-vector* Used for getting the event-key
;; *event-macro-vector* Used for getting the event-parameter getting macros
;;
;; The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert
;; a server event-code into an internal event-code used to index the following
;; vectors:
;; *event-handler-vector* Used for getting the event-handler function
;; *event-send-vector* Used for getting the event-sending function
;;
;; The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert
;; internal event-codes to external (server) codes.
;;
;; ERRORS: Use DEFINE-ERROR to define new error decodings.
;;
;; Any event-code greater than 34 is for an extension
(defparameter *first-extension-event-code* 35)
(defvar *extensions* nil) ;; alist of (extension-name-symbol events errors)
(defmacro define-extension (name &key events errors)
;; Define extension NAME with EVENTS and ERRORS.
;; Note: The case of NAME is important.
;; To define the request, Use:
;; (with-buffer-request (display (extension-opcode ,name)) ,@body)
;; See the REQUESTS file for lots of examples.
;; To define event handlers, use declare-event.
;; To define error handlers, use declare-error and define-condition.
(declare (type stringable name)
(type list events errors))
(let ((name-symbol (kintern name)) ;; Intern name in the keyword package
(event-list (mapcar #'canonicalize-event-name events)))
`(eval-when (compile load eval)
(setq *extensions* (cons (list ',name-symbol ',event-list ',errors)
(delete ',name-symbol *extensions* :key #'car))))))
(eval-when (compile eval load)
(defun canonicalize-event-name (event)
;; Returns the event name keyword given an event name stringable
(declare (type stringable event))
(declare (values event-key))
(kintern event))
) ;; end eval-when
(eval-when (compile eval load)
(defun allocate-extension-event-code (name)
;; Allocate an event-code for an extension
;; This is executed at COMPILE and LOAD time from DECLARE-EVENT.
;; The event-code is used at compile-time by macros to index the following vectors:
;; *event-key-vector* *event-macro-vector* *event-handler-vector* *event-send-vector*
(let ((event-code (get name 'event-code)))
(declare (type (or null card8) event-code))
(unless event-code
;; First ensure the name is for a declared extension
(unless (dolist (extension *extensions*)
(when (member name (second extension))
(return t)))
(x-type-error name 'event-key))
(setq event-code (position nil *event-key-vector*
:start *first-extension-event-code*))
(setf (svref *event-key-vector* event-code) name)
(setf (get name 'event-code) event-code))
event-code))
) ;; end eval-when
(defun get-internal-event-code (display code)
;; Given an X11 event-code, return the internal event-code.
;; The internal event-code is used for indexing into the following vectors:
;; *event-key-vector* *event-handler-vector* *event-send-vector*
;; Returns NIL when the event-code is for an extension that isn't handled.
(declare (type display display)
(type card8 code))
(declare (values (or null card8)))
(setq code (logand #x7f code))
(if (< code *first-extension-event-code*)
code
(let* ((code-offset (- code *first-extension-event-code*))
(event-extensions (display-event-extensions display))
(code (if (< code-offset (length event-extensions))
(aref event-extensions code-offset)
0)))
(declare (type card8 code-offset code))
(when (zerop code)
(x-cerror "Ignore the event"
'unimplemented-event :event-code code :display display))
code)))
(defun get-external-event-code (display event)
;; Given an X11 event name, return the event-code
(declare (type display display)
(type event-key event))
(declare (values card8))
(let ((code (get-event-code event)))
(declare (type (or null card8) code))
(when (>= code *first-extension-event-code*)
(setq code (+ *first-extension-event-code*
(or (position code (display-event-extensions display))
(x-error 'undefined-event :display display :event-name event)))))
code))
(defmacro extension-opcode (display name)
;; Returns the major opcode for extension NAME.
;; This is a macro to enable NAME to be interned for fast run-time
;; retrieval.
;; Note: The case of NAME is important.
(let ((name-symbol (kintern name))) ;; Intern name in the keyword package
`(or (second (assoc ',name-symbol (display-extension-alist ,display)))
(x-error 'absent-extension :name ',name-symbol :display ,display))))
(defun initialize-extensions (display)
;; Initialize extensions for DISPLAY
(let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0))
(extension-alist nil))
(declare (type vector event-extensions)
(type list extension-alist))
(dolist (extension *extensions*)
(let ((name (first extension))
(events (second extension)))
(declare (type keyword name)
(type list events))
(multiple-value-bind (major-opcode first-event first-error)
(query-extension display name)
(declare (type (or null card8) major-opcode first-event first-error))
(when (and major-opcode (plusp major-opcode))
(push (list name major-opcode first-event first-error)
extension-alist)
(when (plusp first-event) ;; When there are extension events
;; Grow extension vector when needed
(let ((max-event (- (+ first-event (length events))
*first-extension-event-code*)))
(declare (type card8 max-event))
(when (>= max-event (length event-extensions))
(let ((new-extensions (make-array (+ max-event 16) :element-type 'card8
:initial-element 0)))
(declare (type vector new-extensions))
(replace new-extensions event-extensions)
(setq event-extensions new-extensions))))
(dolist (event events)
(declare (type symbol event))
(setf (aref event-extensions (- first-event *first-extension-event-code*))
(get-event-code event))
(incf first-event)))))))
(setf (display-event-extensions display) event-extensions)
(setf (display-extension-alist display) extension-alist)))
;;
;; Reply handlers
;;
#-allegro-pre-smp
(defvar *pending-command-free-list* nil)
(defun start-pending-command (display)
(declare (type display display))
(let ((pending-command (or (threaded-atomic-pop *pending-command-free-list*
pending-command-next pending-command)
(make-pending-command))))
(declare (type pending-command pending-command))
(setf (pending-command-reply-buffer pending-command) nil)
(setf (pending-command-process pending-command) (current-process))
(setf (pending-command-sequence pending-command)
(ldb (byte 16 0) (1+ (buffer-request-number display))))
;; Add the pending command to the end of the threaded list of pending
;; commands for the display.
(with-event-queue-internal (display)
(threaded-nconc pending-command (display-pending-commands display)
pending-command-next pending-command))
pending-command))
(defun stop-pending-command (display pending-command)
(declare (type display display)
(type pending-command pending-command))
(with-event-queue-internal (display)
;; Remove the pending command from the threaded list of pending commands
;; for the display.
(threaded-delete pending-command (display-pending-commands display)
pending-command-next pending-command)
;; Deallocate any reply buffers in this pending command
(loop
(let ((reply-buffer
(threaded-pop (pending-command-reply-buffer pending-command)
reply-next reply-buffer)))
(declare (type (or null reply-buffer) reply-buffer))
(if reply-buffer
(deallocate-reply-buffer reply-buffer)
(return nil)))))
;; Clear pointers to help the Garbage Collector
(setf (pending-command-process pending-command) nil)
;; Deallocate this pending-command
(threaded-atomic-push pending-command *pending-command-free-list*
pending-command-next pending-command)
nil)
;;;
(defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil))
(defun allocate-reply-buffer (size)
(declare (type array-index size))
(if (index<= size *replysize*)
(allocate-event)
(let ((index (integer-length (index1- size))))
(declare (type array-index index))
(or (threaded-atomic-pop (svref *reply-buffer-free-lists* index)
reply-next reply-buffer)
(make-reply-buffer (index-ash 1 index))))))
(defun deallocate-reply-buffer (reply-buffer)
(declare (type reply-buffer reply-buffer))
(let ((size (reply-size reply-buffer)))
(declare (type array-index size))
(if (index<= size *replysize*)
(deallocate-event reply-buffer)
(let ((index (integer-length (index1- size))))
(declare (type array-index index))
(threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index)
reply-next reply-buffer)))))
;;;
(defun read-error-input (display sequence reply-buffer token)
(declare (type display display)
(type reply-buffer reply-buffer)
(type card16 sequence))
(tagbody
(with-event-queue-internal (display)
(let ((command
;; Find any pending command with this sequence number.
(threaded-dolist (pending-command (display-pending-commands display)
pending-command-next pending-command)
(when (= (pending-command-sequence pending-command) sequence)
(return pending-command)))))
(declare (type (or null pending-command) command))
(cond ((not (null command))
;; Give this reply to the pending command
(threaded-nconc reply-buffer (pending-command-reply-buffer command)
reply-next reply-buffer)
(process-wakeup (pending-command-process command)))
((member :immediately (display-report-asynchronous-errors display))
;; No pending command and we should report the error immediately
(go report-error))
(t
;; No pending command found, count this as an asynchronous error
(threaded-nconc reply-buffer (display-asynchronous-errors display)
reply-next reply-buffer)))))
(return-from read-error-input nil)
report-error
(note-input-complete display token)
(apply #'report-error display
(prog1 (make-error display reply-buffer t)
(deallocate-event reply-buffer)))))
(defun read-reply-input (display sequence length reply-buffer)
(declare (type display display)
(type (or null reply-buffer) reply-buffer)
(type card16 sequence)
(type array-index length))
(unwind-protect
(progn
(when (index< *replysize* length)
(let ((repbuf nil))
(declare (type (or null reply-buffer) repbuf))
(unwind-protect
(progn
(setq repbuf (allocate-reply-buffer length))
(buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer)
0 *replysize*)
(deallocate-event (shiftf reply-buffer repbuf nil)))
(when repbuf
(deallocate-reply-buffer repbuf))))
(when (buffer-input display (reply-ibuf8 reply-buffer) *replysize* length)
(return-from read-reply-input t))
(setf (reply-data-size reply-buffer) length))
(with-event-queue-internal (display)
;; Find any pending command with this sequence number.
(let ((command
(threaded-dolist (pending-command (display-pending-commands display)
pending-command-next pending-command)
(when (= (pending-command-sequence pending-command) sequence)
(return pending-command)))))
(declare (type (or null pending-command) command))
(when command
;; Give this reply to the pending command
(threaded-nconc (shiftf reply-buffer nil)
(pending-command-reply-buffer command)
reply-next reply-buffer)
(process-wakeup (pending-command-process command)))))
nil)
(when reply-buffer
(deallocate-reply-buffer reply-buffer))))
(defun read-event-input (display code reply-buffer)
(declare (type display display)
(type card8 code)
(type reply-buffer reply-buffer))
;; Push the event in the input buffer on the display's event queue
(setf (event-code reply-buffer)
(get-internal-event-code display code))
(enqueue-event reply-buffer display)
nil)
(defun note-input-complete (display token)
(declare (type display display))
(when (eq (display-input-in-progress display) token)
;; Indicate that input is no longer in progress
(setf (display-input-in-progress display) nil)
;; Let the event process get the first chance to do input
(let ((process (display-event-process display)))
(when (not (null process))
(process-wakeup process)))
;; Then give processes waiting for command responses a chance
(unless (display-input-in-progress display)
(with-event-queue-internal (display)
(threaded-dolist (command (display-pending-commands display)
pending-command-next pending-command)
(process-wakeup (pending-command-process command)))))))
(defun read-input (display timeout force-output-p predicate &rest predicate-args)
(declare (type display display)
(type (or null number) timeout)
(type boolean force-output-p)
(dynamic-extent predicate-args))
(declare (type function predicate)
#+clx-ansi-common-lisp
(dynamic-extent predicate)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg predicate))
(let ((reply-buffer nil)
(token (or (current-process) (cons nil nil))))
(declare (type (or null reply-buffer) reply-buffer))
(unwind-protect
(tagbody
loop
(when (display-dead display)
(x-error 'closed-display :display display))
(when (apply predicate predicate-args)
(return-from read-input nil))
;; Check and see if we have to force output
(when (and force-output-p
(or (and (not (eq (display-input-in-progress display) token))
(not (conditional-store
(display-input-in-progress display) nil token)))
(null (buffer-listen display))))
(go force-output))
;; Ensure that ony one process is reading input.
(unless (or (eq (display-input-in-progress display) token)
(conditional-store (display-input-in-progress display) nil token))
(if (eql timeout 0)
(return-from read-input :timeout)
(apply #'process-block "CLX Input Lock"
#'(lambda (display predicate &rest predicate-args)
(declare (type display display)
(dynamic-extent predicate-args)
(type function predicate)
#+clx-ansi-common-lisp
(dynamic-extent predicate)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg predicate))
(or (apply predicate predicate-args)
(null (display-input-in-progress display))
(not (null (display-dead display)))))
display predicate predicate-args))
(go loop))
;; Now start gobbling.
(setq reply-buffer (allocate-event))
(with-buffer-input (reply-buffer :sizes (8 16 32))
(let ((type 0))
(declare (type card8 type))
;; Wait for input before we disallow aborts.
(unless (eql timeout 0)
(let ((eof-p (buffer-input-wait display timeout)))
(when eof-p (return-from read-input eof-p))))
(without-aborts
(let ((eof-p (buffer-input display buffer-bbuf 0 *replysize*
(if force-output-p 0 timeout))))
(when eof-p
(when (eq eof-p :timeout)
(if force-output-p
(go force-output)
(return-from read-input :timeout)))
(setf (display-dead display) t)
(return-from read-input eof-p)))
(setf (reply-data-size reply-buffer) *replysize*)
(when (= (the card8 (setq type (read-card8 0))) 1)
;; Normal replies can be longer than *replysize*, so we
;; have to handle them while aborts are still disallowed.
(let ((value
(read-reply-input
display (read-card16 2)
(index+ *replysize* (index* (read-card32 4) 4))
(shiftf reply-buffer nil))))
(when value
(return-from read-input value))
(go loop))))
(if (zerop type)
(read-error-input
display (read-card16 2) (shiftf reply-buffer nil) token)
(read-event-input
display (read-card8 0) (shiftf reply-buffer nil)))))
(go loop)
force-output
(note-input-complete display token)
(display-force-output display)
(setq force-output-p nil)
(go loop))
(when (not (null reply-buffer))
(deallocate-reply-buffer reply-buffer))
(note-input-complete display token))))
(defun report-asynchronous-errors (display mode)
(when (and (display-asynchronous-errors display)
(member mode (display-report-asynchronous-errors display)))
(let ((aborted t))
(unwind-protect
(loop
(let ((error
(with-event-queue-internal (display)
(threaded-pop (display-asynchronous-errors display)
reply-next reply-buffer))))
(declare (type (or null reply-buffer) error))
(if error
(apply #'report-error display
(prog1 (make-error display error t)
(deallocate-event error)))
(return (setq aborted nil)))))
;; If we get aborted out of this, deallocate all outstanding asynchronous
;; errors.
(when aborted
(with-event-queue-internal (display)
(loop
(let ((reply-buffer
(threaded-pop (display-asynchronous-errors display)
reply-next reply-buffer)))
(declare (type (or null reply-buffer) reply-buffer))
(if reply-buffer
(deallocate-event reply-buffer)
(return nil))))))))))
(defun wait-for-event (display timeout force-output-p)
(declare (type display display)
(type (or null number) timeout)
(type boolean force-output-p))
(let ((event-process-p (not (eql timeout 0))))
(declare (type boolean event-process-p))
(unwind-protect
(loop
(when event-process-p
(conditional-store (display-event-process display) nil (current-process)))
(let ((eof (read-input
display timeout force-output-p
#'(lambda (display)
(declare (type display display))
(or (not (null (display-new-events display)))
(and (display-asynchronous-errors display)
(member :before-event-handling
(display-report-asynchronous-errors display))
t)))
display)))
(when eof (return eof)))
;; Report asynchronous errors here if the user wants us to.
(when event-process-p
(report-asynchronous-errors display :before-event-handling))
(when (not (null (display-new-events display)))
(return nil)))
(when (and event-process-p
(eq (display-event-process display) (current-process)))
(setf (display-event-process display) nil)))))
(defun read-reply (display pending-command)
(declare (type display display)
(type pending-command pending-command))
(loop
(when (read-input display nil nil
#'(lambda (pending-command)
(declare (type pending-command pending-command))
(not (null (pending-command-reply-buffer pending-command))))
pending-command)
(x-error 'closed-display :display display))
(let ((reply-buffer
(with-event-queue-internal (display)
(threaded-pop (pending-command-reply-buffer pending-command)
reply-next reply-buffer))))
(declare (type reply-buffer reply-buffer))
;; Check for error.
(with-buffer-input (reply-buffer)
(ecase (read-card8 0)
(0 (apply #'report-error display
(prog1 (make-error display reply-buffer nil)
(deallocate-reply-buffer reply-buffer))))
(1 (return reply-buffer)))))))
;;;
(defun event-listen (display &optional (timeout 0))
(declare (type display display)
(type (or null number) timeout)
(values number-of-events-queued eof-or-timeout))
;; Returns the number of events queued locally, if any, else nil. Hangs
;; waiting for events, forever if timeout is nil, else for the specified
;; number of seconds.
(let* ((current-event-symbol (car (display-current-event-symbol display)))
(current-event (and (boundp current-event-symbol)
(symbol-value current-event-symbol)))
(queue (if current-event
(reply-next (the reply-buffer current-event))
(display-event-queue-head display))))
(declare (type symbol current-event-symbol)
(type (or null reply-buffer) current-event queue))
(if queue
(values
(with-event-queue-internal (display :timeout timeout)
(threaded-length queue reply-next reply-buffer))
nil)
(with-event-queue (display :timeout timeout :inline t)
(let ((eof-or-timeout (wait-for-event display timeout nil)))
(if eof-or-timeout
(values nil eof-or-timeout)
(values
(with-event-queue-internal (display :timeout timeout)
(threaded-length (display-new-events display)
reply-next reply-buffer))
nil)))))))
(defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys)
;; The event is put at the head of the queue if append-p is nil, else the tail.
;; Additional arguments depend on event-key, and are as specified above with
;; declare-event, except that both resource-ids and resource objects are accepted
;; in the event components.
(declare (type display display)
(type event-key event-key)
(type boolean append-p send-event-p)
(dynamic-extent args))
(unless (get event-key 'event-code)
(x-type-error event-key 'event-key))
(let* ((event (allocate-event))
(buffer (reply-ibuf8 event))
(event-code (get event-key 'event-code)))
(declare (type reply-buffer event)
(type buffer-bytes buffer)
(type (or null card8) event-code))
(unless event-code (x-type-error event-key 'event-key))
(setf (event-code event) event-code)
(with-display (display)
(apply (svref *event-send-vector* event-code) display args)
(buffer-replace buffer
(display-obuf8 display)
0
*replysize*
(index+ 12 (buffer-boffset display)))
(setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code)
(aref buffer 2) 0
(aref buffer 3) 0))
(with-event-queue (display)
(if append-p
(enqueue-event event display)
(with-event-queue-internal (display)
(threaded-requeue event
(display-event-queue-head display)
(display-event-queue-tail display)
reply-next reply-buffer))))))
(defun enqueue-event (new-event display)
(declare (type reply-buffer new-event)
(type display display))
;; Place EVENT at the end of the event queue for DISPLAY
(let* ((event-code (event-code new-event))
(event-key (and (index< event-code (length *event-key-vector*))
(svref *event-key-vector* event-code))))
(declare (type array-index event-code)
(type (or null keyword) event-key))
(if (null event-key)
(unwind-protect
(cerror "Ignore this event" "No handler for ~s event" event-key)
(deallocate-event new-event))
(with-event-queue-internal (display)
(threaded-enqueue new-event
(display-event-queue-head display)
(display-event-queue-tail display)
reply-next reply-buffer)
(unless (display-new-events display)
(setf (display-new-events display) new-event))))))
(defmacro define-event (name code)
`(eval-when (eval compile load)
(setf (svref *event-key-vector* ,code) ',name)
(setf (get ',name 'event-code) ,code)))
;; Event names. Used in "type" field in XEvent structures. Not to be
;; confused with event masks above. They start from 2 because 0 and 1
;; are reserved in the protocol for errors and replies. */
(define-event :key-press 2)
(define-event :key-release 3)
(define-event :button-press 4)
(define-event :button-release 5)
(define-event :motion-notify 6)
(define-event :enter-notify 7)
(define-event :leave-notify 8)
(define-event :focus-in 9)
(define-event :focus-out 10)
(define-event :keymap-notify 11)
(define-event :exposure 12)
(define-event :graphics-exposure 13)
(define-event :no-exposure 14)
(define-event :visibility-notify 15)
(define-event :create-notify 16)
(define-event :destroy-notify 17)
(define-event :unmap-notify 18)
(define-event :map-notify 19)
(define-event :map-request 20)
(define-event :reparent-notify 21)
(define-event :configure-notify 22)
(define-event :configure-request 23)
(define-event :gravity-notify 24)
(define-event :resize-request 25)
(define-event :circulate-notify 26)
(define-event :circulate-request 27)
(define-event :property-notify 28)
(define-event :selection-clear 29)
(define-event :selection-request 30)
(define-event :selection-notify 31)
(define-event :colormap-notify 32)
(define-event :client-message 33)
(define-event :mapping-notify 34)
(defmacro declare-event (event-codes &body declares)
;; Used to indicate the keyword arguments for handler functions in
;; process-event and event-case.
;; Generates the functions used in SEND-EVENT.
;; A compiler warning is printed when all of EVENT-CODES are not
;; defined by a preceding DEFINE-EXTENSION.
;; The body is a list of declarations, each of which has the form:
;; (type . items) Where type is a data-type, and items is a list of
;; symbol names. The item order corresponds to the order of fields
;; in the event sent by the server. An item may be a list of items.
;; In this case, each item is aliased to the same event field.
;; This is used to give all events an EVENT-WINDOW item.
;; See the INPUT file for lots of examples.
(declare (type (or keyword list) event-codes)
(type (alist (field-type symbol) (field-names list))
declares))
(when (atom event-codes) (setq event-codes (list event-codes)))
(setq event-codes (mapcar #'canonicalize-event-name event-codes))
(let* ((keywords nil)
(name (first event-codes))
(get-macro (xintern name '-event-get-macro))
(get-function (xintern name '-event-get))
(put-function (xintern name '-event-put)))
(multiple-value-bind (get-code get-index get-sizes)
(get-put-items
2 declares nil
#'(lambda (type index item args)
(flet ((event-get (type index item args)
(unless (member type '(pad8 pad16))
`(,(kintern item)
(,(getify type) ,index ,@args)))))
(if (atom item)
(event-get type index item args)
(mapcan #'(lambda (item)
(event-get type index item args))
item)))))
(declare (ignore get-index))
(multiple-value-bind (put-code put-index put-sizes)
(get-put-items
2 declares t
#'(lambda (type index item args)
(unless (member type '(pad8 pad16))
(if (atom item)
(progn
(push item keywords)
`((,(putify type) ,index ,item ,@args)))
(let ((names (mapcar #'(lambda (name) (kintern name))
item)))
(setq keywords (append item keywords))
`((,(putify type) ,index
(check-consistency ',names ,@item) ,@args)))))))
(declare (ignore put-index))
`(within-definition (,name declare-event)
(defun ,get-macro (display event-key variable)
;; Note: we take pains to macroexpand the get-code here to enable application
;; code to be compiled without having the CLX macros file loaded.
(subst display '%buffer
(getf `(:display (the display ,display)
:event-key (the keyword ,event-key)
:event-code (the card8 (logand #x7f (read-card8 0)))
:send-event-p (the boolean (logbitp 7 (read-card8 0)))
,@',(mapcar #'macroexpand get-code))
variable)))
(defun ,get-function (display event handler)
(declare (type display display)
(type reply-buffer event))
(declare (type function handler)
#+clx-ansi-common-lisp
(dynamic-extent handler)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg handler))
(reading-event (event :display display :sizes (8 16 ,@get-sizes))
(funcall handler
:display display
:event-key (svref *event-key-vector* (event-code event))
:event-code (logand #x7f (card8-get 0))
:send-event-p (logbitp 7 (card8-get 0))
,@get-code)))
(defun ,put-function (display &key ,@(setq keywords (nreverse keywords))
&allow-other-keys)
(declare (type display display))
,(when (member 'sequence keywords)
`(unless sequence (setq sequence (display-request-number display))))
(with-buffer-output (display :sizes ,put-sizes
:index (index+ (buffer-boffset display) 12))
,@put-code))
,@(mapcar #'(lambda (name)
(allocate-extension-event-code name)
`(let ((event-code (or (get ',name 'event-code)
(allocate-extension-event-code ',name))))
(setf (svref *event-macro-vector* event-code)
(function ,get-macro))
(setf (svref *event-handler-vector* event-code)
(function ,get-function))
(setf (svref *event-send-vector* event-code)
(function ,put-function))))
event-codes)
',name)))))
(defun check-consistency (names &rest args)
;; Ensure all args are nil or have the same value.
;; Returns the consistent non-nil value.
(let ((value (car args)))
(dolist (arg (cdr args))
(if value
(when (and arg (not (eq arg value)))
(x-error 'inconsistent-parameters
:parameters (mapcan #'list names args)))
(setq value arg)))
value))
(declare-event (:key-press :key-release :button-press :button-release)
;; for key-press and key-release, code is the keycode
;; for button-press and button-release, code is the button number
(data code)
(card16 sequence)
((or null card32) time)
(window root (window event-window))
((or null window) child)
(int16 root-x root-y x y)
(card16 state)
(boolean same-screen-p)
)
(declare-event :motion-notify
((data boolean) hint-p)
(card16 sequence)
((or null card32) time)
(window root (window event-window))
((or null window) child)
(int16 root-x root-y x y)
(card16 state)
(boolean same-screen-p))
(declare-event (:enter-notify :leave-notify)
((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind)
(card16 sequence)
((or null card32) time)
(window root (window event-window))
((or null window) child)
(int16 root-x root-y x y)
(card16 state)
((member8 :normal :grab :ungrab) mode)
((bit 0) focus-p)
((bit 1) same-screen-p))
(declare-event (:focus-in :focus-out)
((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
:pointer :pointer-root :none))
kind)
(card16 sequence)
(window (window event-window))
((member8 :normal :while-grabbed :grab :ungrab) mode))
(declare-event :keymap-notify
((bit-vector256 0) keymap))
(declare-event :exposure
(card16 sequence)
(window (window event-window))
(card16 x y width height count))
(declare-event :graphics-exposure
(card16 sequence)
(drawable (drawable event-window))
(card16 x y width height)
(card16 minor) ;; Minor opcode
(card16 count)
(card8 major))
(declare-event :no-exposure
(card16 sequence)
(drawable (drawable event-window))
(card16 minor)
(card8 major))
(declare-event :visibility-notify
(card16 sequence)
(window (window event-window))
((member8 :unobscured :partially-obscured :fully-obscured) state))
(declare-event :create-notify
(card16 sequence)
(window (parent event-window) window)
(int16 x y)
(card16 width height border-width)
(boolean override-redirect-p))
(declare-event :destroy-notify
(card16 sequence)
(window event-window window))
(declare-event :unmap-notify
(card16 sequence)
(window event-window window)
(boolean configure-p))
(declare-event :map-notify
(card16 sequence)
(window event-window window)
(boolean override-redirect-p))
(declare-event :map-request
(card16 sequence)
(window (parent event-window) window))
(declare-event :reparent-notify
(card16 sequence)
(window event-window window parent)
(int16 x y)
(boolean override-redirect-p))
(declare-event :configure-notify
(card16 sequence)
(window event-window window)
((or null window) above-sibling)
(int16 x y)
(card16 width height border-width)
(boolean override-redirect-p))
(declare-event :configure-request
((data (member :above :below :top-if :bottom-if :opposite)) stack-mode)
(card16 sequence)
(window (parent event-window) window)
((or null window) above-sibling)
(int16 x y)
(card16 width height border-width value-mask))
(declare-event :gravity-notify
(card16 sequence)
(window event-window window)
(int16 x y))
(declare-event :resize-request
(card16 sequence)
(window (window event-window))
(card16 width height))
(declare-event :circulate-notify
(card16 sequence)
(window event-window window parent)
((member16 :top :bottom) place))
(declare-event :circulate-request
(card16 sequence)
(window (parent event-window) window)
(pad16 1 2)
((member16 :top :bottom) place))
(declare-event :property-notify
(card16 sequence)
(window (window event-window))
(keyword atom) ;; keyword
((or null card32) time)
((member16 :new-value :deleted) state))
(declare-event :selection-clear
(card16 sequence)
((or null card32) time)
(window (window event-window))
(keyword selection) ;; keyword
)
(declare-event :selection-request
(card16 sequence)
((or null card32) time)
(window (window event-window) requestor)
(keyword selection target)
((or null keyword) property)
)
(declare-event :selection-notify
(card16 sequence)
((or null card32) time)
(window (window event-window))
(keyword selection target)
((or null keyword) property)
)
(declare-event :colormap-notify
(card16 sequence)
(window (window event-window))
((or null colormap) colormap)
(boolean new-p installed-p))
(declare-event :client-message
(data format)
(card16 sequence)
(window (window event-window))
(keyword type)
((client-message-sequence format) data))
(declare-event :mapping-notify
(card16 sequence)
((member8 :modifier :keyboard :pointer) request)
(card8 start) ;; first key-code
(card8 count))
;;
;; EVENT-LOOP
;;
(defun event-loop-setup (display)
(declare (type display display)