;;; -*- Mode:Common-Lisp; Package:MACTOOLBOX; Base:10; Patch-file:T -*-

;;; Reason: Add the flavor rpc-application. Also fixup default tb servers to keep them from hanging the misc 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/21/89 14:51:54 by JONES,
;;; while running on HOBBS from band LOD1
;;; 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.2, 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*1

#!C
; From file RPC-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 rpc-application
	   ((*application-channel*)
	    (*mac-application*))
	   (mac-application-internal)
  :settable-instance-variables
  :gettable-instance-variables
  :outside-accessible-instance-variables
  (:special-instance-variables *application-channel* *mac-application*))

(defmethod (rpc-application :after :init) (init-plist)
  (let ((no-launch-server (getf (contents init-plist) :no-launch-server)))
    
    (setf process  (apply #'process-run-function process-options
			  #'(lambda (application-inst &rest args) (lexpr-send application-inst :top-level args))
			  self no-launch-server lisp-function-args))))

(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))
      (setf async-events nil)
      (send self :set-async-event-mode)
      (makunbound '*application-channel*)
      (setf *mac-application* nil))))

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


;;;
;;; Default-tb-server fixup
;;;

(defmethod (default-tb-server :after :init) (init-plist)
  (let ((no-launch-server (getf (contents init-plist) :no-launch-server)))
    
    (setf process  (apply #'process-run-function process-options
			  #'(lambda (application-inst &rest args) (lexpr-send application-inst :top-level args))
			  self no-launch-server lisp-function-args))))

(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))
	     (setf async-events nil)
	     (send self :set-async-event-mode)
	     (makunbound '*application-channel*)
	     (setf *mac-application* nil)
	     (setf *default-tb-server* nil))))))
))