Return to tcplisp.el CVS log

Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / dist-1.3 / fi

Annotation of 43BSDReno/contrib/emacs-18.55/dist-1.3/fi/tcplisp.el, revision 1.1

1.1     ! root        1: ;;
        !             2: ;; copyright (C) 1987, 1988 Franz Inc, Berkeley, Ca.
        !             3: ;;
        !             4: ;; The software, data and information contained herein are the property 
        !             5: ;; of Franz, Inc.  
        !             6: ;;
        !             7: ;; This file (or any derivation of it) may be distributed without 
        !             8: ;; further permission from Franz Inc. as long as:
        !             9: ;;
        !            10: ;;     * it is not part of a product for sale,
        !            11: ;;     * no charge is made for the distribution, other than a tape
        !            12: ;;       fee, and
        !            13: ;;     * all copyright notices and this notice are preserved.
        !            14: ;;
        !            15: ;; If you have any comments or questions on this interface, please feel
        !            16: ;; free to contact Franz Inc. at
        !            17: ;;     Franz Inc.
        !            18: ;;     Attn: Kevin Layer
        !            19: ;;     1995 University Ave
        !            20: ;;     Suite 275
        !            21: ;;     Berkeley, CA 94704
        !            22: ;;     (415) 548-3600
        !            23: ;; or
        !            24: ;;     emacs-info%[email protected]
        !            25: ;;     ucbvax!franz!emacs-info
        !            26: ;;
        !            27: ;; $Header: tcplisp.el,v 1.11 88/11/21 13:37:02 layer Exp $
        !            28: ;;
        !            29: ;; Description:
        !            30: ;;  Implemented in this file are the backdoor lisp listener and lisp
        !            31: ;;  evalserver.
        !            32: 
        !            33: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !            34: ;;;;;;;;;;;;;;;;;;;;; The Backdoor Lisp Listener ;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !            35: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !            36: 
        !            37: ;;;;
        !            38: ;;; User Visibles
        !            39: ;;;;
        !            40: 
        !            41: (defvar fi:unix-domain t
        !            42:   "*If non-nil, then `fi:unix-domain-socket' specifies the name of the
        !            43: socket file.  It is recommended that this interface be used, and not
        !            44: internet ports, because when internet ports are used only one process on a
        !            45: machine may use this interface (it is a global resource).  When using UNIX
        !            46: domain sockets, communication is done through a socket file in the user's
        !            47: home directory.  But, if you really want to use internet ports, here are
        !            48: the steps to take:
        !            49: 
        !            50: 1. Set this variable to nil.
        !            51: 2. Add the following line to /etc/services:
        !            52:        excl            6789/tcp
        !            53: 3. Make sure `fi:local-host-name' is in /etc/hosts and points to the local
        !            54: or loopback host.
        !            55: 4. On the Common Lisp side, put the following in you .clinit.cl file:
        !            56:        (setq ipc:*inet-port* 6789)     ; the number from /etc/services
        !            57:        (setq ipc:*unix-domain* nil)
        !            58: 
        !            59: The problem with this, is that people can then use `telnet' to get a
        !            60: listener on your lisp!")
        !            61: 
        !            62: (defvar fi:unix-domain-socket "~/.excl_to_emacs"
        !            63:   "*The name of the socket file that lisp and emacs use to communicate.
        !            64: This is used when fi:unix-domain is non-nil.")
        !            65: 
        !            66: (defvar fi:local-host-name "localhost"
        !            67:   "*On 4.2 BSD the name of 127.1--usually localhost or loopback.
        !            68: This is only used when fi:unix-domain is nil.")
        !            69: 
        !            70: (defvar fi:excl-service-name "excl"
        !            71:   "*The service name from /etc/services (`tcp' type).  This is only used
        !            72: when fi:unix-domain is nil.")
        !            73: 
        !            74: (defvar fi:source-info-not-found-hook 'find-tag
        !            75:   "*The value of this variable is funcalled when source information is not
        !            76: present in Lisp for a symbol.  The function is given one argument, the name
        !            77: for which source is desired (a string).  The null string means use the word
        !            78: at the point as the search word.  This allows the GNU Emacs tags facility
        !            79: to be used when the information is not present in Lisp.")
        !            80: 
        !            81: ;;;;
        !            82: ;;; Internals
        !            83: ;;;;
        !            84: 
        !            85: (defvar fi::lisp-macroexpand-command
        !            86:   "(progn
        !            87:     (errorset
        !            88:      (let ((*print-pretty* t)(excl::*print-nickname* t)(*package* %s))
        !            89:        (with-open-file (*standard-input* \"%s\")
        !            90:         (lisp:prin1 (%s (lisp:read)))))
        !            91:      t)
        !            92:     (values))\n")
        !            93: 
        !            94: (defvar fi::backdoor-process nil
        !            95:   "Process connected to sublist socket for fi:lisp-arglist and friends.")
        !            96: 
        !            97: (defvar fi::backdoor-read-eval-loop
        !            98:   "(progn
        !            99:  (setf (getf (mp:process-property-list mp:*current-process*)
        !           100:              ':no-interrupts)
        !           101:        t)
        !           102:  (loop
        !           103:   (princ \"&\n\")
        !           104:   (errorset (eval (read)) t)))\n"
        !           105:  "The program executed by the backdoor lisp listener.")
        !           106: 
        !           107: (defun fi:backdoor-eval (string &rest args)
        !           108:   "Evaluate apply format to STRING and ARGS and evaluate this in Common
        !           109: Lisp at the other end of our socket."
        !           110:   (if (fi::background-sublisp-process)
        !           111:       (process-send-string
        !           112:        fi::backdoor-process
        !           113:        (format "(progn (format t \"\1\") %s)\n"
        !           114:               (apply 'format string args)))
        !           115:     (error "The backdoor listener to Lisp is not responding.")))
        !           116: 
        !           117: (defun fi::background-sublisp-process ()
        !           118:   (if (or (null fi::backdoor-process)
        !           119:          (not (eq (process-status fi::backdoor-process) 'open)))
        !           120:       (progn
        !           121:        (and fi::backdoor-process
        !           122:             (delete-process fi::backdoor-process))
        !           123:        (setq fi::backdoor-process
        !           124:          (condition-case ()
        !           125:              (if fi:unix-domain
        !           126:                  (open-network-stream "lisp-backdoor" nil
        !           127:                                       (expand-file-name fi:unix-domain-socket)
        !           128:                                       0)
        !           129:                (open-network-stream "lisp-backdoor" nil fi:local-host-name
        !           130:                                     fi:excl-service-name))
        !           131:            (error nil)))
        !           132:        (if fi::backdoor-process
        !           133:            (progn
        !           134:              (setq fi::sublisp-returns-state nil)
        !           135:              (process-send-string      ; first send the process name
        !           136:               fi::backdoor-process
        !           137:               (format "\"%s\"" "GNU Listener"))
        !           138:              (process-send-string fi::backdoor-process
        !           139:                                   fi::backdoor-read-eval-loop)
        !           140:              (set-process-filter fi::backdoor-process
        !           141:                                  'fi::backdoor-filter)))))
        !           142:   fi::backdoor-process)
        !           143: 
        !           144: ;; This is the filter for the back door lisp process.
        !           145: ;; It collects output until it sees a ctl-A\n, then prints the preceding
        !           146: ;; collected text.  If the text fits on one line, it is printed to the message
        !           147: ;; area.  Otherwise it goes to a temporary pop up buffer.
        !           148: 
        !           149: (defvar fi::sublisp-returns "")
        !           150: (defvar fi::sublisp-returns-state nil)
        !           151: 
        !           152: (defun fi::backdoor-filter (proc string)
        !           153:   ;; This collects everything returned until a ^A\n prompt is seen,
        !           154:   ;; then displays it.  The first time is special cased to throw away
        !           155:   ;; the initial prompt without display.  Someday we should use the state
        !           156:   ;; variable for detecting screwups and coordinating reset.
        !           157:   ;; The \n is part of the prompt so that a subsequent prettyprint isn't
        !           158:   ;; confused about the starting column.
        !           159:   ;;
        !           160:   ;; The first character has special meaning:
        !           161:   ;;  ^A  toss the output from lisp after eval (for fi:backdoor-eval)
        !           162:   ;;  ^B  for fi:lisp-find-tag
        !           163:   ;;  ^C  for fi:lisp-find-tag-other-window
        !           164:   (setq fi::sublisp-returns (concat fi::sublisp-returns string))
        !           165:   (let ((len (length fi::sublisp-returns)))
        !           166:     (if (and (= 10 (aref fi::sublisp-returns (- len 1))); newline
        !           167:             (= 1 (aref fi::sublisp-returns (- len 2))))
        !           168:        (if (eq fi::sublisp-returns-state nil); ignore the startup response
        !           169:            (setq fi::sublisp-returns-state t
        !           170:                  fi::sublisp-returns "")
        !           171:          (progn (setq fi::sublisp-returns
        !           172:                   (substring fi::sublisp-returns
        !           173:                              (progn (string-match "\n*" fi::sublisp-returns)
        !           174:                                     (match-end 0))
        !           175:                              -2))
        !           176:                 (let ((first-char (elt fi::sublisp-returns 0)))
        !           177:                   (cond
        !           178:                     ((= first-char 1)
        !           179:                      ;;throw away the result
        !           180:                      (setq fi::sublisp-returns ""))
        !           181:                     ((or (= first-char 2) (= first-char 3))
        !           182:                      (fi::backdoor-find-tag-request (= first-char 3)))
        !           183:                     (t  
        !           184:                      (if (or (> (length fi::sublisp-returns) 78)
        !           185:                              ;; should be mbuf width
        !           186:                              (string-match "\n" fi::sublisp-returns nil))
        !           187:                          (with-output-to-temp-buffer "*CL-Help*"
        !           188:                            (princ fi::sublisp-returns))
        !           189:                        (message fi::sublisp-returns))
        !           190:                      (setq fi::sublisp-returns "")))))))))
        !           191: 
        !           192: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !           193: ;;;;;;;;;;;;;;;;;;;;;;;; The Lisp Eval Server ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !           194: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !           195: 
        !           196: ;;;;
        !           197: ;;; User Visibles
        !           198: ;;;;
        !           199: 
        !           200: (defconst fi:lisp-evalserver-timeout 5
        !           201:   "The time which fi:eval-in-lisp will wait before timing out and
        !           202: signalling an error.  Without a timeout Emacs would potentially be locked
        !           203: out if Lisp did not `return' a result.")
        !           204: 
        !           205: (defconst fi:lisp-evalserver-number-reads 20
        !           206:   "The number of times the Lisp eval server tries to read from the
        !           207: lisp-evalserver process before giving up.  Without this feature Emacs would
        !           208: hang if Lisp got into an infinite loop while printing.  If the size of the
        !           209: values returned to Emacs is large, then the value of this variable should
        !           210: be increased.")
        !           211: 
        !           212: (defun fi:eval-in-lisp (string &rest args)
        !           213:   "Apply format (in Emacs) to STRING and ARGS and evaluate the result
        !           214: in the Common Lisp to which we are connected.  If a lisp-eval-server has
        !           215: not been started, then this function starts it."
        !           216:   (if (not (fi::lisp-evalserver-process))
        !           217:       (error "The Lisp Eval Server is not responding."))
        !           218:   (setq fi::lisp-evalserver-response nil)
        !           219:   (setq fi::lisp-evalserver-returns "")
        !           220:   (process-send-string fi::lisp-evalserver-process
        !           221:                       (format "%s\n" (apply 'format string args)))
        !           222:   (accept-process-output fi::lisp-evalserver-process
        !           223:                         fi:lisp-evalserver-timeout)
        !           224:   (let ((i 0))
        !           225:     (while (and (< i fi:lisp-evalserver-number-reads)
        !           226:                fi::lisp-evalserver-collecting)
        !           227:       (accept-process-output fi::lisp-evalserver-process
        !           228:                             fi:lisp-evalserver-timeout)
        !           229:       (setq i (+ i 1))))
        !           230:   (if (null fi::lisp-evalserver-response)
        !           231:       (error "timeout (%d secs) on response from lisp!"
        !           232:             fi:lisp-evalserver-timeout))
        !           233:   (condition-case ()
        !           234:       (car (read-from-string fi::lisp-evalserver-returns))
        !           235:     (error (error "parse error: %s" fi::lisp-evalserver-returns))))
        !           236: 
        !           237: ;;;;
        !           238: ;;; Internals
        !           239: ;;;;
        !           240: 
        !           241: (defconst fi::lisp-evalserver-read-eval-loop
        !           242:   "(progn
        !           243:      (setf (getf (mp:process-property-list mp:*current-process*)
        !           244:            ':no-interrupts)
        !           245:            t)
        !           246:      (setq tpl::*prompt* \"\")
        !           247:      (loop (errorset (princ (with-output-to-string (*standard-output*)
        !           248:                                 (princ \"&\")
        !           249:                                 (prin1 (eval (read)))
        !           250:                                 (princ \"\")))
        !           251:                       t)))\n")
        !           252: 
        !           253: (defvar fi::lisp-evalserver-process nil)
        !           254: 
        !           255: (defun fi::lisp-evalserver-process ()
        !           256:   (if (or (null fi::lisp-evalserver-process)
        !           257:          (not (eq (process-status fi::lisp-evalserver-process) 'open)))
        !           258:       (progn
        !           259:        (and fi::lisp-evalserver-process
        !           260:             (delete-process fi::lisp-evalserver-process))
        !           261:        (setq fi::lisp-evalserver-process
        !           262:          (condition-case ()
        !           263:              (if fi:unix-domain
        !           264:                  (open-network-stream "lisp-evalserver" nil
        !           265:                                       (expand-file-name fi:unix-domain-socket)
        !           266:                                       0)
        !           267:                (open-network-stream "lisp-evalserver" nil fi:local-host-name
        !           268:                                     fi:excl-service-name))
        !           269:            (error nil)))
        !           270:        (if fi::lisp-evalserver-process
        !           271:            (progn
        !           272:              (setq fi::sublisp-returns-state nil)
        !           273:              (process-send-string      ; first send the process name
        !           274:               fi::lisp-evalserver-process
        !           275:               (format "\"%s\"" "Lisp Eval Server"))
        !           276:              (process-send-string fi::lisp-evalserver-process
        !           277:                                   fi::lisp-evalserver-read-eval-loop)
        !           278:              ;; wait for the prompt
        !           279:              (accept-process-output fi::lisp-evalserver-process)
        !           280:              (set-process-filter fi::lisp-evalserver-process
        !           281:                                  'fi::lisp-evalserver-filter)))))
        !           282:   fi::lisp-evalserver-process)
        !           283: 
        !           284: (defconst fi::lisp-evalserver-returns "")
        !           285: (defconst fi::lisp-evalserver-response nil)
        !           286: (defconst fi::lisp-evalserver-counter 0)
        !           287: (defconst fi::lisp-evalserver-collecting nil)
        !           288: 
        !           289: (defun fi::lisp-evalserver-filter (proc string)
        !           290:   (setq fi::lisp-evalserver-counter (+ 1 fi::lisp-evalserver-counter))
        !           291:   (let ((len (length string)))
        !           292:     (cond
        !           293:       ((> len 0)
        !           294:        (if (/= (elt string 0) ?&)
        !           295:         (setq string (concat fi::lisp-evalserver-returns string)))
        !           296: 
        !           297:        (setq len (length string))
        !           298:        (if (and (= (elt string 0) ?&)
        !           299:                (= (elt string (- len 1)) ?))
        !           300:           (setq fi::lisp-evalserver-returns (substring string 1 (- len 1))
        !           301:                 fi::lisp-evalserver-collecting nil
        !           302:                 fi::lisp-evalserver-response t)
        !           303:         (setq fi::lisp-evalserver-returns string
        !           304:               fi::lisp-evalserver-collecting t))))))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.