;;-*- Cold-load:t; Mode:Common-Lisp; Package:NET; Base:10; Fonts: Courier, Medfnt, Medfnb, Courier, Medfnb; -*-

;1;;                           RESTRICTED RIGHTS LEGEND*

;1;; Use, duplication, or disclosure by the Government is subject to*
;1;; restrictions as set forth in subdivision (b)(3)(ii) of the Rights in*
;1;; Technical Data and Computer Software clause at 52.227-7013.*

;1;;                     TEXAS INSTRUMENTS INCORPORATED.*
;1;;                              P.O. BOX 2909*
;1;;                           AUSTIN, TEXAS 78769*
;1;;                                 MS 2151*

;1;; Copyright (C) 1986,1988 Texas Instruments Incorporated. All rights reserved.*

;1; From sys:network-support;local-connection.lisp#19*

;;; Change history:
;;;
;;;  Date      Author	Description
;;; -------------------------------------------------------------------------------------
;;; 12/22/88	LGO	Added check for closed pipe to the :next-input-buffer method.
;;; 10/12/88	WJB	Commented out LOCAL-CONNECTION-POSSIBLE-P-FUNCTION since it is now
;;;			a part of the standard 4.1 band.

;1;;;;;;;;;;;;;;;;*
;1;; Local Mediums*
;1;;;;;;;;;;;;;;;;*

(DEFVAR 4local-server-alist *nil)

;1; LOCAL-CONNECT-FUNCTION returns one end of a local-pipe, and starts up a server.*
;1; The server calls *listen-for-connection-on-medium1 which calls LOCAL-STREAM-LISTEN.
;; LOCAL-STREAM-LISTEN must return the other end of the pipe that was returned by*
;1; LOCAL-CONNECT-FUNCTION. This is done through 4*local-server-connections**.*
;1; LOCAL-CONNECT-FUNCTION pushes the pipe on 4*local-server-connections**, and*
;1; LOCAL-STREAM-LISTEN pops it off.  Note that if the server process is re-started,*
;1; the pipe will be missing from 4*local-server-connections**, and fail.*
(DEFVAR 4*local-server-connections* *nil)

(defun 4LOCAL-CONNECT-FUNCTION* (host logical-contact-name connection
				  &key window-size stream-type
				  &allow-other-keys)
  (DECLARE (IGNORE host connection window-size))
  (LET ((SERVER (ASSOC (STRING (logical-contact-name-name logical-contact-name))
		       local-server-alist :test 'equalp)))
    (WHEN server
      (LET ((STREAM (make-instance (net:find-stream-type-flavor stream-type :local))))
	(WITHOUT-INTERRUPTS (PUSH stream *local-server-connections*))
	(EVAL (SI::INIT-FORM SERVER))
	stream))))

(defun 4LOCAL-STREAM-LISTEN-FUNCTION* (logical-contact-name connection &rest ignore)
  (declare (ignore logical-contact-name connection))
  (LET* ((STREAM (WITHOUT-INTERRUPTS (POP *local-server-connections*))))
    (when stream
      (SEND stream :input-pipe))))

#|
Now supplied by 4.1.1

(defun 4LOCAL-CONNECTION-POSSIBLE-P-FUNCTION* (host-a &optional host-b logical-contact-name)
  "2Return T if it is possible to create a connection from host-a to host-b*"
  (declare (ignore logical-contact-name))
  (and (send host-a :local-host-p)
       (or (null host-b)
	   (send host-b :local-host-p))))

|#

(defun 4LOCAL-ADD-SERVER-FUNCTION* (logical-contact-name form &rest ignore)
  (let ((contact-name (net:translate-logical-contact-name logical-contact-name :local)))
    (when contact-name
      (add-initialization (format nil 3"~a"* contact-name)
			  (if (symbolp form)
			      (list 'quote form)
			      form) nil 'local-server-alist))))

(defun 4LOCAL-DELETE-SERVER-FUNCTION* (logical-contact-name &rest ignore)
  (let ((contact-name (net:translate-logical-contact-name logical-contact-name :local)))
    (when contact-name
      (delete-initialization (format nil 3"~a"* contact-name) nil 'local-server-alist))))

(define-medium 4:LOCAL*
  :connection-steps '((:network :local))
  :medium-desirability .9
  :implementation-desirability .9
  :connect-function 'local-connect-function
  :connection-possible-p-function 'local-connection-possible-p-function
  :listen-function 'local-stream-listen-function
  :add-server-function 'local-add-server-function
  :delete-server-function 'local-delete-server-function
  :superior-medium-list '(:byte-stream)
  )

;1;;-----------------------------------------------------------------------------*
;1;; Pipes*

(net:define-stream-type :character-stream 'local-pipe :local)

(DEFPARAMETER 4*local-pipe-buffer-size* *2048.)
(DEFVAR 4*local-pipe-buffers* *nil)

(DEFUN 4allocate-pipe-buffer *()
  (WITHOUT-INTERRUPTS
    (OR (POP 4*local-pipe-buffers**)
	(MAKE-ARRAY 4*local-pipe-buffer-size** :element-type '(unsigned-byte 8)))))

(DEFUN 4deallocate-pipe-buffer *(buffer)
  (WITHOUT-INTERRUPTS
    (PUSH buffer 4*local-pipe-buffers**)))

(DEFFLAVOR 4local-pipe *((input-pipe nil)      ;1; Instance of local-pipe for the other direction*
			1 *(input-buffers nil)  ;1; *alist of 1(buffer start end)*
			 (status :closed))
	   (si:buffered-stream)
  (:inittable-instance-variables input-pipe)
  (:gettable-instance-variables input-pipe input-buffers status)
  (:settable-instance-variables input-buffers status))

(DEFMETHOD 4(local-pipe :init)* (&rest ignore)
  (UNLESS input-pipe
    (SETQ input-pipe (MAKE-INSTANCE 'local-pipe :input-pipe self
				    :status :open))
    (setq status :open)))

(DEFMETHOD 4(local-pipe :next-input-buffer)* (no-hang-p)
  (LET ((result (POP input-buffers)))
    (IF result
	(VALUES-LIST result)
      (UNLESS no-hang-p
	(when (eq (PROCESS-WAIT "3Local-Pipe*"
				#'(lambda (pipe)
				    (or (send pipe :input-buffers)
					(and (eq (send pipe :status) :closed) :closed)))
				self)
		  :closed)
	  (error "3Pipe closed*"))	
	(VALUES-LIST (POP input-buffers))))))

(DEFMETHOD 4(local-pipe :discard-input-buffer) (buffer-array)*
  (deallocate-pipe-buffer buffer-array))

(DEFMETHOD 4(local-pipe :new-output-buffer)* ()
  (VALUES (allocate-pipe-buffer) 0 4*local-pipe-buffer-size**))

(DEFMETHOD 4(local-pipe :send-output-buffer)* (buffer-array ending-index)
  (LET ((queue (SEND input-pipe :input-buffers)))
    (SEND input-pipe :set-input-buffers 
	  (NCONC queue (CONS (LIST buffer-array 0 ending-index) nil)))))

(DEFMETHOD 4(local-pipe :discard-output-buffer) (buffer-array)*
  (deallocate-pipe-buffer buffer-array))

(defmethod 4(local-pipe :close)* (&optional mode)
  mode ;1; ignored*
  (setq status :closed)
  (send input-pipe :set-status :closed))