;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	Begin Change Log
;;;-------------------------------------------------------------------------
;;;
;;;     Almond/Mickish  17-Sep-93  Added lexical closure around launch-main-
;;;                                event-loop, added restart-case
;;;     Clive Tong  06-Sep-93 Fixed lispworks stuff
;;;     Mickish  6-Aug-93 Added lispworks stuff
;;;     Almond   5-Jan-92 Bound *trace-output* in launch-mel-process
;;;     Dzg/Mickish 21-Sep-92 Added Update-Start-Fn and Update-Stop-Fn
;;;     Myers   20-Aug-92 Added running-main-event-loop-process-elsewhere-p
;;;     Almond  26-May-92 Added patch to launch-main-event-loop-process
;;;			  to handle background streams for Lapidary.
;;;     Pervin  21-Apr-92 Added main-event-loop-process-running-p
;;;     Pervin  14-Apr-92 Uncommented out process code.
;;;			  Got it to work on HP.
;;;     Pervin  30-Mar-92 Commented out process code.
;;;     Pervin  25-Mar-92 Made to be permanent part of Opal.
;;;			  Merged process-allegro and process-lucid.   
;;;     Pervin   9-Aug-90 Released for Garnet.
;;;	Stork	18-Jul-90 Created.
;;;
;;;-------------------------------------------------------------------------
;;;	End Change Log
;;;
;;;
(in-package "OPAL" :use '("LISP" "KR"))


;;;===========================================================================
;;;
;;;  Global variables
;;;
;;;===========================================================================

(defvar update-locking-p T
  "If T, uses process locks to keep Update in a process from interrupting
   itself in a different process.")

(defparameter *main-event-loop-process* nil
  "The variable which is a handle to the main-event-loop process.")

(defparameter *update-lock*
  #+ALLEGRO (mp:make-process-lock :name "UPDATE-LOCK")
  #+lispworks (mp:make-lock)
  #-(or ALLEGRO lispworks) NIL)


;;;===========================================================================
;;;
;;;  Define opal:launch-main-event-loop-process
;;;
;;;===========================================================================

#+allegro
(let ((my-tty *terminal-io*))
   ;; RGA --- note this closure means that the value of my-tty will be
   ;; bound to the value *terminal-io* at load time, not run time.  In
   ;; particular, it will not be clobbered by background processes
   ;; which run opal:update or inter:wait-interaction-complete

 (defun launch-main-event-loop-process (&optional (tty my-tty))
  "Spawn a process which is doing Garnet interaction all of the time.
   RETURN the process."
   (when (eq (type-of *main-event-loop-process*) 'mp:process)
      (mp:process-kill *main-event-loop-process*))
   (setf *main-event-loop-process*
          (mp:process-run-restartable-function
	    #+(or allegro-v4.0 allegro-v4.1)
 	    `(:name "Garnet event loop"
              :initial-bindings
              ,(acons '*terminal-io* tty
                       excl:*cl-default-special-bindings*))
	    #-(or allegro-v4.0 allegro-v4.1)
	    "Garnet event loop"
            #'(lambda (t-io)
              ;; RGA --- This gets around a "feature" of Allegro 4.1
              ;; which does not allow background processes to do io.
              ;; Note that the main process function is now a function
              ;; of one arg which is bound to *terminal-io*
                (setq *terminal-io* t-io)
                (setq *query-io* t-io)
                (setq *standard-input* t-io)
                (setq *standard-output* t-io)
		(setq *error-output* t-io)
		(setq *trace-output* t-io)
	      ;; Don't bind *debug-io* because RGA suggests other problems
	      ;; might arise
		;(setq *debug-io* t-io)
              ;; first, throw away any pending events
                (xlib:event-case (opal::*default-x-display* :discard-p t
							    :timeout 1)
                  (:destroy-notify () NIL)  ; get rid of warnings
                  (otherwise () t))
		;; RGA added an abort restart to the main event loop.
		(restart-case
		 (loop
		  (inter::default-event-handler opal::*default-x-display*))
		 (abort () :report "Discard pending X events, restart loop"
			(xlib:event-case (opal::*default-x-display*
					  :discard-p t :timeout 1)
					 (:destroy-notify () NIL) 
					 (otherwise () t)))
		 ))
            tty))
   (setf (mp:process-priority *main-event-loop-process*) 1)
   *main-event-loop-process*)
 )

#+lispworks
(defun launch-main-event-loop-process ()
  "Spawn a process which is doing Garnet interaction all of the time.
   RETURN the process."
   (when (eq (type-of *main-event-loop-process*) 'mp:process)
      (mp:process-kill *main-event-loop-process*))
   (setf *main-event-loop-process*
          (mp:process-run-function
	    "Garnet event loop"
 	    `(:name "Garnet event loop")
            #'(lambda (t-io)
		(declare (ignore t-io))
		;; first, throw away any pending events
                (xlib:event-case
		 (opal::*default-x-display* :discard-p t :timeout 1)
		 (:destroy-notify () NIL)  ; get rid of warnings
		 (otherwise () t))
                (loop
		 (inter::default-event-handler opal::*default-x-display*)))
            *terminal-io*))
   (setf (mp:process-priority *main-event-loop-process*) 1)
   *main-event-loop-process*)

;;; This was needed in order to survive the debugger on the HP.
;;; There is probably something wrong with Lucid on the HP, since this is needed.
#+lucid
(unless (fboundp 'lucid::machine-specific-restart-current-process)
  (defun lucid::machine-specific-restart-current-process ()))

#+lucid
(defun launch-main-event-loop-process ()
  "Spawn a process which is doing Garnet interaction all of the time.
   RETURN the process."
  ;; If there was already a process running, kill it.
  (when (and *main-event-loop-process*
             (lcl:processp *main-event-loop-process*))
    (lcl:kill-process *main-event-loop-process*))
  (setf *main-event-loop-process*
          (lcl:make-process
	    :name "Garnet event loop"
	    :priority 50
            :function 
	       #'(lambda ()
		   ;; first, throw away any pending events
	           (xlib:event-case (opal::*default-x-display* :discard-p t :timeout 1)
		     (:destroy-notify () NIL)  ; get rid of warnings
		     (otherwise () t))
		   (lcl:handler-bind
		     ((lcl::error #'lcl:invoke-debugger))
	 	     (loop
		       (inter::default-event-handler
			  opal::*default-x-display*)))))))


#-(or allegro lucid lispworks)
(defun launch-main-event-loop-process ())


;;;===========================================================================
;;;
;;;  Define opal:kill-main-event-loop-process
;;;
;;;===========================================================================

#+(or allegro lispworks)
(defun kill-main-event-loop-process ()
  "
  Kill the current main-event-loop process.
  "
  (when (eq (type-of *main-event-loop-process*) 'mp:process)
    (mp:process-kill *main-event-loop-process*)
    (setf *main-event-loop-process* nil)))

#+lucid
(defun kill-main-event-loop-process ()
  "
  Kill the current main-event-loop process.
  "
  (when (and *main-event-loop-process*
             (lcl:processp *main-event-loop-process*))
    (lcl:kill-process *main-event-loop-process*)
    (setf *main-event-loop-process* nil)))


#-(or allegro lucid lispworks)
(defun kill-main-event-loop-process ())

;;;===========================================================================
;;;
;;;  Define running-p functions
;;;
;;;===========================================================================

(defun main-event-loop-process-running-p ()
  (and opal::*main-event-loop-process*
       #+lucid
       (not (equal "Run"
		   (lcl:process-whostate
			opal::*main-event-loop-process*)))
       ;;; Franz's comments about mp:process-runnable-p:  It is true of any
       ;;; process that has a stack-group (meaning that is has been reset and
       ;;; has not yet exhausted its computation), has at least one run reason,
       ;;; has zero arrest reasons, and is not blocked in a call like
       ;;; PROCESS-WAIT or any of its close relatives.  This last clause --
       ;;; testing that the process is not blocked in PROCESS-WAIT --
       ;;; perhaps isn't what you want.  If the process happens temporarily
       ;;; to be waiting for something, it won't be killed.  Perhaps you
       ;;; want to use the PROCESS-ACTIVE-P predicate instead, which
       ;;; is true whether or not the process is in a PROCESS-WAIT.
       #+allegro
       (not (mp:process-runnable-p
		opal::*main-event-loop-process*))
       #+old-lispworks
       (not (mp::process-active-p
	        opal::*main-event-loop-process*))
       #+lispworks
       ;; CT 2Sep93
       (not (and
	     (not (mp::process-wait-reason opal::*main-event-loop-process*))
	     (mp::process-run-reasons opal::*main-event-loop-process*)
	     (not (mp::process-arrest-reasons opal::*main-event-loop-process*))
	     ))
	    
       ))

(defun running-main-event-loop-process-elsewhere-p ()
  (and opal::*main-event-loop-process*
       (not (eq opal::*main-event-loop-process*
		#+(or allegro lispworks) mp:*current-process*
		#+lucid user::*current-process*
		#-(or allegro lucid lispworks) T)
	    )))


;;;===========================================================================
;;;
;;;  Define process lock functions
;;;
;;;===========================================================================

(defun update-start-fn (window)
  (declare (ignore window))
  #+ALLEGRO
  (if update-locking-p
      (unless (eq (mp:process-lock-locker *update-lock*) mp:*current-process*)
	;; Lock only if lock is held by a different process, or unlocked.
	(mp:process-lock *update-lock*)))
  #+old-lispworks
  (if update-locking-p
      (mp:process-lock *update-lock*))

  #+lispworks
  ;; CT 2Sep93
  (if update-locking-p
      (unless (eq (mp:lock-owner *update-lock*) mp:*current-process*)
	;; Lock only if lock is held by a different process, or unlocked.
	(mp:process-lock *update-lock*)))
      
  #+LUCID
  (if update-locking-p
      (lcl:process-lock *update-lock*)))

(defun update-stop-fn (window)
  (declare (ignore window))
  #+ALLEGRO
  (if (and update-locking-p
	   (eq (mp:process-lock-locker *update-lock*) mp:*current-process*))
      (mp:process-unlock *update-lock*))
  #+old-lispworks
  (if update-locking-p
      (mp:process-unlock *update-lock*))
  
  #+lispworks
  ;; CT 3Sep93
  (if (and update-locking-p
	   (eq (mp:lock-owner *update-lock*) mp:*current-process*))
      (mp:process-unlock *update-lock*))
    
  #+LUCID
  (if update-locking-p
      (lcl:process-unlock *update-lock* user::*current-process* :ignore)))
