| 1 | ;;; -*- Log: hemlock.log; Package: Hemlock -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; **********************************************************************
|
|---|
| 4 | ;;; This code was written as part of the CMU Common Lisp project at
|
|---|
| 5 | ;;; Carnegie Mellon University, and has been placed in the public domain.
|
|---|
| 6 | ;;;
|
|---|
| 7 | (hemlock-ext:file-comment
|
|---|
| 8 | "$Header$")
|
|---|
| 9 | ;;;
|
|---|
| 10 | ;;; **********************************************************************
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; This file contains code for connecting to eval servers and some command
|
|---|
| 13 | ;;; level stuff too.
|
|---|
| 14 | ;;;
|
|---|
| 15 | ;;; Written by William Lott.
|
|---|
| 16 | ;;;
|
|---|
| 17 |
|
|---|
| 18 | (in-package :hemlock)
|
|---|
| 19 |
|
|---|
| 20 |
|
|---|
| 21 | |
|---|
| 22 |
|
|---|
| 23 | ;;;; Structures.
|
|---|
| 24 |
|
|---|
| 25 | (defstruct (server-info (:print-function print-server-info))
|
|---|
| 26 | name ; String name of this server.
|
|---|
| 27 | wire ; Wire connected to this server.
|
|---|
| 28 | notes ; List of note objects for operations
|
|---|
| 29 | ; which have not yet completed.
|
|---|
| 30 | slave-info ; Ts-Info used in "Slave Lisp" buffer
|
|---|
| 31 | ; (formerly the "Lisp Listener" buffer).
|
|---|
| 32 | slave-buffer ; "Slave Lisp" buffer for slave's *terminal-io*.
|
|---|
| 33 | background-info ; Ts-Info structure of typescript we use in
|
|---|
| 34 | ; "background" buffer.
|
|---|
| 35 | background-buffer ; Buffer "background" typescript is in.
|
|---|
| 36 | (errors ; Array of errors while compiling
|
|---|
| 37 | (make-array 16 :adjustable t :fill-pointer 0))
|
|---|
| 38 | error-index) ; Index of current error.
|
|---|
| 39 | ;;;
|
|---|
| 40 | (defun print-server-info (obj stream n)
|
|---|
| 41 | (declare (ignore n))
|
|---|
| 42 | (format stream "#<Server-info for ~A>" (server-info-name obj)))
|
|---|
| 43 |
|
|---|
| 44 |
|
|---|
| 45 | (defstruct (error-info (:print-function print-error-info))
|
|---|
| 46 | buffer ; Buffer this error is for.
|
|---|
| 47 | message ; Error Message
|
|---|
| 48 | line ; Pointer to message in log buffer.
|
|---|
| 49 | region) ; Region of faulty text
|
|---|
| 50 | ;;;
|
|---|
| 51 | (defun print-error-info (obj stream n)
|
|---|
| 52 | (declare (ignore n))
|
|---|
| 53 | (format stream "#<Error: ~A>" (error-info-message obj)))
|
|---|
| 54 |
|
|---|
| 55 |
|
|---|
| 56 | (defvar *server-names* (make-string-table)
|
|---|
| 57 | "A string-table of the name of all Eval servers and their corresponding
|
|---|
| 58 | server-info structures.")
|
|---|
| 59 |
|
|---|
| 60 | (defvar *abort-operations* nil
|
|---|
| 61 | "T iff we should ignore any operations sent to us.")
|
|---|
| 62 |
|
|---|
| 63 | (defvar *inside-operation* nil
|
|---|
| 64 | "T iff we are currenly working on an operation. A catcher for the tag
|
|---|
| 65 | abort-operation will be established whenever this is T.")
|
|---|
| 66 |
|
|---|
| 67 | (defconstant *slave-connect-wait* 300)
|
|---|
| 68 |
|
|---|
| 69 | ;;; Used internally for communications.
|
|---|
| 70 | ;;;
|
|---|
| 71 | (defvar *newly-created-slave* nil)
|
|---|
| 72 | (defvar *compiler-wire* nil)
|
|---|
| 73 | (defvar *compiler-error-stream* nil)
|
|---|
| 74 | (defvar *compiler-note* nil)
|
|---|
| 75 |
|
|---|
| 76 |
|
|---|
| 77 | |
|---|
| 78 |
|
|---|
| 79 | ;;;; Hemlock Variables
|
|---|
| 80 |
|
|---|
| 81 | (defhvar "Current Compile Server"
|
|---|
| 82 | "The Server-Info object for the server currently used for compilation
|
|---|
| 83 | requests."
|
|---|
| 84 | :value nil)
|
|---|
| 85 |
|
|---|
| 86 | (defhvar "Current Package"
|
|---|
| 87 | "This variable holds the name of the package currently used for Lisp
|
|---|
| 88 | evaluation and compilation. If it is Nil, the value of *Package* is used
|
|---|
| 89 | instead."
|
|---|
| 90 | :value nil)
|
|---|
| 91 |
|
|---|
| 92 | (defhvar "Slave Utility"
|
|---|
| 93 | "This is the pathname of the utility to fire up slave Lisps. It defaults
|
|---|
| 94 | to \"cmucl\"."
|
|---|
| 95 | :value "cmucl")
|
|---|
| 96 |
|
|---|
| 97 | (defhvar "Slave Utility Switches"
|
|---|
| 98 | "These are additional switches to pass to the Slave Utility.
|
|---|
| 99 | For example, (list \"-core\" <core-file-name>). The -slave
|
|---|
| 100 | switch and the editor name are always supplied, and they should
|
|---|
| 101 | not be present in this variable."
|
|---|
| 102 | :value nil)
|
|---|
| 103 |
|
|---|
| 104 | (defhvar "Ask About Old Servers"
|
|---|
| 105 | "When set (the default), Hemlock will prompt for an existing server's name
|
|---|
| 106 | in preference to prompting for a new slave's name and creating it."
|
|---|
| 107 | :value t)
|
|---|
| 108 |
|
|---|
| 109 | (defhvar "Confirm Slave Creation"
|
|---|
| 110 | "When set (the default), Hemlock always confirms a slave's creation for
|
|---|
| 111 | whatever reason."
|
|---|
| 112 | :value t)
|
|---|
| 113 |
|
|---|
| 114 |
|
|---|
| 115 | (defhvar "Slave GC Alarm"
|
|---|
| 116 | "Determines that is done when the slave notifies that it is GCing.
|
|---|
| 117 | :MESSAGE prints a message in the echo area, :LOUD-MESSAGE beeps as well.
|
|---|
| 118 | NIL does nothing."
|
|---|
| 119 | :value :message)
|
|---|
| 120 |
|
|---|
| 121 | |
|---|
| 122 |
|
|---|
| 123 | ;;;; Slave destruction.
|
|---|
| 124 |
|
|---|
| 125 | ;;; WIRE-DIED -- Internal.
|
|---|
| 126 | ;;;
|
|---|
| 127 | ;;; The routine is called whenever a wire dies. We roll through all the
|
|---|
| 128 | ;;; servers looking for any that use this wire and nuke them with server-died.
|
|---|
| 129 | ;;;
|
|---|
| 130 | (defun wire-died (wire)
|
|---|
| 131 | (let ((servers nil))
|
|---|
| 132 | (do-strings (name info *server-names*)
|
|---|
| 133 | (declare (ignore name))
|
|---|
| 134 | (when (eq wire (server-info-wire info))
|
|---|
| 135 | (push info servers)))
|
|---|
| 136 | (dolist (server servers)
|
|---|
| 137 | (server-died server))))
|
|---|
| 138 |
|
|---|
| 139 | ;;; SERVER-DIED -- Internal.
|
|---|
| 140 | ;;;
|
|---|
| 141 | ;;; Clean up the server. Remove any references to it from variables, etc.
|
|---|
| 142 | ;;;
|
|---|
| 143 | (defun server-died (server)
|
|---|
| 144 | (declare (special *breakpoints*))
|
|---|
| 145 | (let ((name (server-info-name server)))
|
|---|
| 146 | (delete-string name *server-names*)
|
|---|
| 147 | (message "Server ~A just died." name))
|
|---|
| 148 | (when (server-info-wire server)
|
|---|
| 149 | #+NILGB
|
|---|
| 150 | (let ((fd (hemlock.wire:wire-fd (server-info-wire server))))
|
|---|
| 151 | (system:invalidate-descriptor fd)
|
|---|
| 152 | (unix:unix-close fd))
|
|---|
| 153 | (setf (server-info-wire server) nil))
|
|---|
| 154 | (when (server-info-slave-info server)
|
|---|
| 155 | (ts-buffer-wire-died (server-info-slave-info server))
|
|---|
| 156 | (setf (server-info-slave-info server) nil))
|
|---|
| 157 | (when (server-info-background-info server)
|
|---|
| 158 | (ts-buffer-wire-died (server-info-background-info server))
|
|---|
| 159 | (setf (server-info-background-info server) nil))
|
|---|
| 160 | (clear-server-errors server)
|
|---|
| 161 | (when (eq server (variable-value 'current-eval-server :global))
|
|---|
| 162 | (setf (variable-value 'current-eval-server :global) nil))
|
|---|
| 163 | (when (eq server (variable-value 'current-compile-server :global))
|
|---|
| 164 | (setf (variable-value 'current-compile-server :global) nil))
|
|---|
| 165 | (dolist (buffer *buffer-list*)
|
|---|
| 166 | (dolist (var '(current-eval-server current-compile-server server-info))
|
|---|
| 167 | (when (and (hemlock-bound-p var :buffer buffer)
|
|---|
| 168 | (eq (variable-value var :buffer buffer) server))
|
|---|
| 169 | (delete-variable var :buffer buffer))))
|
|---|
| 170 | (setf *breakpoints* (delete-if #'(lambda (b)
|
|---|
| 171 | (eq (breakpoint-info-slave b) server))
|
|---|
| 172 | *breakpoints*)))
|
|---|
| 173 |
|
|---|
| 174 | ;;; SERVER-CLEANUP -- Internal.
|
|---|
| 175 | ;;;
|
|---|
| 176 | ;;; This routine is called as a buffer delete hook. It takes care of any
|
|---|
| 177 | ;;; per-buffer cleanup that is necessary. It clears out all references to the
|
|---|
| 178 | ;;; buffer from server-info structures and that any errors that refer to this
|
|---|
| 179 | ;;; buffer are finalized.
|
|---|
| 180 | ;;;
|
|---|
| 181 | (defun server-cleanup (buffer)
|
|---|
| 182 | (let ((info (if (hemlock-bound-p 'server-info :buffer buffer)
|
|---|
| 183 | (variable-value 'server-info :buffer buffer))))
|
|---|
| 184 | (when info
|
|---|
| 185 | (when (eq buffer (server-info-slave-buffer info))
|
|---|
| 186 | (setf (server-info-slave-buffer info) nil)
|
|---|
| 187 | (setf (server-info-slave-info info) nil))
|
|---|
| 188 | (when (eq buffer (server-info-background-buffer info))
|
|---|
| 189 | (setf (server-info-background-buffer info) nil)
|
|---|
| 190 | (setf (server-info-background-info info) nil))))
|
|---|
| 191 | (do-strings (string server *server-names*)
|
|---|
| 192 | (declare (ignore string))
|
|---|
| 193 | (clear-server-errors server
|
|---|
| 194 | #'(lambda (error)
|
|---|
| 195 | (eq (error-info-buffer error) buffer)))))
|
|---|
| 196 | ;;;
|
|---|
| 197 | (add-hook delete-buffer-hook 'server-cleanup)
|
|---|
| 198 |
|
|---|
| 199 | ;;; CLEAR-SERVER-ERRORS -- Public.
|
|---|
| 200 | ;;;
|
|---|
| 201 | ;;; Clears all known errors for the given server and resets it so more can
|
|---|
| 202 | ;;; accumulate.
|
|---|
| 203 | ;;;
|
|---|
| 204 | (defun clear-server-errors (server &optional test-fn)
|
|---|
| 205 | "This clears compiler errors for server cleaning up any pointers for GC
|
|---|
| 206 | purposes and allowing more errors to register."
|
|---|
| 207 | (let ((array (server-info-errors server))
|
|---|
| 208 | (current nil))
|
|---|
| 209 | (dotimes (i (fill-pointer array))
|
|---|
| 210 | (let ((error (aref array i)))
|
|---|
| 211 | (when (or (null test-fn)
|
|---|
| 212 | (funcall test-fn error))
|
|---|
| 213 | (let ((region (error-info-region error)))
|
|---|
| 214 | (when (regionp region)
|
|---|
| 215 | (delete-mark (region-start region))
|
|---|
| 216 | (delete-mark (region-end region))))
|
|---|
| 217 | (setf (aref array i) nil))))
|
|---|
| 218 | (let ((index (server-info-error-index server)))
|
|---|
| 219 | (when index
|
|---|
| 220 | (setf current
|
|---|
| 221 | (or (aref array index)
|
|---|
| 222 | (find-if-not #'null array
|
|---|
| 223 | :from-end t
|
|---|
| 224 | :end current)))))
|
|---|
| 225 | (delete nil array)
|
|---|
| 226 | (setf (server-info-error-index server)
|
|---|
| 227 | (position current array))))
|
|---|
| 228 |
|
|---|
| 229 |
|
|---|
| 230 | |
|---|
| 231 |
|
|---|
| 232 | ;;;; Slave creation.
|
|---|
| 233 |
|
|---|
| 234 | ;;; INITIALIZE-SERVER-STUFF -- Internal.
|
|---|
| 235 | ;;;
|
|---|
| 236 | ;;; Reinitialize stuff when a core file is saved.
|
|---|
| 237 | ;;;
|
|---|
| 238 | (defun initialize-server-stuff ()
|
|---|
| 239 | (clrstring *server-names*))
|
|---|
| 240 |
|
|---|
| 241 |
|
|---|
| 242 | (defvar *editor-name* nil "Name of this editor.")
|
|---|
| 243 | (defvar *accept-connections* nil
|
|---|
| 244 | "When set, allow slaves to connect to the editor.")
|
|---|
| 245 |
|
|---|
| 246 | ;;; GET-EDITOR-NAME -- Internal.
|
|---|
| 247 | ;;;
|
|---|
| 248 | ;;; Pick a name for the editor. Names consist of machine-name:port-number. If
|
|---|
| 249 | ;;; in ten tries we can't get an unused port, choak. We don't save the result
|
|---|
| 250 | ;;; of HEMLOCK.WIRE:CREATE-REQUEST-SERVER because we don't think the editor needs to
|
|---|
| 251 | ;;; ever kill the request server, and we can always inhibit connection with
|
|---|
| 252 | ;;; "Accept Connections".
|
|---|
| 253 | ;;;
|
|---|
| 254 | (defun get-editor-name ()
|
|---|
| 255 | (if *editor-name*
|
|---|
| 256 | *editor-name*
|
|---|
| 257 | (let ((random-state (make-random-state t)))
|
|---|
| 258 | (dotimes (tries 10 (error "Could not create an internet listener."))
|
|---|
| 259 | (let ((port (+ 2000 (random 10000 random-state))))
|
|---|
| 260 | (setf port 4711) ;###
|
|---|
| 261 | (when (handler-case (hemlock.wire:create-request-server
|
|---|
| 262 | port
|
|---|
| 263 | #'(lambda (wire addr)
|
|---|
| 264 | (declare (ignore addr))
|
|---|
| 265 | (values *accept-connections*
|
|---|
| 266 | #'(lambda () (wire-died wire)))))
|
|---|
| 267 | (error () nil))
|
|---|
| 268 | (return (setf *editor-name*
|
|---|
| 269 | (format nil "~A:~D" (machine-instance) port)))))))))
|
|---|
| 270 |
|
|---|
| 271 |
|
|---|
| 272 | ;;; MAKE-BUFFERS-FOR-TYPESCRIPT -- Internal.
|
|---|
| 273 | ;;;
|
|---|
| 274 | ;;; This function returns no values because it is called remotely for value by
|
|---|
| 275 | ;;; connecting slaves. Though we know the system will propagate nil back to
|
|---|
| 276 | ;;; the slave, we indicate here that nil is meaningless.
|
|---|
| 277 | ;;;
|
|---|
| 278 | (defun make-buffers-for-typescript (slave-name background-name)
|
|---|
| 279 | "Make the interactive and background buffers slave-name and background-name.
|
|---|
| 280 | If either is nil, then prompt the user."
|
|---|
| 281 | (multiple-value-bind (slave-name background-name)
|
|---|
| 282 | (cond ((not (and slave-name background-name))
|
|---|
| 283 | (pick-slave-buffer-names))
|
|---|
| 284 | ((getstring slave-name *server-names*)
|
|---|
| 285 | (multiple-value-bind
|
|---|
| 286 | (new-sn new-bn)
|
|---|
| 287 | (pick-slave-buffer-names)
|
|---|
| 288 | (message "~S is already an eval server; ~
|
|---|
| 289 | using ~S instead."
|
|---|
| 290 | slave-name new-sn)
|
|---|
| 291 | (values new-sn new-bn)))
|
|---|
| 292 | (t (values slave-name background-name)))
|
|---|
| 293 | (let* ((slave-buffer (or (getstring slave-name *buffer-names*)
|
|---|
| 294 | (make-buffer slave-name :modes '("Lisp"))))
|
|---|
| 295 | (background-buffer (or (getstring background-name *buffer-names*)
|
|---|
| 296 | (make-buffer background-name
|
|---|
| 297 | :modes '("Lisp"))))
|
|---|
| 298 | (server-info (make-server-info :name slave-name
|
|---|
| 299 | :wire hemlock.wire:*current-wire*
|
|---|
| 300 | :slave-buffer slave-buffer
|
|---|
| 301 | :background-buffer background-buffer))
|
|---|
| 302 | (slave-info (typescriptify-buffer slave-buffer server-info
|
|---|
| 303 | hemlock.wire:*current-wire*))
|
|---|
| 304 | (background-info (typescriptify-buffer background-buffer server-info
|
|---|
| 305 | hemlock.wire:*current-wire*)))
|
|---|
| 306 | (setf (server-info-slave-info server-info) slave-info)
|
|---|
| 307 | (setf (server-info-background-info server-info) background-info)
|
|---|
| 308 | (setf (getstring slave-name *server-names*) server-info)
|
|---|
| 309 | (unless (variable-value 'current-eval-server :global)
|
|---|
| 310 | (setf (variable-value 'current-eval-server :global) server-info))
|
|---|
| 311 | (hemlock.wire:remote-value
|
|---|
| 312 | hemlock.wire:*current-wire*
|
|---|
| 313 | (made-buffers-for-typescript (hemlock.wire:make-remote-object slave-info)
|
|---|
| 314 | (hemlock.wire:make-remote-object background-info)))
|
|---|
| 315 | (setf *newly-created-slave* server-info)
|
|---|
| 316 | (values))))
|
|---|
| 317 |
|
|---|
| 318 |
|
|---|
| 319 | ;;; CREATE-SLAVE -- Public.
|
|---|
| 320 | ;;;
|
|---|
| 321 | #+NILGB
|
|---|
| 322 | (defun create-slave (&optional name)
|
|---|
| 323 | "This creates a slave that tries to connect to the editor. When the slave
|
|---|
| 324 | connects to the editor, this returns a slave-information structure. Name is
|
|---|
| 325 | the name of the interactive buffer. If name is nil, this generates a name.
|
|---|
| 326 | If name is supplied, and a buffer with that name already exists, this
|
|---|
| 327 | signals an error. In case the slave never connects, this will eventually
|
|---|
| 328 | timeout and signal an editor-error."
|
|---|
| 329 | (when (and name (getstring name *buffer-names*))
|
|---|
| 330 | (editor-error "Buffer ~A is already in use." name))
|
|---|
| 331 | (let ((lisp (unix-namestring (merge-pathnames (value slave-utility) "path:")
|
|---|
| 332 | t t)))
|
|---|
| 333 | (unless lisp
|
|---|
| 334 | (editor-error "Can't find ``~S'' in your path to run."
|
|---|
| 335 | (value slave-utility)))
|
|---|
| 336 | (multiple-value-bind (slave background)
|
|---|
| 337 | (if name
|
|---|
| 338 | (values name (format nil "Background ~A" name))
|
|---|
| 339 | (pick-slave-buffer-names))
|
|---|
| 340 | (when (value confirm-slave-creation)
|
|---|
| 341 | (setf slave (prompt-for-string
|
|---|
| 342 | :prompt "New slave name? "
|
|---|
| 343 | :help "Enter the name to use for the newly created slave."
|
|---|
| 344 | :default slave
|
|---|
| 345 | :default-string slave))
|
|---|
| 346 | (setf background (format nil "Background ~A" slave))
|
|---|
| 347 | (when (getstring slave *buffer-names*)
|
|---|
| 348 | (editor-error "Buffer ~A is already in use." slave))
|
|---|
| 349 | (when (getstring background *buffer-names*)
|
|---|
| 350 | (editor-error "Buffer ~A is already in use." background)))
|
|---|
| 351 | (message "Spawning slave ... ")
|
|---|
| 352 | (let ((proc
|
|---|
| 353 | (ext:run-program lisp
|
|---|
| 354 | `("-slave" ,(get-editor-name)
|
|---|
| 355 | ,@(if slave (list "-slave-buffer" slave))
|
|---|
| 356 | ,@(if background
|
|---|
| 357 | (list "-background-buffer" background))
|
|---|
| 358 | ,@(value slave-utility-switches))
|
|---|
| 359 | :wait nil
|
|---|
| 360 | :output "/dev/null"
|
|---|
| 361 | :if-output-exists :append))
|
|---|
| 362 | (*accept-connections* t)
|
|---|
| 363 | (*newly-created-slave* nil))
|
|---|
| 364 | (unless proc
|
|---|
| 365 | (editor-error "Could not start slave."))
|
|---|
| 366 | (dotimes (i *slave-connect-wait*
|
|---|
| 367 | (editor-error
|
|---|
| 368 | "Client Lisp is still unconnected. ~
|
|---|
| 369 | You must use \"Accept Slave Connections\" to ~
|
|---|
| 370 | allow the slave to connect at this point."))
|
|---|
| 371 | (system:serve-event 1)
|
|---|
| 372 | (case (ext:process-status proc)
|
|---|
| 373 | (:exited
|
|---|
| 374 | (editor-error "The slave lisp exited before connecting."))
|
|---|
| 375 | (:signaled
|
|---|
| 376 | (editor-error "The slave lisp was kill before connecting.")))
|
|---|
| 377 | (when *newly-created-slave*
|
|---|
| 378 | (message "DONE")
|
|---|
| 379 | (return *newly-created-slave*)))))))
|
|---|
| 380 |
|
|---|
| 381 | ;;; MAYBE-CREATE-SERVER -- Internal interface.
|
|---|
| 382 | ;;;
|
|---|
| 383 | (defun maybe-create-server ()
|
|---|
| 384 | "If there is an existing server and \"Ask about Old Servers\" is set, then
|
|---|
| 385 | prompt for a server's name and return that server's info. Otherwise,
|
|---|
| 386 | create a new server."
|
|---|
| 387 | (if (value ask-about-old-servers)
|
|---|
| 388 | (multiple-value-bind (first-server-name first-server-info)
|
|---|
| 389 | (do-strings (name info *server-names*)
|
|---|
| 390 | (return (values name info)))
|
|---|
| 391 | (if first-server-info
|
|---|
| 392 | (multiple-value-bind
|
|---|
| 393 | (name info)
|
|---|
| 394 | (prompt-for-keyword (list *server-names*)
|
|---|
| 395 | :prompt "Existing server name: "
|
|---|
| 396 | :default first-server-name
|
|---|
| 397 | :default-string first-server-name
|
|---|
| 398 | :help
|
|---|
| 399 | "Enter the name of an existing eval server."
|
|---|
| 400 | :must-exist t)
|
|---|
| 401 | (declare (ignore name))
|
|---|
| 402 | (or info (create-slave)))
|
|---|
| 403 | (create-slave)))
|
|---|
| 404 | (create-slave)))
|
|---|
| 405 |
|
|---|
| 406 |
|
|---|
| 407 | (defvar *next-slave-index* 0
|
|---|
| 408 | "Number to use when creating the next slave.")
|
|---|
| 409 |
|
|---|
| 410 | ;;; PICK-SLAVE-BUFFER-NAMES -- Internal.
|
|---|
| 411 | ;;;
|
|---|
| 412 | ;;; Return two unused names to use for the slave and background buffers.
|
|---|
| 413 | ;;;
|
|---|
| 414 | (defun pick-slave-buffer-names ()
|
|---|
| 415 | (loop
|
|---|
| 416 | (let ((slave (format nil "Slave ~D" (incf *next-slave-index*)))
|
|---|
| 417 | (background (format nil "Background Slave ~D" *next-slave-index*)))
|
|---|
| 418 | (unless (or (getstring slave *buffer-names*)
|
|---|
| 419 | (getstring background *buffer-names*))
|
|---|
| 420 | (return (values slave background))))))
|
|---|
| 421 |
|
|---|
| 422 |
|
|---|
| 423 | |
|---|
| 424 |
|
|---|
| 425 | ;;;; Slave selection.
|
|---|
| 426 |
|
|---|
| 427 | ;;; GET-CURRENT-EVAL-SERVER -- Public.
|
|---|
| 428 | ;;;
|
|---|
| 429 | (defun get-current-eval-server (&optional errorp)
|
|---|
| 430 | "Returns the server-info struct for the current eval server. If there is
|
|---|
| 431 | none, and errorp is non-nil, then signal an editor error. If there is no
|
|---|
| 432 | current server, and errorp is nil, then create one, prompting the user for
|
|---|
| 433 | confirmation. Also, set the current server to be the newly created one."
|
|---|
| 434 | (let ((info (value current-eval-server)))
|
|---|
| 435 | (cond (info)
|
|---|
| 436 | (errorp
|
|---|
| 437 | (editor-error "No current eval server."))
|
|---|
| 438 | (t
|
|---|
| 439 | (setf (value current-eval-server) (maybe-create-server))))))
|
|---|
| 440 |
|
|---|
| 441 | ;;; GET-CURRENT-COMPILE-SERVER -- Public.
|
|---|
| 442 | ;;;
|
|---|
| 443 | ;;; If a current compile server is defined, return it, otherwise return the
|
|---|
| 444 | ;;; current eval server using get-current-eval-server.
|
|---|
| 445 | ;;;
|
|---|
| 446 | (defun get-current-compile-server (&optional errorp)
|
|---|
| 447 | "Returns the server-info struct for the current compile server. If there is
|
|---|
| 448 | no current compile server, return the current eval server."
|
|---|
| 449 | (or (value current-compile-server)
|
|---|
| 450 | (get-current-eval-server errorp)))
|
|---|
| 451 |
|
|---|
| 452 |
|
|---|
| 453 | |
|---|
| 454 |
|
|---|
| 455 | ;;;; Server Manipulation commands.
|
|---|
| 456 |
|
|---|
| 457 | (defcommand "Select Slave" (p)
|
|---|
| 458 | "Switch to the current slave's buffer. When given an argument, create a new
|
|---|
| 459 | slave."
|
|---|
| 460 | "Switch to the current slave's buffer. When given an argument, create a new
|
|---|
| 461 | slave."
|
|---|
| 462 | (let* ((info (if p (create-slave) (get-current-eval-server)))
|
|---|
| 463 | (slave (server-info-slave-buffer info)))
|
|---|
| 464 | (unless slave
|
|---|
| 465 | (editor-error "The current eval server doesn't have a slave buffer!"))
|
|---|
| 466 | (change-to-buffer slave)))
|
|---|
| 467 |
|
|---|
| 468 | (defcommand "Select Background" (p)
|
|---|
| 469 | "Switch to the current slave's background buffer. When given an argument, use
|
|---|
| 470 | the current compile server instead of the current eval server."
|
|---|
| 471 | "Switch to the current slave's background buffer. When given an argument, use
|
|---|
| 472 | the current compile server instead of the current eval server."
|
|---|
| 473 | (let* ((info (if p
|
|---|
| 474 | (get-current-compile-server t)
|
|---|
| 475 | (get-current-eval-server t)))
|
|---|
| 476 | (background (server-info-background-buffer info)))
|
|---|
| 477 | (unless background
|
|---|
| 478 | (editor-error "The current ~A server doesn't have a background buffer!"
|
|---|
| 479 | (if p "compile" "eval")))
|
|---|
| 480 | (change-to-buffer background)))
|
|---|
| 481 |
|
|---|
| 482 | #+NILGB
|
|---|
| 483 | (defcommand "Kill Slave" (p)
|
|---|
| 484 | "This aborts any operations in the slave, tells the slave to QUIT, and shuts
|
|---|
| 485 | down the connection to the specified eval server. This makes no attempt to
|
|---|
| 486 | assure the eval server actually dies."
|
|---|
| 487 | "This aborts any operations in the slave, tells the slave to QUIT, and shuts
|
|---|
| 488 | down the connection to the specified eval server. This makes no attempt to
|
|---|
| 489 | assure the eval server actually dies."
|
|---|
| 490 | (declare (ignore p))
|
|---|
| 491 | (let ((default (and (value current-eval-server)
|
|---|
| 492 | (server-info-name (value current-eval-server)))))
|
|---|
| 493 | (multiple-value-bind
|
|---|
| 494 | (name info)
|
|---|
| 495 | (prompt-for-keyword
|
|---|
| 496 | (list *server-names*)
|
|---|
| 497 | :prompt "Kill Slave: "
|
|---|
| 498 | :help "Enter the name of the eval server you wish to destroy."
|
|---|
| 499 | :must-exist t
|
|---|
| 500 | :default default
|
|---|
| 501 | :default-string default)
|
|---|
| 502 | (declare (ignore name))
|
|---|
| 503 | (let ((wire (server-info-wire info)))
|
|---|
| 504 | (when wire
|
|---|
| 505 | (ext:send-character-out-of-band (hemlock.wire:wire-fd wire) #\N)
|
|---|
| 506 | (hemlock.wire:remote wire (ext:quit))
|
|---|
| 507 | (hemlock.wire:wire-force-output wire)))
|
|---|
| 508 | (server-died info))))
|
|---|
| 509 |
|
|---|
| 510 | #+NILGB
|
|---|
| 511 | (defcommand "Kill Slave and Buffers" (p)
|
|---|
| 512 | "This is the same as \"Kill Slave\", but it also deletes the slaves
|
|---|
| 513 | interaction and background buffers."
|
|---|
| 514 | "This is the same as \"Kill Slave\", but it also deletes the slaves
|
|---|
| 515 | interaction and background buffers."
|
|---|
| 516 | (declare (ignore p))
|
|---|
| 517 | (let ((default (and (value current-eval-server)
|
|---|
| 518 | (server-info-name (value current-eval-server)))))
|
|---|
| 519 | (multiple-value-bind
|
|---|
| 520 | (name info)
|
|---|
| 521 | (prompt-for-keyword
|
|---|
| 522 | (list *server-names*)
|
|---|
| 523 | :prompt "Kill Slave: "
|
|---|
| 524 | :help "Enter the name of the eval server you wish to destroy."
|
|---|
| 525 | :must-exist t
|
|---|
| 526 | :default default
|
|---|
| 527 | :default-string default)
|
|---|
| 528 | (declare (ignore name))
|
|---|
| 529 | (let ((wire (server-info-wire info)))
|
|---|
| 530 | (when wire
|
|---|
| 531 | (ext:send-character-out-of-band (hemlock.wire:wire-fd wire) #\N)
|
|---|
| 532 | (hemlock.wire:remote wire (ext:quit))
|
|---|
| 533 | (hemlock.wire:wire-force-output wire)))
|
|---|
| 534 | (let ((buffer (server-info-slave-buffer info)))
|
|---|
| 535 | (when buffer (delete-buffer-if-possible buffer)))
|
|---|
| 536 | (let ((buffer (server-info-background-buffer info)))
|
|---|
| 537 | (when buffer (delete-buffer-if-possible buffer)))
|
|---|
| 538 | (server-died info))))
|
|---|
| 539 |
|
|---|
| 540 | (defcommand "Accept Slave Connections" (p)
|
|---|
| 541 | "This causes Hemlock to accept slave connections and displays the port of
|
|---|
| 542 | the editor's connections request server. This is suitable for use with the
|
|---|
| 543 | Lisp's -slave switch. Given an argument, this inhibits slave connections."
|
|---|
| 544 | "This causes Hemlock to accept slave connections and displays the port of
|
|---|
| 545 | the editor's connections request server. This is suitable for use with the
|
|---|
| 546 | Lisp's -slave switch. Given an argument, this inhibits slave connections."
|
|---|
| 547 | (let ((accept (not p)))
|
|---|
| 548 | (setf *accept-connections* accept)
|
|---|
| 549 | (message "~:[Inhibiting~;Accepting~] connections to ~S"
|
|---|
| 550 | accept (get-editor-name))))
|
|---|
| 551 |
|
|---|
| 552 |
|
|---|
| 553 | |
|---|
| 554 |
|
|---|
| 555 | ;;;; Slave initialization junk.
|
|---|
| 556 |
|
|---|
| 557 | (defvar *original-beep-function* nil
|
|---|
| 558 | "Handle on original beep function.")
|
|---|
| 559 |
|
|---|
| 560 | (defvar *original-gc-notify-before* nil
|
|---|
| 561 | "Handle on original before-GC notification function.")
|
|---|
| 562 |
|
|---|
| 563 | (defvar *original-gc-notify-after* nil
|
|---|
| 564 | "Handle on original after-GC notification function.")
|
|---|
| 565 |
|
|---|
| 566 | (defvar *original-terminal-io* nil
|
|---|
| 567 | "Handle on original *terminal-io* so we can restore it.")
|
|---|
| 568 |
|
|---|
| 569 | (defvar *original-standard-input* nil
|
|---|
| 570 | "Handle on original *standard-input* so we can restore it.")
|
|---|
| 571 |
|
|---|
| 572 | (defvar *original-standard-output* nil
|
|---|
| 573 | "Handle on original *standard-output* so we can restore it.")
|
|---|
| 574 |
|
|---|
| 575 | (defvar *original-error-output* nil
|
|---|
| 576 | "Handle on original *error-output* so we can restore it.")
|
|---|
| 577 |
|
|---|
| 578 | (defvar *original-debug-io* nil
|
|---|
| 579 | "Handle on original *debug-io* so we can restore it.")
|
|---|
| 580 |
|
|---|
| 581 | (defvar *original-query-io* nil
|
|---|
| 582 | "Handle on original *query-io* so we can restore it.")
|
|---|
| 583 |
|
|---|
| 584 | (defvar *original-trace-output* nil
|
|---|
| 585 | "Handle on original *trace-output* so we can restore it.")
|
|---|
| 586 |
|
|---|
| 587 | (defvar *background-io* nil
|
|---|
| 588 | "Stream connected to the editor's background buffer in case we want to use it
|
|---|
| 589 | in the future.")
|
|---|
| 590 |
|
|---|
| 591 | ;;; CONNECT-STREAM -- internal
|
|---|
| 592 | ;;;
|
|---|
| 593 | ;;; Run in the slave to create a new stream and connect it to the supplied
|
|---|
| 594 | ;;; buffer. Returns the stream.
|
|---|
| 595 | ;;;
|
|---|
| 596 | (defun connect-stream (remote-buffer)
|
|---|
| 597 | (let ((stream (make-ts-stream hemlock.wire:*current-wire* remote-buffer)))
|
|---|
| 598 | (hemlock.wire:remote hemlock.wire:*current-wire*
|
|---|
| 599 | (ts-buffer-set-stream remote-buffer
|
|---|
| 600 | (hemlock.wire:make-remote-object stream)))
|
|---|
| 601 | stream))
|
|---|
| 602 |
|
|---|
| 603 | ;;; MADE-BUFFERS-FOR-TYPESCRIPT -- Internal Interface.
|
|---|
| 604 | ;;;
|
|---|
| 605 | ;;; Run in the slave by the editor with the two buffers' info structures,
|
|---|
| 606 | ;;; actually remote-objects in the slave. Does any necessary stream hacking.
|
|---|
| 607 | ;;; Return nil to make sure no weird objects try to go back over the wire
|
|---|
| 608 | ;;; since the editor calls this in the slave for value. The editor does this
|
|---|
| 609 | ;;; for synch'ing, not for values.
|
|---|
| 610 | ;;;
|
|---|
| 611 | (defun made-buffers-for-typescript (slave-info background-info)
|
|---|
| 612 | (setf *original-terminal-io* *terminal-io*)
|
|---|
| 613 | (warn "made-buffers-for-typescript ~S ~S ~S."
|
|---|
| 614 | (connect-stream slave-info)
|
|---|
| 615 | *terminal-io*
|
|---|
| 616 | (connect-stream background-info))
|
|---|
| 617 | (sleep 3)
|
|---|
| 618 | (macrolet ((frob (symbol new-value)
|
|---|
| 619 | `(setf ,(intern (concatenate 'simple-string
|
|---|
| 620 | "*ORIGINAL-"
|
|---|
| 621 | (subseq (string symbol) 1)))
|
|---|
| 622 | ,symbol
|
|---|
| 623 | ,symbol ,new-value)))
|
|---|
| 624 | #+NILGB
|
|---|
| 625 | (let ((wire hemlock.wire:*current-wire*))
|
|---|
| 626 | (frob system:*beep-function*
|
|---|
| 627 | #'(lambda (&optional stream)
|
|---|
| 628 | (declare (ignore stream))
|
|---|
| 629 | (hemlock.wire:remote-value wire (beep))))
|
|---|
| 630 | (frob ext:*gc-notify-before*
|
|---|
| 631 | #'(lambda (bytes-in-use)
|
|---|
| 632 | (hemlock.wire:remote wire
|
|---|
| 633 | (slave-gc-notify-before
|
|---|
| 634 | slave-info
|
|---|
| 635 | (format nil
|
|---|
| 636 | "~%[GC threshold exceeded with ~:D bytes in use. ~
|
|---|
| 637 | Commencing GC.]~%"
|
|---|
| 638 | bytes-in-use)))
|
|---|
| 639 | (hemlock.wire:wire-force-output wire)))
|
|---|
| 640 | (frob ext:*gc-notify-after*
|
|---|
| 641 | #'(lambda (bytes-retained bytes-freed new-trigger)
|
|---|
| 642 | (hemlock.wire:remote wire
|
|---|
| 643 | (slave-gc-notify-after
|
|---|
| 644 | slave-info
|
|---|
| 645 | (format nil
|
|---|
| 646 | "[GC completed with ~:D bytes retained and ~:D ~
|
|---|
| 647 | bytes freed.]~%[GC will next occur when at least ~
|
|---|
| 648 | ~:D bytes are in use.]~%"
|
|---|
| 649 | bytes-retained bytes-freed new-trigger)))
|
|---|
| 650 | (hemlock.wire:wire-force-output wire))))
|
|---|
| 651 | (warn "#7")(sleep 1)
|
|---|
| 652 | (frob *terminal-io* (connect-stream slave-info))
|
|---|
| 653 | #+NIL
|
|---|
| 654 | (progn
|
|---|
| 655 | (setf cl-user::*io* (connect-stream slave-info))
|
|---|
| 656 | (let ((*terminal-io* *original-terminal-io*))
|
|---|
| 657 | (warn "#8")(sleep 1))
|
|---|
| 658 | (frob *standard-input* (make-synonym-stream '*terminal-io*))
|
|---|
| 659 | (let ((*terminal-io* *original-terminal-io*))
|
|---|
| 660 | (warn "#9")(sleep 1))
|
|---|
| 661 | (frob *standard-output* *standard-input*)
|
|---|
| 662 | (let ((*terminal-io* *original-terminal-io*))
|
|---|
| 663 | (warn "#10")(sleep 1))
|
|---|
| 664 | ;;###
|
|---|
| 665 | ;;(frob *error-output* *standard-input*)
|
|---|
| 666 | ;;(frob *debug-io* *standard-input*)
|
|---|
| 667 | (let ((*terminal-io* *original-terminal-io*))
|
|---|
| 668 | (warn "#11")(sleep 1))
|
|---|
| 669 | (frob *query-io* *standard-input*)
|
|---|
| 670 | (let ((*terminal-io* *original-terminal-io*))
|
|---|
| 671 | (warn "#12")(sleep 1)))
|
|---|
| 672 | (frob *trace-output* *original-terminal-io*)
|
|---|
| 673 | )
|
|---|
| 674 | #+NILGB (setf *background-io* (connect-stream background-info))
|
|---|
| 675 | nil)
|
|---|
| 676 |
|
|---|
| 677 | ;;; SLAVE-GC-NOTIFY-BEFORE and SLAVE-GC-NOTIFY-AFTER -- internal
|
|---|
| 678 | ;;;
|
|---|
| 679 | ;;; These two routines are run in the editor by the slave's gc notify routines.
|
|---|
| 680 | ;;;
|
|---|
| 681 | (defun slave-gc-notify-before (remote-ts message)
|
|---|
| 682 | (let ((ts (hemlock.wire:remote-object-value remote-ts)))
|
|---|
| 683 | (ts-buffer-output-string ts message t)
|
|---|
| 684 | (when (value slave-gc-alarm)
|
|---|
| 685 | (message "~A is GC'ing." (buffer-name (ts-data-buffer ts)))
|
|---|
| 686 | (when (eq (value slave-gc-alarm) :loud-message)
|
|---|
| 687 | (beep)))))
|
|---|
| 688 |
|
|---|
| 689 | (defun slave-gc-notify-after (remote-ts message)
|
|---|
| 690 | (let ((ts (hemlock.wire:remote-object-value remote-ts)))
|
|---|
| 691 | (ts-buffer-output-string ts message t)
|
|---|
| 692 | (when (value slave-gc-alarm)
|
|---|
| 693 | (message "~A is done GC'ing." (buffer-name (ts-data-buffer ts)))
|
|---|
| 694 | (when (eq (value slave-gc-alarm) :loud-message)
|
|---|
| 695 | (beep)))))
|
|---|
| 696 |
|
|---|
| 697 | ;;; EDITOR-DIED -- internal
|
|---|
| 698 | ;;;
|
|---|
| 699 | ;;; Run in the slave when the editor goes belly up.
|
|---|
| 700 | ;;;
|
|---|
| 701 | (defun editor-died ()
|
|---|
| 702 | (macrolet ((frob (symbol)
|
|---|
| 703 | (let ((orig (intern (concatenate 'simple-string
|
|---|
| 704 | "*ORIGINAL-"
|
|---|
| 705 | (subseq (string symbol) 1)))))
|
|---|
| 706 | `(when ,orig
|
|---|
| 707 | (setf ,symbol ,orig)))))
|
|---|
| 708 | #+NILGB
|
|---|
| 709 | (progn
|
|---|
| 710 | (frob system:*beep-function*)
|
|---|
| 711 | (frob ext:*gc-notify-before*)
|
|---|
| 712 | (frob ext:*gc-notify-after*))
|
|---|
| 713 | (frob *terminal-io*)
|
|---|
| 714 | (frob *standard-input*)
|
|---|
| 715 | (frob *standard-output*)
|
|---|
| 716 | (frob *error-output*)
|
|---|
| 717 | (frob *debug-io*)
|
|---|
| 718 | (frob *query-io*)
|
|---|
| 719 | (frob *trace-output*))
|
|---|
| 720 | (setf *background-io* nil)
|
|---|
| 721 | (format t "~2&Connection to editor died.~%")
|
|---|
| 722 | #+NILGB
|
|---|
| 723 | (ext:quit))
|
|---|
| 724 |
|
|---|
| 725 | ;;; START-SLAVE -- internal
|
|---|
| 726 | ;;;
|
|---|
| 727 | ;;; Initiate the process by which a lisp becomes a slave.
|
|---|
| 728 | ;;;
|
|---|
| 729 | (defun start-slave (editor)
|
|---|
| 730 | (declare (simple-string editor))
|
|---|
| 731 | (let ((seperator (position #\: editor :test #'char=)))
|
|---|
| 732 | (unless seperator
|
|---|
| 733 | (error "Editor name ~S invalid. ~
|
|---|
| 734 | Must be of the form \"MachineName:PortNumber\"."
|
|---|
| 735 | editor))
|
|---|
| 736 | (let ((machine (subseq editor 0 seperator))
|
|---|
| 737 | (port (parse-integer editor :start (1+ seperator))))
|
|---|
| 738 | (format t "Connecting to ~A:~D~%" machine port)
|
|---|
| 739 | (connect-to-editor machine port))))
|
|---|
| 740 |
|
|---|
| 741 |
|
|---|
| 742 | ;;; PRINT-SLAVE-STATUS -- Internal
|
|---|
| 743 | ;;;
|
|---|
| 744 | ;;; Print out some useful information about what the slave is up to.
|
|---|
| 745 | ;;;
|
|---|
| 746 | #+NILGB
|
|---|
| 747 | (defun print-slave-status ()
|
|---|
| 748 | (ignore-errors
|
|---|
| 749 | (multiple-value-bind (sys user faults)
|
|---|
| 750 | (system:get-system-info)
|
|---|
| 751 | (let* ((seconds (truncate (+ sys user) 1000000))
|
|---|
| 752 | (minutes (truncate seconds 60))
|
|---|
| 753 | (hours (truncate minutes 60))
|
|---|
| 754 | (days (truncate hours 24)))
|
|---|
| 755 | (format *error-output* "~&; Used ~D:~2,'0D:~2,'0D~V@{!~}, "
|
|---|
| 756 | hours (rem minutes 60) (rem seconds 60) days))
|
|---|
| 757 | (format *error-output* "~D fault~:P. In: " faults)
|
|---|
| 758 |
|
|---|
| 759 | (do ((i 0 (1+ i))
|
|---|
| 760 | (frame (di:top-frame) (di:frame-down frame)))
|
|---|
| 761 | (#-x86(= i 3)
|
|---|
| 762 | #+x86
|
|---|
| 763 | (and (> i 6) ; get past extra cruft
|
|---|
| 764 | (let ((name (di:debug-function-name
|
|---|
| 765 | (di:frame-debug-function frame))))
|
|---|
| 766 | (and (not (string= name "Bogus stack frame"))
|
|---|
| 767 | (not (string= name "Foreign function call land")))))
|
|---|
| 768 | (prin1 (di:debug-function-name (di:frame-debug-function frame))
|
|---|
| 769 | *error-output*))
|
|---|
| 770 | (unless frame (return)))
|
|---|
| 771 | (terpri *error-output*)
|
|---|
| 772 | (force-output *error-output*)))
|
|---|
| 773 | (values))
|
|---|
| 774 |
|
|---|
| 775 |
|
|---|
| 776 | ;;; CONNECT-TO-EDITOR -- internal
|
|---|
| 777 | ;;;
|
|---|
| 778 | ;;; Do the actual connect to the editor.
|
|---|
| 779 | ;;;
|
|---|
| 780 | (defun connect-to-editor (machine port
|
|---|
| 781 | &optional
|
|---|
| 782 | (slave (find-eval-server-switch "slave-buffer"))
|
|---|
| 783 | (background (find-eval-server-switch
|
|---|
| 784 | "background-buffer")))
|
|---|
| 785 | (let ((wire (hemlock.wire:connect-to-remote-server machine port 'editor-died)))
|
|---|
| 786 | #+NILGB
|
|---|
| 787 | (progn
|
|---|
| 788 | (ext:add-oob-handler (hemlock.wire:wire-fd wire)
|
|---|
| 789 | #\B
|
|---|
| 790 | #'(lambda ()
|
|---|
| 791 | (system:without-hemlock
|
|---|
| 792 | (system:with-interrupts
|
|---|
| 793 | (break "Software Interrupt")))))
|
|---|
| 794 | (ext:add-oob-handler (hemlock.wire:wire-fd wire)
|
|---|
| 795 | #\T
|
|---|
| 796 | #'(lambda ()
|
|---|
| 797 | (when lisp::*in-top-level-catcher*
|
|---|
| 798 | (throw 'lisp::top-level-catcher nil))))
|
|---|
| 799 | (ext:add-oob-handler (hemlock.wire:wire-fd wire)
|
|---|
| 800 | #\A
|
|---|
| 801 | #'abort)
|
|---|
| 802 | (ext:add-oob-handler (hemlock.wire:wire-fd wire)
|
|---|
| 803 | #\N
|
|---|
| 804 | #'(lambda ()
|
|---|
| 805 | (setf *abort-operations* t)
|
|---|
| 806 | (when *inside-operation*
|
|---|
| 807 | (throw 'abort-operation
|
|---|
| 808 | (if debug::*in-the-debugger*
|
|---|
| 809 | :was-in-debugger)))))
|
|---|
| 810 | (ext:add-oob-handler (hemlock.wire:wire-fd wire) #\S #'print-slave-status))
|
|---|
| 811 |
|
|---|
| 812 | (hemlock.wire:remote-value wire
|
|---|
| 813 | (make-buffers-for-typescript slave background))))
|
|---|
| 814 |
|
|---|
| 815 | |
|---|
| 816 |
|
|---|
| 817 | ;;;; Eval server evaluation functions.
|
|---|
| 818 |
|
|---|
| 819 | (defvar *eval-form-stream*
|
|---|
| 820 | (make-two-way-stream
|
|---|
| 821 | #+NILGB
|
|---|
| 822 | (lisp::make-lisp-stream
|
|---|
| 823 | :in #'(lambda (&rest junk)
|
|---|
| 824 | (declare (ignore junk))
|
|---|
| 825 | (error "You cannot read when handling an eval_form request.")))
|
|---|
| 826 | #-NILGB
|
|---|
| 827 | (make-concatenated-stream)
|
|---|
| 828 | (make-broadcast-stream)))
|
|---|
| 829 |
|
|---|
| 830 | ;;; SERVER-EVAL-FORM -- Public.
|
|---|
| 831 | ;;; Evaluates the given form (which is a string to be read from in the given
|
|---|
| 832 | ;;; package) and returns the results as a list.
|
|---|
| 833 | ;;;
|
|---|
| 834 | (defun server-eval-form (package form)
|
|---|
| 835 | (declare (type (or string null) package) (simple-string form))
|
|---|
| 836 | (handler-bind
|
|---|
| 837 | ((error #'(lambda (condition)
|
|---|
| 838 | (hemlock.wire:remote hemlock.wire:*current-wire*
|
|---|
| 839 | (eval-form-error (format nil "~A~&" condition)))
|
|---|
| 840 | (return-from server-eval-form nil))))
|
|---|
| 841 | (let ((*package* (if package
|
|---|
| 842 | (lisp::package-or-lose package)
|
|---|
| 843 | *package*))
|
|---|
| 844 | (*terminal-io* *eval-form-stream*))
|
|---|
| 845 | (stringify-list (multiple-value-list (eval (read-from-string form)))))))
|
|---|
| 846 |
|
|---|
| 847 |
|
|---|
| 848 | ;;; DO-OPERATION -- Internal.
|
|---|
| 849 | ;;; Checks to see if we are aborting operations. If not, do the operation
|
|---|
| 850 | ;;; wrapping it with operation-started and operation-completed calls. Also
|
|---|
| 851 | ;;; deals with setting up *terminal-io* and *package*.
|
|---|
| 852 | ;;;
|
|---|
| 853 | (defmacro do-operation ((note package terminal-io) &body body)
|
|---|
| 854 | `(let ((aborted t)
|
|---|
| 855 | (*terminal-io* (if ,terminal-io
|
|---|
| 856 | (hemlock.wire:remote-object-value ,terminal-io)
|
|---|
| 857 | *terminal-io*))
|
|---|
| 858 | (*package* (maybe-make-package ,package)))
|
|---|
| 859 | (unwind-protect
|
|---|
| 860 | (unless *abort-operations*
|
|---|
| 861 | (when (eq :was-in-debugger
|
|---|
| 862 | (catch 'abort-operation
|
|---|
| 863 | (let ((*inside-operation* t))
|
|---|
| 864 | (hemlock.wire:remote hemlock.wire:*current-wire*
|
|---|
| 865 | (operation-started ,note))
|
|---|
| 866 | (hemlock.wire:wire-force-output hemlock.wire:*current-wire*)
|
|---|
| 867 | ,@body
|
|---|
| 868 | (setf aborted nil))))
|
|---|
| 869 | (format t
|
|---|
| 870 | "~&[Operation aborted. ~
|
|---|
| 871 | You are no longer in this instance of the debugger.]~%")))
|
|---|
| 872 | (hemlock.wire:remote hemlock.wire:*current-wire*
|
|---|
| 873 | (operation-completed ,note aborted))
|
|---|
| 874 | (hemlock.wire:wire-force-output hemlock.wire:*current-wire*))))
|
|---|
| 875 |
|
|---|
| 876 |
|
|---|
| 877 | ;;; unique-thingie is a unique eof-value for READ'ing. Its a parameter, so
|
|---|
| 878 | ;;; we can reload the file.
|
|---|
| 879 | ;;;
|
|---|
| 880 | (defparameter unique-thingie (gensym)
|
|---|
| 881 | "Used as eof-value in reads to check for the end of a file.")
|
|---|
| 882 |
|
|---|
| 883 | ;;; SERVER-EVAL-TEXT -- Public.
|
|---|
| 884 | ;;;
|
|---|
| 885 | ;;; Evaluate all the forms read from text in the given package, and send the
|
|---|
| 886 | ;;; results back. The error handler bound does not handle any errors. It
|
|---|
| 887 | ;;; simply notifies the client that an error occurred and then returns.
|
|---|
| 888 | ;;;
|
|---|
| 889 | (defun server-eval-text (note package text terminal-io)
|
|---|
| 890 | (do-operation (note package terminal-io)
|
|---|
| 891 | (with-input-from-string (stream text)
|
|---|
| 892 | (let ((last-pos 0))
|
|---|
| 893 | (handler-bind
|
|---|
| 894 | ((error
|
|---|
| 895 | #'(lambda (condition)
|
|---|
| 896 | (hemlock.wire:remote hemlock.wire:*current-wire*
|
|---|
| 897 | (lisp-error note last-pos
|
|---|
| 898 | (file-position stream)
|
|---|
| 899 | (format nil "~A~&" condition))))))
|
|---|
| 900 | (loop
|
|---|
| 901 | (let ((form (read stream nil unique-thingie)))
|
|---|
| 902 | (when (eq form unique-thingie)
|
|---|
| 903 | (return nil))
|
|---|
| 904 | (let* ((values (stringify-list (multiple-value-list (eval form))))
|
|---|
| 905 | (pos (file-position stream)))
|
|---|
| 906 | (hemlock.wire:remote hemlock.wire:*current-wire*
|
|---|
| 907 | (eval-text-result note last-pos pos values))
|
|---|
| 908 | (setf last-pos pos)))))))))
|
|---|
| 909 |
|
|---|
| 910 | (defun stringify-list (list)
|
|---|
| 911 | (mapcar #'prin1-to-string list))
|
|---|
| 912 | #|
|
|---|
| 913 | (defun stringify-list (list)
|
|---|
| 914 | (mapcar #'(lambda (thing)
|
|---|
| 915 | (with-output-to-string (stream)
|
|---|
| 916 | (write thing
|
|---|
| 917 | :stream stream :radix nil :base 10 :circle t
|
|---|
| 918 | :pretty nil :level nil :length nil :case :upcase
|
|---|
| 919 | :array t :gensym t)))
|
|---|
| 920 | list))
|
|---|
| 921 | |#
|
|---|
| 922 |
|
|---|
| 923 | |
|---|
| 924 |
|
|---|
| 925 | ;;;; Eval server compilation stuff.
|
|---|
| 926 |
|
|---|
| 927 | ;;; DO-COMPILER-OPERATION -- Internal.
|
|---|
| 928 | ;;;
|
|---|
| 929 | ;;; Useful macro that does the operation with *compiler-note* and
|
|---|
| 930 | ;;; *compiler-wire* bound.
|
|---|
| 931 | ;;;
|
|---|
| 932 | (defmacro do-compiler-operation ((note package terminal-io error) &body body)
|
|---|
| 933 | #+NILGB
|
|---|
| 934 | `(let ((*compiler-note* ,note)
|
|---|
| 935 | (*compiler-error-stream* ,error)
|
|---|
| 936 | (*compiler-wire* hemlock.wire:*current-wire*)
|
|---|
| 937 | (c:*compiler-notification-function* #'compiler-note-in-editor))
|
|---|
| 938 | (do-operation (*compiler-note* ,package ,terminal-io)
|
|---|
| 939 | (unwind-protect
|
|---|
| 940 | (handler-bind ((error #'compiler-error-handler))
|
|---|
| 941 | ,@body)
|
|---|
| 942 | (when *compiler-error-stream*
|
|---|
| 943 | (force-output *compiler-error-stream*))))))
|
|---|
| 944 |
|
|---|
| 945 | ;;; COMPILER-NOTE-IN-EDITOR -- Internal.
|
|---|
| 946 | ;;;
|
|---|
| 947 | ;;; DO-COMPILER-OPERATION binds c:*compiler-notification-function* to this, so
|
|---|
| 948 | ;;; interesting observations in the compilation can be propagated back to the
|
|---|
| 949 | ;;; editor. If there is a notification point defined, we send information
|
|---|
| 950 | ;;; about the position and kind of error. The actual error text is written out
|
|---|
| 951 | ;;; using typescript operations.
|
|---|
| 952 | ;;;
|
|---|
| 953 | ;;; Start and End are the compiler's best guess at the file position where the
|
|---|
| 954 | ;;; error occurred. Function is some string describing where the error was.
|
|---|
| 955 | ;;;
|
|---|
| 956 | (defun compiler-note-in-editor (severity function name pos)
|
|---|
| 957 | (declare (ignore name))
|
|---|
| 958 | (when *compiler-wire*
|
|---|
| 959 | (force-output *compiler-error-stream*)
|
|---|
| 960 | (hemlock.wire:remote *compiler-wire*
|
|---|
| 961 | (compiler-error *compiler-note* pos pos function severity)))
|
|---|
| 962 | (hemlock.wire:wire-force-output *compiler-wire*))
|
|---|
| 963 |
|
|---|
| 964 |
|
|---|
| 965 | ;;; COMPILER-ERROR-HANDLER -- Internal.
|
|---|
| 966 | ;;;
|
|---|
| 967 | ;;; The error handler function for the compiler interfaces.
|
|---|
| 968 | ;;; DO-COMPILER-OPERATION binds this as an error handler while evaluating the
|
|---|
| 969 | ;;; compilation form.
|
|---|
| 970 | ;;;
|
|---|
| 971 | (defun compiler-error-handler (condition)
|
|---|
| 972 | (when *compiler-wire*
|
|---|
| 973 | (hemlock.wire:remote *compiler-wire*
|
|---|
| 974 | (lisp-error *compiler-note* nil nil
|
|---|
| 975 | (format nil "~A~&" condition)))))
|
|---|
| 976 |
|
|---|
| 977 |
|
|---|
| 978 | ;;; SERVER-COMPILE-TEXT -- Public.
|
|---|
| 979 | ;;;
|
|---|
| 980 | ;;; Similar to server-eval-text, except that the stuff is compiled.
|
|---|
| 981 | ;;;
|
|---|
| 982 | #+NILGB
|
|---|
| 983 | (defun server-compile-text (note package text defined-from
|
|---|
| 984 | terminal-io error-output)
|
|---|
| 985 | (let ((error-output (if error-output
|
|---|
| 986 | (hemlock.wire:remote-object-value error-output))))
|
|---|
| 987 | (do-compiler-operation (note package terminal-io error-output)
|
|---|
| 988 | (with-input-from-string (input-stream text)
|
|---|
| 989 | (terpri error-output)
|
|---|
| 990 | (c::compile-from-stream input-stream
|
|---|
| 991 | :error-stream error-output
|
|---|
| 992 | :source-info defined-from)))))
|
|---|
| 993 |
|
|---|
| 994 | ;;; SERVER-COMPILE-FILE -- Public.
|
|---|
| 995 | ;;;
|
|---|
| 996 | ;;; Compiles the file sending error info back to the editor.
|
|---|
| 997 | ;;;
|
|---|
| 998 | (defun server-compile-file (note package input output error trace
|
|---|
| 999 | load terminal background)
|
|---|
| 1000 | (macrolet ((frob (x)
|
|---|
| 1001 | `(if (hemlock.wire:remote-object-p ,x)
|
|---|
| 1002 | (hemlock.wire:remote-object-value ,x)
|
|---|
| 1003 | ,x)))
|
|---|
| 1004 | (let ((error-stream (frob background)))
|
|---|
| 1005 | (do-compiler-operation (note package terminal error-stream)
|
|---|
| 1006 | (compile-file (frob input)
|
|---|
| 1007 | :output-file (frob output)
|
|---|
| 1008 | :error-file (frob error)
|
|---|
| 1009 | :trace-file (frob trace)
|
|---|
| 1010 | :load load
|
|---|
| 1011 | :error-output error-stream)))))
|
|---|
| 1012 |
|
|---|
| 1013 | |
|---|
| 1014 |
|
|---|
| 1015 | ;;;; Other random eval server stuff.
|
|---|
| 1016 |
|
|---|
| 1017 | ;;; MAYBE-MAKE-PACKAGE -- Internal.
|
|---|
| 1018 | ;;;
|
|---|
| 1019 | ;;; Returns a package for a name. Creates it if it doesn't already exist.
|
|---|
| 1020 | ;;;
|
|---|
| 1021 | (defun maybe-make-package (name)
|
|---|
| 1022 | (cond ((null name) *package*)
|
|---|
| 1023 | ((find-package name))
|
|---|
| 1024 | (t
|
|---|
| 1025 | (hemlock.wire:remote-value (ts-stream-wire *terminal-io*)
|
|---|
| 1026 | (ts-buffer-output-string
|
|---|
| 1027 | (ts-stream-typescript *terminal-io*)
|
|---|
| 1028 | (format nil "~&Creating package ~A.~%" name)
|
|---|
| 1029 | t))
|
|---|
| 1030 | (make-package name))))
|
|---|
| 1031 |
|
|---|
| 1032 | ;;; SERVER-SET-PACKAGE -- Public.
|
|---|
| 1033 | ;;;
|
|---|
| 1034 | ;;; Serves package setting requests. It simply sets
|
|---|
| 1035 | ;;; *package* to an already existing package or newly created one.
|
|---|
| 1036 | ;;;
|
|---|
| 1037 | (defun server-set-package (package)
|
|---|
| 1038 | (setf *package* (maybe-make-package package)))
|
|---|
| 1039 |
|
|---|
| 1040 | ;;; SERVER-ACCEPT-OPERATIONS -- Public.
|
|---|
| 1041 | ;;;
|
|---|
| 1042 | ;;; Start accepting operations again.
|
|---|
| 1043 | ;;;
|
|---|
| 1044 | (defun server-accept-operations ()
|
|---|
| 1045 | (setf *abort-operations* nil))
|
|---|
| 1046 |
|
|---|
| 1047 |
|
|---|
| 1048 | |
|---|
| 1049 |
|
|---|
| 1050 | ;;;; Command line switches.
|
|---|
| 1051 |
|
|---|
| 1052 | #+NILGB
|
|---|
| 1053 | (progn
|
|---|
| 1054 |
|
|---|
| 1055 | ;;; FIND-EVAL-SERVER-SWITCH -- Internal.
|
|---|
| 1056 | ;;;
|
|---|
| 1057 | ;;; This is special to the switches supplied by CREATE-SLAVE and fetched by
|
|---|
| 1058 | ;;; CONNECT-EDITOR-SERVER, so we can use STRING=.
|
|---|
| 1059 | ;;;
|
|---|
| 1060 | (defun find-eval-server-switch (string)
|
|---|
| 1061 | #+NILGB
|
|---|
| 1062 | (let ((switch (find string ext:*command-line-switches*
|
|---|
| 1063 | :test #'string=
|
|---|
| 1064 | :key #'ext:cmd-switch-name)))
|
|---|
| 1065 | (if switch
|
|---|
| 1066 | (or (ext:cmd-switch-value switch)
|
|---|
| 1067 | (car (ext:cmd-switch-words switch))))))
|
|---|
| 1068 |
|
|---|
| 1069 |
|
|---|
| 1070 | (defun slave-switch-demon (switch)
|
|---|
| 1071 | (let ((editor (ext:cmd-switch-arg switch)))
|
|---|
| 1072 | (unless editor
|
|---|
| 1073 | (error "Editor to connect to unspecified."))
|
|---|
| 1074 | (start-slave editor)
|
|---|
| 1075 | (setf debug:*help-line-scroll-count* most-positive-fixnum)))
|
|---|
| 1076 | ;;;
|
|---|
| 1077 | (defswitch "slave" 'slave-switch-demon)
|
|---|
| 1078 | (defswitch "slave-buffer")
|
|---|
| 1079 | (defswitch "background-buffer")
|
|---|
| 1080 |
|
|---|
| 1081 |
|
|---|
| 1082 | (defun edit-switch-demon (switch)
|
|---|
| 1083 | (declare (ignore switch))
|
|---|
| 1084 | #| (let ((arg (or (ext:cmd-switch-value switch)
|
|---|
| 1085 | (car (ext:cmd-switch-words switch)))))
|
|---|
| 1086 | (when (stringp arg) (setq *editor-name* arg)))|#
|
|---|
| 1087 | (let ((initp (not (ext:get-command-line-switch "noinit"))))
|
|---|
| 1088 | (if (stringp (car ext:*command-line-words*))
|
|---|
| 1089 | (ed (car ext:*command-line-words*) :init initp)
|
|---|
| 1090 | (ed nil :init initp))))
|
|---|
| 1091 | ;;;
|
|---|
| 1092 | (defswitch "edit" 'edit-switch-demon)
|
|---|
| 1093 | )
|
|---|
| 1094 |
|
|---|
| 1095 | #+SBCL
|
|---|
| 1096 | (defun hemlock.wire::serve-all-events ()
|
|---|
| 1097 | (sleep .1))
|
|---|
