NetNews Usenet Archive 1992 #20/NN_1992_20.iso/spool/comp/lang/lisp/2403

Text File | 1992-09-10 | 25.4 KB | 749 lines

Newsgroups: comp.lang.lisp
Path: sparky!uunet!stanford.edu!CSD-NewsHost.Stanford.EDU!Xenon.Stanford.EDU!geddis
From: [e-mail] (Don Geddis)
Subject: Re: Interprocess comms using Allegro 4.1
To: [e-mail]
Message-ID: <[e-mail]>
Keywords: IPC, Allegro, socket, stream
Sender: [e-mail]
Reply-To: [e-mail]
Organization: CS Department, Stanford University, California, USA
References: <[e-mail]>
Distribution: usa
Date: 10 Sep 92 22:08:52 GMT
Lines: 733

djasson@zion (Drew Asson) writes:
>This is a request for help to set up a unix-domain (socket file) server
>in Allegro (4.1), that will accept 1 connection from a C code client.
>The lisp side only need service one connection at a time (ergo no
>fork needed), but I'd like it to stay resident and be able to accept
>another connection when the last one is finished.

>I've looked at the sample code in the ipc.cl file.  Setting up a lisp
>client is no problem (just use open-network-stream), but I want a lisp
>server. So I started playing around w/ the function lisp-server-socket-daemon.
>I thought I took out all I needed.  But it didn't work.

Without analyzing your detailed problem, I'll just say that I had exactly
the same desire a few months ago.  Contacting Franz led to them sending me
an experimental copy of a new ipc.cl file.  With some minor modifications
by myself, it seems to work fine.  I'll include my modified ipc.cl and
some sample server code below.

-------------------------------------------------------------------------------
IPC.CL

;;                    -[Wed Jan 15 14:27:09 1992 by layer]-
;;
;; Allegro CL IPC interface [cer version!!]
;;
;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Suppplement 252 52.227-7013 (c) (1) (ii), as
;; applicable.
;;

;;; Added 7/23/92 by Don Geddis ([e-mail])
(defconstant new-ipc-installed t)

;;;;; I hacked this  to support the LEP protocol
;;;; This seems like a dreadful piece of code.
;;;; Changes:
;;;; 1. Support for multiple servers listening on different connections.
;;;; 2. The default behaviour is that the server reads a protocol name that specifies the type of the
;;;; server process to create.  Currently, supported protocols are:
;;;; a. :listener - RUN a listener
;;;; b. :lep - start up an LEP server

(eval-when (compile eval load)
  (if (find-symbol (symbol-name :rcsnote) (find-package :si))
      (push :has-rcsnote *features*))

  #-(or little-endian big-endian)
  (pushnew
   (let ((x '#(1)))
     (if (not (= 0 (sys::memref x #.(comp::mdparam 'comp::md-svector-data0-adj)
                0 :unsigned-byte)))
     :little-endian
       :big-endian))
   *features*)
  )

#+has-rcsnote
(si::rcsnote
 "ipc"
 "$aclHeader: ipc.cl,v 1.50 91/12/04 01:10:45 cox acl4_1 $")

(eval-when (compile eval load)
  (excl::require :process)
  (excl::require :foreign)
  (excl::provide :ipc))

#+(version>= 4 0)
(defpackage :ipc (:use :lisp :excl :ff :mp)
        (:export #:start-lisp-listener-daemon #:open-network-stream
             #:*inet-port-min* #:*inet-port-max* #:*inet-port-used*
             #:start-process-for-network-stream
             ))

#+(version>= 4 0)
(in-package :ipc)

#-(version>= 4 0)
(in-package :ipc :use '(:lisp :excl :ff :mp))

#-(version>= 4 0)
(export '(start-lisp-listener-daemon open-network-stream
      *inet-port-min* *inet-port-max* *inet-port-used*))

#+allegro-v3.1
(progn
  (excl::require :cstructs)
  (defmacro ff::cstruct-length (x) `(ff::cstruct-len ,x))
  )

#+(or allegro-v3.2 (version>= 4 0))
(eval-when (compile eval load)
  (excl::require :defctype))

(defvar *unix-domain* nil
  ;; If non-nil then use a UNIX domain socket, otherwise use an internet
  ;; domain port (see *inet-port* variable).
  )

(defvar *socket-pathname* nil
  ;; When the UNIX domain is used, then if non-nil this is the pathname of
  ;; the socket file to use for the communication between GNU Emacs and
  ;; Allegro CL.
  )

(defparameter *inet-port-min* 1025
  "The smallest internet service port number on which Lisp listens for
connections.")

(defparameter *inet-port-max* 2025
  "The largest internet service port number on which Lisp listens for
connections.")

(defvar *inet-port-used* 0
  "Port actually in use for lisp listeners.")

(defvar *inet-listener-password* 0
  ;; A magic number that mnust be supplied to verify that someone trying to
  ;; connect to our listener is really the person who started the lisp
  )

(defvar *ipc-version* 1
  ;; This indicates the version of the IPC protocol
  )

(defconstant *af-unix* 1
  ;; The AF_UNIX constant from /usr/include/sys/socket.h.
  )

(defconstant *af-inet* 2
  ;; The AF_INET constant from /usr/include/sys/socket.h.
  )

(defconstant *sock-stream* 1
  ;; The SOCK_STREAM constant from /usr/include/sys/socket.h.
  )

;; from <netinet/in.h>
(defcstruct sockaddr-in
  (family :unsigned-short)        ; short sin_family
  (port :unsigned-short)        ; u_short sin_port
  (addr :unsigned-long)            ; struct in_addr sin_addr
  (zero 8 :char)            ; char sin_zero[8]
  )

;; from <??>
(defcstruct sockaddr-un
  (family :unsigned-short)
  (path 109 :char))

;; from <netdb.h>
(defcstruct (hostent :malloc)
  (name * :char)            ; char *h_name
  (aliases * * :char)            ; char **h_aliases
  (addrtype :long)            ; int h_addrtype
  (length :long)            ; int h_length
  (addr * :char)            ; char *h_addr   --or--
                    ; char **h_addr_list (for SunOS 4.0)
  )

(defcstruct (servent :malloc)        ; Returned by getservent
  (name * :char)
  (aliases * * :char)
  (port :signed-long)
  (proto * :char))

(defcstruct timeval
  (sec :long)
  (usec :long))

(defcstruct unsigned-long
  (unsigned-long :unsigned-long))

(defvar .lisp-listener-daemon-ff-loaded. nil)
(defvar .lisp-listener-daemon. nil)

(defparameter .needed-funcs.
    (mapcar #'convert-to-lang
        ;; this list appears in makefile.cl, too
        '("socket" "bind" "listen" "accept" "getsockname"
          "gethostbyname" "getservbyname"
          "connect" "bcopy" "bcmp" "bzero")))

(defvar .junk-name. (make-array 1))
(defvar .junk-address. (make-array 1 :element-type '(unsigned-byte 32)))

(defun entry-point-exists-p (string)
  (setf (aref .junk-name. 0) string)
  (setf (aref .junk-address. 0) 0)
  (= 0 (get-entry-points .junk-name. .junk-address.)))

(eval-when (load eval)
  (unless .lisp-listener-daemon-ff-loaded.
    (excl::machine-case :host
      ((:apollo :tek4300 :rs6000))
      (t (unless (dolist (name .needed-funcs. t)
           (if (not (entry-point-exists-p name))
               (return nil)))
       (princ ";  Loading TCP routines from C library...")
       (force-output)
       (unless (load ""
             :verbose nil
             :unreferenced-lib-names .needed-funcs.
             #+(target sgi4d) :system-libraries
             #+(target sgi4d) '("bsd")
             )
         (error "foreign load failed"))
       (princ "done")
       (terpri)
       (force-output))))

    (setq .lisp-listener-daemon-ff-loaded. t)
    (defforeign-list '((getuid :entry-point #,(convert-to-lang "getuid"))
               (socket :entry-point #,(convert-to-lang "socket"))
               (bind :entry-point #,(convert-to-lang "bind"))
               (accept :entry-point #,(convert-to-lang "accept"))
               (getsockname :entry-point #,(convert-to-lang
                            "getsockname"))
               (gethostbyname :entry-point #,(convert-to-lang
                              "gethostbyname"))
               (getservbyname :entry-point #,(convert-to-lang
                              "getservbyname"))
               (select :entry-point #,(convert-to-lang "select"))
               (connect :entry-point #,(convert-to-lang "connect"))
               (bcopy :entry-point #,(convert-to-lang "bcopy"))
               (bzero :entry-point #,(convert-to-lang "bzero"))
               (bcmp :entry-point #,(convert-to-lang "bcmp"))
               (perror :entry-point #,(convert-to-lang "perror"))
               (unix-listen :entry-point #,(convert-to-lang "listen"))
               (unix-close :entry-point #,(convert-to-lang "close")))
             :print nil)))

(if* (entry-point-exists-p (convert-to-lang "lisp_htons"))
   then ;; Allegro CL 3.1 or later...
    (defforeign-list '((lisp_htons :entry-point #,(convert-to-lang
                               "lisp_htons"))
               (lisp_htonl :entry-point #,(convert-to-lang
                               "lisp_htonl"))
               (lisp_ntohs :entry-point #,(convert-to-lang
                               "lisp_ntohs"))
               (lisp_ntohl :entry-point #,(convert-to-lang
                               "lisp_ntohl")))
             :print nil)
   else ;; pre-3.1 Allegro CL.  Do it the hard way...
    #+little-endian
    (progn
      (setf (symbol-function 'lisp_htons)
        #'(lambda (x)
        (logior (ash (logand x #x00ff) 8)
            (ash (logand x #xff00) -8))))
      (setf (symbol-function 'lisp_ntohs)
        #'(lambda (x) (lisp_htons x)))

      (setf (symbol-function 'lisp_htonl)
        #'(lambda (x)
        (logior (ash (logand x #x000000ff)  24)
            (ash (logand x #x0000ff00)   8)
            (ash (logand x #x00ff0000)  -8)
            (ash (logand x #xff000000) -24))))
      (setf (symbol-function 'lisp_ntohl)
        #'(lambda (x) (lisp_htonl x))))

    #+big-endian
    (progn
      (setf (symbol-function 'lisp_htons) #'(lambda (x) x))
      (setf (symbol-function 'lisp_htonl) #'(lambda (x) x))
      (setf (symbol-function 'lisp_ntohs) #'(lambda (x) x))
      (setf (symbol-function 'lisp_ntohl) #'(lambda (x) x))))

(defun start-lisp-listener-daemon (&rest args)
  "Starts a daemon process which listens to a socket for attempts to
connect, and starts a lisp listener for each connection.  If the Lisp
listener ever completes, the daemon makes sure its connection is closed."
  (cond ((or (null .lisp-listener-daemon.)
         (not (member .lisp-listener-daemon. mp::*all-processes*
              :test #'eq)))
     (setq .lisp-listener-daemon.
       (apply #'process-run-function "TCP Listener Socket Daemon"
          'lisp-server-socket-daemon
          args))
     (setf (mp::process-interruptable-p .lisp-listener-daemon.) nil)
     (setf (getf (process-property-list .lisp-listener-daemon.)
             ':survive-dumplisp)
       'mp:process-kill))
    (t (warn "the listener daemon is already running"))))

(defun kill-lisp-listener-daemon ()
  (if* (or (null .lisp-listener-daemon.)
       (not (member .lisp-listener-daemon. mp::*all-processes*
            :test #'eq))
       (progn
         (mp:process-kill .lisp-listener-daemon.)
         ;; this makes sure the kill is allowed to complete:
         (mp:process-allow-schedule)
         t))
     then (setq .lisp-listener-daemon. nil)
      t
     else (error "couldn't kill the listener daemon")))

(defun start-lisp-server-process (&rest args
                  &key (server-name
                    "TCP Listener Socket Daemon")
                  &allow-other-keys)
  (remf args :server-name)
  (let ((proc
     (apply #'process-run-function server-name
        'lisp-server-socket-daemon
        args)))
    (setf (mp::process-interruptable-p proc) nil)
    (setf (getf (process-property-list proc) ':survive-dumplisp) 't)
    proc))

;;;============================================================================
;;; New "lisp-server-socket-daemon" added 7/7/92 by Don Geddis
;;; Code from [e-mail] (Steve Haflich)

(defun lisp-server-socket-daemon (&rest args &key
                  (use-lep nil)
                  (startup-stream-process
                   (if use-lep
                       #'new-default-stream-startup
                     #'default-stream-startup))
                  ((:unix-domain *unix-domain*) *unix-domain*)
                  (inet-port 0 inet-port-p)
                   ((:inet-port-min *inet-port-min*)
                    (if inet-port-p inet-port *inet-port-min*))
                   ((:inet-port-max *inet-port-max*)
                    (if inet-port-p inet-port *inet-port-max*))
                  ((:socket-pathname *socket-pathname*)
                   *socket-pathname*)
                  (raw-connection nil)
                  &allow-other-keys
;;; We should decide this if we
;;; implement background streams
;;; then it is no good just outputting to random locations.
                  &aux
                  (*standard-output* *initial-terminal-io*)
                  (*debug-io* *initial-terminal-io*)
                  (*terminal-io* *initial-terminal-io*)
                  (*error-output* *initial-terminal-io*))

  ;; Code added 7/19/92 by Don Geddis ([e-mail])
  (when raw-connection
    (setq startup-stream-process #'don-stream-startup) )

  ;; use-lep should default to Nil and the LEP should start things up with T
  ;; In this way a new lisp can work with the old Emacs interface
  (block bad-news
    (let (listen-socket-fd
      (listen-sockaddr
       (if *unix-domain*
           (make-cstruct 'sockaddr-un)
         (let ((sin (make-cstruct 'sockaddr-in)))
           (bzero sin (ff::cstruct-length 'sockaddr-in))
           sin)))
      (timeval (make-cstruct 'timeval))
      (mask-obj (make-cstruct 'unsigned-long))
      (int (make-cstruct 'unsigned-long))
      mask
      stream
      fd)

      (unless *socket-pathname*
    (setq *socket-pathname* (format nil "/tmp/GnuToAcl~d" (getuid))))

      (setf (timeval-sec timeval) 0
        (timeval-usec timeval) 0)
      (unwind-protect
      (progn
        (if *unix-domain* (errorset (delete-file *socket-pathname*)))
        (setq listen-socket-fd (socket
                    (if *unix-domain* *af-unix* *af-inet*)
                    *sock-stream*
                    0))
        (when (< listen-socket-fd 0)
          (perror "socket")
          (setq listen-socket-fd nil)
          (return-from bad-news))
        (mp::mpwatchfor listen-socket-fd)

        ;; Compute a select mask for the daemon's socket.
        (setq mask (ash 1 listen-socket-fd))

        (if* *unix-domain*
           then (setf (sockaddr-un-family listen-sockaddr) *af-unix*)
           ;; Set pathname.
            (dotimes (i (length *socket-pathname*)
                   (setf (sockaddr-un-path listen-sockaddr i) 0))
              (setf (sockaddr-un-path listen-sockaddr i)
            (char-int (elt *socket-pathname* i))))
            (unless (zerop (bind listen-socket-fd
                     listen-sockaddr
                     (+ (length *socket-pathname*) 2)))
              (perror "bind")
              (return-from bad-news))
           else (setf (sockaddr-in-family listen-sockaddr) *af-inet*)
            (do ((port *inet-port-min* (1+ port)))
            ((progn
               (setf (sockaddr-in-port listen-sockaddr)
                 (lisp_htons (setq *inet-port-used* port)))
               (zerop (bind listen-socket-fd
                    listen-sockaddr
                    (ff::cstruct-length 'sockaddr-in)))))
              (if* (= port *inet-port-max*)
             then (perror "bind")
                  (return-from bad-news))))

        (finish-output)
        (unless (zerop (unix-listen listen-socket-fd 5))
          (perror "listen")
          (return-from bad-news))

        (if* (not raw-connection)
           then (format t "~d ~d ~a ~s ~d"
                ;; ^Aport password case-mode socket-file ipc-version^A
                (if* *unix-domain*
                   then 0
                   else *inet-port-used*)
                (setq *inet-listener-password*
                  (random 1000000 (make-random-state t)))
                (case excl::*current-case-mode*
                  ((:case-insensitive-upper
                :case-sensitive-upper) ":upper")
                  ((:case-insensitive-lower
                :case-sensitive-lower) ":lower"))
                (if* *unix-domain*
                   then *socket-pathname*
                   else nil)
                *ipc-version*)

            (finish-output))
        (loop
          (process-wait "waiting for a connection"
                #'(lambda (mask mask-obj timeout)
                (setf (unsigned-long-unsigned-long
                       mask-obj)
                  mask)
                (not (zerop (select 32 mask-obj 0 0 timeout))))
                mask mask-obj timeval)
          (setf (unsigned-long-unsigned-long int)
        (if *unix-domain*
            (ff::cstruct-length 'sockaddr-un)
          (ff::cstruct-length 'sockaddr-in)))
          (setq fd (accept listen-socket-fd listen-sockaddr int))
          (finish-output *standard-output*)
          (finish-output *error-output*)
          (when (< fd 0)
        (perror "accept")
        (return-from bad-news))

          (setq stream (make-ipc-terminal-stream fd))

          ;; the first thing that comes over the stream is the name of the
          ;; emacs buffer which was created--we name the process the
          ;; same.
          ;; For internet sockets, the next thing is the password.
          (apply startup-stream-process stream :fd fd
             :listen-sockaddr listen-sockaddr
             ;; unused? -smh
             ;; :listen-sockaddr-len int
             args)))
    (when listen-socket-fd
      (mp::mpunwatchfor listen-socket-fd)
      (unix-close listen-socket-fd)
      (if* (not raw-connection)
         then (setq .lisp-listener-daemon. nil))
      ))))
  (error "couldn't start listener daemon"))

;; added function, corresponds to start-lisp-server-process

(defun kill-lisp-server-process (process)
  (if* (or (null process)
       (not (member process mp::*all-processes* :test #'eq))
       (progn
         (mp:process-kill process)
         ;; this makes sure the kill is allowed to complete:
         (mp:process-allow-schedule)
         t))
     then t
     else (error "couldn't kill the listener daemon")))

;;;============================================================================

;;;; The first thing that comes over is the name of the protocol to use.
;;;; The old scheme is the listener protocol which means fire up a listener.
;;;; The LEP uses the :lep protocol

(defun new-default-stream-startup (stream &rest args)
  (declare (ignore function))
  (apply #'start-process-for-network-stream stream (read stream) args))

(defgeneric start-process-for-network-stream (stream protocol &rest arguments)
        (:documentation "Create the process to serve the stream"))

(defmethod start-process-for-network-stream (stream (protocol (eql :listener)) &rest args)
  (apply #'default-stream-startup stream args))

(defmethod start-process-for-network-stream (stream protocol &rest args)
  (declare (ignore args))
  (warn "Tried to start unknown protocol ~S for stream ~S" protocol stream))

;;; Code added 7/19/92 by Don Geddis ([e-mail])
(defun don-stream-startup
  (stream
   &key (function 'lisp-listener-with-stream-as-terminal-io)
   listen-sockaddr fd
   &allow-other-keys)
  (process-run-function "Don-Process" function stream) )

(defun default-stream-startup (stream
                   &key (function 'lisp-listener-with-stream-as-terminal-io)
                    listen-sockaddr fd
                   &allow-other-keys)
  (let ((proc-name (read stream))
    (password
     (if (null *unix-domain*)
         (read stream))))
    (if* *unix-domain*
       then (process-run-function
         proc-name
         function
         stream)
       else (if* (not (and (numberp password)
               (= password *inet-listener-password*)))
           then (let ((hostaddr
               (lisp_ntohl
                (sockaddr-in-addr listen-sockaddr))))
              (format t ";; access denied for host ")
              (format-in-addr t hostaddr)
              (format t ", password ~s~%" password))
            (refuse-connection fd)
           else (process-run-function
             proc-name
             function
             stream)))))

(defun refuse-connection (fd &aux s)
  (setq s (make-ipc-terminal-stream fd))
  #-(version>= 4 0)
  (setf (excl::sm_read-char s) #'mp::stm-bterm-read-string-char-wait)
  (format s "connection refused.~%")
  (force-output s)
  #-(version>= 4 0) (setf (excl::sm_bterm-out-pos s) 0)
  #+(version>= 4 0) (excl::clear-output-1 s)
  (close s))

(defun lisp-listener-with-stream-as-terminal-io (s)
  (unwind-protect
      #+(version>= 4 0)
      (tpl:start-interactive-top-level
       s 'tpl:top-level-read-eval-print-loop nil)
      #-(version>= 4 0)
      (progn
    (setf (excl::sm_read-char s) #'mp::stm-bterm-read-string-char-wait)
    (tpl:start-interactive-top-level
     s 'tpl:top-level-read-eval-print-loop nil))
    ;; This next crock is to prevent the force-output done by close from
    ;; signalling an error if there are characters buffered to the output
    ;; stream, which there will be if the remote client closed the connection.
    ;; This should be changed to a clear-output once that works on a buffered
    ;; terminal stream.
    #-(version>= 4 0) (setf (excl::sm_bterm-out-pos s) 0)
    #+(version>= 4 0) (excl::clear-output-1 s)
    (close s)))

(defun open-network-stream (&key host port socket-file)
  "Open a stream to a port, which is a TCP/IP communication channel.  There
are two types of ports supported, UNIX and INTERNET domain.  The domain is
chosen based on the keyword arguments supplied:
For internet domain:
 HOST is the string host name or an integer internet address.
 PORT is the string service name or a port number.
For Unix domain:
 SOCKET-FILE is the string pathname of the socket."
  (when (or (and host port socket-file)
        (and (or (null host) (null port))
         (null socket-file)))
    (error "Must either supply HOST and PORT *or* SOCKET-FILE keywords."))
  (if* socket-file
     then ;; UNIX domain
      (let ((server (make-cstruct 'sockaddr-un))
        socket-fd)
        (setf (sockaddr-un-family server) *af-unix*)
        (dotimes (i (length socket-file)
              (setf (sockaddr-un-path server i) 0))
          (setf (sockaddr-un-path server i)
        (char-int (elt socket-file i))))
        (setq socket-fd (socket *af-unix* *sock-stream* 0))
        (if (< (connect socket-fd server (+ 2 (length socket-file))) 0)
        (error "connect failed to ~s" socket-file))
        (make-ipc-terminal-stream socket-fd))
     else ;; INTERNET domain
      (let (sock server hostaddress)
        ;; Open a socket
        (when (< (setf sock (socket *af-inet* *sock-stream* 0)) 0)
          (error "couldn't open socket"))
        ;; construct a socket address
        (setf server (make-cstruct 'sockaddr-in))
        (bzero server (ff::cstruct-length 'sockaddr-in))
        (if* (integerp host)
           then (setq hostaddress (lisp_htonl host))
         elseif (stringp host)
           then (when (= (setq hostaddress (gethostbyname host)) 0)
              (error "unknown host: ~a" host))
            (if (not (= 4 (hostent-length hostaddress)))
            (error "address length not 4"))
            (setq hostaddress
              (let ((addr (hostent-addr hostaddress)))
            (si:memref-int
             ;; SunOS 4.0 requires an extra indirection
             (if (or (member comp::.target.
                     '(:hp :sgi4d :sony :dec3100 :rs6000)
                     :test #'eq)
                 (probe-file "/lib/ld.so"))
                 (si:memref-int addr 0 0 :unsigned-long)
               addr)
             0 0 :unsigned-long)))
           else (error "HOST not a string or integer internet address:"
               host))
        (setf (sockaddr-in-addr server) hostaddress)

        (setf (sockaddr-in-port server)
          (if* (integerp port)
         then (lisp_htons port)
           elseif (stringp port)
         then (let ((serv (getservbyname port "tcp")))
            (if* (= 0 serv)
               then (error "Unknown service name: ~s" port))
            (servent-port serv))
         else (error "PORT not a string or integer internet service:"
                 port)))

        (setf (sockaddr-in-family server) *af-inet*)
        ;; open the connection
        ;; Modified 7/21/92 by Don Geddis ([e-mail])
        ;;   so that connection failure returns nil instead of an error
        ;; 8/12/92 Replace perror/error with format to *error-output*
        (if (< (connect sock server (ff::cstruct-length 'sockaddr-in)) 0)
        (progn
          (format *error-output* "Connect failure: ")
          (unix-close sock)
          (format *error-output* "couldn't connect to socket")
          nil )
          ;; build and return the stream
          (make-ipc-terminal-stream sock)))))

(defun make-ipc-terminal-stream (fd)
  #+allegro-v3.1 (excl::make-buffered-terminal-stream fd fd t t)
  #+(version>= 4 0) (make-instance 'excl::bidirectional-terminal-stream
           :fn-in  fd
           :fn-out fd)
  )

(defun format-in-addr (stm addr)    ; assumes host byte order
  (format stm "[~11,1,1,'.<~2,'0D~;~2,'0D~;~2,'0D~;~2,'0D~>]"
      (ldb (byte 8 24) addr)
      (ldb (byte 8 16) addr)
      (ldb (byte 8  8) addr)
      (ldb (byte 8  0) addr)))

#|
;;; Allegro Common Lisp as the client side of `finger'.
;;; This is a simple demo of how easily a lisp program can become the
;;; client of a client/server connection.

(defun finger (host &optional (name ""))
  (with-open-stream (s (open-network-stream :host host
                        :port "finger"))
    ;; The first interaction of the finger protocol is to send the
    ;; name in which we are interested.  The empty string will
    ;; report on all current users.
    (format s "~a~%" name)
    ;; Then we read back multiple lines of information.
    (do ((line (read-line s nil nil) (read-line s nil nil)))
    ((null line) (values))
      ;; The returned data contains extra #\return characters
      ;; which we might not want to print.
      (write-line (remove #\return line)))))
|#

-------------------------------------------------------------------------------
MY SAMPLE CODE TO USE IPC.CL

(unless (boundp 'new-ipc-installed)
  (load "/local/lib/cl/code/ipc") )    ; Use the modified IPC code

;;;----------------------------------------------------------------------------

(defconstant *myself* 2130706433 "Self IP address: 127.0.0.1")

(defun test-port-send
    (port &optional (str (format nil "Test of send to ~A" port)))
  (with-open-stream
      (s (ipc:open-network-stream :host *myself* :port port))
    (format s "~A~%" str)
    (force-output s) ))

(defvar *test-process* nil)

(defun test-port-daemon (tcp-stream)
  (let ((str (read-line tcp-stream)))
    (format t "Got ~S~%" str) ))

(defun setup-test-daemon (port)
  (when *test-process*
    (ipc::kill-lisp-server-process *test-process*) )
  (setq *test-process*
    (ipc::start-lisp-server-process
     :server-name "Test Daemon" :function #'test-port-daemon
     :inet-port port :raw-connection t ) ))

;;;----------------------------------------------------------------------------

Hope this helps.

    -- Don Geddis
--
Don Geddis        "It's too bad that whole families have to be torn apart
[e-mail]     by something as simple as wild dogs." -- DT on SNL
Hi, I'm a replicating signature virus!  Join in the fun and copy me into yours!