;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-

;;; Reason: Fixed 'out of application memory' errors that could
;;; happen when leaving tbserver windows.

;;;                           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 149149, M/S 2151             
;;;   AUSTIN, TEXAS 78714-9149                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 11/21/89 13:10:00 by Battenhouse,
;;; while running on MX61 from band d929
;;; With SYSTEM 6.14, GC 6.3, VIRTUAL-MEMORY 6.1, MICRONET 6.0, MICRONET-COMM 6.1,
;;;  DISK-IO 6.1, DISK-LABEL 6.0, BASIC-PATHNAME 6.1, MAC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0,
;;;  BASIC-NAMESPACE 6.2, BASIC-FILE 6.2, RPC 6.2, NFS-MX 6.1, EH 6.4, MAKE-SYSTEM 6.0,
;;;  MEMORY-AUX 6.0, COMPILER 6.10, TV 6.15, NVRAM 6.1, UCL 6.0, INPUT-EDITOR 6.0,
;;;  Inconsistent MACTOOLBOX 2.10, METER 6.1, ZWEI 6.5, DEBUG-TOOLS 6.3, WINDOW-MX 6.7,
;;;  PRINTER 6.3, MAC-PRINTER-TYPES 6.1, CLIPBOARD 6.1, TI-CLOS 6.20, CLEH 6.5, NETWORK-PATHNAME 6.0,
;;;  NETWORK-NAMESPACE 6.0, DATALINK 6.0, CHAOSNET 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1,
;;;  DATALINK-DISPLAYS 6.0, MX-DATALINK 6.1, NAMESPACE-EDITOR 6.0, IP 3.47, NFS-MX-SERVER 6.0,
;;;  MX-SERIAL 6.1, PRINTER-TYPES 6.1, IMAGEN 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.2,
;;;  TELNET 6.0, VT100 6.0, STREAMER-TAPE 6.4, DECNET 1.69, VISIDOC 6.2, PROFILE 6.1,
;;;  Experimental CLX 6.2, CLUE 6.10, Experimental BUG 11.14,  microcode 138, Band Name: microExplorer Network + SLE (8/17)

;;;  code-read sbw 11/21/89.
;;;  Fixed sprs 10723 and 10724, problem in which update events 
;;;  were being recorded for previously disposed windows.

#!C
; From file DQ-EVENT.LISP HD:MX:PATCH: MX61:
#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: MX.PATCH; DQ-EVENT.#"

(DEFVAR *updates-for-disposed-windows* 0)

(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))
      
      ;; may 09/29/89 Corrected paren mismatch with :key lambda and simplified
      ;; by changing the FIND into the DOLIST below. Logand of 0 is still true!
      ;;(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))
      (DOLIST (EVENT EVENT-LIST)
	(UNLESS (ZEROP (LOGAND MASK EVENT-MASK (ASH 1 (SEND EVENT :WHAT))))
	  (RETURN (SETF EVT EVENT)))))
      
      
    (when evt					;; changed by *ab*
      (COND ((AND (EQ (SEND evt :what) !updateEvt)
		  (NULL (ASSOC (SEND evt :message) *mac-window-list*)))
	     ;; An update event that is NOT for a known window (one on *MAC-WINDOW-LIST*)
	     ;; This can occur because of ASYNC events, so catch it here.
	     ;; This evt has already been dequeued, so look again for a candidate event...
	     (without-interrupts (setf event-list (delete evt event-list :test #'eq :count 1)))
	     (deallocate-event evt)
	     (INCF *updates-for-disposed-windows*)
	     (RETURN-FROM dequeue-event
	       (SEND self :dequeue-event event-mask user-event leave-in-queue mouse-moved-region)))
	    (t
	     (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))
	     
	     (when (not leave-in-queue)	
	       (without-interrupts (setf event-list (delete evt event-list :test #'eq :count 1)))
	       (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)))
))