;;; -*- Mode:Common-Lisp; Package:MACTOOLBOX; Base:10; Patch-file:T -*- ;;; Reason: Add the handler for synchronizing suspend events to the async-command-handler. ;;; 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, M/S 2151 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Written 06/22/89 14:50:05 by jones, ;;; while running on HOBBS from band lod2 ;;; With SYSTEM 6.7, GC 6.3, VIRTUAL-MEMORY 6.1, MICRONET 6.0, MICRONET-COMM 6.1, ;;; DISK-IO 6.0, DISK-LABEL 6.0, BASIC-PATHNAME 6.0, MAC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, ;;; BASIC-NAMESPACE 6.1, BASIC-FILE 6.2, RPC 6.1, NFS 6.0, EH 6.3, MAKE-SYSTEM 6.0, ;;; MEMORY-AUX 6.0, COMPILER 6.4, TV 6.10, NVRAM 6.0, UCL 6.0, INPUT-EDITOR 6.0, ;;; MACTOOLBOX 2.3, METER 6.0, ZWEI 6.3, Experimental DEBUG-TOOLS 6.2, WINDOW-MX 6.3, ;;; PRINTER 6.1, MAC-PRINTER-TYPES 6.1, CLIPBOARD 6.0, NETWORK-PATHNAME 6.0, NETWORK-NAMESPACE 6.0, ;;; DATALINK 6.0, CHAOSNET 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, ;;; MX-DATALINK 6.1, NAMESPACE-EDITOR 6.0, IP 3.46, NFS-SERVER 6.0, MX-SERIAL 6.0, ;;; PRINTER-TYPES 6.0, IMAGEN 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, TELNET 6.0, ;;; VT100 6.0, STREAMER-TAPE 6.2, DECNET 1.69, VISIDOC 6.2, PROFILE 6.1, TI-CLOS 6.8, ;;; CLEH 6.4, CLX 6.0, CLUE 6.0, Experimental BUG 11.10, microcode 137, Band Name: p526*2 #!C ; From file MAC-APPLICATIONS.LISP#> JONES; HEYERDAHL: #10R MACTOOLBOX#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "MACTOOLBOX")) (SI:*LISP-MODE* :Common-lisp) (*READTABLE* Sys:Common-lisp-readtable) (SI:*READER-SYMBOL-SUBSTITUTIONS* Sys::*common-lisp-symbol-substitutions*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: toolbox-interface; MAC-APPLICATIONS.#" (defflavor mac-application-internal ((name) (server-name) (directory) (lisp-function) (lisp-function-args) (process) (process-options `(:name ,(string (type-of self)))) (event-list) (last-event-arrival-time 0) (last-event-current-port 0) (last-mouse-h 0) (last-mouse-v 0) (last-mouse-moved-time 0) (last-mouse-moved-event-time 0) (last-when 0) (last-modifiers 0) (async-events *async-events*) ; If non nil then events are being transmitted from the toolbox server. (last-event-return-time 0) (last-time-time-given-up 0) (last-time-i-saw-suspend 0)) (si:property-list-mixin) (:init-keywords :no-launch-server) :gettable-instance-variables :settable-instance-variables :inittable-instance-variables :outside-accessible-instance-variables (:accessor-prefix "MAC-APPLICATION-") ) (defun increase-suspend-event-limit-time (delta) (let ((cmd (add:get-acb-fast 4))) (setf (add:requestor-complete cmd) t) (setf (add:parm-32b cmd 0) delta) (setf (add:opcode cmd) 4) (tb-transmit-packet cmd))) (defmethod (mac-application-internal :handle-event) (acb) (block handle-event (case (add:opcode acb) (0 (when (or (not (= last-mouse-h (parm-16b acb 7))) (not (= last-mouse-v (parm-16b acb 6)))) (setf last-mouse-h (parm-16b acb 7)) (setf last-mouse-v (parm-16b acb 6)) (setf last-mouse-moved-time (time))) (setf last-event-arrival-time (time)) (setf last-when (parm-32b acb 2)) (setf last-modifiers (parm-16b acb 8)) (setf last-event-current-port (parm-32b acb 5)) ;; Don't queue mouse moved or null events. (when (or (zerop (parm-16b acb 0)) (and (eql (parm-16b acb 0) !App4Evt) (= (ldb (byte 8 24) (parm-32b acb 1)) *mouse-moved-event-opcode*))) (return-from handle-event)) (push-end (allocate-event (parm-16b acb 0) (parm-32b acb 1) (parm-32b acb 2) (parm-16b acb 8) (parm-16b acb 6) (parm-16b acb 7) ) event-list)) (1 ;; Follow a suspend event to make sure that it is retrieved. (let ((limit-time (+ (time) 650)) (event (allocate-event))) (increase-suspend-event-limit-time 600) (setf last-time-i-saw-suspend (time)) ;; Make sure that the application has pulled the suspend event. (when (and (!EventAvail !App4Evt event) (= (ldb (byte 8 24) (send event :message)) 1)) (process-wait "Suspend Event Wait" #'(lambda (event app limit-time) (let ((*mac-application* app) (*application-channel* (send app :*application-channel*))) (cond ((time-lessp limit-time (time)) t) ((and (!EventAvail !App4Evt event) (= (ldb (byte 8 24) (send event :message)) 1)) (setf (send app :last-time-i-saw-suspend) (time)) nil) (t t)))) event self limit-time)) ;; Wait until the application has called one of the traps that give up time before ;; releasing the mac. (unless (time-lessp (send *mac-application* :last-time-i-saw-suspend) (send *mac-application* :last-time-time-given-up)) (process-wait "Suspend Event Wait" #'(lambda (app limit-time) (or (time-lessp (send app :last-time-i-saw-suspend) (send app :last-time-time-given-up)) (time-lessp limit-time (time)))) *mac-application* limit-time)) ) )))) (defmethod (mac-application-internal :dequeue-event) (event-mask user-event &optional leave-in-queue mouse-moved-region &aux evt) "Return an event from applications event queue for event-mask." (block dequeue-event ;; Return mouse moved events only if a region was specified and we have seen the mouse move. (when (and mouse-moved-region (not (zerop (send mouse-moved-region :handle))) (not (= last-mouse-moved-time last-mouse-moved-event-time))) (without-interrupts (send *temp-point* := last-mouse-v last-mouse-h) (when (not (!PtInRgn *temp-point* mouse-moved-region)) (setf last-mouse-moved-event-time last-mouse-moved-time) (setf (send user-event :what) !app4Evt) (setf (send user-event :message) (dpb *mouse-moved-event-opcode* (byte 8 24) 0)) (setf (send user-event :when) last-mouse-moved-time) (setf (send user-event :h) last-mouse-h) (setf (send user-event :v) last-mouse-v) (setf (send user-event :modifiers) last-modifiers) (return-from dequeue-event t)))) (dolist (mask `(,(logior !app4Mask !activMask) ,(logior !mDownMask !mUpMask !keyDownMask !keyUpMask !diskMask !networkMask !driverMask !app1Mask !app2Mask !app3Mask) ,!autoKeyMask ,!updateMask)) (when (setf evt (find (logand mask event-mask) event-list :test #'(lambda (a b) (logand a (ash 1 b)) :key #'(lambda (el) (send el :what)))))) (return)) (when evt (when (not leave-in-queue) (without-interrupts (setf event-list (delete evt event-list :test #'eq :count 1)))) (setf (send user-event :what) (send evt :what)) (setf (send user-event :message) (send evt :message)) (setf (send user-event :when) (send evt :when)) (setf (send user-event :modifiers) (send evt :modifiers)) (setf (send user-event :h) (send evt :h)) (setf (send user-event :v) (send evt :v)) (deallocate-event evt) (return-from dequeue-event t)) ;; No events available. return a null event. (setf (send user-event :what) 0) (setf (send user-event :message) 0) ;; A crude way to generate :when for null events. (setf (send user-event :when) (+ (time-difference (time) last-event-arrival-time) last-when)) (setf (send user-event :h) last-mouse-h) (setf (send user-event :v) last-mouse-v) (setf (send user-event :modifiers) last-modifiers) (return-from dequeue-event nil))) (defun !WaitNextEvent (eventmask AnEventRecordInstance sleep region) (setf (send *mac-application* :last-time-time-given-up) (time)) (cond ((mac-application-async-events *mac-application*) (let (evt-p timeout-interval (exit-time (time-increment (time) (or sleep 0)))) (loop (setf evt-p (send *mac-application* :dequeue-event eventMask AnEventRecordInstance nil region)) (cond ((zerop (send AnEventRecordInstance :what)) (cond ;; If we have received an event since the last time we returned an event return a null ;; event to show the mouse and modifiers. ((time-lessp (mac-application-last-event-return-time *mac-application*) (mac-application-last-mouse-moved-time *mac-application*)) (setf (mac-application-last-event-return-time *mac-application*) (time)) (return-from !WaitNextEvent nil)) ((setf timeout-interval (if (time-lessp (time) exit-time) (time-difference exit-time (time)))) (process-wait-with-timeout "!WaitNextEvent" timeout-interval #'(lambda (time application) (or (not (send application :async-events)) (not (= time (send application :last-event-arrival-time))))) (mac-application-last-event-arrival-time *mac-application*) *mac-application*)) (t (setf (mac-application-last-event-return-time *mac-application*) (time)) (return-from !WaitNextEvent nil))) ) (t (setf (mac-application-last-event-return-time *mac-application*) (time)) (return-from !WaitNextEvent evt-p)))))) (t (!WaitNextEventInternal eventmask AnEventRecordInstance sleep region)))) (defun !GetNextEvent (eventmask AnEventRecordInstance) (setf (send *mac-application* :last-time-time-given-up) (time)) (cond ((mac-application-async-events *mac-application*) (setf (mac-application-last-event-return-time *mac-application*) (time)) (send *mac-application* :dequeue-event eventMask AnEventRecordInstance)) (t ;; Call WaitNextEvent here since GetNextEvent cannot be patched easily on the mac side. (!WaitNextEventInternal eventmask AnEventRecordInstance 0 nilRgn))) ) (defun !EventAvail (eventmask AnEventRecordInstance) (setf (send *mac-application* :last-time-time-given-up) (time)) (cond ((mac-application-async-events *mac-application*) (send *mac-application* :dequeue-event eventMask AnEventRecordInstance t)) (t (!EventAvailInternal eventmask AnEventRecordInstance))) ) (compile-flavor-methods mac-application default-tb-server rpc-application) ))