;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-
;;; Patch file for MACTOOLBOX version 2.16
;;; Reason: Changes to support new tbserver (rel 6.0+) to allow async-events
;;; to take on 0,1,2 values that previously were nil(0) and t(1).
;;; Reason: New mode changes where async-events can take on 0,1,2 values
;;; instead of just nil(0) or t(1) values. Supports new (6.0+/7.0) action tbserver.
;;; Written 03/08/90 15:36:10 by ab,
;;; while running on RAMP-4 from band N214
;;; With SYSTEM 6.30, GC 6.3, VIRTUAL-MEMORY 6.3, MICRONET 6.0, MICRONET-COMM 6.2,
;;;  DISK-IO 6.2, DISK-LABEL 6.0, BASIC-PATHNAME 6.3, MAC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.2,
;;;  BASIC-NAMESPACE 6.7, BASIC-FILE 6.7, RPC 6.2, NFS-MX 6.4, EH 6.6, MAKE-SYSTEM 6.2,
;;;  MEMORY-AUX 6.0, COMPILER 6.14, TV 6.23, NVRAM 6.2, UCL 6.0, INPUT-EDITOR 6.0,
;;;  MACTOOLBOX 2.13, METER 6.1, ZWEI 6.12, DEBUG-TOOLS 6.4, WINDOW-MX 6.10, PRINTER 6.3,
;;;  MAC-PRINTER-TYPES 6.1, CLIPBOARD 6.1, TI-CLOS 6.37, CLEH 6.5, NETWORK-PATHNAME 6.1,
;;;  NETWORK-NAMESPACE 6.1, DATALINK 6.0, CHAOSNET 6.5, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.2,
;;;  DATALINK-DISPLAYS 6.0, MX-DATALINK 6.1, NAMESPACE-EDITOR 6.4, IP 3.57, NFS-MX-SERVER 6.0,
;;;  MX-SERIAL 6.1, PRINTER-TYPES 6.2, IMAGEN 6.1, MAIL-DAEMON 6.5, MAIL-READER 6.7,
;;;  TELNET 6.1, VT100 6.0, STREAMER-TAPE 6.5, DECNET 1.71, VISIDOC 6.7, PROFILE 6.2,
;;;  Experimental CONFLICT-RESOLUTION 37.0, Experimental SNRL 4.0, Experimental SNRL-ADD-ONS 1.0,
;;;  Experimental SST-WINDOWS 1.0, Experimental QUERY 1.0,  microcode 138, Band Name: Rel6+patches+SNRL (2/14/90)

#!C
; From file MAC-APPLICATIONS.LISP#> TOOLBOX-INTERFACE; Hotel:
#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.#"


(DEFVAR *event-discard-flag* nil)		       ;; *ab* 2/23, 3/8/90.  For new-mode


;;;added MacStateAcb to origional definition
(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)
	    (MacStateAcb)
	    (ProcessApp4))			       ;; *ab* 3/8/90, for new-mode
	   (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-")
  )


(defmethod (mac-application :flush-events) (eventMask stopMask)
  (without-interrupts
    (let ((events-to-be-deleted))
      
      ;; Flush pending events on the mac side.
      (!FlushEventsInternal eventMask stopMask)

      (when (= 1 async-events)			       ;; *ab* 3/8/90  for new-mode
	;; Give any events in transit time to be delivered.
	(process-sleep 60 "Event Wait")	     
	
	(dolist (evt event-list)
	  (when (not (zerop (logand (ash 1 (send evt :what)) stopMask)))
	    (return))
	  
	  (when (not (zerop (logand (ash 1 (send evt :what)) eventMask)))
	    (pushnew evt events-to-be-deleted)))
	
	(dolist (evt events-to-be-deleted)
	  (setf event-list (delete evt event-list :test #'eq :count 1))))
      )))

;;;11/28/89 sbw
(defmethod (mac-application-internal :flush-events) (eventMask stopMask)
  (without-interrupts
    (let ((events-to-be-deleted))
      
      ;; Flush pending events on the mac side.
      (!FlushEventsInternal eventMask stopMask)

      (when (= 1 async-events)			       ;; *ab* 3/8/90  for new-mode
	;; Give any events in transit time to be delivered.
	(process-sleep 60 "Event Wait")	     
	
	(dolist (evt event-list)
	  (when (not (zerop (logand (ash 1 (send evt :what)) stopMask)))
	    (return))
	  
	  (when (not (zerop (logand (ash 1 (send evt :what)) eventMask)))
	    (pushnew evt events-to-be-deleted)))
	
	(dolist (evt events-to-be-deleted)
	  (setf event-list (delete evt event-list :test #'eq :count 1))))
      )))

(defmethod (mac-application-internal :flush-update-events) (window)
  (when (= 1 async-events)			       ;; *ab* 3/8/90  for new-mode
    (without-interrupts
      ;; WAit until all pending events are in the queue.
      (process-wait "Event Wait" #'(lambda (ch)
				     (zerop (add:q-length (send ch :host-queue))))
		    (find-channel *application-channel*))
      ;; Now flush all update events for window.
      (dolist (event event-list)
	(when (and (= (send event :what) !UpdateEvt)
		   (= (send event :message) (send window :pointer)))
	  (setf event-list (delete event event-list :test #'eq :count 1))
	  (deallocate-event event))))))

;; *ab* 3/8/90.  For new-mode.
(defmethod (mac-application-internal :set-async-event-mode) (&optional (mode async-events))
  "Add or delete channel to the async-event handler's list of channels to service."
  (case mode
    ((0 2) nil)
    (nil (setq mode 0)) ;; nil & t are old ways of specifying 0 & 1
    (t (setq mode 1)))  ;; should force to 2 in REL 7 ???
  (cond ((= mode 2)
	 (let ((acb (add:get-acb 256)))
	   (delete-async-event-channel *application-channel*)
	   (setf (add:opcode acb) *set-async-event-mode-opcode*)
	   (setf (add:requestor-complete acb) t)
	   (setf (add:deallocatable acb) nil)
	   (setf MacStateAcb acb)
	   (set-event-discard-flag nil)
	   (setf (add:parm-8b acb 0) 2) ;; mode
	   (tb:tb-transmit-packet acb)
	   (setf async-events 2)))
	(t
	 (cond ((not (zerop (send (!GetResource "evts" 0) :handle))) ;; rel6 tbserver or later
		(let ((acb (add:get-acb-fast 12)))
		  (setf (add:opcode acb) *set-async-event-mode-opcode*)
		  (setf (add:requestor-complete acb) t)
		  (cond ((= mode 1)
			 (setf MacStateAcb acb)
			 (setf (add:parm-8b acb 0) 1) ;; mode 
			 (add-async-event-channel *application-channel* self)
			 (setf async-events 1))
			(t
			 (setf (add:parm-8b acb 0) 0) ;; mode
			 (delete-async-event-channel *application-channel*)
			 (setf async-events 0)))
		  (tb:tb-transmit-packet acb)))
	       (t
		(delete-async-event-channel *application-channel*)
		(setf async-events 0))))
	))


;; *ab* 3/8/90.  For new-mode.
(defun set-event-discard-flag (&optional flag)
  (cond ((eql (send *mac-application* :async-events) 2)
	 (SETF *event-discard-flag* flag)	       ;; *ab* 2/23
	 (setf (add:parm-16b (send *mac-application* :MacStateAcb) 12)
	       (if flag 1 0))
	 ))
  )


;;*ab* 3/8/90.  For new-mode.
(defun !WaitNextEvent (eventmask AnEventRecordInstance sleep region)
  (setf (send *mac-application* :last-time-time-given-up) (time))
  
  (when (send *mac-application* :ProcessApp4)
    (setf (send *mac-application* :ProcessApp4) nil)
    (setf (add:parm-32b (send *mac-application* :MacStateAcb) 2) 0)
    )
  
  (cond
    ((= (mac-application-async-events *mac-application*) 2)
     (cond
       ;;app4Evt signaled by counter with tick-time will wait until before
       ;;actually suspending/resuming
       ((plusp (add:parm-32b (send *mac-application* :MacStateAcb) 2))
	(setf (send AnEventRecordInstance :modifiers) 0)
	(setf (send AnEventRecordInstance :when) 0)
	(setf (send AnEventRecordInstance :what) !App4Evt)
	(setf (send AnEventRecordInstance :message)
	      (add:parm-32b (send *mac-application* :MacStateAcb) 3))
	;;Remind self to signal complete next !WaitNextEvent
	;;Bump up counter while doing susp/resume proc
	(setf (send *mac-application* :ProcessApp4) (si:%fixnum-microsecond-time))
	(setf (add:parm-32b (send *mac-application* :MacStateAcb) 2)
	      (+ (add:parm-32b (send *mac-application* :MacStateAcb) 2) 300))
	;; We need to fill in the rest of the event here.
	;(sleep 20)
;;	(!Sysbeep 0)
	(return-from !WaitNextEvent t))
       ;; Look to see if one of events are already there to keep from
       ;; taking the context switch.
       ((plusp (logand eventMask (add:parm-32b (send *mac-application* :MacStateAcb) 1)))
	(setf (add:parm-32b (send *mac-application* :MacStateAcb) 1) 0)
	(return-from !WaitNextEvent
	  (!WaitNextEventInternal eventmask AnEventRecordInstance
				  sleep region)))
       ((process-wait-with-timeout
	  "!WaitNextEvent" sleep
	  #'(lambda (app)
	      (plusp (logand eventMask (add:parm-32b (send app :MacStateAcb) 1))))
	  *mac-application*)
	(setf (add:parm-32b (send *mac-application* :MacStateAcb) 1) 0) 
	(return-from !WaitNextEvent
	  (!WaitNextEventInternal eventmask AnEventRecordInstance
				  sleep region)))
       (t
	(setf (send AnEventRecordInstance :what) 0)
	;; We need to fill in the rest of the event here.
	(return-from !WaitNextEvent nil)
	)))
    ((= (mac-application-async-events *mac-application*) 1)
     (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 (= 1 (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 ((= 1 (mac-application-async-events *mac-application*))	       ;; *ab* 3/8/90  for new-mode
	 (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 ((= 1 (mac-application-async-events *mac-application*))	       ;; *ab* 3/8/90  for new-mode
	 (send *mac-application* :dequeue-event eventMask AnEventRecordInstance t))
	(t
	 (!EventAvailInternal eventmask AnEventRecordInstance)))
  )

(defun !FlushEvents (eventMask stopMask)
  (cond ((= 1 (mac-application-async-events *mac-application*))	       ;; *ab* 3/8/90  for new-mode
	 (send *mac-application* :flush-events eventMask stopMask)
	 )
	(t
	 (!FlushEventsInternal eventMask stopMask))))

(defun !GetOSEvent (eventMask theEvent)
  (cond ((= 1 (mac-application-async-events *mac-application*))	       ;; *ab* 3/8/90  for new-mode
	 (!GetNextEvent eventMask theEvent))
	(t
	 (!GetOSEventInternal eventMask theEvent))))

(defun !OSEventAvail (eventMask theEvent)
  (cond ((= 1 (mac-application-async-events *mac-application*))	       ;; *ab* 3/8/90  for new-mode
	 (!EventAvail eventMask theEvent))
	(t
	 (!OSEventAvailInternal eventMask theEvent))))

(defmethod (mac-application :top-level) (no-launch-server &rest args)
  (unwind-protect
      (progn
	(cond (server-name
	       (send self :allocate-application-channel)
	       (unless no-launch-server
		   (send self :launch-server)))
	       (t
		(setf *application-channel* (send self :default-application-channel))))
	
	(setf *mac-application* self)
	(clear-application-channel)
	(send self :set-async-event-mode)
	(apply lisp-function args))
    (when (or (= async-events 0) (= async-events 1))
      (setf async-events 0)
      (send self :set-async-event-mode))
    (send self :kill-server)
    (send self :deallocate-mac-application)
    (setf *application-channel* nil)
    (setf *mac-application* nil))
  )

(defmethod (default-tb-server :top-level) (no-launch-server &aux (launched-p))
  (cond (*default-tb-server*
	 (when no-launch-server
	   (ferror 'server-already-launched
		   "There was an attempt to re-launch the default tbServer.")))
	(t
	 (setf *default-tb-server* self)
	 (unwind-protect
	     (progn
	       (send self :allocate-application-channel)
	       (setf channel *application-channel*)
	       (setf *mac-application* self)
	       (clear-application-channel)
	       (unless no-launch-server
		 (send self :launch-server))
	       (send self :set-async-event-mode)
	       (setf launched-p t))
	   (unless launched-p
	     (if *application-channel*
		 (send self :deallocate-mac-application))
	     (when (or (= async-events 0) (= async-events 1))
	       (setf async-events 0)
	       (send self :set-async-event-mode))
	     (makunbound '*application-channel*)
	     (setf *mac-application* nil)
	     (setf *default-tb-server* nil))))))

(defmethod (default-tb-server :kill) ()
  (when (or (= async-events 0) (= async-events 1))
    (setf async-events 0)
    (send self :set-async-event-mode))
  (send self :kill-server)
  (send self :deallocate-mac-application)
  (setf channel nil)
  (makunbound '*application-channel*)
  (setf *mac-application* nil)
  (setf *default-tb-server* nil)
  t)

(defmethod (rpc-application :top-level) (no-launch-server &aux (launched-p))
  (declare (ignore no-launch-server))
  (unwind-protect
      (progn
	(send self :allocate-application-channel)
	(setf *mac-application* self)
	(clear-application-channel)
	(send self :set-async-event-mode)
	(setf launched-p t))
    (unless launched-p
      (if *application-channel*
	  (send self :deallocate-mac-application))
      (when (or (= async-events 0) (= async-events 1))
	(setf async-events 0)
	(send self :set-async-event-mode))
      (makunbound '*application-channel*)
      (setf *mac-application* nil))))

(defmethod (rpc-application :kill) ()
  (when (or (= async-events 0) (= async-events 1))
	(setf async-events 0)
;;;	(send self :set-async-event-mode)
	)
  (send self :kill-server)
  (send self :deallocate-mac-application)
  (makunbound '*application-channel*)
  (setf *mac-application* nil)
  t)

(defmethod (mac-application-internal :set-async-events) (mode)
  (send self :set-async-event-mode mode))

))