Communicating Lisp images

[cutting@sics.se]

   Date: 	Fri, 11 Jun 1993 10:01:58 PDT
   From: bha <bha%gumby.boeing.com@ada3.ca.boeing.com>

   Do you have any examples/samples of code that facilitates
   communication between two ACL images?  What I want to do is implement
   a simple eval server where an ACL image (4.2beta) acts as a client and
   communicates with an ICAD image (ACL 4.1beta) acting as a server.

We've used the following in ACL 4.1, mostly to talk to lisp from shell
scripts, but it also works from lisp to lisp.  A sample client is
given at the end.  Enjoy.

	Doug

(eval-when (compile eval load)
  (require :ipc)
  (require :process))

(cl:defpackage :eval-service
  (:use :common-lisp :ipc :mp)
  (:export *eval-service-port* eval-server *eval-server-stream* force-prin1))

(cl:in-package :eval-service)

(defvar *eval-service-port* 4322)
(defvar *eval-server-stream* nil)

(defun eval-server (&key (port *eval-service-port*)
                         (binds `((*package* ,(find-package :cl-user))))
                         background)
  (start-lisp-listener-daemon :use-lep t :inet-port port :binds binds)
  (unless background
    (process-wait "waiting" #'(lambda (p) (not (process-active-p p)))
                  (process-name-to-process "TCP Listener Socket Daemon"))))

(defmethod start-process-for-network-stream (stream (p (eql :eval-service))
                                             &rest args)
  (apply #'process-run-function (read stream) #'eval-server-proc stream args))

(defun eval-server-proc (stream &key binds &allow-other-keys)
  (unwind-protect (eval-server-loop stream binds)
    (excl::clear-output-1 stream)
    (close stream)))

(defvar *tracing* t)

(defun eval-server-loop (stream binds
                         &aux (process-name (process-name *current-process*)))
  (handler-bind ((stream-error
                  #'(lambda (condition)
                      (when *tracing*
                        (format *error-output* "~&; ~A EXITING: ~?~%"
                                process-name
                                (simple-condition-format-control condition)
                                (simple-condition-format-arguments condition)))
                      (return-from eval-server-loop))))
     (let ((*eval-server-stream* stream)
           (*print-pretty* nil))
       (progv (mapcar #'car binds) (mapcar #'cadr binds)
         (when *tracing*
           (format *error-output* "~&; ~A OPEN~%" process-name))
         (loop (let ((form (error-trapping-read stream)))
                 (case form
                   (:exit (return))
                   (:error (force-prin1 :error stream))
                   (t (force-prin1 (error-trapping-eval form) stream)))))
         (when *tracing*
           (format *error-output* "~&; ~A EXIT~%" process-name))))))

(defun force-prin1 (obj stream)
  (prin1 obj stream)
  (terpri stream)
  (force-output stream))

(defun error-trapping-read (stream)
  (handler-bind ((simple-error
                  #'(lambda (condition)
                      (when *tracing*
                        (format *error-output* "~&; ~A READ ERROR: ~?~%"
                                (process-name *current-process*)
                                (simple-condition-format-control condition)
                                (simple-condition-format-arguments condition)))
                      ;; skip the rest of the input
                      ;; assume each input is contained on one line
                      (when (listen) (read-line stream))
                      (return-from error-trapping-read :error))))
    (read stream)))


(defun error-trapping-eval
    (form &aux (process-name (process-name *current-process*)))
  (when *tracing*
    (let ((*print-length* 5)
          (*print-level* 3))
      (format *error-output* "~&; ~A > ~S~%" process-name form)))
  (handler-bind ((simple-error
                  #'(lambda (condition)
                      (when *tracing*
                        (format *error-output* "~&; ~A EVAL ERROR: ~?~%"
                                process-name
                                (simple-condition-format-control condition)
                                (simple-condition-format-arguments condition)))
                      ;; all errors return :ERROR
                      (return-from error-trapping-eval :error))))
    (eval form)))


;;;; simple client

(defun remote-exec (host)
  ;; client side
  (let ((stream (open-network-stream :host host :port *eval-service-port*)))
    ;; first send type of connection and name
    (force-prin1 :eval-service stream)
    (force-prin1
     (format nil "~A@~A" (system:getenv "USER") (system:getenv "HOST"))
     stream)
    (loop
     (format t "~A > " host)
     (let ((input (read)))
       (force-prin1 input stream)
       (when (eq input :exit) (return))
       (force-prin1 (read stream) *standard-output*)))))