;;; -*- Mode:Common-Lisp; Package:X11; Base:10; Fonts:(MEDFNB HL12B HL12BI) -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1988 Texas Instruments Incorporated. All rights reserved. #| This file contains all of the code for handling complex events. It is closely modeled after the events.c file in the server/dix/ directory. |# ;;; Change history: ;;; ;;; Date Author Description ;;; ------------------------------------------------------------------------------------- ;;; 03/29/89 WJB Patch 1.65; Change ACTIVATE-POINTER-GRAB to call new-cursor-confines correctly. ;;; 03/29/89 WJB Patch 1.60; Add new function CHANGE-SCREEN-SIZE. ;;; 03/23/89 DAN Patch 1.58; Fix EXPLORER-KEYBOARD-PROCESS-EVENT to recognize the ;;; CAPS-LOCK key. ;;; 03/21/89 WJB Patch 1.51; Modified CHANGE-TO-CURSOR and PROCESS-INPUT-EVENTS to eliminate ;;; mouse turds when changing cursors. Now only the dispatch process changes the cursor. ;;; 03/17/89 DAN Patch 1.49; Removed Auto-Repeat code from EXPLORER-KEYBOARD-PROCESS-EVENT. ;;; 02/02/89 WJB Patch 1.5: avoid cursor lock condition. Modified CHANGE-TO-CURSOR ;;; 12/22/88 LGO Fixed get-input-focus to return revert-to-pointer-root ;;; 12/20/88 DAN Fixed DELIVER-EVENTS-TO-WINDOW to handle -1 from TRY-CLIENT-EVENTS. ;;; 12/16/88 DAN Fixed TRY-CLIENT-EVENTS. When the client doesn't match the grab- ;;; client, it was returning 0. It should return -1, but not do anything ;;; else. ;;; 12/14/88 LGO Move event-trace & friends to the debug file ;;; 12/14/88 LGO Replace all catch/throw's in events with block/return-from's ;;; 12/13/88 DAN Fixed a bad THROW in EVENT-SELECT-FOR-WINDOW. ;;; 12/07/88 WJB Added code in CHECK-MOTION to detect sprite.reconsider. ;;; 12/05/88 WJB Avoid lock in WINDOWS-RESTRUCTURED when changing cursors. ;;; 11/218*/88 LGO 1Enqueue events, rather than write them directly to the client.* ;;; 11/123*/88 LGO 1Make event-trace a macro, so its arguments aren't evaluated when trace is off.* ;;; 11/123*/88 LGO 1Eliminate the use of *EVENT-TRACE-NESTING-SPACING ;;; 11/123*/88 LGO 1Make the call to POINT-IN-WINDOW from *XY-TO-WINDOW1 inline.* ;;; 11/123*/88 LGO 1Remove unnecessary call to *XY-TO-WINDOW1, cutting number of calls by half.* ;;; 11/22/88 WJB Added array bounds checking to trace statement in WRITE-TO-CLIENT. ;;; 11/14/88 LGO 1Don't check for errors in SEND-EVENT (protocol spec says not to...)* ;;; 10/20/88 WJB Added cursor locking. ;;; 10/19/88 DAN Fixed CHECK-PASSIVE-GRABS-ON-WINDOW to add DETAIL field to ;;; GRAB-RECORD it creates. ;;; 10/117*/88 LGO 1Ensure *DELIVER-EVENTS-TO-WINDOW 1delivers events to the correct clients* ;;; 10/117*/88 LGO 1Replace OTHER-CLIENT-GONE (which was never called, and was a kludge in the C code)* ;1;;* 1with a new function: *REMOVE-CLIENTS-EVENTS1, called from STATE-SHUTDOWN* ;;; 10/117*/88 LGO 1Ensure *EVENT-SELECT-FOR-WINDOW1 doesn't add duplicate event entries* ;;; 10/117*/88 LGO 1Ensure client-events get written out* ;;; 10/114*/88 LGO 1Maintain the number field of sync-events structure in play-released-events* ;;; 10/114*/88 LGO 1Make *INSQUE 1and *REMQUE1 use qd-event-record structure accessors.* ;;; 10/06/88 DAN/LGO Wrote SWAP-EVENT-CLIENT-MESSAGE and READ-EVENT-CLIENT-MESSAGE. ;;; 10/05/88 LGO 1Write the DEFEVENT macro, which translates client events to event structures* ;;; 9/26/88 DAN Initialize SYNC-EVENTS.FREE in INIT-EVENTS. ;;; 9/14/88 LGO Copy default arrays in add-keyboard and add-pointer ;;; 9/09/88 LGO Make MODIFIER-KEY-MAP a byte vector ;;; 9/01/88 LGO Rewrite PROCESS-INPUT-EVENTS to ensure events aren't lost. ;;; 8/12/88 WJB Fix CHANGE-TO-CURSOR to install new cursor when new<>current ;;; (instead of when new=current!!!) ;;;1 * 7/13/881 * DAN Changed *MONOCHROME-SERVER-EVENT-TRACE-ENABLED* to default to NIL. ;;; 5/13/88 TWE Removed dependencies on I/O buffers. ;;; 5/12/88 TWE Added a call to INIT-POINTER-DEVICE-STRUCT in ;;; INITIALIZE-MONOCHROME-SERVER-DEVICES. ;;; 5/10/88 TWE Fixed EVENT-MASK-FOR-CLIENT to return a 0 as its first value ;;; instead of NIL. ;;; 4/12/88 TWE Changed INIT-KEYBOARD-DEVICE-STRUCT to initialize ;;; DEVICE.FOCUS-REVERT to UNIVERSAL-NONE instead of NIL. ;;; 4/08/88 KDB Got rid of1 extraneous *COUNT arg in WRITE-EVENT-NO-EXPOSURE. ;;; 4/07/881 * DAN Added CLIENT-TIME-TO-SERVER-TIME. ;;; 3/25/88 TWE Moved top-level initialization code to SERVER-INIT. ;;; 3/09/88 TWE Fixed XY-TO-WINDOW to not go into an infinite loop. Fixed up the ;;; initialization of the keyboard, mouse and dispatcher processes. ;;; 3/09/88 TWE Changed trace code to have a better name. Also changed ;;; INITIALIZE-MONOCHROME-SERVER to set up values for the trace ;;; variables. Fixed event output functions to always output the ;;; DETAIL slot. ;;; 3/01/88 TWE Inserted tracing code. Fixed PROCESS-KEYBOARD-EVENT to check for ;;; a release properly. ;;; 2/12/88 TWE Initial creation. ;;; ProcessInputEvents -- ;;; Retrieve all waiting input events and pass them to DIX in their ;;; correct chronological order. Only reads from the system pointer ;;; and keyboard. ;;; ;;; Results: ;;; None. ;;; ;;; Side Effects: ;;; Events are passed to the DIX layer. (defun process-input-events () (event-trace-entering "PROCESS-INPUT-EVENTS") (let ((pointer (lookup-pointer-device)) (keyboard (lookup-keyboard-device)) ptr-events ; Current pointer event kbd-events ; Current keyboard event number-pointer-events ; Number of remaining pointer events number-kbd-events ; Number of remaining keyboard events (new-last-event-time nil)) ; Time of last event processed ;; Get events from both the pointer and the keyboard, storing the number of ;; events gotten in nPE and nKE and keeping the start of both arrays in pE ;; and kE. (setq ptr-events (device.events pointer)) (setq kbd-events (device.events keyboard)) (setq number-pointer-events (device.event-count ptr-events)) (setq number-kbd-events (device.event-count kbd-events)) (event-trace "~% in PROCESS-INPUT-EVENTS, # mouse events=~D, # keyboard events=~D" number-pointer-events number-kbd-events) ;; So long as one event from either device remains unprocess, we loop: Take ;; the oldest remaining event and pass it to the proper module for ;; processing. The DDXEvent will be sent to ProcessInput by the function ;; called. (do (ptr-detail ptr-time ptr-x ptr-y kbd-detail kbd-time kbd-x kbd-y (last-type :none-yet)) ; Type of last event ((not (or (plusp number-pointer-events) (plusp number-kbd-events)))) (when (plusp number-kbd-events) (decf number-kbd-events) (multiple-value-setq (kbd-detail kbd-time kbd-x kbd-y) (read-events kbd-events))) (when (plusp number-pointer-events) (decf number-pointer-events) (multiple-value-setq (ptr-detail ptr-time ptr-x ptr-y) (read-events ptr-events))) (when (and ptr-time kbd-time ;; When the pointer event is the oldest, process it first. (minusp (time-difference ptr-time kbd-time))) ;; Process pointer event (when (eq last-type :kbd) (done-keyboard-events keyboard nil)) (explorer-mouse-process-event pointer ptr-detail ptr-time ptr-x ptr-y) (setq new-last-event-time ptr-time) (setq last-type :ptr) (setq ptr-time nil)) ;; Process keyboard event (when kbd-time (when (eq last-type :ptr) (done-pointer-events pointer nil)) (explorer-keyboard-process-event keyboard kbd-detail kbd-time kbd-x kbd-y) (setq new-last-event-time kbd-time) (setq last-type :kbd) (setq kbd-time nil)) ;; Process pointer event (when ptr-time (when (eq last-type :kbd) (done-keyboard-events keyboard nil)) (explorer-mouse-process-event pointer ptr-detail ptr-time ptr-x ptr-y) (setq new-last-event-time ptr-time) (setq last-type :ptr) (setq ptr-time nil))) (when new-last-event-time (setq last-event-time new-last-event-time) (when screen-saved #+comment (save-screens screen-saver-forcer screen-saver-reset))) (done-keyboard-events keyboard) (done-pointer-events pointer) (with-cursor-locked (nil t) ;; Change the displayed cursor if necessary (when (neq (sprite.current sprite) current-cursor) (explorer-display-cursor current-screen (sprite.current sprite))) ;; Display cursor or new location if necessary (explorer-restore-cursor))) (event-trace-leaving "PROCESS-INPUT-EVENTS")) (DEFUN TV-TO-MILLI (TIME) (DECLARE (TYPE INTEGER TIME) (VALUES INTEGER)) ;; Convert microseconds to milliseconds. ;; Return only one value. Truncate returns 2. (VALUES (TRUNCATE TIME 1000.))) #| ;;; Debug code. The following will display the current X Y position of the mouse. ;;; This was used to move the mouse to a specific place and then to see if the server ;;; will have the same coordinate for the root window. (loop with old-x = (1+ tv:mouse-x) with old-y = tv:mouse-y when (or (not (= old-x tv:mouse-x)) (not (= old-y tv:mouse-y))) do (progn (send tv:selected-window :set-cursorpos 800 10) (send tv:selected-window :clear-eol) (format tv:selected-window "(~d,~d)" tv:mouse-x tv:mouse-y) (setq old-x tv:mouse-x old-y tv:mouse-y))) |# ;;;------------------------------------------------------------------ ;;; EXPLORER-MOUSE-PROCESS-EVENT -- ;;; Given a Firm_event for a mouse, pass it off the the dix layer ;;; properly converted... ;;; ;;; Results: ;;; None. ;;; ;;; Side Effects: ;;; The cursor may be redrawn...? devPrivate/x/y will be altered. (DEFUN EXPLORER-MOUSE-PROCESS-EVENT (POINTER-INFO DETAIL TIME X Y) (DECLARE (TYPE DEVICE POINTER-INFO) (TYPE INTEGER DETAIL TIME X Y)) (EVENT-TRACE-ENTERING "EXPLORER-MOUSE-PROCESS-EVENT") (EVENT-TRACE ", (LENGTH DEVICE.GRAB)=~D" (LENGTH (DEVICE.GRAB POINTER-INFO))) (LET ((XE (MAKE-EVENT-KEY-BUTTON-POINTER)) (IGNORE-EVENT NIL) BMASK) ; Temporary button mask (SETF (X-EVENT-KEY-BUTTON-POINTER.TIME XE) (TV-TO-MILLI TIME)) (SETF (DEVICE.X POINTER-INFO) X) (SETF (DEVICE.Y POINTER-INFO) Y) (EVENT-TRACE "~%EXPLORER-MOUSE-PROCESS-EVENT, detail=x~16R, time=~D, (~D,~D)" DETAIL TIME X Y) (CASE (WHICH-MOUSE-BUTTON DETAIL) ((:LEFT :MIDDLE :RIGHT) ;; A button changed state. Sometimes we will get two events ;; for a single state change. Should we get a button event which ;; reflects the current state of affairs, that event is discarded. ;; ;; Mouse buttons start at 1. (SETF (X-EVENT-KEY-BUTTON-POINTER.DETAIL XE) (CASE (WHICH-MOUSE-BUTTON DETAIL) (:LEFT 1) (:MIDDLE 2) (:RIGHT 3))) (SETQ BMASK (ASH 1 (X-EVENT-KEY-BUTTON-POINTER.DETAIL XE))) (EVENT-TRACE "~%EXPLORER-MOUSE-PROCESS-EVENT, button=~A, Mask=b~2,4,48R, direction=~A" (WHICH-MOUSE-BUTTON DETAIL) BMASK (MOUSE-BUTTON-STATE DETAIL)) (IF (EQ (MOUSE-BUTTON-STATE DETAIL) :BUTTON-UP) (IF (NOT (ZEROP (LOGAND (DEVICE.BMASK POINTER-INFO) BMASK))) (PROGN ;; The device bmask indicates that the button is down. (SETF (X-EVENT-KEY-BUTTON-POINTER.TYPE XE) BUTTON-RELEASE-EVENT) ;; Turn off this button's bit in the device mask. (SETF (DEVICE.BMASK POINTER-INFO) (LOGXOR (DEVICE.BMASK POINTER-INFO) BMASK))) ;;ELSE ;; The device bmask indicated that the button is already up. Discard ;; this duplicate event. (SETQ IGNORE-EVENT T)) ;;ELSE :Button-Down (IF (ZEROP (LOGAND (DEVICE.BMASK POINTER-INFO) BMASK)) (PROGN ;; The device bmask indicates that the button is down. (SETF (X-EVENT-KEY-BUTTON-POINTER.TYPE XE) BUTTON-PRESS-EVENT) ;; Turn on this button's bit in the device mask. (SETF (DEVICE.BMASK POINTER-INFO) (LOGIOR (DEVICE.BMASK POINTER-INFO) BMASK))) ;;ELSE ;; The device bmask indicated that the button is already down. Discard ;; this duplicate event. (SETQ IGNORE-EVENT T))) ;; If the mouse has moved, we must update any interested client ;; as well as DIX before sending a button event along. (WHEN (AND (NOT IGNORE-EVENT) (DEVICE.MOUSE-MOVED POINTER-INFO)) (DONE-POINTER-EVENTS POINTER-INFO NIL))) (:DELTA-X-Y ;; When we detect a change in the mouse coordinates, we call ;; the cursor module to move the cursor. It has the option of ;; simply removing the cursor or just shifting it a bit. ;; If it is removed, DIX will restore it before we goes to sleep... ;; ;; What should be done if it goes off the screen? Move to another ;; screen? For now, we just force the pointer to stay on the ;; screen... (SETF (DEVICE.X POINTER-INFO) (MOUSE-ACCELERATE POINTER-INFO X)) (SETF (DEVICE.Y POINTER-INFO) (MOUSE-ACCELERATE POINTER-INFO Y)) ;; Active Zaphod implementation (remember the `Hitchhiker's Guide to the Galaxy'): ;; increment or decrement the current screen ;; if the x is to the right or the left of ;; the current screen. (WHEN (AND (> (SCREEN-INFO.NUM-SCREENS SCREEN-INFO) 1) (OR (> (DEVICE.X POINTER-INFO) (SCREEN.WIDTH (DEVICE.SCREEN POINTER-INFO))) (MINUSP (DEVICE.X POINTER-INFO)))) (WITH-CURSOR-LOCKED (NIL) (EXPLORER-REMOVE-CURSOR)) ;; Disable color plane if it's current. (EXPLORER-ENTER-LEAVE (DEVICE.SCREEN POINTER-INFO) T) (IF (MINUSP (DEVICE.X POINTER-INFO)) (PROGN (IF (ZEROP (SCREEN.MY-NUMBER (DEVICE.SCREEN POINTER-INFO))) (SETF (DEVICE.SCREEN POINTER-INFO) (NTH (SCREEN-INFO.NUM-SCREENS SCREEN-INFO) (SCREEN-INFO.SCREENS SCREEN-INFO))) ;;ELSE (SETF (DEVICE.SCREEN POINTER-INFO) (NTH (1- (SCREEN.MY-NUMBER (DEVICE.SCREEN POINTER-INFO))) (SCREEN-INFO.SCREENS SCREEN-INFO)))) (INCF (DEVICE.X POINTER-INFO) (SCREEN.WIDTH (DEVICE.SCREEN POINTER-INFO)))) ;;ELSE (PROGN (DECF (DEVICE.X POINTER-INFO) (SCREEN.WIDTH (DEVICE.SCREEN POINTER-INFO))) (IF (NOT (= (SCREEN.MY-NUMBER (DEVICE.SCREEN POINTER-INFO)) (1- (SCREEN-INFO.NUM-SCREENS SCREEN-INFO)))) (SETF (DEVICE.SCREEN POINTER-INFO) (NTH (1+ (SCREEN.MY-NUMBER (DEVICE.SCREEN POINTER-INFO))) (SCREEN-INFO.SCREENS SCREEN-INFO))) ;;ELSE (SETF (DEVICE.SCREEN POINTER-INFO) (NTH 0 (SCREEN-INFO.SCREENS SCREEN-INFO)))))) ;; Enable color plane if new current screen. (EXPLORER-ENTER-LEAVE (DEVICE.SCREEN POINTER-INFO) NIL)) (MULTIPLE-VALUE-BIND (CONSTRAINED NEW-X NEW-Y) (EXPLORER-CONSTRAIN-XY (DEVICE.X POINTER-INFO) (DEVICE.Y POINTER-INFO)) (SETF (DEVICE.X POINTER-INFO) NEW-X) (SETF (DEVICE.Y POINTER-INFO) NEW-Y) (IF (NOT CONSTRAINED) (SETQ IGNORE-EVENT T) ;;ELSE (NEW-CURRENT-SCREEN (DEVICE.SCREEN POINTER-INFO) (DEVICE.X POINTER-INFO) (DEVICE.Y POINTER-INFO)))) (WHEN (NOT IGNORE-EVENT) (SETF (X-EVENT-KEY-BUTTON-POINTER.TYPE XE) MOTION-NOTIFY-EVENT) (WITH-CURSOR-LOCKED (NIL T) (EXPLORER-MOVE-CURSOR (DEVICE.SCREEN POINTER-INFO) (DEVICE.X POINTER-INFO) (DEVICE.Y POINTER-INFO))))) (OTHERWISE (ERROR "EXPLORER-MOUSE-PROCESS-EVENT: unrecognized ~A id" (WHICH-MOUSE-BUTTON DETAIL)))) (EVENT-TRACE "~%After CASE in EXPLORER-MOUSE-PROCESS-EVENT, IGNORE-EVENT=~A" IGNORE-EVENT) (WHEN (NOT IGNORE-EVENT) (SETF (X-EVENT-KEY-BUTTON-POINTER.ROOT-X XE) (DEVICE.X POINTER-INFO)) (SETF (X-EVENT-KEY-BUTTON-POINTER.ROOT-Y XE) (DEVICE.Y POINTER-INFO)) (PROCESS-POINTER-EVENT XE POINTER-INFO))) (EVENT-TRACE-LEAVING "EXPLORER-MOUSE-PROCESS-EVENT") (EVENT-TRACE ", (LENGTH DEVICE.GRAB)=~D" (LENGTH (DEVICE.GRAB POINTER-INFO)))) (DEFUN DONE-KEYBOARD-EVENTS (EVENT-INFO &OPTIONAL (FINAL NIL)) (DECLARE (IGNORE EVENT-INFO FINAL)) (EVENT-TRACE-ENTERING "DONE-KEYBOARD-EVENTS") ;; Nothing to do here. NIL (EVENT-TRACE-LEAVING "DONE-KEYBOARD-EVENTS")) ;;; Finish off any mouse motions we haven't done yet. (At the moment ;;; this code is unused since we never save mouse motions as I'm ;;; unsure of the effect of getting a keystroke at a given [x,y] w/o ;;; having gotten a motion event to that [x,y]) (DEFUN DONE-POINTER-EVENTS (THE-MOUSE-DEVICE &OPTIONAL (FINAL NIL)) (DECLARE (TYPE DEVICE THE-MOUSE-DEVICE) (TYPE BOOLEAN FINAL) ;; The C code doesn't use this argument either. (IGNORE FINAL)) (EVENT-TRACE-ENTERING "DONE-POINTER-EVENTS") (WHEN (DEVICE.MOUSE-MOVED THE-MOUSE-DEVICE) (WITH-CURSOR-LOCKED (NIL T) (EXPLORER-MOVE-CURSOR (DEVICE.SCREEN THE-MOUSE-DEVICE) (DEVICE.X THE-MOUSE-DEVICE) (DEVICE.Y THE-MOUSE-DEVICE))) (LET ((EVENT (MAKE-EVENT-KEY-BUTTON-POINTER :ROOT-X (DEVICE.X THE-MOUSE-DEVICE) :ROOT-Y (DEVICE.Y THE-MOUSE-DEVICE) :TIME LAST-EVENT-TIME :TYPE MOTION-NOTIFY-EVENT))) (PROCESS-POINTER-EVENT EVENT THE-MOUSE-DEVICE) (SETF (DEVICE.MOUSE-MOVED THE-MOUSE-DEVICE) NIL))) (EVENT-TRACE-LEAVING "DONE-POINTER-EVENTS")) ;;; Enable or disable color plane ;;; Color plane enabled for select =T, disabled otherwise. (DEFUN EXPLORER-ENTER-LEAVE (SCREEN SELECT) "Enable or disable color plane. SELECT - T for enable color plane, NIL disable." (DECLARE (TYPE SCREEN SCREEN) (TYPE BOOLEAN SELECT) (IGNORE SCREEN SELECT)) (SERVER-TRACE "~%EXPLORER-ENTER-LEAVE is stubbed out.") NIL) (DEFUN MOUSE-ACCELERATE (POINTER-INFO X-OR-Y) (DECLARE (TYPE DEVICE POINTER-INFO) (VALUES INTEGER) (IGNORE POINTER-INFO)) (EVENT-TRACE-ENTERING "MOUSE-ACCELERATE") ;; The Explorer already does this in the microcode. The registers kept in ;; MOUSE-X-SCALE-ARRAY and MOUSE-Y-SCALE-ARRAY are used by the microcode to ;; convert a mouse movement into an accelerated movement. (EVENT-TRACE-LEAVING "MOUSE-ACCELERATE") X-OR-Y) (DEFMACRO MOTION-FILTER (STATE) `(LOGIOR POINTER-MOTION-MASK (LOGAND ALL-BUTTONS-MASK ,STATE) BUTTON-MOTION-MASK-VARIABLE)) ;;; This function was written to generate a copy of an event, but it will ;;; actually work on any structure which has a copy function. (DEFUN COPY-STRUCTURE-OBJECT (OBJECT) "Generate a new copy of a structured object. Only works for objects in server's package." (LET ((COPY-FUNCTION (FIND-SYMBOL (CONCATENATE 'SIMPLE-STRING "COPY-" (SYMBOL-NAME (TYPE-OF OBJECT))) ;; Make sure we look for the copy function ;; in the server package, instead of whatever package ;; we are running in. *MONOCHROME-SERVER-PACKAGE*))) (IF COPY-FUNCTION (FUNCALL COPY-FUNCTION OBJECT) ;;ELSE ;; Can't find a copy function. (ERROR "Can't copy object of type ~A:~A" *PACKAGE* (TYPE-OF OBJECT))))) ;;; insque, remque - insert/remove element from a queue ;;; ;;; DESCRIPTION: ;;; Insque and remque manipulate queues built from doubly linked lists. ;;; Each element in the queue must in the form shown in QUEUE-FORM. ;;; Insque inserts elem in a queue immediately after pred; remque removes ;;; an entry elem from a queue. (DEFUN INSQUE (ELEM PRED) (DECLARE (TYPE QD-EVENT-RECORD ELEM) (TYPE (OR NULL QD-EVENT-RECORD) PRED)) (EVENT-TRACE-ENTERING "INSQUE") (WITHOUT-INTERRUPTS (LET ((Q (IF PRED (QD-EVENT-RECORD.FORWARD PRED) PRED))) (SETF (QD-EVENT-RECORD.FORWARD ELEM) Q) (WHEN Q (SETF (QD-EVENT-RECORD.BACKWARD Q) ELEM)) (SETF (QD-EVENT-RECORD.BACKWARD ELEM) PRED) (WHEN PRED (SETF (QD-EVENT-RECORD.FORWARD PRED) ELEM)))) (EVENT-TRACE-LEAVING "INSQUE")) (DEFUN REMQUE (ELEM) (DECLARE (TYPE (OR NULL QD-EVENT-RECORD) ELEM)) (EVENT-TRACE-ENTERING "REMQUE") (WHEN ELEM (WITHOUT-INTERRUPTS (LET ((Q (QD-EVENT-RECORD.BACKWARD ELEM))) (DECLARE (TYPE (OR NULL QD-EVENT-RECORD) Q)) (WHEN Q (SETF (QD-EVENT-RECORD.FORWARD Q) (QD-EVENT-RECORD.FORWARD ELEM))) (SETQ Q (QD-EVENT-RECORD.FORWARD ELEM)) (WHEN Q (SETF (QD-EVENT-RECORD.BACKWARD Q) (QD-EVENT-RECORD.BACKWARD ELEM)))))) (EVENT-TRACE-LEAVING "REMQUE")) (DEFUN ENQUEUE-EVENT (DEVICE EVENT) (DECLARE (TYPE DEVICE DEVICE) (TYPE EVENT-RECORD EVENT)) (EVENT-TRACE-ENTERING "ENQUEUE-EVENT") (LET ((TAIL (QD-EVENT-RECORD.BACKWARD (SYNC-EVENTS.PENDING SYNC-EVENTS))) NEW) (IF (AND (PLUSP (SYNC-EVENTS.NUMBER SYNC-EVENTS)) (= (EVENT-U.TYPE EVENT) MOTION-NOTIFY-EVENT) (= (EVENT-U.TYPE (QD-EVENT-RECORD.EVENT TAIL)) MOTION-NOTIFY-EVENT)) (SETF (QD-EVENT-RECORD.EVENT TAIL) (COPY-STRUCTURE-OBJECT EVENT)) ;;ELSE (PROGN (INCF (SYNC-EVENTS.NUMBER SYNC-EVENTS)) (IF (EQ (QD-EVENT-RECORD.FORWARD (SYNC-EVENTS.FREE SYNC-EVENTS)) (SYNC-EVENTS.FREE SYNC-EVENTS)) (SETQ NEW (MAKE-QD-EVENT-RECORD)) ;;ELSE (PROGN (SETQ NEW (QD-EVENT-RECORD.FORWARD (SYNC-EVENTS.FREE SYNC-EVENTS))) (REMQUE NEW))) (SETF (QD-EVENT-RECORD.DEVICE NEW) DEVICE) (SETF (QD-EVENT-RECORD.EVENT NEW) (COPY-STRUCTURE-OBJECT EVENT)) (INSQUE NEW TAIL) (WHEN (> (SYNC-EVENTS.NUMBER SYNC-EVENTS) MAX-QUEUED-EVENTS) ;; XXX here we send all the pending events and break the locks. )))) (EVENT-TRACE-LEAVING "ENQUEUE-EVENT")) (DEFUN POINTER-EVENT-P (EVENT) (DECLARE (TYPE EVENT-RECORD EVENT) (VALUES BOOLEAN)) (MEMBER (EVENT-U.TYPE EVENT) ALL-POINTER-EVENTS)) (DEFUN PLAY-RELEASED-EVENTS () (EVENT-TRACE-ENTERING "PLAY-RELEASED-EVENTS") (LET ((QE (QD-EVENT-RECORD.FORWARD (SYNC-EVENTS.PENDING SYNC-EVENTS))) (NEXT NIL) DEVICE) (DECLARE (TYPE QD-EVENT-RECORD QE) (TYPE (OR NULL QD-EVENT-RECORD) NEXT)) (LOOP (WHEN (EQ QE (SYNC-EVENTS.PENDING SYNC-EVENTS)) (RETURN NIL)) (SETQ DEVICE (QD-EVENT-RECORD.DEVICE QE)) (IF (NULL (SYNC.FROZEN (DEVICE.SYNC DEVICE))) (PROGN (SETQ NEXT (QD-EVENT-RECORD.FORWARD QE)) (decf (sync-events.number sync-events)) (REMQUE QE) (IF (POINTER-EVENT-P (QD-EVENT-RECORD.EVENT QE)) (PROCESS-POINTER-EVENT (QD-EVENT-RECORD.EVENT QE) DEVICE) ;;ELSE (PROCESS-KEYBOARD-EVENT (QD-EVENT-RECORD.EVENT QE) DEVICE)) (INSQUE QE (SYNC-EVENTS.FREE SYNC-EVENTS)) (SETQ QE NEXT)) ;;ELSE (SETQ QE (QD-EVENT-RECORD.FORWARD QE))))) (EVENT-TRACE-LEAVING "PLAY-RELEASED-EVENTS")) (DEFUN POST-NEW-CURSOR () (EVENT-TRACE-ENTERING "POST-NEW-CURSOR") (LET (WINDOW (ALL-DONE NIL) (GRAB (DEVICE.GRAB (INPUT-INFO.POINTER INPUT-INFO)))) (DECLARE (TYPE (OR NULL GRAB-RECORD) GRAB) (TYPE BOOLEAN ALL-DONE)) (IF GRAB (COND ((GRAB-RECORD.CURSOR GRAB) (SETQ ALL-DONE T) (CHANGE-TO-CURSOR (GRAB-RECORD.CURSOR GRAB))) ((IS-PARENT (GRAB-RECORD.WINDOW GRAB) (SPRITE.WINDOW SPRITE)) (SETQ WINDOW (SPRITE.WINDOW SPRITE))) (T (SETQ WINDOW (GRAB-RECORD.WINDOW GRAB)))) ;;ELSE (SETQ WINDOW (SPRITE.WINDOW SPRITE))) (WHEN (NOT ALL-DONE) (LOOP (WHEN (NULL WINDOW) (RETURN NIL)) (WHEN (WINDOW.CURSOR WINDOW) (CHANGE-TO-CURSOR (WINDOW.CURSOR WINDOW)) (RETURN NIL)) (SETQ WINDOW (WINDOW.PARENT WINDOW))))) (EVENT-TRACE-LEAVING "POST-NEW-CURSOR")) (DEFUN CHANGE-TO-CURSOR (CURSOR) (DECLARE (TYPE (OR NULL CURSOR-RECORD) CURSOR)) (EVENT-TRACE-ENTERING "CHANGE-TO-CURSOR") (WHEN (NULL CURSOR) (ERROR "Somebody is setting NullCursor")) (WHEN (NEQ CURSOR (SPRITE.CURRENT SPRITE)) (WHEN (OR (NOT (= (CURSOR-RECORD.XHOT (SPRITE.CURRENT SPRITE)) (CURSOR-RECORD.XHOT CURSOR))) (NOT (= (CURSOR-RECORD.YHOT (SPRITE.CURRENT SPRITE)) (CURSOR-RECORD.YHOT CURSOR)))) (CHECK-PHYSICAL-LIMITS CURSOR)) ;;The on-screen cursor can only be changed by the Dispatcher process to avoid conflicts. ;;(EXPLORER-DISPLAY-CURSOR CURRENT-SCREEN CURSOR) (SETF (SPRITE.CURRENT SPRITE) CURSOR) ;; Ensure dispatch process sees the change (MOUSE-WAKEUP)) (EVENT-TRACE-LEAVING "CHANGE-TO-CURSOR")) (DEFUN CHECK-PHYSICAL-LIMITS (CURSOR) (DECLARE (TYPE (OR NULL CURSOR-RECORD) CURSOR)) (EVENT-TRACE-ENTERING "CHECK-PHYSICAL-LIMITS") (WHEN CURSOR (LET ((OLD (MAKE-HOT-SPOT))) (SETF (HOT-SPOT.X OLD) (HOT-SPOT.X (SPRITE.HOT SPRITE))) (SETF (HOT-SPOT.Y OLD) (HOT-SPOT.Y (SPRITE.HOT SPRITE))) (SETF (SPRITE.PHYS-LIMITS SPRITE) (EXPLORER-CURSOR-LIMITS CURRENT-SCREEN CURSOR (SPRITE.HOT-LIMITS SPRITE))) ;; Notice that the following adjustments leave the hot spot not really where ;; it would be if you looked at the screen. This is probably the right thing ;; to do since the user does not want the hot spot to move just because the ;; hardware cannot display the physical sprite where we would like it. The ;; next time the pointer device moves, the hot spot will then "jump" to its ;; visual position. (IF (< (HOT-SPOT.X (SPRITE.HOT SPRITE)) (BOX.LEFT (SPRITE.PHYS-LIMITS SPRITE))) (SETF (HOT-SPOT.X (SPRITE.HOT SPRITE)) (BOX.LEFT (SPRITE.PHYS-LIMITS SPRITE))) ;;ELSE (IF (>= (HOT-SPOT.X (SPRITE.HOT SPRITE)) (BOX.RIGHT (SPRITE.PHYS-LIMITS SPRITE))) (SETF (HOT-SPOT.X (SPRITE.HOT SPRITE)) (1- (BOX.RIGHT (SPRITE.PHYS-LIMITS SPRITE)))))) (IF (< (HOT-SPOT.Y (SPRITE.HOT SPRITE)) (BOX.TOP (SPRITE.PHYS-LIMITS SPRITE))) (SETF (HOT-SPOT.Y (SPRITE.HOT SPRITE)) (BOX.TOP (SPRITE.PHYS-LIMITS SPRITE))) ;;ELSE (IF (>= (HOT-SPOT.Y (SPRITE.HOT SPRITE)) (BOX.BOTTOM (SPRITE.PHYS-LIMITS SPRITE))) (SETF (HOT-SPOT.Y (SPRITE.HOT SPRITE)) (1- (BOX.BOTTOM (SPRITE.PHYS-LIMITS SPRITE)))))) (WHEN (OR (NOT (= (HOT-SPOT.X OLD) (HOT-SPOT.X (SPRITE.HOT SPRITE)))) (NOT (= (HOT-SPOT.Y OLD) (HOT-SPOT.Y (SPRITE.HOT SPRITE))))) (EXPLORER-SET-CURSOR-POSITION CURRENT-SCREEN (HOT-SPOT.X (SPRITE.HOT SPRITE)) (HOT-SPOT.Y (SPRITE.HOT SPRITE)) NIL)))) (EVENT-TRACE-LEAVING "CHECK-PHYSICAL-LIMITS")) (DEFUN GET-NEXT-EVENT-MASK () (DECLARE (VALUES INTEGER)) (SETQ LAST-EVENT-MASK (ASH LAST-EVENT-MASK 1)) LAST-EVENT-MASK) (DEFUN SET-MASK-FOR-EVENT (MASK EVENT) (DECLARE (TYPE INTEGER MASK EVENT)) (WHEN (OR (< EVENT LAST-EVENT) (>= EVENT 128)) (ERROR "MaskForEvent: bogus event number ~D" EVENT)) (SETF (AREF FILTERS EVENT) MASK)) (DEFUN NEW-CURSOR-CONFINES (X1 X2 Y1 Y2) (DECLARE (TYPE INTEGER X1 X2 Y1 Y2)) (EVENT-TRACE-ENTERING "NEW-CURSOR-CONFINES") (SETF (BOX.LEFT (SPRITE.HOT-LIMITS SPRITE)) X1) (SETF (BOX.RIGHT (SPRITE.HOT-LIMITS SPRITE)) X2) (SETF (BOX.TOP (SPRITE.HOT-LIMITS SPRITE)) Y1) (SETF (BOX.BOTTOM (SPRITE.HOT-LIMITS SPRITE)) Y2) (CHECK-PHYSICAL-LIMITS (SPRITE.CURRENT SPRITE)) (CONSTRAIN-CURSOR CURRENT-SCREEN (SPRITE.PHYS-LIMITS SPRITE)) (EVENT-TRACE-LEAVING "NEW-CURSOR-CONFINES")) (DEFUN COMPUTE-FREEZES (DEV1 DEV2) (DECLARE (TYPE DEVICE DEV1 DEV2)) (EVENT-TRACE-ENTERING "COMPUTE-FREEZES") (LET ((REPLAY-DEV (SYNC-EVENTS.REPLAY-DEVICE SYNC-EVENTS)) WINDOW IS-KEYBOARD EVENT) (SETF (SYNC.FROZEN (DEVICE.SYNC DEV1)) (IF (OR (SYNC.OTHER (DEVICE.SYNC DEV1)) (>= (SYNC.STATE (DEVICE.SYNC DEV1)) FROZEN)) T NIL)) (SETF (SYNC.FROZEN (DEVICE.SYNC DEV2)) (IF (OR (SYNC.OTHER (DEVICE.SYNC DEV2)) (>= (SYNC.STATE (DEVICE.SYNC DEV2)) FROZEN)) T NIL)) (WHEN (NULL (SYNC-EVENTS.PLAYING-EVENTS SYNC-EVENTS)) (SETF (SYNC-EVENTS.PLAYING-EVENTS SYNC-EVENTS) T) (WHEN REPLAY-DEV (block PLAYMORE (SETQ IS-KEYBOARD (= REPLAY-DEV (INPUT-INFO.KEYBOARD INPUT-INFO))) (SETQ EVENT (SYNC.EVENT REPLAY-DEV)) (SETF (SYNC-EVENTS.REPLAY-DEVICE SYNC-EVENTS) NIL) (SETQ WINDOW (XY-TO-WINDOW (X-EVENT-KEY-BUTTON-POINTER.ROOT-X EVENT) (X-EVENT-KEY-BUTTON-POINTER.ROOT-Y EVENT))) (LOOP FOR INDEX FROM 0 BELOW SPRITE-TRACE-GOOD WHEN (= (SYNC-EVENTS.REPLAY-WINDOW SYNC-EVENTS) (AREF SPRITE-TRACE INDEX)) DO (PROGN (WHEN (NULL (CHECK-DEVICE-GRABS REPLAY-DEV EVENT (1+ INDEX) IS-KEYBOARD)) (IF IS-KEYBOARD (NORMAL-KEYBOARD-EVENT REPLAY-DEV EVENT WINDOW) ;;ELSE (DELIVER-DEVICE-EVENTS WINDOW EVENT NIL NIL))) (return-from PLAYMORE NIL))) ;; Must not still be in the same stack. (IF IS-KEYBOARD (NORMAL-KEYBOARD-EVENT REPLAY-DEV EVENT WINDOW) ;;ELSE (DELIVER-DEVICE-EVENTS WINDOW EVENT NIL NIL)))) (WHEN (OR (NOT (SYNC.FROZEN (DEVICE.SYNC DEV1))) (NOT (SYNC.FROZEN (DEVICE.SYNC DEV2)))) (PLAY-RELEASED-EVENTS)) (SETF (SYNC-EVENTS.PLAYING-EVENTS SYNC-EVENTS) NIL))) (EVENT-TRACE-LEAVING "COMPUTE-FREEZES")) (DEFUN CHECK-GRAB-FOR-SYNCS (GRAB THIS-DEV THIS-MODE OTHER-DEV OTHER-MODE) (DECLARE (TYPE GRAB-RECORD GRAB) (TYPE DEVICE THIS-DEV OTHER-DEV) (TYPE boolean THIS-MODE OTHER-MODE)) (EVENT-TRACE-ENTERING "CHECK-GRAB-FOR-SYNCS") (IF (= THIS-MODE GRAB-MODE-SYNC) (SETF (SYNC.STATE (DEVICE.SYNC THIS-DEV)) FROZEN-NO-EVENT) ;;ELSE (PROGN ;; Free both if same client owns both. (SETF (SYNC.STATE (DEVICE.SYNC THIS-DEV)) THAWED) (WHEN (AND (SYNC.OTHER (DEVICE.SYNC THIS-DEV)) (EQ (GRAB-RECORD.CLIENT (SYNC.OTHER (DEVICE.SYNC THIS-DEV))) (GRAB-RECORD.CLIENT GRAB))) (SETF (SYNC.OTHER (DEVICE.SYNC THIS-DEV)) NIL)))) (IF (= OTHER-MODE GRAB-MODE-SYNC) (SETF (SYNC.OTHER (DEVICE.SYNC OTHER-DEV)) GRAB) ;;ELSE (PROGN ;; Free both if same client owns both. (WHEN (AND (SYNC.OTHER (DEVICE.SYNC OTHER-DEV)) (EQ (GRAB-RECORD.CLIENT (SYNC.OTHER (DEVICE.SYNC OTHER-DEV))) (GRAB-RECORD.CLIENT GRAB))) (SETF (SYNC.OTHER (DEVICE.SYNC OTHER-DEV)) NIL)))) (COMPUTE-FREEZES THIS-DEV OTHER-DEV) (EVENT-TRACE-LEAVING "CHECK-GRAB-FOR-SYNCS")) (DEFUN ACTIVATE-POINTER-GRAB (MOUSE GRAB TIME AUTO-GRAB) (DECLARE (TYPE DEVICE MOUSE) (TYPE GRAB-RECORD GRAB) (TYPE TIME-STAMP TIME) (TYPE BOOLEAN AUTO-GRAB)) (EVENT-TRACE-ENTERING "ACTIVATE-POINTER-GRAB") (EVENT-TRACE ", (LENGTH DEVICE.GRAB)=~D" (LENGTH (DEVICE.GRAB MOUSE))) (LET ((WINDOW (GRAB-RECORD.CONFINE-TO GRAB)) (OLD-WIN (IF (DEVICE.GRAB MOUSE) (GRAB-RECORD.WINDOW (DEVICE.GRAB MOUSE)) ;;ELSE (SPRITE.WINDOW SPRITE)))) (DECLARE (TYPE (OR NULL WINDOW) WINDOW) (TYPE WINDOW OLD-WIN)) (WHEN WINDOW (NEW-CURSOR-CONFINES (WINDOW.ABSOLUTE-INSIDE-X WINDOW) (+ (WINDOW.ABSOLUTE-INSIDE-X WINDOW) (WINDOW.WIDTH WINDOW)) (WINDOW.ABSOLUTE-INSIDE-Y WINDOW) (+ (WINDOW.ABSOLUTE-INSIDE-Y WINDOW) (WINDOW.HEIGHT WINDOW)))) (DO-ENTER-LEAVE-EVENTS OLD-WIN (GRAB-RECORD.WINDOW GRAB) NOTIFY-GRAB) (SETQ MOTION-HINT-WINDOW NIL) (SETF (DEVICE.GRAB-TIME MOUSE) TIME) (SETQ PTR-GRAB (COPY-STRUCTURE-OBJECT GRAB)) (SETF (DEVICE.GRAB MOUSE) PTR-GRAB) (EVENT-TRACE "~%Inside ACTIVATE-POINTER-GRAB, (LENGTH DEVICE.GRAB)=~D" (LENGTH (DEVICE.GRAB MOUSE))) (SETF (DEVICE.AUTO-RELEASE-GRAB MOUSE) AUTO-GRAB) (POST-NEW-CURSOR) (EVENT-TRACE "~%Inside ACTIVATE-POINTER-GRAB, (LENGTH DEVICE.GRAB)=~D" (LENGTH (DEVICE.GRAB MOUSE))) (CHECK-GRAB-FOR-SYNCS (DEVICE.GRAB MOUSE) MOUSE (GRAB-RECORD.POINTER-MODE GRAB) (INPUT-INFO.KEYBOARD INPUT-INFO) (GRAB-RECORD.KEYBOARD-MODE GRAB))) (EVENT-TRACE-LEAVING "ACTIVATE-POINTER-GRAB") (EVENT-TRACE ", (LENGTH DEVICE.GRAB)=~D" (LENGTH (DEVICE.GRAB MOUSE)))) (DEFUN DEACTIVATE-POINTER-GRAB (MOUSE) (DECLARE (TYPE DEVICE MOUSE)) (EVENT-TRACE-ENTERING "DEACTIVATE-POINTER-GRAB") (LET ((GRAB (DEVICE.GRAB MOUSE)) (KEYBOARD (INPUT-INFO.KEYBOARD INPUT-INFO))) (DECLARE (TYPE GRAB-RECORD GRAB) (TYPE DEVICE KEYBOARD)) (EVENT-TRACE ", (length grab)=~D" (length grab)) (SETQ MOTION-HINT-WINDOW NIL) (SETF (DEVICE.GRAB MOUSE) NIL) (SETF (SYNC.STATE (DEVICE.SYNC MOUSE)) NOT-GRABBED) (SETF (DEVICE.AUTO-RELEASE-GRAB MOUSE) NIL) (WHEN (EQ (SYNC.OTHER (DEVICE.SYNC KEYBOARD)) GRAB) (SETF (SYNC.OTHER (DEVICE.SYNC KEYBOARD)) NIL)) (DO-ENTER-LEAVE-EVENTS (GRAB-RECORD.WINDOW GRAB) (SPRITE.WINDOW SPRITE) NOTIFY-UNGRAB) (COMPUTE-FREEZES KEYBOARD MOUSE) (WHEN (GRAB-RECORD.CONFINE-TO GRAB) (NEW-CURSOR-CONFINES 0 (SCREEN.WIDTH CURRENT-SCREEN) 0 (SCREEN.HEIGHT CURRENT-SCREEN))) (POST-NEW-CURSOR)) (EVENT-TRACE-LEAVING "DEACTIVATE-POINTER-GRAB")) (DEFUN ACTIVATE-KEYBOARD-GRAB (KEYBOARD GRAB TIME PASSIVE) (DECLARE (TYPE DEVICE KEYBOARD) (TYPE GRAB-RECORD GRAB) (TYPE TIME-STAMP TIME) (TYPE BOOLEAN PASSIVE)) (EVENT-TRACE-ENTERING "ACTIVATE-KEYBOARD-GRAB") (LET ((OLD-WIN (IF (DEVICE.GRAB KEYBOARD) (GRAB-RECORD.WINDOW (DEVICE.GRAB KEYBOARD)) ;;ELSE (DEVICE.FOCUS-WINDOW KEYBOARD)))) (DO-FOCUS-EVENTS OLD-WIN (GRAB-RECORD.WINDOW GRAB) NOTIFY-GRAB) (SETF (DEVICE.GRAB-TIME KEYBOARD) TIME) (SETQ KEYBD-GRAB (COPY-STRUCTURE-OBJECT GRAB)) (SETF (DEVICE.GRAB KEYBOARD) KEYBD-GRAB) (SETF (DEVICE.PASSIVE-GRAB KEYBOARD) PASSIVE) (CHECK-GRAB-FOR-SYNCS (DEVICE.GRAB KEYBOARD) KEYBOARD (GRAB-RECORD.KEYBOARD-MODE GRAB) (INPUT-INFO.POINTER INPUT-INFO) (GRAB-RECORD.POINTER-MODE GRAB))) (EVENT-TRACE-LEAVING "ACTIVATE-KEYBOARD-GRAB")) (DEFUN DEACTIVATE-KEYBOARD-GRAB (KEYBOARD) (DECLARE (TYPE DEVICE KEYBOARD)) (EVENT-TRACE-ENTERING "DEACTIVATE-KEYBOARD-GRAB") (LET ((MOUSE (INPUT-INFO.POINTER INPUT-INFO)) (GRAB (DEVICE.GRAB KEYBOARD))) (DECLARE (TYPE DEVICE MOUSE) (TYPE GRAB-RECORD GRAB)) (SETF (DEVICE.GRAB KEYBOARD) NIL) (SETF (SYNC.STATE (DEVICE.SYNC KEYBOARD)) NOT-GRABBED) (SETF (DEVICE.PASSIVE-GRAB KEYBOARD) NIL) (WHEN (EQ (SYNC.OTHER (DEVICE.SYNC MOUSE)) GRAB) (SETF (SYNC.OTHER (DEVICE.SYNC MOUSE)) NIL)) (DO-FOCUS-EVENTS (GRAB-RECORD.WINDOW GRAB) (DEVICE.FOCUS-WINDOW KEYBOARD) NOTIFY-UNGRAB) (COMPUTE-FREEZES KEYBOARD MOUSE)) (EVENT-TRACE-LEAVING "DEACTIVATE-KEYBOARD-GRAB")) (DEFUN COMPARE-TIME-STAMPS (A B) "Compare timestamps for A with B. If AB in time then returns 1, otherwise returns 0." (DECLARE (TYPE TIME-STAMP A B) (VALUES (INTEGER -1 1))) (COND ((< (TIME-STAMP.MONTHS A) (TIME-STAMP.MONTHS B)) -1) ((> (TIME-STAMP.MONTHS A) (TIME-STAMP.MONTHS B)) 1) ((< (TIME-STAMP.MILLISECONDS A) (TIME-STAMP.MILLISECONDS B)) -1) ((> (TIME-STAMP.MILLISECONDS A) (TIME-STAMP.MILLISECONDS B)) 1) (T 0))) (DEFUN ALLOW-SOME (CLIENT TIME THIS-DEV OTHER-DEV NEW-STATE) (DECLARE (TYPE STATE CLIENT) (TYPE TIME-STAMP TIME) (TYPE DEVICE THIS-DEV OTHER-DEV) (TYPE INTEGER NEW-STATE)) (EVENT-TRACE-ENTERING "ALLOW-SOME") (LET ((THIS-GRABBED (AND (DEVICE.GRAB THIS-DEV) (EQ (GRAB-RECORD.CLIENT (DEVICE.GRAB THIS-DEV)) CLIENT))) (OTHER-GRABBED (AND (DEVICE.GRAB OTHER-DEV) (EQ (GRAB-RECORD.CLIENT (DEVICE.GRAB OTHER-DEV)) CLIENT))) GRAB-TIME) (DECLARE (TYPE BOOLEAN THIS-GRABBED ) (TYPE (OR NULL TIME-STAMP) GRAB-TIME)) (WHEN (OR (AND THIS-GRABBED (>= (SYNC.STATE (DEVICE.SYNC THIS-DEV)) FROZEN)) (AND OTHER-GRABBED (SYNC.OTHER (DEVICE.SYNC THIS-DEV)))) (IF (AND THIS-GRABBED (OR (NULL OTHER-GRABBED) (MINUSP (COMPARE-TIME-STAMPS (DEVICE.GRAB-TIME OTHER-DEV) (DEVICE.GRAB-TIME THIS-DEV))))) (SETQ GRAB-TIME (DEVICE.GRAB-TIME THIS-DEV)) ;;ELSE (SETQ GRAB-TIME (DEVICE.GRAB-TIME OTHER-DEV))) (IF (OR (PLUSP (COMPARE-TIME-STAMPS TIME CURRENT-TIME)) (MINUSP (COMPARE-TIME-STAMPS TIME GRAB-TIME))) NIL ;;ELSE (SELECTOR NEW-STATE eql (THAWED ; Async (WHEN THIS-GRABBED (SETF (SYNC.STATE (DEVICE.SYNC THIS-DEV)) THAWED)) (WHEN OTHER-GRABBED (SETF (SYNC.OTHER (DEVICE.SYNC THIS-DEV)) NIL)) (COMPUTE-FREEZES THIS-DEV OTHER-DEV)) (FREEZE-NEXT-EVENT ; Sync (WHEN THIS-GRABBED (SETF (SYNC.STATE (DEVICE.SYNC THIS-DEV)) FREEZE-NEXT-EVENT) (WHEN OTHER-GRABBED (SETF (SYNC.OTHER (DEVICE.SYNC THIS-DEV)) NIL)) (COMPUTE-FREEZES THIS-DEV OTHER-DEV))) (THAWED-BOTH ; AsyncBoth (WHEN (OR (AND OTHER-GRABBED (>= (SYNC.STATE (DEVICE.SYNC OTHER-DEV)) FROZEN)) (AND THIS-GRABBED (SYNC.OTHER (DEVICE.SYNC OTHER-DEV)))) (WHEN THIS-GRABBED (SETF (SYNC.STATE (DEVICE.SYNC THIS-DEV)) THAWED) (SETF (SYNC.OTHER (DEVICE.SYNC OTHER-DEV)) NIL)) (WHEN OTHER-GRABBED (SETF (SYNC.STATE (DEVICE.SYNC OTHER-DEV)) THAWED) (SETF (SYNC.OTHER (DEVICE.SYNC THIS-DEV)) NIL)) (COMPUTE-FREEZES THIS-DEV OTHER-DEV))) (FREEZE-BOTH-NEXT-EVENT ; SyncBoth (WHEN (OR (AND OTHER-GRABBED (>= (SYNC.STATE (DEVICE.SYNC OTHER-DEV)) FROZEN)) (AND THIS-GRABBED (SYNC.OTHER (DEVICE.SYNC OTHER-DEV)))) (WHEN THIS-GRABBED (SETF (SYNC.STATE (DEVICE.SYNC THIS-DEV)) FREEZE-BOTH-NEXT-EVENT) (SETF (SYNC.OTHER (DEVICE.SYNC OTHER-DEV)) NIL)) (WHEN OTHER-GRABBED (SETF (SYNC.STATE (DEVICE.SYNC OTHER-DEV)) FREEZE-BOTH-NEXT-EVENT) (SETF (SYNC.OTHER (DEVICE.SYNC THIS-DEV)) NIL) (COMPUTE-FREEZES THIS-DEV OTHER-DEV)))) (NOT-GRABBED ; Replay (WHEN (AND THIS-GRABBED (= (SYNC.STATE (DEVICE.SYNC THIS-DEV)) FROZEN-WITH-EVENT)) (SETF (SYNC-EVENTS.REPLAY-DEVICE SYNC-EVENTS) THIS-DEV) (SETF (SYNC-EVENTS.REPLAY-WINDOW SYNC-EVENTS) (GRAB-RECORD.WINDOW (DEVICE.GRAB THIS-DEV))) (IF (= THIS-DEV (INPUT-INFO.POINTER INPUT-INFO)) (DEACTIVATE-POINTER-GRAB THIS-DEV) ;;ELSE (DEACTIVATE-KEYBOARD-GRAB THIS-DEV)) (SETF (SYNC-EVENTS.REPLAY-DEVICE SYNC-EVENTS) NIL))))))) (EVENT-TRACE-LEAVING "ALLOW-SOME")) (DEFUN RELEASE-ACTIVE-GRABS (CLIENT) (DECLARE (TYPE STATE CLIENT)) (EVENT-TRACE-ENTERING "RELEASE-ACTIVE-GRABS") (LOOP FOR INDEX FROM 0 BELOW (INPUT-INFO.NUM-DEVICES INPUT-INFO) FOR DEVICE = (AREF (INPUT-INFO.DEVICES INPUT-INFO) INDEX) WHEN (AND (DEVICE.GRAB DEVICE) (EQ (GRAB-RECORD.CLIENT (DEVICE.GRAB DEVICE)) CLIENT)) DO (COND ((SETQ DEVICE (INPUT-INFO.KEYBOARD INPUT-INFO)) (DEACTIVATE-KEYBOARD-GRAB DEVICE)) ((EQ DEVICE (INPUT-INFO.POINTER INPUT-INFO)) (DEACTIVATE-POINTER-GRAB DEVICE)) (T (SETF (DEVICE.GRAB DEVICE) NIL)))) (EVENT-TRACE-LEAVING "RELEASE-ACTIVE-GRABS")) (DEFUN TRY-CLIENT-EVENTS (CLIENT EVENTS COUNT MASK FILTER GRAB) (DECLARE (TYPE (OR NULL STATE) CLIENT) (TYPE (OR LIST EVENT-RECORD) EVENTS) (TYPE INTEGER COUNT MASK FILTER) (TYPE (OR NULL GRAB-RECORD) GRAB) (VALUES INTEGER)) (EVENT-TRACE-ENTERING "TRY-CLIENT-EVENTS") (LET ((RETURN-VALUE 0) ;; Events can be a single event or several events. (EVENT (IF (NOT (CONSP EVENTS)) EVENTS ;;ELSE (CAR EVENTS))) (ALL-DONE NIL)) (WHEN (AND CLIENT ;; The C code compared CLIENT with serverClient, which we can't do. ;; Hopefully, not doing this comparison will still work OK. (TWE) ;;(NEQ CLIENT *STATE*) (NOT (STATE.CLIENT-GONE CLIENT)) (OR (= FILTER CANT-BE-FILTERED) (NOT (ZEROP (LOGAND MASK FILTER))))) (COND ((AND grab (NOT (EQ CLIENT (GRAB-RECORD.CLIENT GRAB)))) (SETQ all-done t) (SETQ return-value -1)) ((= (EVENT-U.TYPE EVENT) MOTION-NOTIFY-EVENT) (EVENT-TRACE "~%IN TRY-CLIENT-EVENTS, have MOTION-NOTIFY-EVENT, mask=x~16R, MOTION-HINT-WINDOW=~A" MASK MOTION-HINT-WINDOW) (EVENT-TRACE "~% POINTER.EVENT=~A, NOT ZEROP=~A, EQ=~A" (X-EVENT-KEY-BUTTON-POINTER.EVENT EVENT) (NOT (ZEROP (LOGAND MASK POINTER-MOTION-HINT-MASK))) (EQ MOTION-HINT-WINDOW (X-EVENT-KEY-BUTTON-POINTER.EVENT EVENT))) (IF (NOT (ZEROP (LOGAND MASK POINTER-MOTION-HINT-MASK))) (IF (EQ MOTION-HINT-WINDOW (X-EVENT-KEY-BUTTON-POINTER.EVENT EVENT)) (SETQ ALL-DONE T) ;;ELSE (SETF (X-EVENT-KEY-BUTTON-POINTER.DETAIL EVENT) NOTIFY-HINT)) ;;ELSE (SETF (X-EVENT-KEY-BUTTON-POINTER.DETAIL EVENT) NOTIFY-NORMAL)))) (WHEN (NOT ALL-DONE) ;; Note that the keymap event doesn't have a sequence-ID. (IF (NOT (CONSP EVENTS)) (WHEN (NOT (TYPEP EVENTS 'EVENT-KEYMAP-EVENT)) (SETF (EVENT-U.SEQUENCE-ID EVENTS) (STATE.SEQUENCE-ID CLIENT))) ;;ELSE ;; There is more than one event. Handle all of them at once. (DOLIST (EVENT EVENTS) (WHEN (NOT (TYPEP EVENT 'EVENT-KEYMAP-EVENT)) (SETF (EVENT-U.SEQUENCE-ID EVENT) (STATE.SEQUENCE-ID CLIENT))))) (WRITE-EVENTS-TO-CLIENT CLIENT COUNT EVENTS) (SETQ RETURN-VALUE 1))) (EVENT-TRACE-LEAVING "TRY-CLIENT-EVENTS") (EVENT-TRACE ", Returning ~A" RETURN-VALUE) RETURN-VALUE)) (DEFUN DELIVER-EVENTS-TO-WINDOW (WINDOW EVENTS COUNT FILTER GRAB) (DECLARE (TYPE WINDOW WINDOW) (TYPE EVENT-RECORD EVENTS) (TYPE INTEGER COUNT FILTER) (TYPE (OR NULL GRAB-RECORD) GRAB) (VALUES INTEGER)) (EVENT-TRACE-ENTERING "DELIVER-EVENTS-TO-WINDOW") (LET ((*STATE* (WINDOW.CLIENT WINDOW)) ;; Events can be a single event or several events. (EVENT (IF (NOT (CONSP EVENTS)) EVENTS ;;ELSE (CAR EVENTS))) (DELIVERIES 0) (nondeliveries 0) (attempts nil) (CLIENT NIL) ;; If a grab occurs due to a button press, then ;; this mask is the mask of the grab. (DELIVERY-MASK 0)) (DECLARE (INTEGER DELIVERIES DELIVERY-MASK)) ;; if nobody ever wants to see this event, skip some work (PROG1 (IF (AND (NOT (= FILTER CANT-BE-FILTERED)) (ZEROP (LOGAND (WINDOW.ALL-EVENT-MASKS WINDOW) FILTER))) 0 ;;ELSE (PROGN (SETQ attempts (TRY-CLIENT-EVENTS (WINDOW.CLIENT WINDOW) EVENTS COUNT (WINDOW-EVENT-MASKS WINDOW) FILTER GRAB)) (WHEN (NOT (ZEROP attempts)) (IF (PLUSP attempts) (PROGN (INCF DELIVERIES) (SETQ CLIENT (WINDOW.CLIENT WINDOW)) 1 *;(SETQ *STATE* CLIENT) (SETQ DELIVERY-MASK (WINDOW-EVENT-MASKS WINDOW))) ;1;ELSE* (decf nondeliveries))) ;; Cant-Be-Filtered means only window owner gets the event. (WHEN (NOT (= FILTER CANT-BE-FILTERED)) (LOOP FOR OTHER IN (OTHER-CLIENTS WINDOW) DO (PROGN (SETQ attempts (TRY-CLIENT-EVENTS (OTHER-CLIENT.CLIENT OTHER) EVENTS COUNT (OTHER-CLIENT.MASK OTHER) FILTER GRAB)) (WHEN (NOT (ZEROP attempts)) (IF (PLUSP attempts) (PROGN (INCF DELIVERIES) (SETQ CLIENT (OTHER-CLIENT.CLIENT OTHER)) (SETQ DELIVERY-MASK (OTHER-CLIENT.MASK OTHER))) ;1;ELSE* (DECF nondeliveries)))))) (IF (AND (= (EVENT-U.TYPE EVENT) BUTTON-PRESS-EVENT) (PLUSP DELIVERIES) (NULL GRAB)) (LET ((TEMP-GRAB (MAKE-GRAB-RECORD :DEVICE (INPUT-INFO.POINTER INPUT-INFO) :CLIENT CLIENT :WINDOW WINDOW :OWNER-EVENTS (NOT (ZEROP (LOGAND DELIVERY-MASK OWNER-GRAB-BUTTON-MASK))) :EVENT-MASK DELIVERY-MASK :KEYBOARD-MODE GRAB-MODE-ASYNC :POINTER-MODE GRAB-MODE-ASYNC :CONFINE-TO NIL :CURSOR NIL))) (ACTIVATE-POINTER-GRAB (INPUT-INFO.POINTER INPUT-INFO) TEMP-GRAB CURRENT-TIME T)) ;;ELSE (WHEN (AND (= (EVENT-U.TYPE EVENT) MOTION-NOTIFY-EVENT) (PLUSP DELIVERIES)) (SETQ MOTION-HINT-WINDOW WINDOW))) (IF (PLUSP DELIVERIES) deliveries nondeliveries))) (EVENT-TRACE-LEAVING "DELIVER-EVENTS-TO-WINDOW")))) (DEFUN MAYBE-DELIVER-EVENTS-TO-CLIENT (WINDOW EVENTS COUNT FILTER DONT-DELIVER-TO-ME) (DECLARE (TYPE WINDOW WINDOW) (TYPE (OR LIST EVENT-RECORD) EVENTS) (TYPE INTEGER COUNT FILTER) (TYPE STATE DONT-DELIVER-TO-ME) (VALUES INTEGER)) (EVENT-TRACE-ENTERING "MAYBE-DELIVER-EVENTS-TO-CLIENT") (LET ((ALL-DONE NIL) (RETURN-VALUE 0)) (WHEN (NOT (ZEROP (LOGAND (WINDOW-EVENT-MASKS WINDOW) FILTER))) (COND ((EQ (WINDOW.CLIENT WINDOW) DONT-DELIVER-TO-ME) (SETQ ALL-DONE T)) (T (SETQ ALL-DONE T RETURN-VALUE (TRY-CLIENT-EVENTS (WINDOW.CLIENT WINDOW) EVENTS COUNT (WINDOW-EVENT-MASKS WINDOW) FILTER NIL))))) (WHEN (NOT ALL-DONE) (LOOP FOR OTHER IN (OTHER-CLIENTS WINDOW) DO (WHEN (NOT (ZEROP (LOGAND (OTHER-CLIENT.MASK OTHER) FILTER))) (COND ((EQ (OTHER-CLIENT.CLIENT OTHER) DONT-DELIVER-TO-ME) (SETQ ALL-DONE T) (RETURN NIL)) (T (SETQ ALL-DONE T RETURN-VALUE (TRY-CLIENT-EVENTS (OTHER-CLIENT.CLIENT OTHER) EVENTS COUNT (OTHER-CLIENT.MASK OTHER) FILTER NIL)) (RETURN NIL)))))) (EVENT-TRACE-LEAVING "MAYBE-DELIVER-EVENTS-TO-CLIENT") (IF ALL-DONE RETURN-VALUE ;;ELSE 2))) (DEFUN FIX-UP-EVENT-FROM-WINDOW (EVENT WINDOW CHILD CALC-CHILD) (DECLARE (TYPE EVENT-RECORD EVENT) (TYPE WINDOW WINDOW) (TYPE (OR NULL WINDOW) CHILD) (TYPE BOOLEAN CALC-CHILD)) (EVENT-TRACE-ENTERING "FIX-UP-EVENT-FROM-WINDOW") (WHEN CALC-CHILD (LET ((W (AREF SPRITE-TRACE (1- SPRITE-TRACE-GOOD)))) ;; If the search ends up past the root should the child field be ;; set to none or should the value in the argument be passed ;; through. It probably doesn't matter since everyone calls ;; this function with child == None anyway. (LOOP (WHEN (NULL W) (RETURN NIL)) ;; If the source window is same as event window, child should be ;; none. Don't bother going all all the way back to the root. (WHEN (EQ W WINDOW) (SETQ CHILD NIL) (RETURN NIL)) (WHEN (EQ (WINDOW.PARENT W) WINDOW) (SETQ CHILD W) (RETURN NIL)) (SETQ W (WINDOW.PARENT W))))) (SETF (X-EVENT-KEY-BUTTON-POINTER.ROOT EVENT) (ROOT)) (SETF (X-EVENT-KEY-BUTTON-POINTER.EVENT EVENT) WINDOW) (IF (EQ CURRENT-SCREEN (SCREEN-FOR-WINDOW WINDOW)) (PROGN (SETF (X-EVENT-KEY-BUTTON-POINTER.SAME-SCREEN EVENT) T) (SETF (X-EVENT-KEY-BUTTON-POINTER.CHILD EVENT) CHILD) (SETF (X-EVENT-KEY-BUTTON-POINTER.EVENT-X EVENT) (- (X-EVENT-KEY-BUTTON-POINTER.ROOT-X EVENT) (WINDOW.ABSOLUTE-INSIDE-X WINDOW))) (SETF (X-EVENT-KEY-BUTTON-POINTER.EVENT-Y EVENT) (- (X-EVENT-KEY-BUTTON-POINTER.ROOT-Y EVENT) (WINDOW.ABSOLUTE-INSIDE-Y WINDOW)))) ;;ELSE (PROGN (SETF (X-EVENT-KEY-BUTTON-POINTER.SAME-SCREEN EVENT) NIL) (SETF (X-EVENT-KEY-BUTTON-POINTER.CHILD EVENT) NIL) (SETF (X-EVENT-KEY-BUTTON-POINTER.EVENT-X EVENT) 0) (SETF (X-EVENT-KEY-BUTTON-POINTER.EVENT-Y EVENT) 0))) (EVENT-TRACE-LEAVING "FIX-UP-EVENT-FROM-WINDOW")) (DEFUN DELIVER-DEVICE-EVENTS (WINDOW EVENT GRAB STOP-AT) (DECLARE (TYPE (OR NULL WINDOW) WINDOW STOP-AT) (TYPE EVENT-RECORD EVENT) (TYPE (OR NULL GRAB-RECORD) GRAB) (VALUES INTEGER)) (EVENT-TRACE-ENTERING "DELIVER-DEVICE-EVENTS") (EVENT-TRACE ", event type=~D., filter=x~16R, deliverable events=x~16R, Window=x~16R" (EVENT-U.TYPE EVENT) (AREF FILTERS (EVENT-U.TYPE EVENT)) (WINDOW.DELIVERABLE-EVENTS WINDOW) (WINDOW.ID WINDOW)) (LET ((FILTER (AREF FILTERS (EVENT-U.TYPE EVENT))) (DELIVERIES 0) CHILD) (DECLARE (INTEGER FILTER DELIVERIES)) (PROG1 (IF (AND (NOT (= FILTER CANT-BE-FILTERED)) (ZEROP (LOGAND FILTER (WINDOW.DELIVERABLE-EVENTS WINDOW)))) 0 ;;ELSE (block RETURN-VALUE (LOOP (WHEN (NULL WINDOW) (RETURN NIL)) (FIX-UP-EVENT-FROM-WINDOW EVENT WINDOW CHILD NIL) (SETQ DELIVERIES (DELIVER-EVENTS-TO-WINDOW WINDOW EVENT 1 FILTER GRAB)) (WHEN (OR (PLUSP DELIVERIES) (NOT (ZEROP (LOGAND FILTER (WINDOW-DONT-PROPAGATE WINDOW))))) (return-from RETURN-VALUE DELIVERIES)) (WHEN (EQ WINDOW STOP-AT) (return-from RETURN-VALUE 0)) (SETQ CHILD WINDOW) (SETQ WINDOW (WINDOW.PARENT WINDOW))) 0)) (EVENT-TRACE-LEAVING "DELIVER-DEVICE-EVENTS")))) (DEFUN DELIVER-EVENTS (WINDOW EVENT COUNT OTHER-PARENT) (DECLARE (TYPE WINDOW WINDOW OTHER-PARENT) (TYPE EVENT-RECORD EVENT) (TYPE INTEGER COUNT) (VALUES INTEGER)) (EVENT-TRACE-ENTERING "DELIVER-EVENTS") ;; Not useful for events that propagate up the tree. (PROG1 (IF (ZEROP COUNT) 0 ;;ELSE (LET ((FILTER (AREF FILTERS (EVENT-U.TYPE EVENT))) DELIVERIES) (WHEN (AND (NOT (ZEROP (LOGAND FILTER SUBSTRUCTURE-NOTIFY-MASK))) (NOT (= (EVENT-U.TYPE EVENT) CREATE-NOTIFY-EVENT))) (SETF (X-EVENT-DESTROY-NOTIFY.EVENT EVENT) WINDOW)) (IF (NOT (= FILTER STRUCTURE-AND-SUB-MASK)) (DELIVER-EVENTS-TO-WINDOW WINDOW EVENT COUNT FILTER NIL) ;;ELSE (PROGN (SETQ DELIVERIES (DELIVER-EVENTS-TO-WINDOW WINDOW EVENT COUNT STRUCTURE-NOTIFY-MASK NIL)) (WHEN (WINDOW.PARENT WINDOW) (SETF (X-EVENT-DESTROY-NOTIFY.EVENT EVENT) (WINDOW.PARENT WINDOW)) (INCF DELIVERIES (DELIVER-EVENTS-TO-WINDOW (WINDOW.PARENT WINDOW) EVENT COUNT SUBSTRUCTURE-NOTIFY-MASK NIL)) (WHEN (= (EVENT-U.TYPE EVENT) REPARENT-NOTIFY-EVENT) (SETF (X-EVENT-DESTROY-NOTIFY.EVENT EVENT) OTHER-PARENT) (INCF DELIVERIES (DELIVER-EVENTS-TO-WINDOW OTHER-PARENT EVENT COUNT SUBSTRUCTURE-NOTIFY-MASK NIL)))) DELIVERIES)))) (EVENT-TRACE-LEAVING "DELIVER-EVENTS"))) ;;; check root -- this fails in Zaphod mode XXX */ ;;; XYToWindow is only called by CheckMotion after it has determined that ;;; the current cache is not accurate. ;;; Implementation note: The absolute-x/y-corner slots in the C window ;;; structure refer to the absolute coordinates of the window's origin, hence ;;; they need to subtract off the border width to obtain the coordinates of the ;;; window's upper left edge. In the Lisp window structure, these same slots ;;; refer to the absolute coordinates of the window's upper left edge. (ZWEI:DEFINE-INDENTATION POINT-IN-WINDOW (1 1)) (DEFUN XY-TO-WINDOW (X Y) (DECLARE (INTEGER X Y) (VALUES WINDOW)) (EVENT-TRACE-ENTERING "XY-TO-WINDOW") (EVENT-TRACE ", (X,Y)=(~D,~D), root=~A" X Y (ROOT)) (LET* ((WINDOW (WINDOW.FIRST-CHILD (ROOT))) (LAST-SIB (IF (AND WINDOW (WINDOW.PARENT WINDOW)) (WINDOW.LAST-CHILD (WINDOW.PARENT WINDOW)) ;;ELSE NIL))) (macrolet ((POINT-IN-WINDOW () ;; Return T if (X,Y) is visible in WINDOW, NIL otherwise. '(LET ((OCCLUSION-STACK (WINDOW.OCCLUSION-STACK WINDOW))) (COND ((EQ OCCLUSION-STACK T) ;; Window is fully visible. T) ((NULL OCCLUSION-STACK) ;; Window is completely obscured by another window. NIL) (T ;; Window is partially visible. Look at the occlusion stack ;; to see if a part that is visible also contains (X,Y). (DOLIST (BOX OCCLUSION-STACK NIL) (WHEN (INSIDE-P BOX X Y) (RETURN T)))))))) (SETQ SPRITE-TRACE-GOOD 1) (LOOP (EVENT-TRACE "~%XY-TO-WINDOW, TRACE=~D" SPRITE-TRACE-GOOD) (WHEN (NULL WINDOW) (RETURN NIL)) (EVENT-TRACE ", looking at window x~16R with (L,R,T,B)=(~D,~D,~D,~D)" (WINDOW.ID WINDOW) (WINDOW.ABSOLUTE-X-CORNER WINDOW) (WINDOW.ABSOLUTE-Y-CORNER WINDOW) (+ (WINDOW.ABSOLUTE-X-CORNER WINDOW) (WINDOW.OUTSIDE-WIDTH WINDOW)) (+ (WINDOW.ABSOLUTE-Y-CORNER WINDOW) (WINDOW.OUTSIDE-HEIGHT WINDOW))) (IF (AND (WINDOW.MAPPED-P WINDOW) (>= X (WINDOW.ABSOLUTE-X-CORNER WINDOW)) (< X (+ (WINDOW.ABSOLUTE-X-CORNER WINDOW) (WINDOW.OUTSIDE-WIDTH WINDOW))) (>= Y (WINDOW.ABSOLUTE-Y-CORNER WINDOW)) (< Y (+ (WINDOW.ABSOLUTE-Y-CORNER WINDOW) (WINDOW.OUTSIDE-HEIGHT WINDOW))) (POINT-IN-WINDOW)) (PROGN (EVENT-TRACE ", ---inside---") (IF (>= SPRITE-TRACE-GOOD SPRITE-TRACE-SIZE) (PROGN (INCF SPRITE-TRACE-SIZE) (VECTOR-PUSH-EXTEND WINDOW SPRITE-TRACE)) ;;ELSE (SETF (AREF SPRITE-TRACE SPRITE-TRACE-GOOD) WINDOW)) (PSETQ WINDOW (WINDOW.FIRST-CHILD WINDOW) LAST-SIB (WINDOW.LAST-CHILD WINDOW)) (INCF SPRITE-TRACE-GOOD)) ;;ELSE (PROGN (WHEN (EQ WINDOW LAST-SIB) (RETURN NIL)) (SETQ WINDOW (WINDOW.NEXT-SIB WINDOW))))) (EVENT-TRACE-LEAVING "XY-TO-WINDOW") (AREF SPRITE-TRACE (1- SPRITE-TRACE-GOOD))))) (DEFUN CHECK-MOTION (X Y IGNORE-CACHE) (DECLARE (TYPE INTEGER X Y) (TYPE BOOLEAN IGNORE-CACHE) (VALUES WINDOW)) (EVENT-TRACE-ENTERING "CHECK-MOTION") (EVENT-TRACE "~%CHECK-MOTION, (X,Y)=(~D,~D), IGNORE-CACHE=~A, SPRITE (X,Y)=(~D,~D), SPRITE.WIN=x~16R" X Y IGNORE-CACHE (HOT-SPOT.X (SPRITE.HOT SPRITE)) (HOT-SPOT.Y (SPRITE.HOT SPRITE)) (IF (SPRITE.WINDOW SPRITE) (WINDOW.ID (SPRITE.WINDOW SPRITE)) 0)) (LET ((PREVIOUS-SPRITE-WINDOW (SPRITE.WINDOW SPRITE))) (IF (OR (NOT (= X (HOT-SPOT.X (SPRITE.HOT SPRITE)))) (NOT (= Y (HOT-SPOT.Y (SPRITE.HOT SPRITE))))) (PROGN (SETF (SPRITE.WINDOW SPRITE) (XY-TO-WINDOW X Y)) (SETF (HOT-SPOT.X (SPRITE.HOT SPRITE)) X) (SETF (HOT-SPOT.Y (SPRITE.HOT SPRITE)) Y) ) ;;ELSE (WHEN (OR IGNORE-CACHE (NULL (SPRITE.WINDOW SPRITE)) (SPRITE.RECONSIDER SPRITE)) (SETF (SPRITE.WINDOW SPRITE) (XY-TO-WINDOW X Y)))) (LET ((RETURN-VALUE (IF (NEQ (SPRITE.WINDOW SPRITE) PREVIOUS-SPRITE-WINDOW) (PROGN (WHEN PREVIOUS-SPRITE-WINDOW (DO-ENTER-LEAVE-EVENTS PREVIOUS-SPRITE-WINDOW (SPRITE.WINDOW SPRITE) NOTIFY-NORMAL)) (POST-NEW-CURSOR) NIL) ;;ELSE (SPRITE.WINDOW SPRITE)))) (EVENT-TRACE-LEAVING "CHECK-MOTION") (IF (TYPEP RETURN-VALUE 'WINDOW) (EVENT-TRACE ", Returning window x~16R" (WINDOW.ID RETURN-VALUE)) ;;ELSE (EVENT-TRACE ", Returning ~A" RETURN-VALUE)) RETURN-VALUE))) (DEFUN WINDOWS-RESTRUCTURED () (EVENT-TRACE-ENTERING "WINDOWS-RESTRUCTURED") ;; This would cause a lock condition between servers and the dispatch process. ;;(CHECK-MOTION (HOT-SPOT.X (SPRITE.HOT SPRITE)) ;;(HOT-SPOT.Y (SPRITE.HOT SPRITE)) T) ;; This is sufficient: the dispatch process will detect any necessary cursor changes. (SETF (SPRITE.RECONSIDER SPRITE) T) (MOUSE-WAKEUP) (EVENT-TRACE-LEAVING "WINDOWS-RESTRUCTURED")) (DEFUN DEFINE-INITIAL-ROOT-WINDOW (WINDOW) (DECLARE (TYPE WINDOW WINDOW)) (EVENT-TRACE-ENTERING "DEFINE-INITIAL-ROOT-WINDOW") (EVENT-TRACE ", root-~A" WINDOW) (LET ((CURSOR (WINDOW.CURSOR WINDOW)) (HOT (MAKE-HOT-SPOT :X (TRUNCATE (SCREEN.WIDTH CURRENT-SCREEN) 2) :Y (TRUNCATE (SCREEN.HEIGHT CURRENT-SCREEN) 2)))) (SETF (SPRITE.HOT SPRITE) HOT) (SETF (SPRITE.WINDOW SPRITE) WINDOW) (SETF (SPRITE.CURRENT SPRITE) CURSOR) (SETF SPRITE-TRACE-GOOD 1) (SETF (ROOT) WINDOW) ;; Set up sprite.hot-limits and sprite.phys-limits. (SETF (SPRITE.PHYS-LIMITS SPRITE) (EXPLORER-CURSOR-LIMITS CURRENT-SCREEN (WINDOW.CURSOR WINDOW) (SPRITE.HOT-LIMITS SPRITE))) (EXPLORER-SET-CURSOR-POSITION CURRENT-SCREEN (HOT-SPOT.X (SPRITE.HOT SPRITE)) (HOT-SPOT.Y (SPRITE.HOT SPRITE)) NIL) ;; Set up sprite-phys-limits. (CONSTRAIN-CURSOR CURRENT-SCREEN (SPRITE.PHYS-LIMITS SPRITE)) (EXPLORER-DISPLAY-CURSOR CURRENT-SCREEN CURSOR)) (EVENT-TRACE-LEAVING "DEFINE-INITIAL-ROOT-WINDOW")) ;;; This does not take any shortcuts, and even ignores its argument, since ;;; it does not happen very often, and one has to walk up the tree since ;;; this might be a newly instantiated cursor for an intermediate window ;;; between the one the pointer is in and the one that the last cursor was ;;; instantiated from. (DEFUN WINDOW-HAS-NEW-CURSOR (WINDOW) (DECLARE (TYPE WINDOW WINDOW) (IGNORE WINDOW)) (POST-NEW-CURSOR)) (DEFUN NEW-CURRENT-SCREEN (NEW-SCREEN X Y) (DECLARE (TYPE SCREEN NEW-SCREEN) (TYPE INTEGER X Y)) (EVENT-TRACE-ENTERING "NEW-CURRENT-SCREEN") (IF (EQ NEW-SCREEN CURRENT-SCREEN) NIL ;;ELSE (PROGN (SETF (ROOT) (SCREEN-ROOT-WINDOW NEW-SCREEN)) (SETQ CURRENT-SCREEN NEW-SCREEN) (NEW-CURSOR-CONFINES 0 (SCREEN.WIDTH CURRENT-SCREEN) 0 (SCREEN.HEIGHT CURRENT-SCREEN)) (CHECK-MOTION X Y T))) (EVENT-TRACE-LEAVING "NEW-CURRENT-SCREEN")) (DEFUN CHANGE-SCREEN-SIZE (SCREEN ROOT NEW-WIDTH NEW-HEIGHT) ;; This does not work particularly well and is intended only ;; for "survival" of the X window should a resize occur. That is, ;; this at least prevents bitblt errors, etc. (SETF (SCREEN.WIDTH SCREEN) NEW-WIDTH) (SETF (SCREEN.HEIGHT SCREEN) NEW-HEIGHT) (setf (window.width root) new-width) (setf (window.height root) new-height) (NEW-CURSOR-CONFINES 0 NEW-WIDTH 0 NEW-HEIGHT) (GENERATE-ALL-INFERIORS-OCCLUSION-STACKS ROOT) ;; Must ensure the dispatch process will wake up since the size change can happen ;; asynchronously via the explorer window system. (SETF (SPRITE.RECONSIDER SPRITE) T)) (DEFUN NOTICE-TIME-AND-STATE (EVENT) (DECLARE (TYPE EVENT-RECORD EVENT)) (EVENT-TRACE-ENTERING "NOTICE-TIME-AND-STATE") (WHEN (< (X-EVENT-KEY-BUTTON-POINTER.TIME EVENT) (TIME-STAMP.MILLISECONDS CURRENT-TIME)) (INCF (TIME-STAMP.MONTHS CURRENT-TIME))) (SETF (TIME-STAMP.MILLISECONDS CURRENT-TIME) (X-EVENT-KEY-BUTTON-POINTER.TIME EVENT)) (SETF (X-EVENT-KEY-BUTTON-POINTER.STATE EVENT) KEY-BUTTON-STATE) (EVENT-TRACE-LEAVING "NOTICE-TIME-AND-STATE")) (DEFUN CHECK-PASSIVE-GRABS-ON-WINDOW (WINDOW DEVICE EVENT IS-KEYBOARD) (DECLARE (TYPE WINDOW WINDOW) (TYPE DEVICE DEVICE) (TYPE EVENT-RECORD EVENT) (TYPE BOOLEAN IS-KEYBOARD) (VALUES BOOLEAN)) (EVENT-TRACE-ENTERING "CHECK-PASSIVE-GRABS-ON-WINDOW") (LET ((TEMPORARY-GRAB (MAKE-GRAB-RECORD :WINDOW WINDOW :DEVICE DEVICE :MODIFIERS-DETAIL (MAKE-DETAIL-REC :EXACT (LOGAND (X-EVENT-KEY-BUTTON-POINTER.STATE EVENT) ALL-MODIFIERS-MASK)) :DETAIL (make-detail-rec :exact 0 :mask 0)))) ;; The following was in the C code and I'm not sure how to translate it into ;; the Lisp equivalent. ;; temporaryGrab.u.keybd.keyDetail.exact = xE->u.u.detail; (PROG1 (LOOP FOR GRAB FIRST (WINDOW.PASSIVE-GRABS WINDOW) THEN (GRAB-RECORD.NEXT GRAB) WHILE GRAB DO (WHEN (GRAB-MATCHES-SECOND TEMPORARY-GRAB GRAB) (IF IS-KEYBOARD (ACTIVATE-KEYBOARD-GRAB DEVICE GRAB CURRENT-TIME T) ;;ELSE (ACTIVATE-POINTER-GRAB DEVICE GRAB CURRENT-TIME T)) (FIX-UP-EVENT-FROM-WINDOW EVENT (GRAB-RECORD.WINDOW GRAB) NIL T) (TRY-CLIENT-EVENTS (GRAB-RECORD.CLIENT GRAB) EVENT 1 (GRAB-RECORD.EVENT-MASK GRAB) (AREF FILTERS (EVENT-U.TYPE EVENT)) GRAB) (WHEN (= (SYNC.STATE (DEVICE.SYNC DEVICE)) FROZEN-NO-EVENT) (SETF (SYNC.EVENT (DEVICE.SYNC DEVICE)) EVENT) (SETF (SYNC.STATE (DEVICE.SYNC DEVICE)) FROZEN-WITH-EVENT)) (RETURN T)) FINALLY (RETURN NIL)) (EVENT-TRACE-LEAVING "CHECK-PASSIVE-GRABS-ON-WINDOW")))) ;;; "CheckDeviceGrabs" handles both keyboard and pointer events that may cause ;;; a passive grab to be activated. If the event is a keyboard event, the ;;; ancestors of the focus window are traced down and tried to see if they have ;;; any passive grabs to be activated. If the focus window itself is reached and ;;; it's descendants contain they pointer, the ancestors of the window that the ;;; pointer is in are then traced down starting at the focus window, otherwise no ;;; grabs are activated. If the event is a pointer event, the ancestors of the ;;; window that the pointer is in are traced down starting at the root until ;;; CheckPassiveGrabs causes a passive grab to activate or all the windows are ;;; tried. PRH (DEFUN CHECK-DEVICE-GRABS (DEVICE X-EVENT CHECK-FIRST IS-KEYBOARD) (DECLARE (TYPE DEVICE DEVICE) (TYPE EVENT-RECORD X-EVENT) (TYPE INTEGER CHECK-FIRST) (TYPE BOOLEAN IS-KEYBOARD) (VALUES BOOLEAN)) (EVENT-TRACE-ENTERING "CHECK-DEVICE-GRABS") (LET ((I CHECK-FIRST) (RETURN-VALUE NIL) (ALL-DONE NIL) WINDOW) (WHEN IS-KEYBOARD (LOOP (WHEN (>= I FOCUS-TRACE-GOOD) (RETURN NIL)) (SETQ WINDOW (AREF FOCUS-TRACE I)) (WHEN (CHECK-PASSIVE-GRABS-ON-WINDOW WINDOW DEVICE X-EVENT IS-KEYBOARD) (SETQ ALL-DONE T RETURN-VALUE T) (RETURN NIL)) (INCF I)) (WHEN (NOT ALL-DONE) (WHEN (OR (EQ (DEVICE.FOCUS-WINDOW DEVICE) NIL) (>= I SPRITE-TRACE-GOOD) (AND (PLUSP I) (NEQ WINDOW (AREF SPRITE-TRACE (1- I))))) (SETQ ALL-DONE T)))) (WHEN (NOT ALL-DONE) (LOOP FOR I FROM I BELOW SPRITE-TRACE-GOOD FOR WINDOW = (AREF SPRITE-TRACE I) DO (WHEN (CHECK-PASSIVE-GRABS-ON-WINDOW WINDOW DEVICE X-EVENT IS-KEYBOARD) (SETQ RETURN-VALUE T) (RETURN NIL)))) (EVENT-TRACE-LEAVING "CHECK-DEVICE-GRABS") (EVENT-TRACE ", returning ~A" RETURN-VALUE) RETURN-VALUE)) (DEFUN NORMAL-KEYBOARD-EVENT (KEYBOARD EVENT WINDOW) (DECLARE (TYPE DEVICE KEYBOARD) (TYPE EVENT-RECORD EVENT) (TYPE WINDOW WINDOW)) (EVENT-TRACE-ENTERING "NORMAL-KEYBOARD-EVENT") (LET ((ALL-DONE NIL) (FOCUS (DEVICE.FOCUS-WINDOW KEYBOARD))) (COND ((NULL FOCUS) (SETQ ALL-DONE T)) ((EQ FOCUS POINTER-ROOT-WINDOW) (DELIVER-DEVICE-EVENTS WINDOW EVENT NIL NIL) (SETQ ALL-DONE T)) ((OR (EQ FOCUS WINDOW) (IS-PARENT FOCUS WINDOW)) (WHEN (DELIVER-DEVICE-EVENTS WINDOW EVENT NIL FOCUS) (SETQ ALL-DONE T)))) (WHEN (NOT ALL-DONE) ;; Just deliver it to the focus window. (FIX-UP-EVENT-FROM-WINDOW EVENT FOCUS NIL NIL) (DELIVER-EVENTS-TO-WINDOW FOCUS EVENT 1 (AREF FILTERS (EVENT-U.TYPE EVENT)) NIL))) (EVENT-TRACE-LEAVING "NORMAL-KEYBOARD-EVENT")) (DEFUN DELIVER-GRABBED-EVENT (EVENT THIS-DEV OTHER-DEV DEACTIVATE-GRAB) (DECLARE (TYPE EVENT-RECORD EVENT) (TYPE DEVICE THIS-DEV OTHER-DEV) (TYPE BOOLEAN DEACTIVATE-GRAB)) (EVENT-TRACE-ENTERING "DELIVER-GRABBED-EVENT") (LET ((GRAB (DEVICE.GRAB THIS-DEV)) (DELIVERIES 0)) (DECLARE (TYPE GRAB-RECORD GRAB) (TYPE INTEGER DELIVERIES)) (WHEN (OR (NULL (GRAB-RECORD.OWNER-EVENTS GRAB)) (ZEROP (SETQ DELIVERIES (DELIVER-DEVICE-EVENTS (SPRITE.WINDOW SPRITE) EVENT GRAB NIL)))) (FIX-UP-EVENT-FROM-WINDOW EVENT (GRAB-RECORD.WINDOW GRAB) NIL T) (SETQ DELIVERIES (TRY-CLIENT-EVENTS (GRAB-RECORD.CLIENT GRAB) EVENT 1 (GRAB-RECORD.EVENT-MASK GRAB) (AREF FILTERS (EVENT-U.TYPE EVENT)) GRAB))) (IF (AND (PLUSP DELIVERIES) (= (EVENT-U.TYPE EVENT) MOTION-NOTIFY-EVENT)) (SETQ MOTION-HINT-WINDOW (GRAB-RECORD.WINDOW GRAB)) ;;ELSE (WHEN (AND (PLUSP DELIVERIES) (NULL DEACTIVATE-GRAB)) (LET ((SYNC-STATE (SYNC.STATE (DEVICE.SYNC THIS-DEV)))) (WHEN (= SYNC-STATE FREEZE-BOTH-NEXT-EVENT) (SETF (SYNC.FROZEN (DEVICE.SYNC OTHER-DEV)) T) (IF (AND (= (SYNC.STATE (DEVICE.SYNC OTHER-DEV)) FREEZE-BOTH-NEXT-EVENT) (EQ (GRAB-RECORD.CLIENT (DEVICE.GRAB OTHER-DEV)) (GRAB-RECORD.CLIENT (DEVICE.GRAB THIS-DEV)))) (SETF (SYNC.STATE (DEVICE.SYNC OTHER-DEV)) FROZEN-NO-EVENT) ;;ELSE (SETF (SYNC.OTHER (DEVICE.SYNC OTHER-DEV)) (DEVICE.GRAB THIS-DEV)))) (WHEN (OR (= SYNC-STATE FREEZE-BOTH-NEXT-EVENT) (= SYNC-STATE FREEZE-NEXT-EVENT)) (SETF (SYNC.STATE (DEVICE.SYNC THIS-DEV)) FROZEN-WITH-EVENT) (SETF (SYNC.FROZEN (DEVICE.SYNC THIS-DEV)) T) (SETF (SYNC.EVENT (DEVICE.SYNC THIS-DEV)) EVENT)))))) (EVENT-TRACE-LEAVING "DELIVER-GRABBED-EVENT")) (DEFUN PROCESS-KEYBOARD-EVENT (EVENT KEYBOARD) (DECLARE (TYPE DEVICE KEYBOARD) (TYPE EVENT-RECORD EVENT)) (EVENT-TRACE-ENTERING "PROCESS-KEYBOARD-EVENT") (LET ((ALL-DONE NIL) (DOWN (DEVICE.DOWN KEYBOARD)) MODIFIERS (DEACTIVATE-GRAB NIL) (GRAB (DEVICE.GRAB KEYBOARD)) KEY KPTR) (IF (SYNC.FROZEN (DEVICE.SYNC KEYBOARD)) (ENQUEUE-EVENT KEYBOARD EVENT) ;;ELSE (PROGN (NOTICE-TIME-AND-STATE EVENT) (SETQ KEY (X-EVENT-KEY-BUTTON-POINTER.DETAIL EVENT)) (SETQ KPTR (AREF DOWN KEY)) (SETQ MODIFIERS (AREF KEY-MODIFIERS-LIST KEY)) (CASE-EVAL (X-EVENT-KEY-BUTTON-POINTER.TYPE EVENT) (KEY-PRESS-EVENT (IF (PLUSP KPTR) ;1; *If key already down (PROGN ;; Allow DDX to generate multiple downs. (WHEN (ZEROP MODIFIERS) (SETF (X-EVENT-KEY-BUTTON-POINTER.TYPE EVENT) KEY-RELEASE-EVENT) (PROCESS-KEYBOARD-EVENT EVENT KEYBOARD) (SETF (X-EVENT-KEY-BUTTON-POINTER.TYPE EVENT) KEY-PRESS-EVENT) ;; Release can have side effects, don't fall through. (PROCESS-KEYBOARD-EVENT EVENT KEYBOARD)) (SETQ ALL-DONE T)) ;;ELSE (PROGN (SETQ MOTION-HINT-WINDOW NIL) (SETF (AREF DOWN KEY) 1) (LOOP FOR I FROM 0 BY 1 FOR MASK FIRST 1 THEN (ash MASK 1) UNTIL (ZEROP MODIFIERS) DO (WHEN (NOT (ZEROP (LOGAND MASK MODIFIERS))) ;; This key affects modifier "i". (INCF (AREF MODIFIER-KEY-COUNT I)) (SETQ KEY-BUTTON-STATE (LOGIOR KEY-BUTTON-STATE MASK)) (SETQ MODIFIERS (LOGANDC2 MODIFIERS MASK)))) (WHEN (AND (NOT GRAB) (CHECK-DEVICE-GRABS KEYBOARD EVENT 0 T)) (SETQ KEY-THAT-ACTIVATED-PASSIVE-GRAB KEY) (SETQ ALL-DONE T))))) (KEY-RELEASE-EVENT (IF (ZEROP KPTR) ;; Guard against duplicates. (SETQ ALL-DONE T) ;;ELSE (PROGN (SETQ MOTION-HINT-WINDOW NIL) (SETF (AREF DOWN KEY) 0) (LOOP FOR I FROM 0 BY 1 FOR MASK FIRST 1 THEN (* MASK 2) UNTIL (ZEROP MODIFIERS) DO (WHEN (NOT (ZEROP (LOGAND MASK MODIFIERS))) ;; This key affects modifier "i". (WHEN (<= (DECF (AREF MODIFIER-KEY-COUNT I)) 0) (SETQ KEY-BUTTON-STATE (LOGAND KEY-BUTTON-STATE (LOGNOT MASK))) (SETF (AREF MODIFIER-KEY-COUNT I) 0)) (SETQ MODIFIERS (LOGAND MODIFIERS (LOGNOT MASK))))) (WHEN (AND (DEVICE.PASSIVE-GRAB KEYBOARD) (= KEY KEY-THAT-ACTIVATED-PASSIVE-GRAB)) (SETQ DEACTIVATE-GRAB T))))) (OTHERWISE (ERROR "BOGUS keyboard event ~D from DDX" (X-EVENT-KEY-BUTTON-POINTER.TYPE EVENT)))) (UNLESS ALL-DONE (IF GRAB (DELIVER-GRABBED-EVENT EVENT KEYBOARD (INPUT-INFO.POINTER INPUT-INFO) DEACTIVATE-GRAB) ;;ELSE (NORMAL-KEYBOARD-EVENT KEYBOARD EVENT (SPRITE.WINDOW SPRITE))) (WHEN DEACTIVATE-GRAB (DEACTIVATE-KEYBOARD-GRAB KEYBOARD)))))) (EVENT-TRACE-LEAVING "PROCESS-KEYBOARD-EVENT")) (DEFUN PROCESS-POINTER-EVENT (EVENT THE-MOUSE-DEVICE) (DECLARE (TYPE EVENT-RECORD EVENT) (TYPE DEVICE THE-MOUSE-DEVICE)) (EVENT-TRACE-ENTERING "PROCESS-POINTER-EVENT") (LET (KEY (ALL-DONE NIL) (GRAB (DEVICE.GRAB THE-MOUSE-DEVICE)) (MOVE-IT NIL) (DEACTIVATE-GRAB NIL)) (DECLARE (TYPE BOOLEAN ALL-DONE MOVE-IT DEACTIVATE-GRAB) (TYPE (OR NULL GRAB-RECORD) GRAB)) (LET ((SPRITE-LEFT (BOX.LEFT (SPRITE.PHYS-LIMITS SPRITE))) (SPRITE-TOP (BOX.TOP (SPRITE.PHYS-LIMITS SPRITE))) (SPRITE-RIGHT (BOX.RIGHT (SPRITE.PHYS-LIMITS SPRITE))) (SPRITE-BOTTOM (BOX.BOTTOM (SPRITE.PHYS-LIMITS SPRITE)))) (DECLARE (TYPE INTEGER SPRITE-LEFT SPRITE-TOP SPRITE-RIGHT SPRITE-BOTTOM)) (COND ((< (X-EVENT-KEY-BUTTON-POINTER.ROOT-X EVENT) SPRITE-LEFT) (SETF (X-EVENT-KEY-BUTTON-POINTER.ROOT-X EVENT) SPRITE-LEFT) (SETQ MOVE-IT T)) ((>= (X-EVENT-KEY-BUTTON-POINTER.ROOT-X EVENT) SPRITE-RIGHT) (SETF (X-EVENT-KEY-BUTTON-POINTER.ROOT-X EVENT) (1- SPRITE-RIGHT)) (SETQ MOVE-IT T))) (COND ((< (X-EVENT-KEY-BUTTON-POINTER.ROOT-Y EVENT) SPRITE-TOP) (SETF (X-EVENT-KEY-BUTTON-POINTER.ROOT-Y EVENT) SPRITE-TOP) (SETQ MOVE-IT T)) ((>= (X-EVENT-KEY-BUTTON-POINTER.ROOT-Y EVENT) SPRITE-BOTTOM) (SETF (X-EVENT-KEY-BUTTON-POINTER.ROOT-Y EVENT) (1- SPRITE-BOTTOM)) (SETQ MOVE-IT T)))) (WHEN MOVE-IT (EVENT-TRACE "~%PROCESS-POINTER-EVENT, mouse position was out of bounds, moved to (~D,~D)" (X-EVENT-KEY-BUTTON-POINTER.ROOT-X EVENT) (X-EVENT-KEY-BUTTON-POINTER.ROOT-Y EVENT)) (EXPLORER-SET-CURSOR-POSITION CURRENT-SCREEN (X-EVENT-KEY-BUTTON-POINTER.ROOT-X EVENT) (X-EVENT-KEY-BUTTON-POINTER.ROOT-Y EVENT) NIL)) (IF (SYNC.FROZEN (DEVICE.SYNC THE-MOUSE-DEVICE)) (ENQUEUE-EVENT THE-MOUSE-DEVICE EVENT) ;;ELSE (PROGN (NOTICE-TIME-AND-STATE EVENT) (SETQ KEY (X-EVENT-KEY-BUTTON-POINTER.DETAIL EVENT)) (CASE-EVAL (X-EVENT-KEY-BUTTON-POINTER.TYPE EVENT) (BUTTON-PRESS-EVENT (SETQ MOTION-HINT-WINDOW NIL) (INCF BUTTONS-DOWN) (SETQ BUTTON-MOTION-MASK-VARIABLE BUTTON-MOTION-MASK) ;;xE->u.u.detail = mouse->u.ptr.map[key]; ;; It looks the previous C statement occurs in both this function ;; and EXPLORER-MOUSE-PROCESS-EVENT, so it was not coded here. (WHEN (<= (X-EVENT-KEY-BUTTON-POINTER.DETAIL EVENT) 5) (SETQ KEY-BUTTON-STATE (LOGIOR KEY-BUTTON-STATE (AREF KEY-MODIFIERS-LIST (X-EVENT-KEY-BUTTON-POINTER.DETAIL EVENT))))) (SETF (AREF FILTERS MOTION-NOTIFY-EVENT) (MOTION-FILTER KEY-BUTTON-STATE)) (WHEN (NOT GRAB) (WHEN (CHECK-DEVICE-GRABS THE-MOUSE-DEVICE EVENT 0 NIL) (SETQ ALL-DONE T)))) (BUTTON-RELEASE-EVENT (SETQ MOTION-HINT-WINDOW NIL) (DECF BUTTONS-DOWN) (WHEN (ZEROP BUTTONS-DOWN) (SETQ BUTTON-MOTION-MASK-VARIABLE 0)) ;;xE->u.u.detail = mouse->u.ptr.map[key]; ;; It looks the previous C statement occurs in both this function ;; and EXPLORER-MOUSE-PROCESS-EVENT, so it was not coded here. (WHEN (<= (X-EVENT-KEY-BUTTON-POINTER.DETAIL EVENT) 5) (SETQ KEY-BUTTON-STATE (LOGAND KEY-BUTTON-STATE (LOGNOT (AREF KEY-MODIFIERS-LIST (X-EVENT-KEY-BUTTON-POINTER.DETAIL EVENT)))))) (SETF (AREF FILTERS MOTION-NOTIFY-EVENT) (MOTION-FILTER KEY-BUTTON-STATE)) (WHEN (AND (ZEROP (LOGAND KEY-BUTTON-STATE ALL-BUTTONS-MASK)) (DEVICE.AUTO-RELEASE-GRAB THE-MOUSE-DEVICE)) (SETQ DEACTIVATE-GRAB T))) (MOTION-NOTIFY-EVENT (WHEN (NULL (CHECK-MOTION (X-EVENT-KEY-BUTTON-POINTER.ROOT-X EVENT) (X-EVENT-KEY-BUTTON-POINTER.ROOT-Y EVENT) NIL)) (SETQ ALL-DONE T))) (OTHERWISE (ERROR "Bogus pointer event ~D from DDX" (X-EVENT-KEY-BUTTON-POINTER.TYPE EVENT)))) (WHEN (NOT ALL-DONE) (IF GRAB (DELIVER-GRABBED-EVENT EVENT THE-MOUSE-DEVICE (INPUT-INFO.KEYBOARD INPUT-INFO) DEACTIVATE-GRAB) ;;ELSE (DELIVER-DEVICE-EVENTS (SPRITE.WINDOW SPRITE) EVENT NIL NIL)) (WHEN DEACTIVATE-GRAB (DEACTIVATE-POINTER-GRAB THE-MOUSE-DEVICE)))))) (EVENT-TRACE-LEAVING "PROCESS-POINTER-EVENT")) (DEFUN PROCESS-OTHER-EVENT (EVENT DEVICE) (DECLARE (TYPE EVENT-RECORD EVENT) (TYPE DEVICE DEVICE) (IGNORE EVENT DEVICE)) ;; Implementation note: The C code for this was a big NO-OP and contained only ;; the following code, which was commented out. ;; XXX What should be done here ? ;; Bool propogate = filters[xE->type]; ) (DEFUN RECALCULATE-DELIVERABLE-EVENTS (WINDOW) (DECLARE (TYPE WINDOW WINDOW)) (EVENT-TRACE-ENTERING "RECALCULATE-DELIVERABLE-EVENTS") ;; Recalculate the all-event-mask window slot. (SETF (WINDOW.ALL-EVENT-MASKS WINDOW) (WINDOW-EVENT-MASKS WINDOW)) (EVENT-TRACE ", ALL-EVENT-MASKS initially=x~16R" (WINDOW.ALL-EVENT-MASKS WINDOW)) (LOOP FOR OTHER IN (OTHER-CLIENTS WINDOW) DO (SETF (WINDOW.ALL-EVENT-MASKS WINDOW) (LOGIOR (WINDOW.ALL-EVENT-MASKS WINDOW) (OTHER-CLIENT.MASK OTHER)))) (EVENT-TRACE ", ALL-EVENT-MASKS finally=x~16R" (WINDOW.ALL-EVENT-MASKS WINDOW)) (SETF (WINDOW.DELIVERABLE-EVENTS WINDOW) (LOGIOR (WINDOW.ALL-EVENT-MASKS WINDOW) (IF (WINDOW.PARENT WINDOW) (LOGAND (WINDOW.DELIVERABLE-EVENTS (WINDOW.PARENT WINDOW)) (LOGNOT (WINDOW-DONT-PROPAGATE WINDOW)) PROPAGATE-MASK) ;;ELSE 0))) (EVENT-TRACE ", DELIVERABLE-EVENTS=x~16R" (WINDOW.DELIVERABLE-EVENTS WINDOW)) (when (window.parent window) (event-trace ", (window.deliverable-events (window.parent window))=x~16r, ~ (lognot (window-dont-propagate window))=x~16r" (window.deliverable-events (window.parent window)) (lognot (window-dont-propagate window)))) (LET ((CHILD (WINDOW.FIRST-CHILD WINDOW)) (LAST-CHILD (WINDOW.LAST-CHILD WINDOW))) (WHEN CHILD (LOOP (RECALCULATE-DELIVERABLE-EVENTS CHILD) (WHEN (EQ CHILD LAST-CHILD) (RETURN NIL)) (SETQ CHILD (WINDOW.NEXT-SIB CHILD))))) (EVENT-TRACE-LEAVING "RECALCULATE-DELIVERABLE-EVENTS")) (DEFUN remove-clients-events (client window) ;1; Called when client is shutdown on root window to remove all the client's events* (LOOP FOR OTHER IN (WINDOW.EVENT-MASKS WINDOW) WHEN (EQ (OTHER-CLIENT.CLIENT other) client) DO (PROGN (REMOVE-CLIENT (OTHER-CLIENT.CLIENT OTHER) WINDOW) (RECALCULATE-DELIVERABLE-EVENTS WINDOW) (RETURN NIL))) (loop for child being the xwindow-children of window do (remove-clients-events client child))) (DEFUN PASSIVE-CLIENT-GONE (WINDOW ID) (DECLARE (TYPE WINDOW WINDOW) (TYPE INTEGER ID)) (EVENT-TRACE-ENTERING "PASSIVE-CLIENT-GONE") (WHEN (LOOP FOR PREVIOUS-GRAB FIRST NIL THEN GRAB FOR GRAB FIRST (WINDOW.PASSIVE-GRABS WINDOW) THEN (GRAB-RECORD.NEXT GRAB) WHILE GRAB WHEN (EQL (GRAB-RECORD.RESOURCE GRAB) ID) DO (PROGN (IF PREVIOUS-GRAB (SETF (GRAB-RECORD.NEXT PREVIOUS-GRAB) (GRAB-RECORD.NEXT GRAB)) ;;ELSE (SETF (WINDOW.PASSIVE-GRABS WINDOW) (GRAB-RECORD.NEXT GRAB))) (RETURN NIL)) FINALLY (RETURN T)) (ERROR "Client not on the passive grab list")) (EVENT-TRACE-LEAVING "PASSIVE-CLIENT-GONE")) #| Test code (setq g4 (x11:make-grab-record :resource 4 :next nil)) (setq g3 (x11:make-grab-record :resource 3 :next g4)) (setq g2 (x11:make-grab-record :resource 2 :next g3)) (setq g1 (x11:make-grab-record :resource 1 :next g2)) (setq win (make-window :passive-grabs g1)) ;;; ID not there (x11:passive-client-gone x11:win 9) ;;; ID at end (x11:passive-client-gone x11:win 4) (setf (grab-record.next g3) g4) ;;; ID at beginning (x11:passive-client-gone x11:win 1) (setf (window.passive-grabs win) g1) ;;; ID in the middle (x11:passive-client-gone x11:win 2) |# (DEFUN FAKE-CLIENT-ID (CLIENT) (DECLARE (TYPE STATE CLIENT) (VALUES INTEGER)) (+ (ASH (STATE.ID-BASE CLIENT) CLIENT-OFFSET) SERVER-BIT (LOGAND (INCF (STATE.FAKE-ID CLIENT)) *RESOURCE-ID-MASK*))) (ZWEI:DEFINE-INDENTATION MASK-SET (1 1)) (DEFUN EVENT-SELECT-FOR-WINDOW (WINDOW CLIENT MASK) (DECLARE (TYPE WINDOW WINDOW) (TYPE STATE CLIENT) (TYPE INTEGER MASK) (VALUES INTEGER)) (EVENT-TRACE-ENTERING "EVENT-SELECT-FOR-WINDOW") (EVENT-TRACE ", WINDOW=x~16R, mask=x~16R, Same client=~A" (WINDOW.ID WINDOW) MASK (EQ (WINDOW.CLIENT WINDOW) CLIENT)) (PROG1 (block get-out (LET ((CHECK (LOGAND MASK AT-MOST-ONE-CLIENT))) (block mask-set (WHEN (NOT (ZEROP (LOGAND CHECK (WINDOW.ALL-EVENT-MASKS WINDOW)))) ;; It is illegal for two different clients to select on any of the events ;; for AT-MOST-ONE-CLIENT. However, it is OK, for some client to continue ;; selecting on one of those events. (WHEN (AND (NEQ (WINDOW.CLIENT WINDOW) CLIENT) (NOT (ZEROP (LOGAND CHECK (WINDOW-EVENT-MASKS WINDOW))))) (RETURN-FROM GET-OUT BAD-ACCESS)) (LOOP FOR OTHER IN (OTHER-CLIENTS WINDOW) DO (WHEN (AND (NEQ (OTHER-CLIENT.CLIENT OTHER) CLIENT) (NOT (ZEROP (LOGAND CHECK (OTHER-CLIENT.MASK OTHER))))) (RETURN-FROM GET-OUT BAD-ACCESS)))) (IF (EQ (WINDOW.CLIENT WINDOW) CLIENT) (PROGN (SETQ CHECK (WINDOW-EVENT-MASKS WINDOW)) (SETF (WINDOW-EVENT-MASKS WINDOW) MASK)) ;;ELSE (PROGN (LOOP FOR OTHER IN (OTHER-CLIENTS WINDOW) WHEN (EQ (OTHER-CLIENT.CLIENT OTHER) CLIENT) DO (PROGN (SETQ CHECK (OTHER-CLIENT.MASK OTHER)) (WHEN (ZEROP MASK) (return-from GET-OUT STATUS-SUCCESS)) (SETF (OTHER-CLIENT.MASK OTHER) MASK) (return-from mask-set nil))) (LET ((*state* client)) (setf (window-event-masks window) (logior (window-event-masks window) mask))) (SETQ CHECK 0)))) ;1; Mask-set* (WHEN (AND (EQ MOTION-HINT-WINDOW WINDOW) (NOT (ZEROP (LOGAND MASK POINTER-MOTION-HINT-MASK))) (ZEROP (LOGAND CHECK POINTER-MOTION-HINT-MASK)) (NULL (DEVICE.GRAB (INPUT-INFO.POINTER INPUT-INFO)))) (SETQ MOTION-HINT-WINDOW NIL)) (RECALCULATE-DELIVERABLE-EVENTS WINDOW))) (EVENT-TRACE-LEAVING "EVENT-SELECT-FOR-WINDOW"))) (DEFUN EVENT-SUPPRESS-FOR-WINDOW (WINDOW CLIENT MASK) (DECLARE (TYPE WINDOW WINDOW) (TYPE STATE CLIENT) (TYPE INTEGER MASK) (VALUES INTEGER) (IGNORE CLIENT)) (EVENT-TRACE-ENTERING "EVENT-SUPPRESS-FOR-WINDOW") (SETF (WINDOW-DONT-PROPAGATE WINDOW) MASK) (RECALCULATE-DELIVERABLE-EVENTS WINDOW) (EVENT-TRACE-LEAVING "EVENT-SUPPRESS-FOR-WINDOW") STATUS-SUCCESS) (DEFUN IS-PARENT (A B) "Returns T if B is a descendent of A." (DECLARE (TYPE WINDOW A) (TYPE (OR NULL WINDOW) B) (VALUES BOOLEAN)) (LOOP (WHEN (NULL B) (RETURN NIL)) (WHEN (EQ B A) (RETURN T)) (SETQ B (WINDOW.PARENT B)))) ;;; This function looks semantically equivalent to WINDOW-LEAST-COMMON-ANCESTER. (TWE) (DEFUN COMMON-ANCESTOR (A B) (DECLARE (TYPE WINDOW A) (TYPE (OR NULL WINDOW) B) (VALUES WINDOW)) (SETQ B (WINDOW.PARENT B)) (LOOP (WHEN (NULL B) (RETURN NIL)) (WHEN (IS-PARENT B A) (RETURN B)) (SETQ B (WINDOW.PARENT B)))) (DEFUN ENTER-LEAVE-EVENT (TYPE MODE DETAIL WINDOW) (DECLARE (TYPE INTEGER TYPE MODE DETAIL) (TYPE WINDOW WINDOW)) (EVENT-TRACE-ENTERING "ENTER-LEAVE-EVENT") (LET* ((EVENT (MAKE-EVENT-ENTER-LEAVE)) (KEYBD (INPUT-INFO.KEYBOARD INPUT-INFO)) (FOCUS (DEVICE.FOCUS-WINDOW KEYBD)) (GRAB (DEVICE.GRAB (INPUT-INFO.POINTER INPUT-INFO)))) (DECLARE (TYPE EVENT-RECORD EVENT) (TYPE DEVICE KEYBD) (TYPE (OR NULL WINDOW) FOCUS) (TYPE (OR NULL GRAB-RECORD) GRAB)) (WHEN (AND (EQ WINDOW MOTION-HINT-WINDOW) (= TYPE LEAVE-NOTIFY-EVENT) (NOT (= DETAIL NOTIFY-INFERIOR))) (SETQ MOTION-HINT-WINDOW NIL)) (IF (AND (= MODE NOTIFY-NORMAL) GRAB (NULL (GRAB-RECORD.OWNER-EVENTS GRAB)) (NEQ (GRAB-RECORD.WINDOW GRAB) WINDOW)) NIL ;;ELSE (PROGN (SETF (X-EVENT-ENTER-LEAVE.TYPE EVENT) TYPE) (SETF (X-EVENT-ENTER-LEAVE.DETAIL EVENT) DETAIL) (SETF (X-EVENT-ENTER-LEAVE.TIME EVENT) (TIME-STAMP.MILLISECONDS CURRENT-TIME)) (SETF (X-EVENT-ENTER-LEAVE.ROOT-X EVENT) (HOT-SPOT.X (SPRITE.HOT SPRITE))) (SETF (X-EVENT-ENTER-LEAVE.ROOT-Y EVENT) (HOT-SPOT.Y (SPRITE.HOT SPRITE))) ;; This call counts on same initial structure beween enter & button events. (FIX-UP-EVENT-FROM-WINDOW EVENT WINDOW NIL T) (SETF (X-EVENT-ENTER-LEAVE.FLAGS EVENT) (IF (X-EVENT-KEY-BUTTON-POINTER.SAME-SCREEN EVENT) EL-FLAG-SAME-SCREEN ;;ELSE 0)) (SETF (X-EVENT-ENTER-LEAVE.STATE EVENT) KEY-BUTTON-STATE) (SETF (X-EVENT-ENTER-LEAVE.MODE EVENT) MODE) (EVENT-TRACE "~%IN ENTER-LEAVE-EVENT, focus=~A, window=~A, or=~A" FOCUS WINDOW (OR (EQ WINDOW FOCUS) (EQ FOCUS POINTER-ROOT-WINDOW) (IS-PARENT FOCUS WINDOW))) (WHEN (AND FOCUS (OR (EQ WINDOW FOCUS) (EQ FOCUS POINTER-ROOT-WINDOW) (IS-PARENT FOCUS WINDOW))) (SETF (X-EVENT-ENTER-LEAVE.FLAGS EVENT) (LOGIOR (X-EVENT-ENTER-LEAVE.FLAGS EVENT) EL-FLAG-FOCUS))) (DELIVER-EVENTS-TO-WINDOW WINDOW EVENT 1 (AREF FILTERS TYPE) GRAB) (WHEN (= TYPE ENTER-NOTIFY-EVENT) (LET* ((KEY-EVENT (MAKE-EVENT-KEYMAP-EVENT :TYPE KEYMAP-NOTIFY-EVENT :MAP (COPY-SEQ (DEVICE.DOWN KEYBD))))) (DELIVER-EVENTS-TO-WINDOW WINDOW KEY-EVENT 1 KEYMAP-STATE-MASK GRAB)))))) (EVENT-TRACE-LEAVING "ENTER-LEAVE-EVENT")) (DEFUN ENTER-NOTIFIES (ANCESTOR CHILD MODE DETAIL) (DECLARE (TYPE WINDOW ANCESTOR) (TYPE (OR NULL WINDOW) CHILD) (TYPE INTEGER MODE DETAIL)) (EVENT-TRACE-ENTERING "ENTER-NOTIFIES") (WHEN (AND CHILD (NEQ ANCESTOR CHILD)) (ENTER-NOTIFIES ANCESTOR (WINDOW.PARENT CHILD) MODE DETAIL) (ENTER-LEAVE-EVENT ENTER-NOTIFY-EVENT MODE DETAIL CHILD)) (EVENT-TRACE-LEAVING "ENTER-NOTIFIES")) ;;; Implementation note from C version: dies horribly if ancestor is not an ;;; ancestor of child. (DEFUN LEAVE-NOTIFIES (CHILD ANCESTOR MODE DETAIL DO-ANCESTOR) (DECLARE (TYPE WINDOW CHILD ANCESTOR) (TYPE INTEGER DETAIL MODE) (TYPE BOOLEAN DO-ANCESTOR)) (EVENT-TRACE-ENTERING "LEAVE-NOTIFIES") (WHEN (NEQ ANCESTOR CHILD) (LET ((WINDOW (WINDOW.PARENT CHILD))) (DECLARE (TYPE WINDOW WINDOW)) (LOOP (WHEN (EQ WINDOW ANCESTOR) (RETURN NIL)) (ENTER-LEAVE-EVENT LEAVE-NOTIFY-EVENT MODE DETAIL WINDOW) (SETQ WINDOW (WINDOW.PARENT WINDOW))) (WHEN DO-ANCESTOR (ENTER-LEAVE-EVENT LEAVE-NOTIFY-EVENT MODE DETAIL ANCESTOR)))) (EVENT-TRACE-LEAVING "LEAVE-NOTIFIES")) (DEFUN DO-ENTER-LEAVE-EVENTS (FROM-WINDOW TO-WINDOW MODE) (DECLARE (TYPE WINDOW FROM-WINDOW TO-WINDOW) (TYPE INTEGER MODE)) (EVENT-TRACE-ENTERING "DO-ENTER-LEAVE-EVENTS") (WHEN (NEQ FROM-WINDOW TO-WINDOW) (COND ((IS-PARENT FROM-WINDOW TO-WINDOW) (ENTER-LEAVE-EVENT LEAVE-NOTIFY-EVENT MODE NOTIFY-INFERIOR FROM-WINDOW) (ENTER-NOTIFIES FROM-WINDOW (WINDOW.PARENT TO-WINDOW) MODE NOTIFY-VIRTUAL) (ENTER-LEAVE-EVENT ENTER-NOTIFY-EVENT MODE NOTIFY-ANCESTOR TO-WINDOW)) ((IS-PARENT TO-WINDOW FROM-WINDOW) (ENTER-LEAVE-EVENT LEAVE-NOTIFY-EVENT MODE NOTIFY-ANCESTOR FROM-WINDOW) (LEAVE-NOTIFIES FROM-WINDOW TO-WINDOW MODE NOTIFY-VIRTUAL NIL) (ENTER-LEAVE-EVENT ENTER-NOTIFY-EVENT MODE NOTIFY-INFERIOR TO-WINDOW)) (T ;; Neither FROM-WINDOW nor TO-WINDOW is descendent of the other. (LET ((COMMON (COMMON-ANCESTOR TO-WINDOW FROM-WINDOW))) (DECLARE (TYPE (OR NULL WINDOW) COMMON)) ;; COMMON == NIL ==> different screens. (ENTER-LEAVE-EVENT LEAVE-NOTIFY-EVENT MODE NOTIFY-NONLINEAR FROM-WINDOW) (IF COMMON (PROGN (LEAVE-NOTIFIES FROM-WINDOW COMMON MODE NOTIFY-NONLINEAR-VIRTUAL NIL) (ENTER-NOTIFIES COMMON (WINDOW.PARENT TO-WINDOW) MODE NOTIFY-NONLINEAR-VIRTUAL)) ;;ELSE (PROGN (LEAVE-NOTIFIES FROM-WINDOW (ROOT-FOR-WINDOW FROM-WINDOW) MODE NOTIFY-NONLINEAR-VIRTUAL T) (ENTER-NOTIFIES (ROOT-FOR-WINDOW TO-WINDOW) (WINDOW.PARENT TO-WINDOW) MODE NOTIFY-NONLINEAR-VIRTUAL))) (ENTER-LEAVE-EVENT ENTER-NOTIFY-EVENT MODE NOTIFY-NONLINEAR TO-WINDOW))))) (EVENT-TRACE-LEAVING "DO-ENTER-LEAVE-EVENTS")) (DEFUN FOCUS-EVENT (TYPE MODE DETAIL WINDOW) (DECLARE (TYPE INTEGER TYPE MODE DETAIL) (TYPE WINDOW WINDOW)) (EVENT-TRACE-ENTERING "FOCUS-EVENT") (LET ((EVENT (MAKE-EVENT-FOCUS :MODE MODE :TYPE TYPE :DETAIL DETAIL :WINDOW WINDOW)) (KEYBOARD (INPUT-INFO.KEYBOARD INPUT-INFO))) (DECLARE (TYPE EVENT-FOCUS EVENT) (TYPE DEVICE KEYBOARD)) (DELIVER-EVENTS-TO-WINDOW WINDOW EVENT 1 (AREF FILTERS TYPE) NIL) (WHEN (= TYPE FOCUS-IN-EVENT) (LET ((KEY-EVENT (MAKE-EVENT-KEYMAP-EVENT :TYPE KEYMAP-NOTIFY-EVENT :MAP (COPY-SEQ (DEVICE.DOWN KEYBOARD))))) (DELIVER-EVENTS-TO-WINDOW WINDOW KEY-EVENT 1 KEYMAP-STATE-MASK NIL)))) (EVENT-TRACE-LEAVING "FOCUS-EVENT")) ;;; Recursive because it is easier ;;; no-op if child not descended from ancestor (DEFUN FOCUS-IN-EVENTS (ANCESTOR CHILD SKIP-CHILD MODE DETAIL DO-ANCESTOR) (DECLARE (TYPE WINDOW ANCESTOR SKIP-CHILD) (TYPE (OR NULL WINDOW) CHILD) (TYPE INTEGER MODE DETAIL) (TYPE BOOLEAN DO-ANCESTOR) (VALUES BOOLEAN)) (EVENT-TRACE-ENTERING "FOCUS-IN-EVENTS") (PROG1 (block GET-OUT (WHEN (NULL CHILD) (RETURN-FROM GET-OUT NIL)) (WHEN (EQ ANCESTOR CHILD) (WHEN DO-ANCESTOR (FOCUS-EVENT FOCUS-IN-EVENT MODE DETAIL CHILD)) (RETURN-FROM GET-OUT NIL)) (WHEN (FOCUS-IN-EVENTS ANCESTOR (WINDOW.PARENT CHILD) SKIP-CHILD MODE DETAIL DO-ANCESTOR) (WHEN (NEQ CHILD SKIP-CHILD) (FOCUS-EVENT FOCUS-IN-EVENT MODE DETAIL CHILD)) (RETURN-FROM GET-OUT T)) NIL) (EVENT-TRACE-LEAVING "FOCUS-IN-EVENTS"))) ;;; Dies horribly if ancestor is not an ancestor of child. (DEFUN FOCUS-OUT-EVENTS (CHILD ANCESTOR MODE DETAIL DO-ANCESTOR) (DECLARE (TYPE WINDOW CHILD ANCESTOR) (TYPE INTEGER MODE DETAIL) (TYPE BOOLEAN DO-ANCESTOR)) (EVENT-TRACE-ENTERING "FOCUS-OUT-EVENTS") (LOOP FOR WINDOW FIRST CHILD THEN (WINDOW.PARENT WINDOW) WHILE (NEQ WINDOW ANCESTOR) DO (FOCUS-EVENT FOCUS-OUT-EVENT MODE DETAIL WINDOW)) (WHEN DO-ANCESTOR (FOCUS-EVENT FOCUS-OUT-EVENT MODE DETAIL ANCESTOR)) (EVENT-TRACE-LEAVING "FOCUS-OUT-EVENTS")) (ZWEI:DEFINE-INDENTATION NOTIFY-ROOTS (1 1)) (DEFUN DO-FOCUS-EVENTS (FROM-WIN TO-WIN MODE) (DECLARE (TYPE (OR NULL WINDOW) FROM-WIN TO-WIN) (TYPE INTEGER MODE)) (EVENT-TRACE-ENTERING "DO-FOCUS-EVENTS") (WHEN (NEQ FROM-WIN TO-WIN) (LET ( ;; In/Out: For holding details for to/from PointerRoot/None. (OUT (IF FROM-WIN NOTIFY-POINTER-ROOT NOTIFY-DETAIL-NONE)) (IN (IF TO-WIN NOTIFY-POINTER-ROOT NOTIFY-DETAIL-NONE))) (FLET ((NOTIFY-ROOTS (EVENT DIRECTION) (LOOP FOR WINDOW IN (SCREEN-INFO.WINDOWS SCREEN-INFO) DO (FOCUS-EVENT EVENT MODE DIRECTION WINDOW)))) ;; Wrong values if neither, but then not referenced. (cond ((OR (NULL TO-WIN) (EQ TO-WIN POINTER-ROOT-WINDOW)) (IF (OR (NULL FROM-WIN) (EQ FROM-WIN POINTER-ROOT-WINDOW)) (PROGN (WHEN (EQ FROM-WIN POINTER-ROOT-WINDOW) (FOCUS-OUT-EVENTS (SPRITE.WINDOW SPRITE) (ROOT) MODE NOTIFY-POINTER T)) ;; Notify all the roots. (NOTIFY-ROOTS FOCUS-OUT-EVENT OUT)) ;;ELSE (PROGN (WHEN (IS-PARENT FROM-WIN (SPRITE.WINDOW SPRITE)) (FOCUS-OUT-EVENTS (SPRITE.WINDOW SPRITE) FROM-WIN MODE NOTIFY-POINTER NIL)) (FOCUS-EVENT FOCUS-OUT-EVENT MODE NOTIFY-NONLINEAR FROM-WIN) ;; Next call catches the root too, if the screen changed. (FOCUS-OUT-EVENTS (WINDOW.PARENT FROM-WIN) NIL MODE NOTIFY-NONLINEAR-VIRTUAL NIL))) ;; Notify all the roots. (NOTIFY-ROOTS FOCUS-IN-EVENT IN) (WHEN (EQ TO-WIN POINTER-ROOT-WINDOW) (FOCUS-IN-EVENTS (ROOT) (SPRITE.WINDOW SPRITE) NIL MODE NOTIFY-POINTER T))) ((OR (NULL FROM-WIN) (EQ FROM-WIN POINTER-ROOT-WINDOW)) (WHEN (EQ FROM-WIN POINTER-ROOT-WINDOW) (FOCUS-OUT-EVENTS (SPRITE.WINDOW SPRITE) (ROOT) MODE NOTIFY-POINTER T)) (NOTIFY-ROOTS FOCUS-OUT-EVENT OUT) (WHEN (WINDOW.PARENT TO-WIN) (FOCUS-IN-EVENTS (ROOT) TO-WIN TO-WIN MODE NOTIFY-NONLINEAR-VIRTUAL T)) (FOCUS-EVENT FOCUS-IN-EVENT MODE NOTIFY-NONLINEAR TO-WIN) (WHEN (IS-PARENT TO-WIN (SPRITE.WINDOW SPRITE)) (FOCUS-IN-EVENTS TO-WIN (SPRITE.WINDOW SPRITE) NIL MODE NOTIFY-POINTER NIL))) ((IS-PARENT TO-WIN FROM-WIN) (FOCUS-EVENT FOCUS-OUT-EVENT MODE NOTIFY-ANCESTOR FROM-WIN) (FOCUS-OUT-EVENTS (WINDOW.PARENT FROM-WIN) TO-WIN MODE NOTIFY-VIRTUAL NIL) (FOCUS-EVENT FOCUS-IN-EVENT MODE NOTIFY-INFERIOR TO-WIN) (WHEN (AND (IS-PARENT TO-WIN (SPRITE.WINDOW SPRITE)) (NEQ (SPRITE.WINDOW SPRITE) FROM-WIN) (NOT (IS-PARENT FROM-WIN (SPRITE.WINDOW SPRITE))) (NOT (IS-PARENT (SPRITE.WINDOW SPRITE) FROM-WIN))) (FOCUS-IN-EVENTS TO-WIN (SPRITE.WINDOW SPRITE) NIL MODE NOTIFY-POINTER NIL))) ((IS-PARENT FROM-WIN TO-WIN) (WHEN (AND (IS-PARENT FROM-WIN (SPRITE.WINDOW SPRITE)) (NEQ (SPRITE.WINDOW SPRITE) FROM-WIN) (NOT (IS-PARENT TO-WIN (SPRITE.WINDOW SPRITE))) (NOT (IS-PARENT (SPRITE.WINDOW SPRITE) TO-WIN))) (FOCUS-OUT-EVENTS (SPRITE.WINDOW SPRITE) FROM-WIN MODE NOTIFY-POINTER NIL)) (FOCUS-EVENT FOCUS-OUT-EVENT MODE NOTIFY-INFERIOR FROM-WIN) (FOCUS-IN-EVENTS FROM-WIN TO-WIN TO-WIN MODE NOTIFY-VIRTUAL NIL) (FOCUS-EVENT FOCUS-IN-EVENT MODE NOTIFY-ANCESTOR TO-WIN)) (t ;; Neither FROM-WIN or TO-WIN is child of other. (LET ((COMMON (COMMON-ANCESTOR TO-WIN FROM-WIN))) (DECLARE (TYPE WINDOW COMMON )) ;; common == NullWindow ==> different screens. (WHEN (IS-PARENT FROM-WIN (SPRITE.WINDOW SPRITE)) (FOCUS-OUT-EVENTS (SPRITE.WINDOW SPRITE) FROM-WIN MODE NOTIFY-POINTER NIL)) (FOCUS-EVENT FOCUS-OUT-EVENT MODE NOTIFY-NONLINEAR FROM-WIN) (WHEN (WINDOW.PARENT FROM-WIN) (FOCUS-OUT-EVENTS (WINDOW.PARENT FROM-WIN) COMMON MODE NOTIFY-NONLINEAR-VIRTUAL NIL)) (WHEN (WINDOW.PARENT TO-WIN) (FOCUS-IN-EVENTS COMMON TO-WIN TO-WIN MODE NOTIFY-NONLINEAR-VIRTUAL NIL)) (FOCUS-EVENT FOCUS-IN-EVENT MODE NOTIFY-NONLINEAR TO-WIN) (WHEN (IS-PARENT TO-WIN (SPRITE.WINDOW SPRITE)) (FOCUS-IN-EVENTS TO-WIN (SPRITE.WINDOW SPRITE) NIL MODE NOTIFY-POINTER NIL)))))))) (EVENT-TRACE-LEAVING "DO-FOCUS-EVENTS")) (DEFUN SET-POINTER-STATE-MASKS (THE-MOUSE-DEVICE) (DECLARE (TYPE DEVICE THE-MOUSE-DEVICE)) (EVENT-TRACE-ENTERING "SET-POINTER-STATE-MASKS") ;; All have to be defined since some button might be mapped here. (LOOP FOR INDEX FROM 0 BELOW 8 DO (SETF (AREF KEY-MODIFIERS-LIST INDEX) (AREF (DEVICE.MODIFIER-MAP THE-MOUSE-DEVICE) INDEX))) (EVENT-TRACE-LEAVING "SET-POINTER-STATE-MASKS")) (DEFUN SET-KEYBOARD-STATE-MASKS (THE-KEYBOARD-DEVICE) (DECLARE (TYPE DEVICE THE-KEYBOARD-DEVICE)) (EVENT-TRACE-ENTERING "SET-KEYBOARD-STATE-MASKS") ;; For all valid keys (from 8 up) copy the bitmap of the modifiers ;; it sets from the keyboard info into the array we use internally. ;; No need to test for bad entries - these are detected when the ;; array in the kbd struct is built. (LOOP FOR INDEX FROM 8 BELOW MAP-LENGTH DO (SETF (AREF KEY-MODIFIERS-LIST INDEX) (AREF (DEVICE.MODIFIER-MAP THE-KEYBOARD-DEVICE) INDEX))) (EVENT-TRACE-LEAVING "SET-KEYBOARD-STATE-MASKS")) #| (INITIALIZE-MONOCHROME-SERVER-DEVICES) |# (DEFUN INITIALIZE-MONOCHROME-SERVER-DEVICES (&OPTIONAL ARGS) (EVENT-TRACE-ENTERING "INITIALIZE-MONOCHROME-SERVER-DEVICES") (SETF (INPUT-INFO.NUM-DEVICES INPUT-INFO) 0) (SETF (FILL-POINTER (INPUT-INFO.DEVICES INPUT-INFO)) 0) (array-initialize key-modifiers-list 0) (ADD-POINTER) (ADD-KEYBOARD) (INIT-AND-START-DEVICES ARGS) (INIT-EVENTS) ;; The following arguments agree semantically with what is in sunMouse.c (INIT-POINTER-DEVICE-STRUCT (INPUT-INFO.POINTER INPUT-INFO) #(NIL 1 2 3) 3 #'(LAMBDA (&REST IGNORE) ;; Count of 0 for the length number of saved mouse motion events. 0) #'IGNORE) (INIT-KEYBOARD-DEVICE-STRUCT (INPUT-INFO.KEYBOARD INPUT-INFO) EXPLORER-KEY-SYMS KEY-MODIFIERS-LIST BELL-FUNCTION #'IGNORE) (DEFINE-INITIAL-ROOT-WINDOW ;1; HACK ALERT!!! I'm not sure that we really want to get the first root window or not.* ;1; This works now since we know there is only one, and it may be correct for multiple* ;1; screens too, but that has yet to be determined.* (CAR (SCREEN-INFO.windows SCREEN-INFO))) (EVENT-TRACE-LEAVING "INITIALIZE-MONOCHROME-SERVER-DEVICES")) (DEFUN KEYBOARD-INITIALIZATION-INTERNAL (DEVICE WHAT IGNORE) (DECLARE (TYPE DEVICE DEVICE) (TYPE BOOLEAN WHAT) (VALUES INTEGER)) (EVENT-TRACE-ENTERING "KEYBOARD-INITIALIZATION-INTERNAL") (WHEN (= WHAT DEVICE-INIT) (CLEAR-EVENT-QUEUE (DEVICE.EVENTS DEVICE))) (EVENT-TRACE-LEAVING "KEYBOARD-INITIALIZATION-INTERNAL") STATUS-SUCCESS) (DEFUN ADD-KEYBOARD () (DECLARE (VALUES DEVICE)) (EVENT-TRACE-ENTERING "ADD-KEYBOARD") (LET ((NEW-DEVICE (ADD-INPUT-DEVICE 'KEYBOARD-INITIALIZATION-INTERNAL T))) (SETF (INPUT-INFO.KEYBOARD INPUT-INFO) NEW-DEVICE) (SETF (DEVICE.EVENTS NEW-DEVICE) KEYBOARD-EVENT-QUEUE) (SETF (DEVICE.SYNC NEW-DEVICE) (MAKE-SYNC :FROZEN NIL :OTHER NIL :STATE NOT-GRABBED :EVENT NIL)) (let ((modifiers (MAKE-KEY-MODIFIERS-LIST))) (copy-array-contents DEFAULT-KEYBOARD-MODIFIERS modifiers) (SETF (DEVICE.MODIFIER-MAP NEW-DEVICE) modifiers)) (EVENT-TRACE-LEAVING "ADD-KEYBOARD") NEW-DEVICE)) (DEFUN POINTER-INITIALIZATION-INTERNAL (DEVICE WHAT IGNORE) (DECLARE (TYPE DEVICE DEVICE) (TYPE BOOLEAN WHAT) (VALUES INTEGER)) (EVENT-TRACE-ENTERING "POINTER-INITIALIZATION-INTERNAL") (WHEN (= WHAT DEVICE-INIT) (CLEAR-EVENT-QUEUE (DEVICE.EVENTS DEVICE))) ;; We haven't hit any buttons yet. (SETQ MOUSE-LAST-BUTTONS 0 BUTTONS-DOWN 0) (EVENT-TRACE-LEAVING "POINTER-INITIALIZATION-INTERNAL") STATUS-SUCCESS) (DEFUN ADD-POINTER () (DECLARE (VALUES DEVICE)) (EVENT-TRACE-ENTERING "ADD-POINTER") (LET ((NEW-DEVICE (ADD-INPUT-DEVICE 'POINTER-INITIALIZATION-INTERNAL T))) (SETF (INPUT-INFO.POINTER INPUT-INFO) NEW-DEVICE) (SETF (DEVICE.EVENTS NEW-DEVICE) MOUSE-EVENT-QUEUE) (SETF (DEVICE.SYNC NEW-DEVICE) (MAKE-SYNC :FROZEN NIL :OTHER NIL :STATE NOT-GRABBED :EVENT NIL)) (let ((modifiers (MAKE-KEY-MODIFIERS-LIST))) (copy-array-contents DEFAULT-MOUSE-MODIFIERS modifiers) (SETF (DEVICE.MODIFIER-MAP NEW-DEVICE) modifiers)) (EVENT-TRACE-LEAVING "ADD-POINTER") NEW-DEVICE)) (DEFUN ADD-INPUT-DEVICE (DEVICE-PROC AUTO-START) (DECLARE (TYPE FUNCTION DEVICE-PROC) (TYPE BOOLEAN AUTO-START) (VALUES DEVICE)) (EVENT-TRACE-ENTERING "ADD-INPUT-DEVICE") (LET ((NEW-DEVICE (MAKE-DEVICE :DEVICE-PROC DEVICE-PROC :PUBLIC.ON NIL :PUBLIC.PROCESS-INPUT-PROC #'IGNORE :STARTUP AUTO-START :SYNC (MAKE-SYNC :FROZEN NIL :OTHER NIL :STATE NOT-GRABBED)))) (DECLARE (TYPE DEVICE NEW-DEVICE)) (VECTOR-PUSH-EXTEND NEW-DEVICE (INPUT-INFO.DEVICES INPUT-INFO)) (INCF (INPUT-INFO.ARRAY-SIZE INPUT-INFO)) (INCF (INPUT-INFO.NUM-DEVICES INPUT-INFO)) (EVENT-TRACE-LEAVING "ADD-INPUT-DEVICE") NEW-DEVICE)) (DEFUN GET-INPUT-DEVICES () (DECLARE (VALUES DEVICES-DESCRIPTOR)) (MAKE-DEVICES-DESCRIPTOR :COUNT (INPUT-INFO.NUM-DEVICES INPUT-INFO) :DEVICES (INPUT-INFO.DEVICES INPUT-INFO))) (DEFUN INIT-EVENTS () (EVENT-TRACE-ENTERING "INIT-EVENTS") (SETF (KEY-SYMS-RECORD.MAP CURRENT-KEY-SYMS) NIL) (SETF (KEY-SYMS-RECORD.MIN-KEY-CODE CURRENT-KEY-SYMS) 0) (SETF (KEY-SYMS-RECORD.MAX-KEY-CODE CURRENT-KEY-SYMS) 0) (SETF (KEY-SYMS-RECORD.MAP-WIDTH CURRENT-KEY-SYMS) 0) (SETQ CURRENT-SCREEN (CAR (SCREEN-INFO.SCREENS SCREEN-INFO))) (SETF (DEVICE.SCREEN (INPUT-INFO.POINTER INPUT-INFO)) CURRENT-SCREEN) (WHEN (ZEROP SPRITE-TRACE-SIZE ) (SETQ SPRITE-TRACE-SIZE 20) (ADJUST-ARRAY SPRITE-TRACE 20)) (SETQ SPRITE-TRACE-GOOD 0) (WHEN (ZEROP FOCUS-TRACE-SIZE) (SETQ FOCUS-TRACE-SIZE 20) (ADJUST-ARRAY FOCUS-TRACE 20)) (SETQ FOCUS-TRACE-GOOD 0) (SETQ LAST-EVENT-MASK OWNER-GRAB-BUTTON-MASK) (SETF (SPRITE.WINDOW SPRITE) NIL) (SETF (SPRITE.CURRENT SPRITE) NIL) (SETF (SPRITE.HOT-LIMITS SPRITE) (MAKE-BOX :left 0 :top 0 :right 0 :bottom 0)) (SETF (BOX.LEFT (SPRITE.HOT-LIMITS SPRITE)) 0) (SETF (BOX.TOP (SPRITE.HOT-LIMITS SPRITE)) 0) (SETF (BOX.RIGHT (SPRITE.HOT-LIMITS SPRITE)) (SCREEN.WIDTH CURRENT-SCREEN)) (SETF (BOX.BOTTOM (SPRITE.HOT-LIMITS SPRITE)) (SCREEN.HEIGHT CURRENT-SCREEN)) (SETQ MOTION-HINT-WINDOW NIL) (SETF (SYNC-EVENTS.REPLAY-DEVICE SYNC-EVENTS) NIL) (SETF (SYNC-EVENTS.PENDING SYNC-EVENTS) (MAKE-QD-EVENT-RECORD)) (SETF (QD-EVENT-RECORD.FORWARD (SYNC-EVENTS.PENDING SYNC-EVENTS)) (SYNC-EVENTS.PENDING SYNC-EVENTS)) (SETF (QD-EVENT-RECORD.BACKWARD (SYNC-EVENTS.PENDING SYNC-EVENTS)) (SYNC-EVENTS.PENDING SYNC-EVENTS)) (SETF (SYNC-EVENTS.FREE SYNC-EVENTS) (MAKE-QD-EVENT-RECORD)) (SETF (QD-EVENT-RECORD.FORWARD (SYNC-EVENTS.FREE SYNC-EVENTS)) (SYNC-EVENTS.FREE SYNC-EVENTS)) (SETF (QD-EVENT-RECORD.BACKWARD (SYNC-EVENTS.FREE SYNC-EVENTS)) (SYNC-EVENTS.FREE SYNC-EVENTS)) (SETF (SYNC-EVENTS.NUMBER SYNC-EVENTS) 0) (SETF (SYNC-EVENTS.PLAYING-EVENTS SYNC-EVENTS) NIL) (SETF (TIME-STAMP.MONTHS CURRENT-TIME) 0) (SETF (TIME-STAMP.MILLISECONDS CURRENT-TIME) (GET-TIME-IN-MILLIS)) (EVENT-TRACE-LEAVING "INIT-EVENTS")) (DEFUN INIT-AND-START-DEVICES (&OPTIONAL ARGS) (DECLARE (VALUES INTEGER)) (EVENT-TRACE-ENTERING "INIT-AND-START-DEVICES") (LOOP FOR INDEX FROM 0 BELOW 8 DO (SETF (AREF MODIFIER-KEY-COUNT INDEX) 0)) (SETQ KEY-BUTTON-STATE 0 BUTTONS-DOWN 0 BUTTON-MOTION-MASK-VARIABLE 0) (LOOP FOR INDEX FROM 0 BELOW (INPUT-INFO.NUM-DEVICES INPUT-INFO) FOR DEVICE = (AREF (INPUT-INFO.DEVICES INPUT-INFO) INDEX) DO (SETF (DEVICE.INITED DEVICE) (IF (= (FUNCALL (DEVICE.DEVICE-PROC DEVICE) DEVICE DEVICE-INIT ARGS) STATUS-SUCCESS) T ;;ELSE NIL))) ;; Do not turn any devices on until all have been inited. (LOOP FOR INDEX FROM 0 BELOW (INPUT-INFO.NUM-DEVICES INPUT-INFO) FOR DEVICE = (AREF (INPUT-INFO.DEVICES INPUT-INFO) INDEX) WHEN (AND (DEVICE.STARTUP DEVICE) (DEVICE.INITED DEVICE)) DO (FUNCALL (DEVICE.DEVICE-PROC DEVICE) DEVICE DEVICE-ON ARGS)) (PROG1 (IF (AND (INPUT-INFO.POINTER INPUT-INFO) (DEVICE.INITED (INPUT-INFO.POINTER INPUT-INFO)) (INPUT-INFO.KEYBOARD INPUT-INFO) (DEVICE.INITED (INPUT-INFO.POINTER INPUT-INFO))) STATUS-SUCCESS ;;ELSE BAD-IMPLEMENTATION) (EVENT-TRACE-LEAVING "INIT-AND-START-DEVICES"))) (DEFUN CLOSE-DOWN-DEVICES (ARGS) (EVENT-TRACE-ENTERING "CLOSE-DOWN-DEVICES") (SETF (KEY-SYMS-RECORD.MAP CURRENT-KEY-SYMS) NIL) (LOOP FOR INDEX FROM (1- (INPUT-INFO.NUM-DEVICES INPUT-INFO)) DOWNTO 0 FOR DEVICE = (AREF (INPUT-INFO.DEVICES INPUT-INFO) INDEX) WHEN (DEVICE.INITED DEVICE) DO (PROGN (FUNCALL (DEVICE.DEVICE-PROC DEVICE) DEVICE DEVICE-CLOSE ARGS) (SETF (INPUT-INFO.NUM-DEVICES INPUT-INFO) INDEX))) (EVENT-TRACE-LEAVING "CLOSE-DOWN-DEVICES")) (DEFUN NUM-MOTION-EVENTS () (DECLARE (VALUES INTEGER)) (INPUT-INFO.NUM-MOTION-EVENTS INPUT-INFO)) (DEFUN REGISTER-POINTER-DEVICE (DEVICE NUM-MOTION-EVENTS) (DECLARE (TYPE DEVICE DEVICE) (TYPE INTEGER NUM-MOTION-EVENTS)) (EVENT-TRACE-ENTERING "REGISTER-POINTER-DEVICE") (SETF (INPUT-INFO.POINTER INPUT-INFO) DEVICE) (SETF (INPUT-INFO.NUM-MOTION-EVENTS INPUT-INFO) NUM-MOTION-EVENTS) (SETF (DEVICE.PUBLIC.PROCESS-INPUT-PROC DEVICE) #'PROCESS-POINTER-EVENT) (EVENT-TRACE-LEAVING "REGISTER-POINTER-DEVICE")) (DEFUN REGISTER-KEYBOARD-DEVICE (DEVICE) (DECLARE (TYPE DEVICE DEVICE)) (EVENT-TRACE-ENTERING "REGISTER-KEYBOARD-DEVICE") (SETF (INPUT-INFO.KEYBOARD INPUT-INFO) DEVICE) (SETF (DEVICE.PUBLIC.PROCESS-INPUT-PROC DEVICE) #'PROCESS-KEYBOARD-EVENT) (EVENT-TRACE-LEAVING "REGISTER-KEYBOARD-DEVICE")) (DEFUN INIT-POINTER-DEVICE-STRUCT (DEVICE MAP THE-MAP-LENGTH MOTION-PROC CONTROL-PROC) (DECLARE (TYPE DEVICE DEVICE) (TYPE SIMPLE-ARRAY MAP) (TYPE INTEGER THE-MAP-LENGTH) (TYPE (FUNCTION () (VALUES INTEGER)) MOTION-PROC) (TYPE (FUNCTION () NIL) CONTROL-PROC)) (EVENT-TRACE-ENTERING "INIT-POINTER-DEVICE-STRUCT") (SETF (DEVICE.GRAB DEVICE) NIL) (SETF (DEVICE.PUBLIC.ON DEVICE) NIL) (SETF (DEVICE.MAP-LENGTH DEVICE) THE-MAP-LENGTH) (WHEN (EQ (DEVICE.MAP DEVICE) :UNBOUND) (SETF (DEVICE.MAP DEVICE) (MAKE-ARRAY (1+ THE-MAP-LENGTH)))) (SETF (AREF (DEVICE.MAP DEVICE) 0) 0) (LOOP WITH DEVICE-MAP = (DEVICE.MAP DEVICE) FOR INDEX FROM 1 TO THE-MAP-LENGTH DO (SETF (AREF DEVICE-MAP INDEX) (AREF MAP INDEX))) (SETF (DEVICE.POINTER-CONTROL DEVICE) DEFAULT-POINTER-CONTROL) (SETF (DEVICE.GET-MOTION-PROC DEVICE) MOTION-PROC) (SETF (DEVICE.CONTROL-PROC DEVICE) CONTROL-PROC) (SETF (DEVICE.AUTO-RELEASE-GRAB DEVICE) NIL) (WHEN (EQ DEVICE (INPUT-INFO.POINTER INPUT-INFO)) (SET-POINTER-STATE-MASKS DEVICE)) (FUNCALL CONTROL-PROC DEVICE (DEVICE.POINTER-CONTROL DEVICE)) (EVENT-TRACE-LEAVING "INIT-POINTER-DEVICE-STRUCT")) (DEFUN QUERY-MIN-MAX-KEY-CODES () (DECLARE (VALUES INTEGER INTEGER)) (VALUES (KEY-SYMS-RECORD.MIN-KEY-CODE CURRENT-KEY-SYMS) (KEY-SYMS-RECORD.MAX-KEY-CODE CURRENT-KEY-SYMS))) (ZWEI:DEFINE-INDENTATION SOURCE-INDEX (1 1)) (ZWEI:DEFINE-INDENTATION DESTINATION-INDEX (1 1)) (DEFUN SET-KEY-SYMS-MAP (KEY-SYMS) (DECLARE (TYPE KEY-SYMS-RECORD KEY-SYMS)) (EVENT-TRACE-ENTERING "SET-KEY-SYMS-MAP") (LET ((ROW-DIF (- (KEY-SYMS-RECORD.MIN-KEY-CODE KEY-SYMS) (KEY-SYMS-RECORD.MIN-KEY-CODE CURRENT-KEY-SYMS)))) (DECLARE (TYPE INTEGER ROW-DIF)) ;; If keysym map size changes, grow map first. (IF (< (KEY-SYMS-RECORD.MAP-WIDTH KEY-SYMS) (KEY-SYMS-RECORD.MAP-WIDTH CURRENT-KEY-SYMS)) (FLET ((SOURCE-INDEX (ROW COLUMN) (+ (* (- ROW (KEY-SYMS-RECORD.MIN-KEY-CODE KEY-SYMS)) (KEY-SYMS-RECORD.MAP-WIDTH KEY-SYMS)) COLUMN)) (DESTINATION-INDEX (ROW COLUMN) (+ (* (- ROW (KEY-SYMS-RECORD.MIN-KEY-CODE CURRENT-KEY-SYMS)) (KEY-SYMS-RECORD.MAP-WIDTH CURRENT-KEY-SYMS)) COLUMN))) (LOOP FOR I FROM (KEY-SYMS-RECORD.MIN-KEY-CODE KEY-SYMS) TO (KEY-SYMS-RECORD.MAX-KEY-CODE KEY-SYMS) DO (PROGN (LOOP FOR J FROM 0 BELOW (KEY-SYMS-RECORD.MAP-WIDTH KEY-SYMS) DO (SETF (AREF (KEY-SYMS-RECORD.MAP CURRENT-KEY-SYMS) (DESTINATION-INDEX I J)) (AREF (KEY-SYMS-RECORD.MAP KEY-SYMS) (SOURCE-INDEX I J)))) (LOOP FOR J FROM (KEY-SYMS-RECORD.MAP-WIDTH KEY-SYMS) BELOW (KEY-SYMS-RECORD.MAP-WIDTH CURRENT-KEY-SYMS) DO (SETF (AREF (KEY-SYMS-RECORD.MAP CURRENT-KEY-SYMS) (DESTINATION-INDEX I J)) NO-SYMBOL))))) ;;ELSE (PROGN (WHEN (> (KEY-SYMS-RECORD.MAP-WIDTH KEY-SYMS) (KEY-SYMS-RECORD.MAP-WIDTH CURRENT-KEY-SYMS)) (LET ((MAP (MAKE-ARRAY (* (KEY-SYMS-RECORD.MAP-WIDTH KEY-SYMS) (1+ (- (KEY-SYMS-RECORD.MAX-KEY-CODE CURRENT-KEY-SYMS) (KEY-SYMS-RECORD.MIN-KEY-CODE CURRENT-KEY-SYMS)))) :ELEMENT-TYPE 'INTEGER :INITIAL-ELEMENT NO-SYMBOL))) (WHEN (KEY-SYMS-RECORD.MAP CURRENT-KEY-SYMS) (LOOP WITH SOURCE = (KEY-SYMS-RECORD.MAP CURRENT-KEY-SYMS) FOR I FROM 0 TO (- (KEY-SYMS-RECORD.MAX-KEY-CODE CURRENT-KEY-SYMS) (KEY-SYMS-RECORD.MIN-KEY-CODE CURRENT-KEY-SYMS)) DO (LOOP WITH DEST-OFFSET = (* I (KEY-SYMS-RECORD.MAP-WIDTH KEY-SYMS)) WITH SOURCE-OFFSET = (* I (KEY-SYMS-RECORD.MAP-WIDTH CURRENT-KEY-SYMS)) FOR J FROM 0 BELOW (KEY-SYMS-RECORD.MAP-WIDTH CURRENT-KEY-SYMS) DO (SETF (AREF MAP (+ DEST-OFFSET J)) (AREF SOURCE (+ SOURCE-OFFSET J)))))) (SETF (KEY-SYMS-RECORD.MAP-WIDTH CURRENT-KEY-SYMS) (KEY-SYMS-RECORD.MAP-WIDTH KEY-SYMS)) (SETF (KEY-SYMS-RECORD.MAP CURRENT-KEY-SYMS) MAP) )))) (LOOP WITH SOURCE = (KEY-SYMS-RECORD.MAP KEY-SYMS) WITH DEST = (KEY-SYMS-RECORD.MAP CURRENT-KEY-SYMS) FOR INDEX FROM 0 BELOW (* (1+ (- (KEY-SYMS-RECORD.MAX-KEY-CODE KEY-SYMS) (KEY-SYMS-RECORD.MIN-KEY-CODE KEY-SYMS))) (KEY-SYMS-RECORD.MAP-WIDTH CURRENT-KEY-SYMS)) DO (SETF (AREF DEST (+ INDEX ROW-DIF)) (AREF SOURCE INDEX))) ) (EVENT-TRACE-LEAVING "SET-KEY-SYMS-MAP")) (DEFUN WIDTH-OF-MODIFIER-TABLE (MODIFIER-MAP) (DECLARE (VALUES INTEGER)) (EVENT-TRACE-ENTERING "WIDTH-OF-MODIFIER-TABLE") (LET ((KEYS-PER-MODIFIER (MAKE-ARRAY 8 :ELEMENT-TYPE 'INTEGER :INITIAL-VALUE 0)) (MAX-KEYS-PER-MODIFIER 0)) (DECLARE (TYPE (ARRAY INTEGER) KEYS-PER-MODIFIER) (TYPE INTEGER MAX-KEYS-PER-MODIFIER)) (LOOP FOR I FROM 8 BELOW MAP-LENGTH DO (LOOP WITH MODIFIER-MAP-BITS = (AREF MODIFIER-MAP I) FOR J FROM 0 BELOW 8 FOR MASK FIRST 1 THEN (ASH MASK 1) WHEN (NOT (ZEROP (LOGAND MASK MODIFIER-MAP-BITS))) DO (PROGN (INCF (AREF KEYS-PER-MODIFIER J)) (WHEN (> (AREF KEYS-PER-MODIFIER J) MAX-KEYS-PER-MODIFIER) (SETQ MAX-KEYS-PER-MODIFIER (AREF KEYS-PER-MODIFIER J)))))) (SETQ MODIFIER-KEY-MAP (MAKE-ARRAY (* 8 MAX-KEYS-PER-MODIFIER) :ELEMENT-TYPE '(unsigned-byte 8) :INITIAL-ELEMENT 0)) (LOOP FOR INDEX FROM 0 BELOW (LENGTH KEYS-PER-MODIFIER) DO (SETF (AREF KEYS-PER-MODIFIER INDEX) 0)) (LOOP FOR I FROM 8 BELOW MAP-LENGTH DO (LOOP WITH MODIFIER-MAP-BITS = (AREF MODIFIER-MAP I) FOR J FROM 0 BELOW 8 FOR MASK FIRST 1 THEN (ASH MASK 1) WHEN (NOT (ZEROP (LOGAND MASK MODIFIER-MAP-BITS))) DO (PROGN (SETF (AREF MODIFIER-KEY-MAP (+ (* J MAX-KEYS-PER-MODIFIER) (AREF KEYS-PER-MODIFIER J))) I) (INCF (AREF KEYS-PER-MODIFIER J))))) (EVENT-TRACE-LEAVING "WIDTH-OF-MODIFIER-TABLE") MAX-KEYS-PER-MODIFIER)) (DEFUN INIT-KEYBOARD-DEVICE-STRUCT (KEYBOARD KEY-SYMS MODIFIERS BELL-PROC CONTROL-PROC) (DECLARE (TYPE DEVICE KEYBOARD) (TYPE KEY-SYMS-RECORD KEY-SYMS) (TYPE (ARRAY INTEGER) MODIFIERS) (TYPE (FUNCTION () NIL) BELL-PROC CONTROL-PROC) (IGNORE MODIFIERS)) (EVENT-TRACE-ENTERING "INIT-KEYBOARD-DEVICE-STRUCT") (SETF (DEVICE.GRAB KEYBOARD) NIL) (SETF (DEVICE.PUBLIC.ON KEYBOARD) NIL) (SETF (DEVICE.KEYBOARD-CONTROL KEYBOARD) DEFAULT-KEYBOARD-CONTROL) (SETF (DEVICE.KEYBOARD-BELL-PROC KEYBOARD) BELL-PROC) (SETF (DEVICE.KEYBOARD-CONTROL-PROC KEYBOARD) CONTROL-PROC) (SETF (DEVICE.FOCUS-WINDOW KEYBOARD) POINTER-ROOT-WINDOW) (SETF (DEVICE.FOCUS-REVERT KEYBOARD) revert-to-pointer-root) (SETF (DEVICE.FOCUS-TIME KEYBOARD) CURRENT-TIME) (SETF (DEVICE.GRAB-TIME KEYBOARD) CURRENT-TIME) (SETF (DEVICE.PASSIVE-GRAB KEYBOARD) NIL) (SETF (KEY-SYMS-RECORD.MIN-KEY-CODE CURRENT-KEY-SYMS) (KEY-SYMS-RECORD.MIN-KEY-CODE KEY-SYMS)) (SETF (KEY-SYMS-RECORD.MAX-KEY-CODE CURRENT-KEY-SYMS) (KEY-SYMS-RECORD.MAX-KEY-CODE KEY-SYMS)) (SETQ MAX-KEYS-PER-MODIFIER (WIDTH-OF-MODIFIER-TABLE (DEVICE.MODIFIER-MAP KEYBOARD))) (WHEN (EQ KEYBOARD (INPUT-INFO.KEYBOARD INPUT-INFO)) (SET-KEYBOARD-STATE-MASKS KEYBOARD) (SET-KEY-SYMS-MAP KEY-SYMS)) (FUNCALL (DEVICE.KEYBOARD-CONTROL-PROC KEYBOARD) KEYBOARD (DEVICE.KEYBOARD-CONTROL KEYBOARD)) (EVENT-TRACE-LEAVING "INIT-KEYBOARD-DEVICE-STRUCT")) (DEFUN INIT-OTHER-DEVICE-STRUCT (DEVICE MAP THE-MAP-LENGTH) (DECLARE (TYPE DEVICE DEVICE) (TYPE (ARRAY INTEGER) MAP) (TYPE INTEGER THE-MAP-LENGTH)) (EVENT-TRACE-ENTERING "INIT-OTHER-DEVICE-STRUCT") (SETF (DEVICE.GRAB DEVICE) NIL) (SETF (DEVICE.PUBLIC.ON DEVICE) NIL) (SETF (DEVICE.MAP-LENGTH DEVICE) THE-MAP-LENGTH) (SETF (AREF (DEVICE.MAP DEVICE) 0) 0) (LOOP WITH DEVICE-MAP = (DEVICE.MAP DEVICE) FOR I FROM 1 TO THE-MAP-LENGTH DO (SETF (AREF DEVICE-MAP I) (AREF MAP I))) (SETF (DEVICE.FOCUS-WINDOW DEVICE) NIL) (SETF (DEVICE.FOCUS-REVERT DEVICE) revert-to-pointer-root) (SETF (DEVICE.FOCUS-TIME DEVICE) CURRENT-TIME) (EVENT-TRACE-LEAVING "INIT-OTHER-DEVICE-STRUCT")) (DEFUN SET-DEVICE-GRAB (DEVICE GRAB) (DECLARE (TYPE DEVICE DEVICE) (TYPE GRAB-RECORD GRAB) (VALUES GRAB-RECORD)) (PROG1 (DEVICE.GRAB DEVICE) (SETF (DEVICE.GRAB DEVICE) GRAB))) (DEFUN LOOKUP-POINTER-DEVICE () (DECLARE (VALUES DEVICE)) (INPUT-INFO.POINTER INPUT-INFO)) (DEFUN LOOKUP-KEYBOARD-DEVICE () (DECLARE (VALUES DEVICE)) (INPUT-INFO.KEYBOARD INPUT-INFO)) ;;; Commented out by TWE because we don't have IDs for devices on the Explorer. ;;;(DEFUN LOOKUP-INPUT-DEVICE (DEVICE-ID) ;;; (DECLARE (TYPE INTEGER DEVICE-ID) ;;; (VALUES (OR NULL DEVICE))) ;;; (LOOP FOR I FROM 0 BELOW (INPUT-INFO.NUM-DEVICES INPUT-INFO) ;;; WHEN (= (DEVICE.ID (AREF (INPUT-INFO.DEVICES INPUT-INFO) I)) ;;; DEVICE-ID) ;;; DO (RETURN (AREF (INPUT-INFO.DEVICES INPUT-INFO) I)) ;;; FINALLY (RETURN NIL))) (DEFUN SEND-MAPPING-NOTIFY (REQUEST FIRST-KEY-CODE COUNT) (DECLARE (TYPE MAPPING-TYPE REQUEST) (TYPE INTEGER FIRST-KEY-CODE COUNT)) (EVENT-TRACE-ENTERING "SEND-MAPPING-NOTIFY") (LET ((EVENT (MAKE-EVENT-MAPPING-NOTIFY :TYPE MAPPING-NOTIFY-EVENT :REQUEST REQUEST))) (WHEN (= REQUEST MAPPING-KEYBOARD) (SETF (X-EVENT-MAPPING-NOTIFY.FIRST-KEYCODE EVENT)FIRST-KEY-CODE) (SETF (X-EVENT-MAPPING-NOTIFY.COUNT EVENT) COUNT)) ;; 0 is the server client. (LOOP FOR CLIENT IN (GLOBAL-STATE.STATES *GLOBALS*) WHEN (NULL (STATE.CLIENT-GONE CLIENT)) DO (WRITE-EVENTS-TO-CLIENT CLIENT 1 EVENT))) (EVENT-TRACE-LEAVING "SEND-MAPPING-NOTIFY")) ;;; N-sqared algorithm. n < 255 and don't want to copy the whole thing and ;;; sort it to do the checking. How often is it called? Just being lazy? (DEFUN BAD-DEVICE-MAP (BUFF BUFF-OFFSET LENGTH LOW HIGH) (DECLARE (TYPE (ARRAY INTEGER) BUFF) (TYPE INTEGER BUFF-OFFSET LENGTH HIGH LOW) (VALUES (OR NULL INTEGER))) (EVENT-TRACE-ENTERING "BAD-DEVICE-MAP") (LOOP NAMED OUTER FOR I FROM BUFF-OFFSET BELOW (+ BUFF-OFFSET LENGTH) FOR BUFF-ELEMENT = (AREF BUFF I) WHEN (NOT (ZEROP BUFF-ELEMENT)) ;; Only check non-zero elements. DO (PROGN (WHEN (OR (> LOW BUFF-ELEMENT) (< HIGH BUFF-ELEMENT)) (RETURN BUFF-ELEMENT)) (LOOP FOR J FROM (1+ I) BELOW (+ BUFF-OFFSET LENGTH) DO (WHEN (= BUFF-ELEMENT (AREF BUFF J)) (RETURN-FROM OUTER BUFF-ELEMENT)))) FINALLY (RETURN NIL))) (DEFUN ALL-MODIFIER-KEYS-ARE-UP (MAP COUNT) (DECLARE (TYPE (ARRAY INTEGER) MAP) (TYPE INTEGER COUNT) (VALUES BOOLEAN)) (DOTIMES (INDEX COUNT T) (WHEN (AND (NOT (ZEROP (AREF MAP INDEX))) (PLUSP (AREF (DEVICE.DOWN (INPUT-INFO.KEYBOARD INPUT-INFO)) (AREF MAP INDEX)))) (RETURN NIL)))) (DEFUN NOTE-LED-STATE (KEYBOARD LED ON) (DECLARE (TYPE DEVICE KEYBOARD) (TYPE INTEGER LED) (TYPE BOOLEAN ON)) (SETF (AREF (KEYBOARD-CONTROL.LEDS (DEVICE.KEYBOARD-CONTROL KEYBOARD)) LED) (IF ON 1 0))) (DEFUN ANCESTORS-MAPPED-P (WINDOW) (DECLARE (TYPE WINDOW WINDOW) (VALUES BOOLEAN)) (LOOP FOR PARENT FIRST (WINDOW.PARENT WINDOW) THEN (WINDOW.PARENT PARENT) WHILE PARENT WHEN (NOT (WINDOW.MAPPED-P PARENT)) DO (RETURN NIL) FINALLY (RETURN T))) (DEFUN DELETE-WINDOW-FROM-ANY-EVENTS (WINDOW FREE-RESOURCES) (DECLARE (TYPE WINDOW WINDOW) (TYPE BOOLEAN FREE-RESOURCES)) (EVENT-TRACE-ENTERING "DELETE-WINDOW-FROM-ANY-EVENTS") (LET ((KEYBOARD (INPUT-INFO.KEYBOARD INPUT-INFO)) (MOUSE (INPUT-INFO.POINTER INPUT-INFO))) ;; Deactivate any grabs performed on this window, before making any ;;input focus changes. (WHEN (AND (DEVICE.GRAB MOUSE) (EQ (GRAB-RECORD.WINDOW (DEVICE.GRAB MOUSE)) WINDOW)) (DEACTIVATE-POINTER-GRAB MOUSE)) ;; Deactivating a keyboard grab should cause focus events. (WHEN (AND (DEVICE.GRAB KEYBOARD) (EQ (GRAB-RECORD.WINDOW (DEVICE.GRAB KEYBOARD)) WINDOW)) (DEACTIVATE-KEYBOARD-GRAB KEYBOARD)) ;; If the focus window is a root window (ie. has no parent) then don't ;; delete the focus from it. (WHEN (AND (EQ WINDOW (DEVICE.FOCUS-WINDOW KEYBOARD)) (WINDOW.PARENT WINDOW)) (LET ((FOCUS-EVENT-MODE NOTIFY-NORMAL)) ;; If a grab is in progress, then alter the mode of focus events. (WHEN (DEVICE.GRAB KEYBOARD) (SETQ FOCUS-EVENT-MODE NOTIFY-WHILE-GRABBED) (SELECTOR (DEVICE.FOCUS-REVERT KEYBOARD) eql (REVERT-TO-NONE (DO-FOCUS-EVENTS WINDOW NIL FOCUS-EVENT-MODE) (SETF (DEVICE.FOCUS-WINDOW KEYBOARD) NIL) (SETQ FOCUS-TRACE-GOOD 0)) (REVERT-TO-PARENT (LOOP FOR PARENT FIRST (WINDOW.PARENT WINDOW) THEN (WINDOW.PARENT PARENT) WHILE (NOT (ANCESTORS-MAPPED-P PARENT)) DO (DECF FOCUS-TRACE-GOOD) FINALLY (PROGN (DO-FOCUS-EVENTS WINDOW PARENT FOCUS-EVENT-MODE) (SETF (DEVICE.FOCUS-WINDOW KEYBOARD) PARENT) (SETF (DEVICE.FOCUS-REVERT KEYBOARD) REVERT-TO-PARENT)))) (REVERT-TO-POINTER-ROOT (DO-FOCUS-EVENTS WINDOW POINTER-ROOT-WINDOW FOCUS-EVENT-MODE) (SETF (DEVICE.FOCUS-WINDOW KEYBOARD) POINTER-ROOT-WINDOW) (SETQ FOCUS-TRACE-GOOD 0)))))) (WHEN (EQ MOTION-HINT-WINDOW WINDOW) (SETQ MOTION-HINT-WINDOW NIL)) ;; I don't think that we need to do this freeing, but I have kept the C code ;; here just in case we need to. (WHEN FREE-RESOURCES ;; while (oc = OTHERCLIENTS(pWin)) ;; FreeResource(oc->resource, RC_NONE); ;; while (passive = PASSIVEGRABS(pWin)) ;; FreeResource(passive->resource, RC_NONE); ;; } )) (EVENT-TRACE-LEAVING "DELETE-WINDOW-FROM-ANY-EVENTS")) ;;; EXPLORER-KEYBOARD-PROCESS-EVENT ;;; ;;; Results: ;;; ;;; Side Effects: ;;; ;;; Caveat: ;;; To reduce duplication of code and logic (and therefore bugs), the ;;; sunwindows version of kbd processing (sunKbdProcessEventSunWin()) ;;; counterfeits a firm event and calls this routine. This ;;; couunterfeiting relies on the fact this this routine only looks at the ;;; id, time, and value fields of the firm event which it is passed. If ;;; this ever changes, the sunKbdProcessEventSunWin will also have to ;;; change. ;;; (DEFUN EXPLORER-KEYBOARD-PROCESS-EVENT (KEYBOARD DETAIL TIME X Y) (DECLARE (TYPE DEVICE KEYBOARD) (TYPE INTEGER DETAIL TIME X Y)) (EVENT-TRACE-ENTERING "EXPLORER-KEYBOARD-PROCESS-EVENT") (LET ((EVENT (MAKE-EVENT-KEY-BUTTON-POINTER)) (ALL-DONE NIL) (KEY 0) (KEY-MODIFIERS 0)) (DECLARE (TYPE EVENT-RECORD EVENT) (TYPE INTEGER KEY KEY-MODIFIERS)) (SETQ KEY (+ (LOGAND DETAIL #x7F) EXPLORER-SCAN-CODE-TRANSLATE)) (SETQ KEY-MODIFIERS (AREF KEY-MODIFIERS-LIST KEY)) ;; (EVENT-TRACE "~%EXPLORER-KEYBOARD-PROCESS-EVENT, key=~D., key-modifiers=x~16R, time=~d, ~ (~D,~D), type=~A" KEY KEY-MODIFIERS TIME X Y (IF (ZEROP (LOGAND #o200 DETAIL)) KEY-RELEASE-EVENT ;;ELSE KEY-PRESS-EVENT)) ;; Convert from device-specific time into milliseconds. (SETF (X-EVENT-KEY-BUTTON-POINTER.TIME EVENT) (TV-TO-MILLI TIME)) (SETF (X-EVENT-KEY-BUTTON-POINTER.ROOT-X EVENT) X) (SETF (X-EVENT-KEY-BUTTON-POINTER.ROOT-Y EVENT) Y) (SETF (X-EVENT-KEY-BUTTON-POINTER.TYPE EVENT) (IF (ZEROP (LOGAND #o200 DETAIL)) KEY-RELEASE-EVENT ;;ELSE KEY-PRESS-EVENT)) (SETF (X-EVENT-KEY-BUTTON-POINTER.DETAIL EVENT) KEY) (WHEN (NOT (ZEROP (LOGAND KEY-MODIFIERS CAPSLOCK-MASK))) (COND ((= (X-EVENT-KEY-BUTTON-POINTER.TYPE EVENT) KEY-RELEASE-EVENT) (SETQ ALL-DONE T)) ((PLUSP (AREF (DEVICE.DOWN KEYBOARD) KEY)) ;; Don't ask me why I'm just a computer. (SETF (X-EVENT-KEY-BUTTON-POINTER.TYPE EVENT) KEY-RELEASE-EVENT)))) (WHEN (NOT ALL-DONE) (PROCESS-KEYBOARD-EVENT EVENT KEYBOARD))) (EVENT-TRACE-LEAVING "EXPLORER-KEYBOARD-PROCESS-EVENT")) (DEFUN EVENT-MASK-FOR-CLIENT (WINDOW CLIENT) (DECLARE (TYPE WINDOW WINDOW) (TYPE STATE CLIENT) (VALUES INTEGER INTEGER)) (EVENT-TRACE-ENTERING "EVENT-MASK-FOR-CLIENT") (LET ((HER 0) ALL-MASK) (WHEN (EQ (WINDOW.CLIENT WINDOW) CLIENT) (SETQ HER (WINDOW-EVENT-MASKS WINDOW))) (SETQ ALL-MASK (WINDOW-EVENT-MASKS WINDOW)) (LOOP FOR OTHER IN (OTHER-CLIENTS WINDOW) DO (WHEN (EQ (OTHER-CLIENT.CLIENT OTHER) CLIENT) (SETQ HER (OTHER-CLIENT.MASK OTHER))) (SETQ ALL-MASK (LOGIOR ALL-MASK (OTHER-CLIENT.MASK OTHER)))) (EVENT-TRACE-LEAVING "EVENT-MASK-FOR-CLIENT") (VALUES HER ALL-MASK))) (defparameter event-output-functions (make-array last-event :initial-element 'ignore)) (defparameter event-input-functions (make-array last-event :initial-element 'ignore)) (defconstant *type-conversion-alist* '((:byte card8) (:word card16) (:long card32) (:drawable drawable) (:boolean bool) (:atom atom))) (defmacro defevent (name events &body output-forms) ;1; Generate event read/write functions.* ;1; output-forms is a plist of type and slot-accessor.* (when (stringp (first output-forms)) (pop output-forms)) (let ((write-function (intern (concatenate 'string "WRITE-EVENT-" (string name)))) (read-function (intern (concatenate 'string "READ-EVENT-" (string name))))) `(progn (defun ,write-function (client event-count event) (declare (ignore event-count)) (FORMAT-EVENT (CLIENT (EVENT-U.TYPE EVENT)) ,@(LOOP FOR (TYPE VALUE) ON OUTPUT-FORMS BY #'CDDR APPEND `(,TYPE (,VALUE EVENT))))) (define-event-read ,name ,@(LOOP FOR (TYPE VALUE) ON OUTPUT-FORMS BY #'CDDR for rtype = (second (assoc type *type-conversion-alist*)) unless rtype collect type into errors collect `(,VALUE ,rtype) into result finally (when errors (error "Unknown types: ~{~s ~}" errors)) (return result))) ,@(loop for event in events collect `(setf (aref event-output-functions ,event) (function ,write-function) (aref event-input-functions ,event) (function ,read-function))) ))) (defmacro define-event-read (name &body forms) (let ((read-function (intern (concatenate 'string "READ-EVENT-" (string name)))) (swap-function (intern (concatenate 'string "SWAP-EVENT-" (string name))))) (multiple-value-bind (length let-args fixups checks swaps) (parse-request-args forms 1 0 0) (declare (ignore checks)) (when (> length 32) (error "Event length ~s greater than 32" length)) `(progn (defun ,swap-function (state offset) (let ((bytes (state.bytes state))) (declare (sys:array-register bytes)) ,@(or swaps '(bytes offset)))) (defun ,read-function (state byte-offset) (when (state.swap-p state) (,swap-function state byte-offset)) (let ((event (,(intern (concatenate 'string "MAKE-EVENT-" (string name)))))) (let* ,let-args ,@fixups #+comment ;1; The X11 protocol spec says "event contents are unaltered and UNCHECKED by the server"* (cond ,@checks) (setf (event-U.type event) (ldb (byte 7 0) (aref bytes (+ byte-offset 0)))) (setf (event-U.sequence-id event) (state.sequence-id state)) ,@(loop for (var) in forms collect `(setf (,var event) ,var))) event)))))) (defevent key-button-pointer (key-press-event key-release-event button-press-event button-release-event motion-notify-event) ;1; *Generate the following events: ;1; *KEY-PRESS-EVENT KEY-RELEASE-EVENT BUTTON-PRESS-EVENT BUTTON-RELEASE-EVENT MOTION-NOTIFY-EVENT :byte x-event-key-button-pointer.detail :long x-event-key-button-pointer.time :drawable x-event-key-button-pointer.root :drawable x-event-key-button-pointer.event :drawable x-event-key-button-pointer.child :word x-event-key-button-pointer.root-x :word x-event-key-button-pointer.root-y :word x-event-key-button-pointer.event-x :word x-event-key-button-pointer.event-y :word x-event-key-button-pointer.state :boolean x-event-key-button-pointer.same-screen) (defevent enter-leave (enter-notify-event leave-notify-event) "Generate the following events: ENTER-NOTIFY-EVENT LEAVE-NOTIFY-EVENT" :byte x-event-enter-leave.detail :long x-event-enter-leave.time :drawable x-event-enter-leave.root :drawable x-event-enter-leave.event :drawable x-event-enter-leave.child :word x-event-enter-leave.root-x :word x-event-enter-leave.root-y :word x-event-enter-leave.event-x :word x-event-enter-leave.event-y :word x-event-enter-leave.state :byte x-event-enter-leave.mode :byte x-event-enter-leave.flags) (defevent focus (focus-in-event focus-out-event) "Generate the following events: FOCUS-IN-EVENT FOCUS-OUT-EVENT" :byte x-event-focus.detail :drawable x-event-focus.window :byte x-event-focus.mode) ;;; Note: this event is much different from all other events in that there is only ;;; room in the 32 byte event data for the code and the keycodes. The special ;;; macros written for the other events can't be used here because it also puts in ;;; the sequence-ID, which won't fit in this event. (zwei:define-indentation bits-to-byte (1 1)) (defun write-event-keymap-event (state event-count event) "Generate the following event: KEYMAP-NOTIFY-EVENT" (declare (type state state) (type integer event-count) (type event-keymap-event event) (ignore event-count)) (macrolet ((bits-to-byte (name index) "Combine 8 bits into one byte." `(logior (ash (aref ,name (+ (* ,index 8) 0)) 0) (ash (aref ,name (+ (* ,index 8) 1)) 1) (ash (aref ,name (+ (* ,index 8) 2)) 2) (ash (aref ,name (+ (* ,index 8) 3)) 3) (ash (aref ,name (+ (* ,index 8) 4)) 4) (ash (aref ,name (+ (* ,index 8) 5)) 5) (ash (aref ,name (+ (* ,index 8) 6)) 6) (ash (aref ,name (+ (* ,index 8) 7)) 7)))) (let ((map (x-event-keymap-event.map event))) (server-string-out state (response.bytes (state.response state)) (simple-reply (state) :byte (x-event-keymap-event.type event) :byte (bits-to-byte map 1) :byte (bits-to-byte map 2) :byte (bits-to-byte map 3) :byte (bits-to-byte map 4) :byte (bits-to-byte map 5) :byte (bits-to-byte map 6) :byte (bits-to-byte map 7) :byte (bits-to-byte map 8) :byte (bits-to-byte map 9) :byte (bits-to-byte map 10) :byte (bits-to-byte map 11) :byte (bits-to-byte map 12) :byte (bits-to-byte map 13) :byte (bits-to-byte map 14) :byte (bits-to-byte map 15) :byte (bits-to-byte map 16) :byte (bits-to-byte map 17) :byte (bits-to-byte map 18) :byte (bits-to-byte map 19) :byte (bits-to-byte map 20) :byte (bits-to-byte map 21) :byte (bits-to-byte map 22) :byte (bits-to-byte map 23) :byte (bits-to-byte map 24) :byte (bits-to-byte map 25) :byte (bits-to-byte map 26) :byte (bits-to-byte map 27) :byte (bits-to-byte map 28) :byte (bits-to-byte map 29) :byte (bits-to-byte map 30) :byte (bits-to-byte map 31)))))) (setf (aref event-output-functions keymap-notify-event) #'write-event-keymap-event) (defevent expose (expose-event) "Generate the following event: EXPOSE-EVENT" :byte x-event-expose.detail :drawable x-event-expose.window :word x-event-expose.x :word x-event-expose.y :word x-event-expose.width :word x-event-expose.height :word x-event-expose.count) (defevent graphics-exposure (graphics-expose-event) "Generate the following event: GRAPHICS-EXPOSE-EVENT" :byte x-event-graphics-exposure.detail :drawable x-event-graphics-exposure.drawable :word x-event-graphics-exposure.x :word x-event-graphics-exposure.y :word x-event-graphics-exposure.width :word x-event-graphics-exposure.height :word x-event-graphics-exposure.minor-event :word x-event-graphics-exposure.count :byte x-event-graphics-exposure.major-event) (defevent no-exposure (no-expose-event) "Generate the following event: NO-EXPOSE-EVENT" :byte x-event-no-exposure.detail :drawable x-event-no-exposure.drawable :word x-event-no-exposure.minor-event :byte x-event-no-exposure.major-event) (defevent visibility (visibility-notify-event) "Generate the following event: VISIBILITY-NOTIFY-EVENT" :byte x-event-visibility.detail :drawable x-event-visibility.window :byte x-event-visibility.state) (defevent create-notify (create-notify-event) "Generate the following event: CREATE-NOTIFY-EVENT" :byte x-event-create-notify.detail :drawable x-event-create-notify.parent :drawable x-event-create-notify.window :word x-event-create-notify.x :word x-event-create-notify.y :word x-event-create-notify.width :word x-event-create-notify.height :word x-event-create-notify.border-width :boolean x-event-create-notify.override) (defevent destroy-notify (destroy-notify-event) "Generate the following event: DESTROY-NOTIFY-EVENT" :byte x-event-destroy-notify.detail :drawable x-event-destroy-notify.event :drawable x-event-destroy-notify.window) (defevent unmap-notify (unmap-notify-event) "Generate the following event: UNMAP-NOTIFY-EVENT" :byte x-event-unmap-notify.detail :drawable x-event-unmap-notify.event :drawable x-event-unmap-notify.window :boolean x-event-unmap-notify.from-configure) (defevent map-notify (map-notify-event) "Generate the following event: MAP-NOTIFY-EVENT" :byte x-event-map-notify.detail :drawable x-event-map-notify.event :drawable x-event-map-notify.window :boolean x-event-map-notify.override) (defevent map-request (map-request-event) "Generate the following event: MAP-REQUEST-EVENT" :byte x-event-map-request.detail :drawable x-event-map-request.parent :drawable x-event-map-request.window) (defevent reparent (reparent-notify-event) "Generate the following event: REPARENT-NOTIFY-EVENT" :byte x-event-reparent.detail :drawable x-event-reparent.event :drawable x-event-reparent.window :drawable x-event-reparent.parent :word x-event-reparent.x :word x-event-reparent.y :boolean x-event-reparent.override) (defevent configure-notify (configure-notify-event) "Generate the following event: CONFIGURE-NOTIFY-EVENT" :byte x-event-configure-notify.detail :drawable x-event-configure-notify.event :drawable x-event-configure-notify.window :drawable x-event-configure-notify.above-sibling :word x-event-configure-notify.x :word x-event-configure-notify.y :word x-event-configure-notify.width :word x-event-configure-notify.height :word x-event-configure-notify.border-width :boolean x-event-configure-notify.override) (defevent configure-request (configure-request-event) "Generate the following event: CONFIGURE-REQUEST-EVENT" :byte x-event-configure-request.detail ; (STACK-MODE) :drawable x-event-configure-request.parent :drawable x-event-configure-request.window :drawable x-event-configure-request.sibling :word x-event-configure-request.x :word x-event-configure-request.y :word x-event-configure-request.width :word x-event-configure-request.height :word x-event-configure-request.border-width :word x-event-configure-request.value-mask) (defevent gravity (gravity-notify-event) "Generate the following event: GRAVITY-NOTIFY-EVENT" :byte x-event-gravity.detail :drawable x-event-gravity.event :drawable x-event-gravity.window :word x-event-gravity.x :word x-event-gravity.y) (defevent resize-request (resize-request-event) "Generate the following event: RESIZE-REQUEST-EVENT" :byte x-event-resize-request.detail :drawable x-event-resize-request.window :word x-event-resize-request.width :word x-event-resize-request.height) (defevent circulate (circulate-notify-event circulate-request-event) "Generate the following events: CIRCULATE-NOTIFY-EVENT CIRCULATE-REQUEST-EVENT" :byte x-event-circulate.detail :drawable x-event-circulate.event :drawable x-event-circulate.window :drawable x-event-circulate.parent :byte x-event-circulate.place) (defevent property (property-notify-event) "Generate the following event: PROPERTY-NOTIFY-EVENT" :byte x-event-property.detail :drawable x-event-property.window :atom x-event-property.atom :long x-event-property.time :byte x-event-property.state) (defevent selection-clear (selection-clear-event) "Generate the following event: SELECTION-CLEAR-EVENT" :byte x-event-selection-clear.detail :long x-event-selection-clear.time :drawable x-event-selection-clear.window ; OWNER :atom x-event-selection-clear.atom) (defevent selection-request (selection-request-event) "Generate the following event: SELECTION-REQUEST-EVENT" :byte x-event-selection-request.detail :long x-event-selection-request.time :drawable x-event-selection-request.owner :drawable x-event-selection-request.requestor :atom x-event-selection-request.selection :atom x-event-selection-request.target :atom x-event-selection-request.property) (defevent selection-notify (selection-notify-event) "Generate the following event: SELECTION-NOTIFY-EVENT" :byte x-event-selection-notify.detail :long x-event-selection-notify.time :drawable x-event-selection-notify.requestor :atom x-event-selection-notify.selection :atom x-event-selection-notify.target :atom x-event-selection-notify.property) (defevent colormap (colormap-notify-event) "Generate the following event: COLORMAP-NOTIFY-EVENT" :byte x-event-colormap.detail :drawable x-event-colormap.window :long x-event-colormap.colormap :boolean x-event-colormap.new :byte x-event-colormap.state) (defevent mapping-notify (mapping-notify-event) "Generate the following event: MAPPING-NOTIFY-EVENT" :byte x-event-mapping-notify.detail :byte x-event-mapping-notify.request :byte x-event-mapping-notify.first-keycode :byte x-event-mapping-notify.count) (defun write-event-client-message (state event-count event) "Generate the following event: CLIENT-MESSAGE-EVENT" (declare (type state state) (type integer event-count) (type event-client-message event) (ignore event-count)) (let ((index (simple-reply (state) :byte (event-u.type event) :byte (x-event-client-message.format event) :word (state.sequence-id state) :long (or (x-event-client-message.window event) 0) :long (x-event-client-message.data-type event)))) (loop with data-format = (x-event-client-message.format event) for datum being the array-elements of (x-event-client-message.data event) do (case data-format (16 (setq index (simple-reply (state index) :word datum))) (32 (setq index (simple-reply (state index) :long datum))) (otherwise (setq index (simple-reply (state index) :byte datum))))) (let ((buf (alloc-event))) (copy-bytes Response-Length (response.bytes (state.response state)) 0 (response.bytes buf) 0) (state-enq-event state buf)))) (DEFUN swap-event-client-message (state offset format) (macrolet ((swap-words (start length) (loop for i from start below (+ start length) by 2 append (swap-buf-word i) into result finally (return `(progn ,@result)))) (swap-longs (start length) (loop for i from start below (+ start length) by 4 append (swap-buf-long i) into result finally (return `(progn ,@result))))) (LET ((bytes (state.bytes state))) (DECLARE (SYS:ARRAY-REGISTER BYTES)) (case format (16 (swap-words 12 20)) (32 (swap-longs 12 20)))))) (DEFUN read-event-client-message (state byte-offset) (LET ((event (make-event-client-message ))) (LET* ((bytes (state.bytes state)) (words (state.words state)) (LONGS (STATE.LONGS STATE)) (word-offset (TRUNCATE byte-offset 2)) (LONG-OFFSET (TRUNCATE BYTE-OFFSET 4)) (format (AREF bytes (+ byte-offset 1))) (window (AREF longs (+ long-offset 1))) (data-type (AREF longs (+ long-offset 2))) (data (macrolet ((array-copy (length element-type from start) `(let ((result (make-array ,length :element-type ',element-type))) (copy-array-portion ,from ,start (+ ,start ,length) result 0 ,length) result))) (WHEN (state.swap-p state) (swap-event-client-message state byte-offset format)) (CASE format (16 (array-copy 10 'card16 words word-offset)) (32 (array-copy 5 'card32 longs long-offset)) (otherwise (array-copy 20 'card8 bytes byte-offset)))))) (SETF (event-u.type event) (LDB (BYTE 7 0) (AREF BYTES (+ BYTE-OFFSET 0)))) (SETF (EVENT-U.SEQUENCE-ID EVENT) (STATE.SEQUENCE-ID STATE)) (SETF (x-event-client-message.window event) window) (SETF (x-event-client-message.data-type event) data-type) (SETF (x-event-client-message.format event) format) (SETF (x-event-client-message.data event) data)) event)) (setf (aref event-output-functions client-message-event) 'write-event-client-message) (setf (aref event-input-functions client-message-event) 'read-event-client-message) (defun read-event-from-client (state byte-offset) (let* ((bytes (state.bytes state)) (event-number (ldb (byte 7 0) (aref bytes byte-offset))) handler) (if (and (< event-number last-event) (setq handler (aref event-input-functions event-number))) (funcall handler state byte-offset) (bad-value event-number)))) (defun write-events-to-client (client count events) (declare (type state client) (type integer count) (type (or list event-record) events)) (write-to-client client count events)) (ZWEI:DEFINE-INDENTATION WRITE-AN-EVENT (1 1)) (DEFUN WRITE-TO-CLIENT (CLIENT EVENT-COUNT EVENTS) (DECLARE (TYPE STATE CLIENT) (TYPE INTEGER EVENT-COUNT) (TYPE (OR LIST EVENT-RECORD) EVENTS)) (EVENT-TRACE-ENTERING "WRITE-TO-CLIENT") (FLET ((WRITE-AN-EVENT (EVENT) (let* ((code (ldb (byte 7 0) (EVENT-RECORD.TYPE EVENT))) (handler (AREF EVENT-OUTPUT-FUNCTIONS code))) (EVENT-TRACE-ENTERING handler) (server-trace "~%Event ~a queued to client ~s" (if (< (event-record.type event) (length event-vector)) (aref event-vector (event-record.type event)) "UNKNOWN") client) (FUNCALL handler CLIENT EVENT-COUNT EVENT) (EVENT-TRACE-LEAVING handler)))) (IF (LISTP EVENTS) (DOLIST (EVENT EVENTS) (WRITE-AN-EVENT EVENT)) ;;ELSE (WRITE-AN-EVENT EVENTS))) (EVENT-TRACE-LEAVING "WRITE-TO-CLIENT")) ;1;; *Convert client times to server TimeStamps (DEFUN CLIENT-TIME-TO-SERVER-TIME (TIME) "2Converts the client time in milliseconds to the server time in time-stamp form. If passed the constant USE-C1U*RRENT-SERVER-TIME it takes the current time from the server.*" (LET ((halfmonth (EXPT 2 31)) (ts (make-time-stamp)) (current-months (time-stamp.months current-time)) (current-milliseconds (time-stamp.milliseconds current-time))) (COND ((= time Use-Current-Server-Time) ;1;if time = 0, it means just use the current X server time* current-time) (t1 *;1;ELSE use the client's time but make sure it's aligned with the server* (SETF (time-stamp.months ts) current-months) (SETF (time-stamp.milliseconds ts) time) (COND ((> time current-milliseconds) (IF (> (- time current-milliseconds) halfmonth) (DECF (time-stamp.months ts)))) ((< time current-milliseconds) (IF (> (- current-milliseconds time) halfmonth) (INCF (time-stamp.months ts))))) ts))))