| 1 | ;;; -*- Package: Hemlock; Log: hemlock.log -*-
|
|---|
| 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 | #+CMU (ext:file-comment
|
|---|
| 8 | "$Header$")
|
|---|
| 9 | ;;;
|
|---|
| 10 | ;;; **********************************************************************
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; This file contains code for sending requests to eval servers and the
|
|---|
| 13 | ;;; commands based on that code.
|
|---|
| 14 | ;;;
|
|---|
| 15 | ;;; Written by William Lott and Rob MacLachlan.
|
|---|
| 16 | ;;;
|
|---|
| 17 |
|
|---|
| 18 | (in-package :hemlock)
|
|---|
| 19 |
|
|---|
| 20 |
|
|---|
| 21 | ;;; The note structure holds everything we need to know about an
|
|---|
| 22 | ;;; operation. Not all operations use all the available fields.
|
|---|
| 23 | ;;;
|
|---|
| 24 | (defstruct (note (:print-function %print-note))
|
|---|
| 25 | (state :unsent) ; :unsent, :pending, :running, :aborted or :dead.
|
|---|
| 26 | server ; Server-Info for the server this op is on.
|
|---|
| 27 | context ; Short string describing what this op is doing.
|
|---|
| 28 | kind ; Either :eval, :compile, or :compile-file
|
|---|
| 29 | buffer ; Buffer source came from.
|
|---|
| 30 | region ; Region of request
|
|---|
| 31 | package ; Package or NIL if none
|
|---|
| 32 | text ; string containing request
|
|---|
| 33 | input-file ; File to compile or where stuff was found
|
|---|
| 34 | net-input-file ; Net version of above.
|
|---|
| 35 | output-file ; Temporary output file for compiler fasl code.
|
|---|
| 36 | net-output-file ; Net version of above
|
|---|
| 37 | output-date ; Temp-file is created before calling compiler,
|
|---|
| 38 | ; and this is its write date.
|
|---|
| 39 | lap-file ; The lap file for compiles
|
|---|
| 40 | error-file ; The file to dump errors into
|
|---|
| 41 | load ; Load compiled file or not?
|
|---|
| 42 | (errors 0) ; Count of compiler errors.
|
|---|
| 43 | (warnings 0) ; Count of compiler warnings.
|
|---|
| 44 | (notes 0)) ; Count of compiler notes.
|
|---|
| 45 | ;;;
|
|---|
| 46 | (defun %print-note (note stream d)
|
|---|
| 47 | (declare (ignore d))
|
|---|
| 48 | (format stream "#<Eval-Server-Note for ~A [~A]>"
|
|---|
| 49 | (note-context note)
|
|---|
| 50 | (note-state note)))
|
|---|
| 51 |
|
|---|
| 52 |
|
|---|
| 53 | |
|---|
| 54 |
|
|---|
| 55 | ;;;; Note support routines.
|
|---|
| 56 |
|
|---|
| 57 | ;;; QUEUE-NOTE -- Internal.
|
|---|
| 58 | ;;;
|
|---|
| 59 | ;;; This queues note for server. SERVER-INFO-NOTES keeps notes in stack order,
|
|---|
| 60 | ;;; not queue order. We also link the note to the server and try to send it
|
|---|
| 61 | ;;; to the server. If we didn't send this note, we tell the user the server
|
|---|
| 62 | ;;; is busy and that we're queuing his note to be sent later.
|
|---|
| 63 | ;;;
|
|---|
| 64 | (defun queue-note (note server)
|
|---|
| 65 | (push note (server-info-notes server))
|
|---|
| 66 | (setf (note-server note) server)
|
|---|
| 67 | (maybe-send-next-note server)
|
|---|
| 68 | (when (eq (note-state note) :unsent)
|
|---|
| 69 | (message "Server ~A busy, ~A queued."
|
|---|
| 70 | (server-info-name server)
|
|---|
| 71 | (note-context note))))
|
|---|
| 72 |
|
|---|
| 73 | ;;; MAYBE-SEND-NEXT-NOTE -- Internal.
|
|---|
| 74 | ;;;
|
|---|
| 75 | ;;; Loop over all notes in server. If we see any :pending or :running, then
|
|---|
| 76 | ;;; punt since we can't send one. Otherwise, by the end of the list, we may
|
|---|
| 77 | ;;; have found an :unsent one, and if we did, next will be the last :unsent
|
|---|
| 78 | ;;; note. Remember, SERVER-INFO-NOTES is kept in stack order not queue order.
|
|---|
| 79 | ;;;
|
|---|
| 80 | (defun maybe-send-next-note (server)
|
|---|
| 81 | (let ((busy nil)
|
|---|
| 82 | (next nil))
|
|---|
| 83 | (dolist (note (server-info-notes server))
|
|---|
| 84 | (ecase (note-state note)
|
|---|
| 85 | ((:pending :running)
|
|---|
| 86 | (setf busy t)
|
|---|
| 87 | (return))
|
|---|
| 88 | (:unsent
|
|---|
| 89 | (setf next note))
|
|---|
| 90 | (:aborted :dead)))
|
|---|
| 91 | (when (and (not busy) next)
|
|---|
| 92 | (send-note next))))
|
|---|
| 93 |
|
|---|
| 94 | (defun send-note (note)
|
|---|
| 95 | (let* ((remote (hemlock.wire:make-remote-object note))
|
|---|
| 96 | (server (note-server note))
|
|---|
| 97 | (ts (server-info-slave-info server))
|
|---|
| 98 | (bg (server-info-background-info server))
|
|---|
| 99 | (wire (server-info-wire server)))
|
|---|
| 100 | (setf (note-state note) :pending)
|
|---|
| 101 | (message "Sending ~A." (note-context note))
|
|---|
| 102 | (case (note-kind note)
|
|---|
| 103 | (:eval
|
|---|
| 104 | (hemlock.wire:remote wire
|
|---|
| 105 | (server-eval-text remote
|
|---|
| 106 | (note-package note)
|
|---|
| 107 | (note-text note)
|
|---|
| 108 | (and ts (ts-data-stream ts)))))
|
|---|
| 109 | (:compile
|
|---|
| 110 | (hemlock.wire:remote wire
|
|---|
| 111 | (server-compile-text remote
|
|---|
| 112 | (note-package note)
|
|---|
| 113 | (note-text note)
|
|---|
| 114 | (note-input-file note)
|
|---|
| 115 | (and ts (ts-data-stream ts))
|
|---|
| 116 | (and bg (ts-data-stream bg)))))
|
|---|
| 117 | (:compile-file
|
|---|
| 118 | (macrolet ((frob (x)
|
|---|
| 119 | `(if (pathnamep ,x)
|
|---|
| 120 | (namestring ,x)
|
|---|
| 121 | ,x)))
|
|---|
| 122 | (hemlock.wire:remote wire
|
|---|
| 123 | (server-compile-file remote
|
|---|
| 124 | (note-package note)
|
|---|
| 125 | (frob (or (note-net-input-file note)
|
|---|
| 126 | (note-input-file note)))
|
|---|
| 127 | (frob (or (note-net-output-file note)
|
|---|
| 128 | (note-output-file note)))
|
|---|
| 129 | (frob (note-error-file note))
|
|---|
| 130 | (frob (note-lap-file note))
|
|---|
| 131 | (note-load note)
|
|---|
| 132 | (and ts (ts-data-stream ts))
|
|---|
| 133 | (and bg (ts-data-stream bg))))))
|
|---|
| 134 | (t
|
|---|
| 135 | (error "Unknown note kind ~S" (note-kind note))))
|
|---|
| 136 | (hemlock.wire:wire-force-output wire)))
|
|---|
| 137 |
|
|---|
| 138 | |
|---|
| 139 |
|
|---|
| 140 | ;;;; Server Callbacks.
|
|---|
| 141 |
|
|---|
| 142 | (defun operation-started (note)
|
|---|
| 143 | (let ((note (hemlock.wire:remote-object-value note)))
|
|---|
| 144 | (setf (note-state note) :running)
|
|---|
| 145 | (message "The ~A started." (note-context note)))
|
|---|
| 146 | (values))
|
|---|
| 147 |
|
|---|
| 148 | (defun eval-form-error (message)
|
|---|
| 149 | (editor-error message))
|
|---|
| 150 |
|
|---|
| 151 | (defun lisp-error (note start end msg)
|
|---|
| 152 | (declare (ignore start end))
|
|---|
| 153 | (let ((note (hemlock.wire:remote-object-value note)))
|
|---|
| 154 | (loud-message "During ~A: ~A"
|
|---|
| 155 | (note-context note)
|
|---|
| 156 | msg))
|
|---|
| 157 | (values))
|
|---|
| 158 |
|
|---|
| 159 | (defun compiler-error (note start end function severity)
|
|---|
| 160 | (let* ((note (hemlock.wire:remote-object-value note))
|
|---|
| 161 | (server (note-server note))
|
|---|
| 162 | (line (mark-line
|
|---|
| 163 | (buffer-end-mark
|
|---|
| 164 | (server-info-background-buffer server))))
|
|---|
| 165 | (message (format nil "~:(~A~) ~@[in ~A ~]during ~A."
|
|---|
| 166 | severity
|
|---|
| 167 | function
|
|---|
| 168 | (note-context note)))
|
|---|
| 169 | (error (make-error-info :buffer (note-buffer note)
|
|---|
| 170 | :message message
|
|---|
| 171 | :line line)))
|
|---|
| 172 | (message "~A" message)
|
|---|
| 173 | (case severity
|
|---|
| 174 | (:error (incf (note-errors note)))
|
|---|
| 175 | (:warning (incf (note-warnings note)))
|
|---|
| 176 | (:note (incf (note-notes note))))
|
|---|
| 177 | (let ((region (case (note-kind note)
|
|---|
| 178 | (:compile
|
|---|
| 179 | (note-region note))
|
|---|
| 180 | (:compile-file
|
|---|
| 181 | (let ((buff (note-buffer note)))
|
|---|
| 182 | (and buff (buffer-region buff))))
|
|---|
| 183 | (t
|
|---|
| 184 | (error "Compiler error in ~S?" note)))))
|
|---|
| 185 | (when region
|
|---|
| 186 | (let* ((region-end (region-end region))
|
|---|
| 187 | (m1 (copy-mark (region-start region) :left-inserting))
|
|---|
| 188 | (m2 (copy-mark m1 :left-inserting)))
|
|---|
| 189 | (when start
|
|---|
| 190 | (character-offset m1 start)
|
|---|
| 191 | (when (mark> m1 region-end)
|
|---|
| 192 | (move-mark m1 region-end)))
|
|---|
| 193 | (unless (and end (character-offset m2 end))
|
|---|
| 194 | (move-mark m2 region-end))
|
|---|
| 195 |
|
|---|
| 196 | (setf (error-info-region error)
|
|---|
| 197 | (region m1 m2)))))
|
|---|
| 198 |
|
|---|
| 199 | (vector-push-extend error (server-info-errors server)))
|
|---|
| 200 |
|
|---|
| 201 | (values))
|
|---|
| 202 |
|
|---|
| 203 | (defun eval-text-result (note start end values)
|
|---|
| 204 | (declare (ignore note start end))
|
|---|
| 205 | (message "=> ~{~#[~;~A~:;~A, ~]~}" values)
|
|---|
| 206 | (values))
|
|---|
| 207 |
|
|---|
| 208 | (defun operation-completed (note abortp)
|
|---|
| 209 | (let* ((note (hemlock.wire:remote-object-value note))
|
|---|
| 210 | (server (note-server note))
|
|---|
| 211 | (file (note-output-file note)))
|
|---|
| 212 | (hemlock.wire:forget-remote-translation note)
|
|---|
| 213 | (setf (note-state note) :dead)
|
|---|
| 214 | (setf (server-info-notes server)
|
|---|
| 215 | (delete note (server-info-notes server)
|
|---|
| 216 | :test #'eq))
|
|---|
| 217 | (setf (note-server note) nil)
|
|---|
| 218 |
|
|---|
| 219 | (if abortp
|
|---|
| 220 | (loud-message "The ~A aborted." (note-context note))
|
|---|
| 221 | (let ((errors (note-errors note))
|
|---|
| 222 | (warnings (note-warnings note))
|
|---|
| 223 | (notes (note-notes note)))
|
|---|
| 224 | (message "The ~A complete.~
|
|---|
| 225 | ~@[ ~D error~:P~]~@[ ~D warning~:P~]~@[ ~D note~:P~]"
|
|---|
| 226 | (note-context note)
|
|---|
| 227 | (and (plusp errors) errors)
|
|---|
| 228 | (and (plusp warnings) warnings)
|
|---|
| 229 | (and (plusp notes) notes))))
|
|---|
| 230 |
|
|---|
| 231 | (let ((region (note-region note)))
|
|---|
| 232 | (when (regionp region)
|
|---|
| 233 | (delete-mark (region-start region))
|
|---|
| 234 | (delete-mark (region-end region))
|
|---|
| 235 | (setf (note-region note) nil)))
|
|---|
| 236 |
|
|---|
| 237 | (when (and (eq (note-kind note)
|
|---|
| 238 | :compile-file)
|
|---|
| 239 | (not (eq file t))
|
|---|
| 240 | file)
|
|---|
| 241 | (if (> (file-write-date file)
|
|---|
| 242 | (note-output-date note))
|
|---|
| 243 | (let ((new-name (make-pathname :type "fasl"
|
|---|
| 244 | :defaults (note-input-file note))))
|
|---|
| 245 | (rename-file file new-name)
|
|---|
| 246 | #+NILGB
|
|---|
| 247 | (unix:unix-chmod (namestring new-name) #o644))
|
|---|
| 248 | (delete-file file)))
|
|---|
| 249 | (maybe-send-next-note server))
|
|---|
| 250 | (values))
|
|---|
| 251 |
|
|---|
| 252 | |
|---|
| 253 |
|
|---|
| 254 | ;;;; Stuff to send noise to the server.
|
|---|
| 255 |
|
|---|
| 256 | ;;; EVAL-FORM-IN-SERVER -- Public.
|
|---|
| 257 | ;;;
|
|---|
| 258 | (defun eval-form-in-server (server-info form
|
|---|
| 259 | &optional (package (value current-package)))
|
|---|
| 260 | "This evals form, a simple-string, in the server for server-info. Package
|
|---|
| 261 | is the name of the package in which the server reads form, and it defaults
|
|---|
| 262 | to the value of \"Current Package\". If package is nil, then the slave uses
|
|---|
| 263 | the value of *package*. If server is busy with other requests, this signals
|
|---|
| 264 | an editor-error to prevent commands using this from hanging. If the server
|
|---|
| 265 | dies while evaluating form, then this signals an editor-error. This returns
|
|---|
| 266 | a list of strings which are the printed representation of all the values
|
|---|
| 267 | returned by form in the server."
|
|---|
| 268 | (declare (simple-string form))
|
|---|
| 269 | (when (server-info-notes server-info)
|
|---|
| 270 | (editor-error "Server ~S is currently busy. See \"List Operations\"."
|
|---|
| 271 | (server-info-name server-info)))
|
|---|
| 272 | (multiple-value-bind (values error)
|
|---|
| 273 | (hemlock.wire:remote-value (server-info-wire server-info)
|
|---|
| 274 | (server-eval-form package form))
|
|---|
| 275 | (when error
|
|---|
| 276 | (editor-error "The server died before finishing"))
|
|---|
| 277 | values))
|
|---|
| 278 |
|
|---|
| 279 | ;;; EVAL-FORM-IN-SERVER-1 -- Public.
|
|---|
| 280 | ;;;
|
|---|
| 281 | ;;; We use VALUES to squelch the second value of READ-FROM-STRING.
|
|---|
| 282 | ;;;
|
|---|
| 283 | (defun eval-form-in-server-1 (server-info form
|
|---|
| 284 | &optional (package (value current-package)))
|
|---|
| 285 | "This calls EVAL-FORM-IN-SERVER and returns the result of READ'ing from
|
|---|
| 286 | the first string EVAL-FORM-IN-SERVER returns."
|
|---|
| 287 | (values (read-from-string
|
|---|
| 288 | (car (eval-form-in-server server-info form package)))))
|
|---|
| 289 |
|
|---|
| 290 | (defun string-eval (string
|
|---|
| 291 | &key
|
|---|
| 292 | (server (get-current-eval-server))
|
|---|
| 293 | (package (value current-package))
|
|---|
| 294 | (context (format nil
|
|---|
| 295 | "evaluation of ~S"
|
|---|
| 296 | string)))
|
|---|
| 297 | "Queues the evaluation of string on an eval server. String is a simple
|
|---|
| 298 | string. If package is not supplied, the string is eval'ed in the slave's
|
|---|
| 299 | current package."
|
|---|
| 300 | (declare (simple-string string))
|
|---|
| 301 | (queue-note (make-note :kind :eval
|
|---|
| 302 | :context context
|
|---|
| 303 | :package package
|
|---|
| 304 | :text string)
|
|---|
| 305 | server)
|
|---|
| 306 | (values))
|
|---|
| 307 |
|
|---|
| 308 | (defun region-eval (region
|
|---|
| 309 | &key
|
|---|
| 310 | (server (get-current-eval-server))
|
|---|
| 311 | (package (value current-package))
|
|---|
| 312 | (context (region-context region "evaluation")))
|
|---|
| 313 | "Queues the evaluation of a region of text on an eval server. If package
|
|---|
| 314 | is not supplied, the string is eval'ed in the slave's current package."
|
|---|
| 315 | (let ((region (region (copy-mark (region-start region) :left-inserting)
|
|---|
| 316 | (copy-mark (region-end region) :left-inserting))))
|
|---|
| 317 | (queue-note (make-note :kind :eval
|
|---|
| 318 | :context context
|
|---|
| 319 | :region region
|
|---|
| 320 | :package package
|
|---|
| 321 | :text (region-to-string region))
|
|---|
| 322 | server))
|
|---|
| 323 | (values))
|
|---|
| 324 |
|
|---|
| 325 | (defun region-compile (region
|
|---|
| 326 | &key
|
|---|
| 327 | (server (get-current-eval-server))
|
|---|
| 328 | (package (value current-package)))
|
|---|
| 329 | "Queues a compilation on an eval server. If package is not supplied, the
|
|---|
| 330 | string is eval'ed in the slave's current package."
|
|---|
| 331 | (let* ((region (region (copy-mark (region-start region) :left-inserting)
|
|---|
| 332 | (copy-mark (region-end region) :left-inserting)))
|
|---|
| 333 | (buf (line-buffer (mark-line (region-start region))))
|
|---|
| 334 | (pn (and buf (buffer-pathname buf)))
|
|---|
| 335 | (defined-from (if pn (namestring pn) "unknown")))
|
|---|
| 336 | (queue-note (make-note :kind :compile
|
|---|
| 337 | :context (region-context region "compilation")
|
|---|
| 338 | :buffer (and region
|
|---|
| 339 | (region-start region)
|
|---|
| 340 | (mark-line (region-start region))
|
|---|
| 341 | (line-buffer (mark-line
|
|---|
| 342 | (region-start region))))
|
|---|
| 343 | :region region
|
|---|
| 344 | :package package
|
|---|
| 345 | :text (region-to-string region)
|
|---|
| 346 | :input-file defined-from)
|
|---|
| 347 | server))
|
|---|
| 348 | (values))
|
|---|
| 349 |
|
|---|
| 350 |
|
|---|
| 351 | |
|---|
| 352 |
|
|---|
| 353 | ;;;; File compiling noise.
|
|---|
| 354 |
|
|---|
| 355 | (defhvar "Remote Compile File"
|
|---|
| 356 | "When set (the default), this causes slave file compilations to assume the
|
|---|
| 357 | compilation is occurring on a remote machine. This means the source file
|
|---|
| 358 | must be world readable. Unsetting this, causes no file accesses to go
|
|---|
| 359 | through the super root."
|
|---|
| 360 | :value nil)
|
|---|
| 361 |
|
|---|
| 362 | ;;; FILE-COMPILE compiles files in a client Lisp. Because of Unix file
|
|---|
| 363 | ;;; protection, one cannot write files over the net unless they are publicly
|
|---|
| 364 | ;;; writeable. To get around this, we create a temporary file that is
|
|---|
| 365 | ;;; publicly writeable for compiler output. This file is renamed to an
|
|---|
| 366 | ;;; ordinary output name if the compiler wrote anything to it, or deleted
|
|---|
| 367 | ;;; otherwise. No temporary file is created when output-file is not t.
|
|---|
| 368 | ;;;
|
|---|
| 369 |
|
|---|
| 370 | (defun file-compile (file
|
|---|
| 371 | &key
|
|---|
| 372 | buffer
|
|---|
| 373 | (output-file t)
|
|---|
| 374 | error-file
|
|---|
| 375 | lap-file
|
|---|
| 376 | load
|
|---|
| 377 | (server (get-current-compile-server))
|
|---|
| 378 | (package (value current-package)))
|
|---|
| 379 | "Compiles file in a client Lisp. When output-file is t, a temporary
|
|---|
| 380 | output file is used that is publicly writeable in case the client is on
|
|---|
| 381 | another machine. This file is renamed or deleted after compilation.
|
|---|
| 382 | Setting \"Remote Compile File\" to nil, inhibits this. If package is not
|
|---|
| 383 | supplied, the string is eval'ed in the slave's current package."
|
|---|
| 384 |
|
|---|
| 385 | (let* ((file (truename file)) ; in case of search-list in pathname.
|
|---|
| 386 | (namestring (namestring file))
|
|---|
| 387 | (note (make-note
|
|---|
| 388 | :kind :compile-file
|
|---|
| 389 | :context (format nil "compilation of ~A" namestring)
|
|---|
| 390 | :buffer buffer
|
|---|
| 391 | :region nil
|
|---|
| 392 | :package package
|
|---|
| 393 | :input-file file
|
|---|
| 394 | :output-file output-file
|
|---|
| 395 | :error-file error-file
|
|---|
| 396 | :lap-file lap-file
|
|---|
| 397 | :load load)))
|
|---|
| 398 |
|
|---|
| 399 | (when (and (value remote-compile-file)
|
|---|
| 400 | (eq output-file t))
|
|---|
| 401 | (multiple-value-bind (net-infile ofile net-ofile date)
|
|---|
| 402 | (file-compile-temp-file file)
|
|---|
| 403 | (setf (note-net-input-file note) net-infile)
|
|---|
| 404 | (setf (note-output-file note) ofile)
|
|---|
| 405 | (setf (note-net-output-file note) net-ofile)
|
|---|
| 406 | (setf (note-output-date note) date)))
|
|---|
| 407 |
|
|---|
| 408 | (clear-server-errors server
|
|---|
| 409 | #'(lambda (error)
|
|---|
| 410 | (eq (error-info-buffer error)
|
|---|
| 411 | buffer)))
|
|---|
| 412 | (queue-note note server)))
|
|---|
| 413 |
|
|---|
| 414 | ;;; FILE-COMPILE-TEMP-FILE creates a a temporary file that is publicly
|
|---|
| 415 | ;;; writable in the directory file is in and with a .fasl type. Four values
|
|---|
| 416 | ;;; are returned -- a pathname suitable for referencing file remotely, the
|
|---|
| 417 | ;;; pathname of the temporary file created, a pathname suitable for referencing
|
|---|
| 418 | ;;; the temporary file remotely, and the write date of the temporary file.
|
|---|
| 419 | ;;;
|
|---|
| 420 |
|
|---|
| 421 | #+NILGB
|
|---|
| 422 | (defun file-compile-temp-file (file)
|
|---|
| 423 | (let ((ofile (loop (let* ((sym (gensym))
|
|---|
| 424 | (f (merge-pathnames
|
|---|
| 425 | (format nil "compile-file-~A.fasl" sym)
|
|---|
| 426 | file)))
|
|---|
| 427 | (unless (probe-file f) (return f))))))
|
|---|
| 428 | (multiple-value-bind (fd err)
|
|---|
| 429 | (unix:unix-open (namestring ofile)
|
|---|
| 430 | unix:o_creat #o666)
|
|---|
| 431 | (unless fd
|
|---|
| 432 | (editor-error "Couldn't create compiler temporary output file:~%~
|
|---|
| 433 | ~A" (unix:get-unix-error-msg err)))
|
|---|
| 434 | (unix:unix-fchmod fd #o666)
|
|---|
| 435 | (unix:unix-close fd))
|
|---|
| 436 | (let ((net-ofile (pathname-for-remote-access ofile)))
|
|---|
| 437 | (values (make-pathname :directory (pathname-directory net-ofile)
|
|---|
| 438 | :defaults file)
|
|---|
| 439 | ofile
|
|---|
| 440 | net-ofile
|
|---|
| 441 | (file-write-date ofile)))))
|
|---|
| 442 |
|
|---|
| 443 | (defun pathname-for-remote-access (file)
|
|---|
| 444 | (let* ((machine (machine-instance))
|
|---|
| 445 | (usable-name (nstring-downcase
|
|---|
| 446 | (the simple-string
|
|---|
| 447 | (subseq machine 0 (position #\. machine))))))
|
|---|
| 448 | (declare (simple-string machine usable-name))
|
|---|
| 449 | (make-pathname :directory (concatenate 'simple-string
|
|---|
| 450 | "/../"
|
|---|
| 451 | usable-name
|
|---|
| 452 | (directory-namestring file))
|
|---|
| 453 | :defaults file)))
|
|---|
| 454 |
|
|---|
| 455 | ;;; REGION-CONTEXT -- internal
|
|---|
| 456 | ;;;
|
|---|
| 457 | ;;; Return a string which describes the code in a region. Thing is the
|
|---|
| 458 | ;;; thing being done to the region. "compilation" or "evaluation"...
|
|---|
| 459 |
|
|---|
| 460 | (defun region-context (region thing)
|
|---|
| 461 | (declare (simple-string thing))
|
|---|
| 462 | (pre-command-parse-check (region-start region))
|
|---|
| 463 | (let ((start (region-start region)))
|
|---|
| 464 | (with-mark ((m1 start))
|
|---|
| 465 | (unless (start-defun-p m1)
|
|---|
| 466 | (top-level-offset m1 1))
|
|---|
| 467 | (with-mark ((m2 m1))
|
|---|
| 468 | (mark-after m2)
|
|---|
| 469 | (form-offset m2 2)
|
|---|
| 470 | (format nil
|
|---|
| 471 | "~A of ~S"
|
|---|
| 472 | thing
|
|---|
| 473 | (if (eq (mark-line m1) (mark-line m2))
|
|---|
| 474 | (region-to-string (region m1 m2))
|
|---|
| 475 | (concatenate 'simple-string
|
|---|
| 476 | (line-string (mark-line m1))
|
|---|
| 477 | "...")))))))
|
|---|
| 478 |
|
|---|
| 479 | |
|---|
| 480 |
|
|---|
| 481 | ;;;; Commands (Gosh, wow gee!)
|
|---|
| 482 |
|
|---|
| 483 | (defcommand "Editor Server Name" (p)
|
|---|
| 484 | "Echos the editor server's name which can be supplied with the -slave switch
|
|---|
| 485 | to connect to a designated editor."
|
|---|
| 486 | "Echos the editor server's name which can be supplied with the -slave switch
|
|---|
| 487 | to connect to a designated editor."
|
|---|
| 488 | (declare (ignore p))
|
|---|
| 489 | (if *editor-name*
|
|---|
| 490 | (message "This editor is named ~S." *editor-name*)
|
|---|
| 491 | (message "This editor is not currently named.")))
|
|---|
| 492 |
|
|---|
| 493 | (defcommand "Set Buffer Package" (p)
|
|---|
| 494 | "Set the package to be used by Lisp evaluation and compilation commands
|
|---|
| 495 | while in this buffer. When in a slave's interactive buffers, do NOT
|
|---|
| 496 | set the editor's package variable, but changed the slave's *package*."
|
|---|
| 497 | "Prompt for a package to make into a buffer-local variable current-package."
|
|---|
| 498 | (declare (ignore p))
|
|---|
| 499 | (let* ((name (string (prompt-for-expression
|
|---|
| 500 | :prompt "Package name: "
|
|---|
| 501 | :help "Name of package to associate with this buffer.")))
|
|---|
| 502 | (buffer (current-buffer))
|
|---|
| 503 | (info (value current-eval-server)))
|
|---|
| 504 | (cond ((and info
|
|---|
| 505 | (or (eq (server-info-slave-buffer info) buffer)
|
|---|
| 506 | (eq (server-info-background-buffer info) buffer)))
|
|---|
| 507 | (hemlock.wire:remote (server-info-wire info)
|
|---|
| 508 | (server-set-package name))
|
|---|
| 509 | (hemlock.wire:wire-force-output (server-info-wire info)))
|
|---|
| 510 | ((eq buffer *selected-eval-buffer*)
|
|---|
| 511 | (setf *package* (maybe-make-package name)))
|
|---|
| 512 | (t
|
|---|
| 513 | (defhvar "Current Package"
|
|---|
| 514 | "The package used for evaluation of Lisp in this buffer."
|
|---|
| 515 | :buffer buffer :value name)))
|
|---|
| 516 | (when (buffer-modeline-field-p buffer :package)
|
|---|
| 517 | (dolist (w (buffer-windows buffer))
|
|---|
| 518 | (update-modeline-field buffer w :package)))))
|
|---|
| 519 |
|
|---|
| 520 | (defcommand "Current Compile Server" (p)
|
|---|
| 521 | "Echos the current compile server's name. With prefix argument,
|
|---|
| 522 | shows global one. Does not signal an error or ask about creating a slave."
|
|---|
| 523 | "Echos the current compile server's name. With prefix argument,
|
|---|
| 524 | shows global one."
|
|---|
| 525 | (let ((info (if p
|
|---|
| 526 | (variable-value 'current-compile-server :global)
|
|---|
| 527 | (value current-compile-server))))
|
|---|
| 528 | (if info
|
|---|
| 529 | (message "~A" (server-info-name info))
|
|---|
| 530 | (message "No ~:[current~;global~] compile server." p))))
|
|---|
| 531 |
|
|---|
| 532 | (defcommand "Set Compile Server" (p)
|
|---|
| 533 | "Specifies the name of the server used globally for file compilation requests."
|
|---|
| 534 | "Call select-current-compile-server."
|
|---|
| 535 | (declare (ignore p))
|
|---|
| 536 | (hlet ((ask-about-old-servers t))
|
|---|
| 537 | (setf (variable-value 'current-compile-server :global)
|
|---|
| 538 | (maybe-create-server))))
|
|---|
| 539 |
|
|---|
| 540 | (defcommand "Set Buffer Compile Server" (p)
|
|---|
| 541 | "Specifies the name of the server used for file compilation requests in
|
|---|
| 542 | the current buffer."
|
|---|
| 543 | "Call select-current-compile-server after making a buffer local variable."
|
|---|
| 544 | (declare (ignore p))
|
|---|
| 545 | (hlet ((ask-about-old-servers t))
|
|---|
| 546 | (defhvar "Current Compile Server"
|
|---|
| 547 | "The Server-Info object for the server currently used for compilation requests."
|
|---|
| 548 | :buffer (current-buffer)
|
|---|
| 549 | :value (maybe-create-server))))
|
|---|
| 550 |
|
|---|
| 551 | (defcommand "Current Eval Server" (p)
|
|---|
| 552 | "Echos the current eval server's name. With prefix argument, shows
|
|---|
| 553 | global one. Does not signal an error or ask about creating a slave."
|
|---|
| 554 | "Echos the current eval server's name. With prefix argument, shows
|
|---|
| 555 | global one. Does not signal an error or ask about creating a slave."
|
|---|
| 556 | (let ((info (if p
|
|---|
| 557 | (variable-value 'current-eval-server :global)
|
|---|
| 558 | (value current-eval-server))))
|
|---|
| 559 | (if info
|
|---|
| 560 | (message "~A" (server-info-name info))
|
|---|
| 561 | (message "No ~:[current~;global~] eval server." p))))
|
|---|
| 562 |
|
|---|
| 563 | (defcommand "Set Eval Server" (p)
|
|---|
| 564 | "Specifies the name of the server used globally for evaluation and
|
|---|
| 565 | compilation requests."
|
|---|
| 566 | "Call select-current-server."
|
|---|
| 567 | (declare (ignore p))
|
|---|
| 568 | (hlet ((ask-about-old-servers t))
|
|---|
| 569 | (setf (variable-value 'current-eval-server :global)
|
|---|
| 570 | (maybe-create-server))))
|
|---|
| 571 |
|
|---|
| 572 | (defcommand "Set Buffer Eval Server" (p)
|
|---|
| 573 | "Specifies the name of the server used for evaluation and compilation
|
|---|
| 574 | requests in the current buffer."
|
|---|
| 575 | "Call select-current-server after making a buffer local variable."
|
|---|
| 576 | (declare (ignore p))
|
|---|
| 577 | (hlet ((ask-about-old-servers t))
|
|---|
| 578 | (defhvar "Current Eval Server"
|
|---|
| 579 | "The Server-Info for the eval server used in this buffer."
|
|---|
| 580 | :buffer (current-buffer)
|
|---|
| 581 | :value (maybe-create-server))))
|
|---|
| 582 |
|
|---|
| 583 | (defcommand "Evaluate Defun" (p)
|
|---|
| 584 | "Evaluates the current or next top-level form.
|
|---|
| 585 | If the current region is active, then evaluate it."
|
|---|
| 586 | "Evaluates the current or next top-level form."
|
|---|
| 587 | (declare (ignore p))
|
|---|
| 588 | (if (region-active-p)
|
|---|
| 589 | (evaluate-region-command nil)
|
|---|
| 590 | (region-eval (defun-region (current-point)))))
|
|---|
| 591 |
|
|---|
| 592 | (defcommand "Re-evaluate Defvar" (p)
|
|---|
| 593 | "Evaluate the current or next top-level form if it is a DEFVAR. Treat the
|
|---|
| 594 | form as if the variable is not bound."
|
|---|
| 595 | "Evaluate the current or next top-level form if it is a DEFVAR. Treat the
|
|---|
| 596 | form as if the variable is not bound."
|
|---|
| 597 | (declare (ignore p))
|
|---|
| 598 | (let* ((form (defun-region (current-point)))
|
|---|
| 599 | (start (region-start form)))
|
|---|
| 600 | (with-mark ((var-start start)
|
|---|
| 601 | (var-end start))
|
|---|
| 602 | (mark-after var-start)
|
|---|
| 603 | (form-offset var-start 1)
|
|---|
| 604 | (form-offset (move-mark var-end var-start) 1)
|
|---|
| 605 | (let ((exp (concatenate 'simple-string
|
|---|
| 606 | "(makunbound '"
|
|---|
| 607 | (region-to-string (region var-start var-end))
|
|---|
| 608 | ")")))
|
|---|
| 609 | (eval-form-in-server (get-current-eval-server) exp)))
|
|---|
| 610 | (region-eval form)))
|
|---|
| 611 |
|
|---|
| 612 | ;;; We use Prin1-To-String in the client so that the expansion gets pretty
|
|---|
| 613 | ;;; printed. Since the expansion can contain unreadable stuff, we can't expect
|
|---|
| 614 | ;;; to be able to read that string back in the editor. We shove the region
|
|---|
| 615 | ;;; at the client Lisp as a string, so it can read from the string with the
|
|---|
| 616 | ;;; right package environment.
|
|---|
| 617 | ;;;
|
|---|
| 618 |
|
|---|
| 619 | (defcommand "Macroexpand Expression" (p)
|
|---|
| 620 | "Show the macroexpansion of the current expression in the null environment.
|
|---|
| 621 | With an argument, use MACROEXPAND instead of MACROEXPAND-1."
|
|---|
| 622 | "Show the macroexpansion of the current expression in the null environment.
|
|---|
| 623 | With an argument, use MACROEXPAND instead of MACROEXPAND-1."
|
|---|
| 624 | (let ((point (current-point)))
|
|---|
| 625 | (with-mark ((start point))
|
|---|
| 626 | (pre-command-parse-check start)
|
|---|
| 627 | (with-mark ((end start))
|
|---|
| 628 | (unless (form-offset end 1) (editor-error))
|
|---|
| 629 | (with-pop-up-display (s)
|
|---|
| 630 | (write-string
|
|---|
| 631 | (eval-form-in-server-1
|
|---|
| 632 | (get-current-eval-server)
|
|---|
| 633 | (format nil "(prin1-to-string (~S (read-from-string ~S)))"
|
|---|
| 634 | (if p 'macroexpand 'macroexpand-1)
|
|---|
| 635 | (region-to-string (region start end))))
|
|---|
| 636 | s))))))
|
|---|
| 637 |
|
|---|
| 638 | (defcommand "Evaluate Expression" (p)
|
|---|
| 639 | "Prompt for an expression to evaluate."
|
|---|
| 640 | "Prompt for an expression to evaluate."
|
|---|
| 641 | (declare (ignore p))
|
|---|
| 642 | (let ((exp (prompt-for-string
|
|---|
| 643 | :prompt "Eval: "
|
|---|
| 644 | :help "Expression to evaluate.")))
|
|---|
| 645 | (message "=> ~{~#[~;~A~:;~A, ~]~}"
|
|---|
| 646 | (eval-form-in-server (get-current-eval-server) exp))))
|
|---|
| 647 |
|
|---|
| 648 | (defcommand "Compile Defun" (p)
|
|---|
| 649 | "Compiles the current or next top-level form.
|
|---|
| 650 | First the form is evaluated, then the result of this evaluation
|
|---|
| 651 | is passed to compile. If the current region is active, compile
|
|---|
| 652 | the region."
|
|---|
| 653 | "Evaluates the current or next top-level form."
|
|---|
| 654 | (declare (ignore p))
|
|---|
| 655 | (if (region-active-p)
|
|---|
| 656 | (compile-region-command nil)
|
|---|
| 657 | (region-compile (defun-region (current-point)))))
|
|---|
| 658 |
|
|---|
| 659 | (defcommand "Compile Region" (p)
|
|---|
| 660 | "Compiles lisp forms between the point and the mark."
|
|---|
| 661 | "Compiles lisp forms between the point and the mark."
|
|---|
| 662 | (declare (ignore p))
|
|---|
| 663 | (region-compile (current-region)))
|
|---|
| 664 |
|
|---|
| 665 | (defcommand "Evaluate Region" (p)
|
|---|
| 666 | "Evaluates lisp forms between the point and the mark."
|
|---|
| 667 | "Evaluates lisp forms between the point and the mark."
|
|---|
| 668 | (declare (ignore p))
|
|---|
| 669 | (region-eval (current-region)))
|
|---|
| 670 |
|
|---|
| 671 | (defcommand "Evaluate Buffer" (p)
|
|---|
| 672 | "Evaluates the text in the current buffer."
|
|---|
| 673 | "Evaluates the text in the current buffer redirecting *Standard-Output* to
|
|---|
| 674 | the echo area. The prefix argument is ignored."
|
|---|
| 675 | (declare (ignore p))
|
|---|
| 676 | (let ((b (current-buffer)))
|
|---|
| 677 | (region-eval (buffer-region b)
|
|---|
| 678 | :context (format nil
|
|---|
| 679 | "evaluation of buffer ``~A''"
|
|---|
| 680 | (buffer-name b)))))
|
|---|
| 681 |
|
|---|
| 682 | (defcommand "Load File" (p)
|
|---|
| 683 | "Prompt for a file to load into the current eval server."
|
|---|
| 684 | "Prompt for a file to load into the current eval server."
|
|---|
| 685 | (declare (ignore p))
|
|---|
| 686 | (let ((name (truename (prompt-for-file
|
|---|
| 687 | :default
|
|---|
| 688 | (or (value load-pathname-defaults)
|
|---|
| 689 | (buffer-default-pathname (current-buffer)))
|
|---|
| 690 | :prompt "File to load: "
|
|---|
| 691 | :help "The name of the file to load"))))
|
|---|
| 692 | (setv load-pathname-defaults name)
|
|---|
| 693 | (string-eval (format nil "(load ~S)"
|
|---|
| 694 | (namestring
|
|---|
| 695 | (if (value remote-compile-file)
|
|---|
| 696 | (pathname-for-remote-access name)
|
|---|
| 697 | name))))))
|
|---|
| 698 |
|
|---|
| 699 | (defcommand "Compile File" (p)
|
|---|
| 700 | "Prompts for file to compile. Does not compare source and binary write
|
|---|
| 701 | dates. Does not check any buffer for that file for whether the buffer
|
|---|
| 702 | needs to be saved."
|
|---|
| 703 | "Prompts for file to compile."
|
|---|
| 704 | (declare (ignore p))
|
|---|
| 705 | (let ((pn (prompt-for-file :default
|
|---|
| 706 | (buffer-default-pathname (current-buffer))
|
|---|
| 707 | :prompt "File to compile: ")))
|
|---|
| 708 | (file-compile pn)))
|
|---|
| 709 |
|
|---|
| 710 | (defhvar "Compile Buffer File Confirm"
|
|---|
| 711 | "When set, \"Compile Buffer File\" prompts before doing anything."
|
|---|
| 712 | :value t)
|
|---|
| 713 |
|
|---|
| 714 | (defcommand "Compile Buffer File" (p)
|
|---|
| 715 | "Compile the file in the current buffer if its associated binary file
|
|---|
| 716 | (of type .fasl) is older than the source or doesn't exist. When the
|
|---|
| 717 | binary file is up to date, the user is asked if the source should be
|
|---|
| 718 | compiled anyway. When the prefix argument is supplied, compile the
|
|---|
| 719 | file without checking the binary file. When \"Compile Buffer File
|
|---|
| 720 | Confirm\" is set, this command will ask for confirmation when it
|
|---|
| 721 | otherwise would not."
|
|---|
| 722 | "Compile the file in the current buffer if the fasl file isn't up to date.
|
|---|
| 723 | When p, always do it."
|
|---|
| 724 | (let* ((buf (current-buffer))
|
|---|
| 725 | (pn (buffer-pathname buf)))
|
|---|
| 726 | (unless pn (editor-error "Buffer has no associated pathname."))
|
|---|
| 727 | (cond ((buffer-modified buf)
|
|---|
| 728 | (when (or (not (value compile-buffer-file-confirm))
|
|---|
| 729 | (prompt-for-y-or-n
|
|---|
| 730 | :default t :default-string "Y"
|
|---|
| 731 | :prompt (list "Save and compile file ~A? "
|
|---|
| 732 | (namestring pn))))
|
|---|
| 733 | (write-buffer-file buf pn)
|
|---|
| 734 | (file-compile pn :buffer buf)))
|
|---|
| 735 | ((older-or-non-existent-fasl-p pn p)
|
|---|
| 736 | (when (or (not (value compile-buffer-file-confirm))
|
|---|
| 737 | (prompt-for-y-or-n
|
|---|
| 738 | :default t :default-string "Y"
|
|---|
| 739 | :prompt (list "Compile file ~A? " (namestring pn))))
|
|---|
| 740 | (file-compile pn :buffer buf)))
|
|---|
| 741 | ((or p
|
|---|
| 742 | (prompt-for-y-or-n
|
|---|
| 743 | :default t :default-string "Y"
|
|---|
| 744 | :prompt
|
|---|
| 745 | "Fasl file up to date, compile source anyway? "))
|
|---|
| 746 | (file-compile pn :buffer buf)))))
|
|---|
| 747 |
|
|---|
| 748 | (defcommand "Compile Group" (p)
|
|---|
| 749 | "Compile each file in the current group which needs it.
|
|---|
| 750 | If a file has type LISP and there is a curresponding file with type
|
|---|
| 751 | FASL which has been written less recently (or it doesn't exit), then
|
|---|
| 752 | the file is compiled, with error output directed to the \"Compiler Warnings\"
|
|---|
| 753 | buffer. If a prefix argument is provided, then all the files are compiled.
|
|---|
| 754 | All modified files are saved beforehand."
|
|---|
| 755 | "Do a Compile-File in each file in the current group that seems to need it."
|
|---|
| 756 | (save-all-files-command ())
|
|---|
| 757 | (unless *active-file-group* (editor-error "No active file group."))
|
|---|
| 758 | (dolist (file *active-file-group*)
|
|---|
| 759 | (when (string-equal (pathname-type file) "lisp")
|
|---|
| 760 | (let ((tn (probe-file file)))
|
|---|
| 761 | (cond ((not tn)
|
|---|
| 762 | (message "File ~A not found." (namestring file)))
|
|---|
| 763 | ((older-or-non-existent-fasl-p tn p)
|
|---|
| 764 | (file-compile tn)))))))
|
|---|
| 765 |
|
|---|
| 766 | |
|---|
| 767 |
|
|---|
| 768 | ;;;; Error hacking stuff.
|
|---|
| 769 |
|
|---|
| 770 | (defcommand "Flush Compiler Error Information" (p)
|
|---|
| 771 | "Flushes all infomation about errors encountered while compiling using the
|
|---|
| 772 | current server"
|
|---|
| 773 | "Flushes all infomation about errors encountered while compiling using the
|
|---|
| 774 | current server"
|
|---|
| 775 | (declare (ignore p))
|
|---|
| 776 | (clear-server-errors (get-current-compile-server t)))
|
|---|
| 777 |
|
|---|
| 778 | (defcommand "Next Compiler Error" (p)
|
|---|
| 779 | "Move to the next compiler error for the current server. If an argument is
|
|---|
| 780 | given, advance that many errors."
|
|---|
| 781 | "Move to the next compiler error for the current server. If an argument is
|
|---|
| 782 | given, advance that many errors."
|
|---|
| 783 | (let* ((server (get-current-compile-server t))
|
|---|
| 784 | (errors (server-info-errors server))
|
|---|
| 785 | (fp (fill-pointer errors)))
|
|---|
| 786 | (when (zerop fp)
|
|---|
| 787 | (editor-error "There are no compiler errors."))
|
|---|
| 788 | (let* ((old-index (server-info-error-index server))
|
|---|
| 789 | (new-index (+ (or old-index -1) (or p 1))))
|
|---|
| 790 | (when (< new-index 0)
|
|---|
| 791 | (if old-index
|
|---|
| 792 | (editor-error "Can't back up ~R, only at the ~:R compiler error."
|
|---|
| 793 | (- p) (1+ old-index))
|
|---|
| 794 | (editor-error "Not even at the first compiler error.")))
|
|---|
| 795 | (when (>= new-index fp)
|
|---|
| 796 | (if (= (1+ (or old-index -1)) fp)
|
|---|
| 797 | (editor-error "No more compiler errors.")
|
|---|
| 798 | (editor-error "Only ~R remaining compiler error~:P."
|
|---|
| 799 | (- fp old-index 1))))
|
|---|
| 800 | (setf (server-info-error-index server) new-index)
|
|---|
| 801 | ;; Display the silly error.
|
|---|
| 802 | (let ((error (aref errors new-index)))
|
|---|
| 803 | (let ((region (error-info-region error)))
|
|---|
| 804 | (if region
|
|---|
| 805 | (let* ((start (region-start region))
|
|---|
| 806 | (buffer (line-buffer (mark-line start))))
|
|---|
| 807 | (change-to-buffer buffer)
|
|---|
| 808 | (move-mark (buffer-point buffer) start))
|
|---|
| 809 | (message "Hmm, no region for this error.")))
|
|---|
| 810 | (let* ((line (error-info-line error))
|
|---|
| 811 | (buffer (line-buffer line)))
|
|---|
| 812 | (if (and line (bufferp buffer))
|
|---|
| 813 | (let ((mark (mark line 0)))
|
|---|
| 814 | (unless (buffer-windows buffer)
|
|---|
| 815 | (let ((window (find-if-not
|
|---|
| 816 | #'(lambda (window)
|
|---|
| 817 | (or (eq window (current-window))
|
|---|
| 818 | (eq window *echo-area-window*)))
|
|---|
| 819 | *window-list*)))
|
|---|
| 820 | (if window
|
|---|
| 821 | (setf (window-buffer window) buffer)
|
|---|
| 822 | (make-window mark))))
|
|---|
| 823 | (move-mark (buffer-point buffer) mark)
|
|---|
| 824 | (dolist (window (buffer-windows buffer))
|
|---|
| 825 | (move-mark (window-display-start window) mark)
|
|---|
| 826 | (move-mark (window-point window) mark))
|
|---|
| 827 | (delete-mark mark))
|
|---|
| 828 | (message "Hmm, no line for this error.")))))))
|
|---|
| 829 |
|
|---|
| 830 | (defcommand "Previous Compiler Error" (p)
|
|---|
| 831 | "Move to the previous compiler error. If an argument is given, move back
|
|---|
| 832 | that many errors."
|
|---|
| 833 | "Move to the previous compiler error. If an argument is given, move back
|
|---|
| 834 | that many errors."
|
|---|
| 835 | (next-compiler-error-command (- (or p 1))))
|
|---|
| 836 |
|
|---|
| 837 |
|
|---|
| 838 | |
|---|
| 839 |
|
|---|
| 840 | ;;;; Operation management commands:
|
|---|
| 841 |
|
|---|
| 842 | (defcommand "Abort Operations" (p)
|
|---|
| 843 | "Abort all operations on current eval server connection."
|
|---|
| 844 | "Abort all operations on current eval server connection."
|
|---|
| 845 | (declare (ignore p))
|
|---|
| 846 | (let* ((server (get-current-eval-server))
|
|---|
| 847 | (wire (server-info-wire server)))
|
|---|
| 848 | ;; Tell the slave to abort the current operation and to ignore any further
|
|---|
| 849 | ;; operations.
|
|---|
| 850 | (dolist (note (server-info-notes server))
|
|---|
| 851 | (setf (note-state note) :aborted))
|
|---|
| 852 | #+NILGB (ext:send-character-out-of-band (hemlock.wire:wire-fd wire) #\N)
|
|---|
| 853 | (hemlock.wire:remote-value wire (server-accept-operations))
|
|---|
| 854 | ;; Synch'ing with server here, causes any operations queued at the socket or
|
|---|
| 855 | ;; in the server to be ignored, and the last thing evaluated is an
|
|---|
| 856 | ;; instruction to go on accepting operations.
|
|---|
| 857 | (hemlock.wire:wire-force-output wire)
|
|---|
| 858 | (dolist (note (server-info-notes server))
|
|---|
| 859 | (when (eq (note-state note) :pending)
|
|---|
| 860 | ;; The HEMLOCK.WIRE:REMOTE-VALUE call should have allowed a handshake to
|
|---|
| 861 | ;; tell the editor anything :pending was aborted.
|
|---|
| 862 | (error "Operation ~S is still around after we aborted it?" note)))
|
|---|
| 863 | ;; Forget anything queued in the editor.
|
|---|
| 864 | (setf (server-info-notes server) nil)))
|
|---|
| 865 |
|
|---|
| 866 | (defcommand "List Operations" (p)
|
|---|
| 867 | "List all eval server operations which have not yet completed."
|
|---|
| 868 | "List all eval server operations which have not yet completed."
|
|---|
| 869 | (declare (ignore p))
|
|---|
| 870 | (let ((notes nil))
|
|---|
| 871 | ;; Collect all notes, reversing them since they act like a queue but
|
|---|
| 872 | ;; are not in queue order.
|
|---|
| 873 | (do-strings (str val *server-names*)
|
|---|
| 874 | (declare (ignore str))
|
|---|
| 875 | (setq notes (nconc notes (reverse (server-info-notes val)))))
|
|---|
| 876 | (if notes
|
|---|
| 877 | (with-pop-up-display (s)
|
|---|
| 878 | (dolist (note notes)
|
|---|
| 879 | (format s "~@(~8A~) ~A on ~A.~%"
|
|---|
| 880 | (note-state note)
|
|---|
| 881 | (note-context note)
|
|---|
| 882 | (server-info-name (note-server note)))))
|
|---|
| 883 | (message "No uncompleted operations.")))
|
|---|
| 884 | (values))
|
|---|
| 885 |
|
|---|
| 886 | |
|---|
| 887 |
|
|---|
| 888 | ;;;; Describing in the client lisp.
|
|---|
| 889 |
|
|---|
| 890 | ;;; "Describe Function Call" gets the function name from the current form
|
|---|
| 891 | ;;; as a string. This string is used as the argument to a call to
|
|---|
| 892 | ;;; DESCRIBE-FUNCTION-CALL-AUX which is eval'ed in the client lisp. The
|
|---|
| 893 | ;;; auxiliary function's name is qualified since it is read in the client
|
|---|
| 894 | ;;; Lisp with *package* bound to the buffer's package. The result comes
|
|---|
| 895 | ;;; back as a list of strings, so we read the first string to get out the
|
|---|
| 896 | ;;; string value returned by DESCRIBE-FUNCTION-CALL-AUX in the client Lisp.
|
|---|
| 897 | ;;;
|
|---|
| 898 | (defcommand "Describe Function Call" (p)
|
|---|
| 899 | "Describe the current function call."
|
|---|
| 900 | "Describe the current function call."
|
|---|
| 901 | (let ((info (value current-eval-server)))
|
|---|
| 902 | (cond
|
|---|
| 903 | ((not info)
|
|---|
| 904 | (message "Describing from the editor Lisp ...")
|
|---|
| 905 | (editor-describe-function-call-command p))
|
|---|
| 906 | (t
|
|---|
| 907 | (with-mark ((mark1 (current-point))
|
|---|
| 908 | (mark2 (current-point)))
|
|---|
| 909 | (pre-command-parse-check mark1)
|
|---|
| 910 | (unless (backward-up-list mark1) (editor-error))
|
|---|
| 911 | (form-offset (move-mark mark2 (mark-after mark1)) 1)
|
|---|
| 912 | (let* ((package (value current-package))
|
|---|
| 913 | (package-exists
|
|---|
| 914 | (eval-form-in-server-1
|
|---|
| 915 | info
|
|---|
| 916 | (format nil
|
|---|
| 917 | "(if (find-package ~S) t (package-name *package*))"
|
|---|
| 918 | package)
|
|---|
| 919 | nil)))
|
|---|
| 920 | (unless (eq package-exists t)
|
|---|
| 921 | (message "Using package ~S in ~A since ~
|
|---|
| 922 | ~:[there is no current package~;~:*~S does not exist~]."
|
|---|
| 923 | package-exists (server-info-name info) package))
|
|---|
| 924 | (with-pop-up-display (s)
|
|---|
| 925 | (write-string (eval-form-in-server-1
|
|---|
| 926 | info
|
|---|
| 927 | (format nil "(hemlock::describe-function-call-aux ~S)"
|
|---|
| 928 | (region-to-string (region mark1 mark2)))
|
|---|
| 929 | (if (eq package-exists t) package nil))
|
|---|
| 930 | s))))))))
|
|---|
| 931 |
|
|---|
| 932 | ;;; DESCRIBE-FUNCTION-CALL-AUX is always evaluated in a client Lisp to some
|
|---|
| 933 | ;;; editor, relying on the fact that the cores have the same functions. String
|
|---|
| 934 | ;;; is the name of a function that is read (in the client Lisp). The result is
|
|---|
| 935 | ;;; a string of all the output from EDITOR-DESCRIBE-FUNCTION.
|
|---|
| 936 | ;;;
|
|---|
| 937 | (defun describe-function-call-aux (string)
|
|---|
| 938 | (let* ((sym (read-from-string string))
|
|---|
| 939 | (fun (function-to-describe sym error)))
|
|---|
| 940 | (with-output-to-string (*standard-output*)
|
|---|
| 941 | (editor-describe-function fun sym))))
|
|---|
| 942 |
|
|---|
| 943 | ;;; "Describe Symbol" gets the symbol name and quotes it as the argument to a
|
|---|
| 944 | ;;; call to DESCRIBE-SYMBOL-AUX which is eval'ed in the client lisp. The
|
|---|
| 945 | ;;; auxiliary function's name is qualified since it is read in the client Lisp
|
|---|
| 946 | ;;; with *package* bound to the buffer's package. The result comes back as a
|
|---|
| 947 | ;;; list of strings, so we read the first string to get out the string value
|
|---|
| 948 | ;;; returned by DESCRIBE-SYMBOL-AUX in the client Lisp.
|
|---|
| 949 | ;;;
|
|---|
| 950 |
|
|---|
| 951 | (defcommand "Describe Symbol" (p)
|
|---|
| 952 | "Describe the previous s-expression if it is a symbol."
|
|---|
| 953 | "Describe the previous s-expression if it is a symbol."
|
|---|
| 954 | (declare (ignore p))
|
|---|
| 955 | (let ((info (value current-eval-server)))
|
|---|
| 956 | (cond
|
|---|
| 957 | ((not info)
|
|---|
| 958 | (message "Describing from the editor Lisp ...")
|
|---|
| 959 | (editor-describe-symbol-command nil))
|
|---|
| 960 | (t
|
|---|
| 961 | (with-mark ((mark1 (current-point))
|
|---|
| 962 | (mark2 (current-point)))
|
|---|
| 963 | (mark-symbol mark1 mark2)
|
|---|
| 964 | (with-pop-up-display (s)
|
|---|
| 965 | (write-string (eval-form-in-server-1
|
|---|
| 966 | info
|
|---|
| 967 | (format nil "(hemlock::describe-symbol-aux '~A)"
|
|---|
| 968 | (region-to-string (region mark1 mark2))))
|
|---|
| 969 | s)))))))
|
|---|
| 970 |
|
|---|
| 971 | (defun describe-symbol-aux (thing)
|
|---|
| 972 | (with-output-to-string (*standard-output*)
|
|---|
| 973 | (describe (if (and (consp thing)
|
|---|
| 974 | (or (eq (car thing) 'quote)
|
|---|
| 975 | (eq (car thing) 'function))
|
|---|
| 976 | (symbolp (cadr thing)))
|
|---|
| 977 | (cadr thing)
|
|---|
| 978 | thing))))
|
|---|
