Commit 6adeeb3b authored by wlott's avatar wlott
Browse files

This commit was generated by cvs2svn to compensate for changes in r6863,

which included commits to RCS files with non-trunk default branches.
parents 6f1fb7fe d02cb20b
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/eval-server.lisp,v 1.1.1.14 1993/08/25 02:08:34 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/eval-server.lisp,v 1.1.1.15 1994/02/04 15:20:29 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -327,50 +327,56 @@ ...@@ -327,50 +327,56 @@
timeout and signal an editor-error." timeout and signal an editor-error."
(when (and name (getstring name *buffer-names*)) (when (and name (getstring name *buffer-names*))
(editor-error "Buffer ~A is already in use." name)) (editor-error "Buffer ~A is already in use." name))
(multiple-value-bind (slave background) (let ((lisp (unix-namestring (merge-pathnames (value slave-utility) "path:")
(if name t t)))
(values name (format nil "Background ~A" name)) (unless lisp
(pick-slave-buffer-names)) (editor-error "Can't find ``~S'' in your path to run."
(when (value confirm-slave-creation) (value slave-utility)))
(setf slave (prompt-for-string (multiple-value-bind (slave background)
:prompt "New slave name? " (if name
:help "Enter the name to use for the newly created slave." (values name (format nil "Background ~A" name))
:default slave (pick-slave-buffer-names))
:default-string slave)) (when (value confirm-slave-creation)
(setf background (format nil "Background ~A" slave)) (setf slave (prompt-for-string
(when (getstring slave *buffer-names*) :prompt "New slave name? "
(editor-error "Buffer ~A is already in use." slave)) :help "Enter the name to use for the newly created slave."
(when (getstring background *buffer-names*) :default slave
(editor-error "Buffer ~A is already in use." background))) :default-string slave))
(message "Spawning slave ... ") (setf background (format nil "Background ~A" slave))
(let ((proc (when (getstring slave *buffer-names*)
(ext:run-program (value slave-utility) (editor-error "Buffer ~A is already in use." slave))
`("-slave" ,(get-editor-name) (when (getstring background *buffer-names*)
,@(if slave (list "-slave-buffer" slave)) (editor-error "Buffer ~A is already in use." background)))
,@(if background (message "Spawning slave ... ")
(list "-background-buffer" background)) (let ((proc
,@(value slave-utility-switches)) (ext:run-program lisp
:wait nil `("-slave" ,(get-editor-name)
:output "/dev/null" ,@(if slave (list "-slave-buffer" slave))
:if-output-exists :append)) ,@(if background
(*accept-connections* t) (list "-background-buffer" background))
(*newly-created-slave* nil)) ,@(value slave-utility-switches))
(unless proc :wait nil
(editor-error "Could not start slave.")) :output "/dev/null"
(dotimes (i *slave-connect-wait* :if-output-exists :append))
(editor-error "Client Lisp is still unconnected. ~ (*accept-connections* t)
You must use \"Accept Slave Connections\" to ~ (*newly-created-slave* nil))
allow the slave to connect at this point.")) (unless proc
(system:serve-event 1) (editor-error "Could not start slave."))
(case (ext:process-status proc) (dotimes (i *slave-connect-wait*
(:exited (editor-error
(editor-error "The slave lisp exited before connecting.")) "Client Lisp is still unconnected. ~
(:signaled You must use \"Accept Slave Connections\" to ~
(editor-error "The slave lisp was kill before connecting."))) allow the slave to connect at this point."))
(when *newly-created-slave* (system:serve-event 1)
(message "DONE") (case (ext:process-status proc)
(return *newly-created-slave*)))))) (:exited
(editor-error "The slave lisp exited before connecting."))
(:signaled
(editor-error "The slave lisp was kill before connecting.")))
(when *newly-created-slave*
(message "DONE")
(return *newly-created-slave*)))))))
;;; MAYBE-CREATE-SERVER -- Internal interface. ;;; MAYBE-CREATE-SERVER -- Internal interface.
;;; ;;;
(defun maybe-create-server () (defun maybe-create-server ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment