| [595] | 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 | ;;;
|
|---|
| 8 | ;;; **********************************************************************
|
|---|
| 9 | ;;;
|
|---|
| 10 | ;;; Listener mode, dervived (sort of) from Hemlock's "Eval" mode.
|
|---|
| 11 | ;;;
|
|---|
| 12 |
|
|---|
| 13 | (in-package :hemlock)
|
|---|
| 14 |
|
|---|
| 15 |
|
|---|
| 16 | (defmacro in-lisp (&body body)
|
|---|
| 17 | "Evaluates body inside HANDLE-LISP-ERRORS. *package* is bound to the package
|
|---|
| 18 | named by \"Current Package\" if it is non-nil."
|
|---|
| 19 | (let ((name (gensym)) (package (gensym)))
|
|---|
| 20 | `(handle-lisp-errors
|
|---|
| [7122] | 21 | (let* ((,name (variable-value 'current-package :buffer (current-buffer)))
|
|---|
| [595] | 22 | (,package (and ,name (find-package ,name))))
|
|---|
| 23 | (progv (if ,package '(*package*)) (if ,package (list ,package))
|
|---|
| 24 | ,@body)))))
|
|---|
| 25 |
|
|---|
| 26 |
|
|---|
| [719] | 27 | (defun package-name-change-hook (name kind where new-value)
|
|---|
| [697] | 28 | (declare (ignore name new-value))
|
|---|
| 29 | (if (eq kind :buffer)
|
|---|
| [8428] | 30 | (hi::note-modeline-change where)))
|
|---|
| [697] | 31 |
|
|---|
| [595] | 32 | (define-file-option "Package" (buffer value)
|
|---|
| [12123] | 33 | (let* ((thing (handler-case (read-from-string value t)
|
|---|
| 34 | (error () (editor-error "Bad package file option value"))))
|
|---|
| 35 | (name
|
|---|
| 36 | (cond
|
|---|
| 37 | ((or (stringp thing) (symbolp thing))
|
|---|
| 38 | (string thing))
|
|---|
| 39 | ((and (consp thing) ;; e.g. Package: (foo :use bar)
|
|---|
| 40 | (or (stringp (car thing)) (symbolp (car thing))))
|
|---|
| 41 | (string (car thing)))
|
|---|
| 42 | (t
|
|---|
| 43 | (message "Ignoring \"package:\" file option ~a" thing)
|
|---|
| 44 | nil))))
|
|---|
| 45 | (when name
|
|---|
| 46 | (ignore-errors (let* ((*package* *package*))
|
|---|
| 47 | (apply 'ccl::old-in-package (if (atom thing) (list thing) thing)))))
|
|---|
| 48 | (defhvar "Current Package"
|
|---|
| 49 | "The package used for evaluation of Lisp in this buffer."
|
|---|
| 50 | :buffer buffer
|
|---|
| 51 | :value (or name (package-name *package*))
|
|---|
| 52 | :hooks (list 'package-name-change-hook))
|
|---|
| 53 | (defhvar "Default Package"
|
|---|
| 54 | "The buffer's default package."
|
|---|
| 55 | :buffer buffer
|
|---|
| 56 | :value (or name (package-name *package*)))))
|
|---|
| 57 |
|
|---|
| [14721] | 58 | (defcommand "Set Default Package" (p)
|
|---|
| 59 | "Set the package to use for forms in this buffer that are
|
|---|
| 60 | not preceeded by an in-package or modeline package"
|
|---|
| 61 | (declare (ignore p))
|
|---|
| 62 | (let ((package (prompt-for-package
|
|---|
| 63 | :must-exist t
|
|---|
| 64 | :prompt "Package: "
|
|---|
| 65 | :default (variable-value 'default-package :buffer (current-buffer))
|
|---|
| 66 | :help "Package to use when no in-package is specified")))
|
|---|
| 67 | (setf (variable-value 'default-package :buffer (current-buffer)) package)))
|
|---|
| [595] | 68 |
|
|---|
| [14721] | 69 |
|
|---|
| [595] | 70 | ;;;; Listener Mode Interaction.
|
|---|
| 71 |
|
|---|
| 72 |
|
|---|
| 73 |
|
|---|
| 74 | (defun setup-listener-mode (buffer)
|
|---|
| 75 | (let ((point (buffer-point buffer)))
|
|---|
| 76 | (setf (buffer-minor-mode buffer "Listener") t)
|
|---|
| 77 | (setf (buffer-minor-mode buffer "Editor") t)
|
|---|
| 78 | (setf (buffer-major-mode buffer) "Lisp")
|
|---|
| 79 | (buffer-end point)
|
|---|
| 80 | (defhvar "Current Package"
|
|---|
| 81 | "This variable holds the name of the package currently used for Lisp
|
|---|
| 82 | evaluation and compilation. If it is Nil, the value of *Package* is used
|
|---|
| 83 | instead."
|
|---|
| 84 | :value nil
|
|---|
| 85 | :buffer buffer)
|
|---|
| 86 | (unless (hemlock-bound-p 'buffer-input-mark :buffer buffer)
|
|---|
| 87 | (defhvar "Buffer Input Mark"
|
|---|
| 88 | "Mark used for Listener Mode input."
|
|---|
| 89 | :buffer buffer
|
|---|
| 90 | :value (copy-mark point :right-inserting))
|
|---|
| [6665] | 91 | (defhvar "Buffer Output Mark"
|
|---|
| 92 | "Mark used for Listener Mode output."
|
|---|
| 93 | :buffer buffer
|
|---|
| 94 | :value (copy-mark point :left-inserting))
|
|---|
| [595] | 95 | (defhvar "Interactive History"
|
|---|
| 96 | "A ring of the regions input to an interactive mode (Eval or Typescript)."
|
|---|
| 97 | :buffer buffer
|
|---|
| 98 | :value (make-ring (value interactive-history-length)))
|
|---|
| 99 | (defhvar "Interactive Pointer"
|
|---|
| 100 | "Pointer into \"Interactive History\"."
|
|---|
| 101 | :buffer buffer
|
|---|
| 102 | :value 0)
|
|---|
| 103 | (defhvar "Searching Interactive Pointer"
|
|---|
| 104 | "Pointer into \"Interactive History\"."
|
|---|
| 105 | :buffer buffer
|
|---|
| [804] | 106 | :value 0)
|
|---|
| 107 | (defhvar "Input Regions"
|
|---|
| 108 | "Input region history list."
|
|---|
| 109 | :buffer buffer
|
|---|
| 110 | :value nil)
|
|---|
| 111 | (defhvar "Current Input Font Region"
|
|---|
| 112 | "Current font region, for listener input"
|
|---|
| 113 | :buffer buffer
|
|---|
| 114 | :value nil)
|
|---|
| 115 | (defhvar "Current Output Font Region"
|
|---|
| 116 | "Current font region, for listener output"
|
|---|
| 117 | :buffer buffer
|
|---|
| 118 | :value nil)
|
|---|
| [14208] | 119 | (defhvar "Grabbed Input Start Mark"
|
|---|
| 120 | "Mark start of grabbed input"
|
|---|
| 121 | :buffer buffer
|
|---|
| 122 | :value (copy-mark point :right-inserting))
|
|---|
| [804] | 123 | )
|
|---|
| 124 | (let* ((input-mark (variable-value 'buffer-input-mark :buffer buffer)))
|
|---|
| [8428] | 125 | (when (hemlock-ext:read-only-listener-p)
|
|---|
| [7348] | 126 | (setf (hi::buffer-protected-region buffer)
|
|---|
| 127 | (region (buffer-start-mark buffer) input-mark)))
|
|---|
| [804] | 128 | (move-mark input-mark point)
|
|---|
| 129 | (append-font-regions buffer))))
|
|---|
| [595] | 130 |
|
|---|
| 131 | (defmode "Listener" :major-p nil :setup-function #'setup-listener-mode)
|
|---|
| 132 |
|
|---|
| [804] | 133 | (declaim (special hi::*listener-input-style* hi::*listener-output-style*))
|
|---|
| 134 |
|
|---|
| 135 | (defun append-font-regions (buffer)
|
|---|
| 136 | (let* ((end (region-end (buffer-region buffer))))
|
|---|
| 137 | (setf (variable-value 'current-output-font-region :buffer buffer)
|
|---|
| 138 | (hi::new-font-region buffer end end hi::*listener-output-style*))
|
|---|
| 139 | (let* ((input (hi::new-font-region buffer end end hi::*listener-input-style*)))
|
|---|
| 140 | (hi::activate-buffer-font-region buffer input)
|
|---|
| 141 | (setf (variable-value 'current-input-font-region :buffer buffer) input))))
|
|---|
| 142 |
|
|---|
| 143 | (defun append-buffer-output (buffer string)
|
|---|
| 144 | (let* ((output-region (variable-value 'current-output-font-region
|
|---|
| 145 | :buffer buffer))
|
|---|
| 146 | (output-end (region-end output-region)))
|
|---|
| 147 | (hi::with-active-font-region (buffer output-region)
|
|---|
| [6665] | 148 | (with-mark ((output-mark output-end :left-inserting))
|
|---|
| 149 | ;(setf (mark-charpos output-mark) 0)
|
|---|
| 150 | (insert-string output-mark string))
|
|---|
| [804] | 151 | (move-mark (variable-value 'buffer-input-mark :buffer buffer)
|
|---|
| 152 | output-end))))
|
|---|
| 153 |
|
|---|
| 154 |
|
|---|
| 155 |
|
|---|
| [597] | 156 | (defparameter *listener-modeline-fields*
|
|---|
| 157 | (list (modeline-field :package)
|
|---|
| 158 | (modeline-field :modes)
|
|---|
| 159 | (modeline-field :process-info)))
|
|---|
| 160 |
|
|---|
| [595] | 161 | (defun listener-mode-lisp-mode-hook (buffer on)
|
|---|
| 162 | "Turn on Lisp mode when we go into Listener Mode."
|
|---|
| 163 | (when on
|
|---|
| 164 | (setf (buffer-major-mode buffer) "Lisp")))
|
|---|
| 165 | ;;;
|
|---|
| 166 | (add-hook listener-mode-hook 'listener-mode-lisp-mode-hook)
|
|---|
| 167 |
|
|---|
| 168 |
|
|---|
| 169 |
|
|---|
| 170 |
|
|---|
| 171 |
|
|---|
| 172 | (defvar lispbuf-eof '(nil))
|
|---|
| 173 |
|
|---|
| [12400] | 174 | (defun skip-line-comment (mark)
|
|---|
| 175 | ;; return t if we skipped a comment, nil otherwise
|
|---|
| 176 | (let ((cstart (to-line-comment mark ";")))
|
|---|
| 177 | (if cstart
|
|---|
| 178 | (progn (to-comment-end mark (string #\newline))
|
|---|
| 179 | t)
|
|---|
| 180 | nil)))
|
|---|
| 181 |
|
|---|
| [597] | 182 | (defun balanced-expressions-in-region (region)
|
|---|
| 183 | "Return true if there's at least one syntactically well-formed S-expression
|
|---|
| 184 | between the region's start and end, and if there are no ill-formed expressions in that region."
|
|---|
| 185 | ;; It helps to know that END-MARK immediately follows a #\newline.
|
|---|
| 186 | (let* ((start-mark (region-start region))
|
|---|
| 187 | (end-mark (region-end region))
|
|---|
| 188 | (end-line (mark-line end-mark))
|
|---|
| 189 | (end-charpos (mark-charpos end-mark)))
|
|---|
| 190 | (with-mark ((m start-mark))
|
|---|
| 191 | (pre-command-parse-check m)
|
|---|
| 192 | (when (form-offset m 1)
|
|---|
| 193 | (let* ((skip-whitespace t))
|
|---|
| 194 | (loop
|
|---|
| 195 | (let* ((current-line (mark-line m))
|
|---|
| 196 | (current-charpos (mark-charpos m)))
|
|---|
| 197 | (when (and (eq current-line end-line)
|
|---|
| 198 | (eql current-charpos end-charpos))
|
|---|
| 199 | (return t))
|
|---|
| 200 | (if skip-whitespace
|
|---|
| 201 | (progn
|
|---|
| 202 | (scan-char m :whitespace nil)
|
|---|
| 203 | (setq skip-whitespace nil))
|
|---|
| 204 | (progn
|
|---|
| 205 | (pre-command-parse-check m)
|
|---|
| [12400] | 206 | (unless (or (form-offset m 1)
|
|---|
| 207 | (skip-line-comment m))
|
|---|
| [597] | 208 | (return nil))
|
|---|
| 209 | (setq skip-whitespace t))))))))))
|
|---|
| 210 |
|
|---|
| [12399] | 211 | #| old version
|
|---|
| [595] | 212 | (defcommand "Confirm Listener Input" (p)
|
|---|
| 213 | "Evaluate Listener Mode input between point and last prompt."
|
|---|
| 214 | (declare (ignore p))
|
|---|
| [804] | 215 | (let* ((input-region (get-interactive-input))
|
|---|
| 216 | (r (if input-region
|
|---|
| 217 | (region (copy-mark (region-start input-region))
|
|---|
| 218 | (copy-mark (region-end input-region) :right-inserting)))))
|
|---|
| 219 |
|
|---|
| [595] | 220 | (when input-region
|
|---|
| [12144] | 221 | (insert-character (current-point-for-insertion) #\NewLine)
|
|---|
| [12321] | 222 | (when (or (input-stream-reading-line
|
|---|
| 223 | (top-listener-input-stream))
|
|---|
| 224 | (balanced-expressions-in-region input-region))
|
|---|
| 225 | (let* ((string (region-to-string input-region)))
|
|---|
| [804] | 226 | (push (cons r nil) (value input-regions))
|
|---|
| [597] | 227 | (move-mark (value buffer-input-mark) (current-point))
|
|---|
| [804] | 228 | (append-font-regions (current-buffer))
|
|---|
| [8428] | 229 | (hemlock-ext:send-string-to-listener (current-buffer) string))))))
|
|---|
| [12399] | 230 | |#
|
|---|
| [595] | 231 |
|
|---|
| [12399] | 232 | (defun point-at-prompt-p ()
|
|---|
| 233 | (with-mark ((input-mark (value buffer-input-mark))
|
|---|
| 234 | (end-mark (value buffer-input-mark)))
|
|---|
| 235 | (buffer-end end-mark)
|
|---|
| 236 | (and (mark>= (current-point) input-mark)
|
|---|
| 237 | (mark>= end-mark (current-point)))))
|
|---|
| 238 |
|
|---|
| 239 | (defun send-input-region-to-lisp ()
|
|---|
| [12400] | 240 | (let* ((input-mark (value buffer-input-mark))
|
|---|
| 241 | (end-mark (region-end (buffer-region (current-buffer))))
|
|---|
| 242 | (input-region (region input-mark end-mark))
|
|---|
| [12399] | 243 | (r (if input-region
|
|---|
| 244 | (region (copy-mark (region-start input-region))
|
|---|
| 245 | (copy-mark (region-end input-region) :right-inserting)))))
|
|---|
| 246 | (when input-region
|
|---|
| [12407] | 247 | (if (or (input-stream-reading-line
|
|---|
| 248 | (top-listener-input-stream))
|
|---|
| 249 | (balanced-expressions-in-region input-region))
|
|---|
| [12545] | 250 | ;; complete expression: send it to lisp
|
|---|
| 251 | (let* ((string (region-to-string input-region))
|
|---|
| 252 | (ring (value interactive-history)))
|
|---|
| 253 | (when (and (or (zerop (ring-length ring))
|
|---|
| 254 | (string/= string (region-to-string (ring-ref ring 0))))
|
|---|
| 255 | (> (length string) (value minimum-interactive-input-length)))
|
|---|
| 256 | (ring-push (copy-region input-region) ring))
|
|---|
| 257 | (insert-character (region-end input-region) #\NewLine)
|
|---|
| 258 | (push (cons r nil) (value input-regions))
|
|---|
| 259 | (set-charprop-value (region-start input-region) :font-weight :bold
|
|---|
| 260 | :end (region-end input-region))
|
|---|
| 261 | (move-mark (value buffer-input-mark) (current-point))
|
|---|
| 262 | (append-font-regions (current-buffer))
|
|---|
| 263 | (hemlock-ext:send-string-to-listener (current-buffer) (concatenate 'string string '(#\Newline)))
|
|---|
| 264 | (buffer-end (current-point)))
|
|---|
| 265 | ;; incomplete expression: enter a newline
|
|---|
| 266 | (progn
|
|---|
| 267 | (insert-character (current-point-for-insertion) #\NewLine))))))
|
|---|
| [12399] | 268 |
|
|---|
| [14816] | 269 | (defun mark-in-region-p (mark region)
|
|---|
| 270 | (and (mark<= (region-start region) mark) (mark<= mark (region-end region))))
|
|---|
| 271 |
|
|---|
| 272 | (defun input-offset ()
|
|---|
| 273 | (if (hi::region-active-p)
|
|---|
| 274 | 0
|
|---|
| 275 | (let* ((mark (current-point))
|
|---|
| 276 | (history (value input-regions))
|
|---|
| 277 | (region (find mark history :key 'car :test 'mark-in-region-p)))
|
|---|
| 278 | (and region (count-characters (region mark (region-end (car region))))))))
|
|---|
| 279 |
|
|---|
| [12406] | 280 | (defun copy-region-to-input (region)
|
|---|
| [14816] | 281 | (when region
|
|---|
| 282 | (let* ((region-string (region-to-string region))
|
|---|
| 283 | (end-mark (region-end (buffer-region (current-buffer))))
|
|---|
| 284 | (offset (or (input-offset) 0)))
|
|---|
| 285 | (move-mark (current-point) end-mark)
|
|---|
| 286 | (insert-string (current-point) region-string)
|
|---|
| 287 | (buffer-end (current-point))
|
|---|
| 288 | (character-offset (current-point) (- offset)))))
|
|---|
| [12399] | 289 |
|
|---|
| [12401] | 290 | (defun find-backward-form (mark)
|
|---|
| 291 | (let ((start (copy-mark mark))
|
|---|
| 292 | (end (copy-mark mark)))
|
|---|
| 293 | (block finding
|
|---|
| 294 | (or (form-offset start -1) (return-from finding nil))
|
|---|
| 295 | (or (form-offset end -1) (return-from finding nil))
|
|---|
| 296 | (or (form-offset end 1) (return-from finding nil))
|
|---|
| 297 | (region start end))))
|
|---|
| 298 |
|
|---|
| 299 | (defun find-forward-form (mark)
|
|---|
| 300 | (let ((start (copy-mark mark))
|
|---|
| 301 | (end (copy-mark mark)))
|
|---|
| 302 | (block finding
|
|---|
| 303 | (or (form-offset start 1) (return-from finding nil))
|
|---|
| 304 | (or (form-offset end 1) (return-from finding nil))
|
|---|
| 305 | (or (form-offset start -1) (return-from finding nil))
|
|---|
| 306 | (region start end))))
|
|---|
| 307 |
|
|---|
| 308 | (defun region= (r1 r2)
|
|---|
| 309 | (multiple-value-bind (r1-start r1-end)(region-bounds r1)
|
|---|
| 310 | (multiple-value-bind (r2-start r2-end)(region-bounds r2)
|
|---|
| 311 | (and (mark= r1-start r2-start)
|
|---|
| 312 | (mark= r1-end r2-end)))))
|
|---|
| 313 |
|
|---|
| 314 | ;;; find the start or end of the nearest lisp form. return a region if
|
|---|
| 315 | ;;; one is found, nil otherwise. try for a commonsense result.
|
|---|
| 316 | (defun mark-nearest-form (mark)
|
|---|
| 317 | (let* ((backward-region (find-backward-form mark))
|
|---|
| 318 | (forward-region (find-forward-form mark)))
|
|---|
| 319 | (if backward-region
|
|---|
| 320 | (if forward-region
|
|---|
| 321 | ;; if we're in the middle of a token, then the backward
|
|---|
| 322 | ;; and forward regions will be the same
|
|---|
| 323 | (if (region= backward-region forward-region)
|
|---|
| 324 | backward-region
|
|---|
| 325 | ;; not equal, so figure out which is closer
|
|---|
| 326 | (let* ((mark-pos (mark-absolute-position mark))
|
|---|
| 327 | (backward-dist (abs (- mark-pos (mark-absolute-position (region-end backward-region)))))
|
|---|
| 328 | (forward-dist (abs (- (mark-absolute-position (region-start forward-region)) mark-pos))))
|
|---|
| 329 | (if (< forward-dist backward-dist)
|
|---|
| 330 | forward-region
|
|---|
| 331 | backward-region)))
|
|---|
| 332 | backward-region)
|
|---|
| 333 | forward-region)))
|
|---|
| 334 |
|
|---|
| [12406] | 335 | (defun copy-expression-at-point-to-input ()
|
|---|
| [12401] | 336 | (let* ((nearest-form-region (mark-nearest-form (current-point))))
|
|---|
| 337 | (if nearest-form-region
|
|---|
| [12406] | 338 | (copy-region-to-input nearest-form-region)
|
|---|
| [12401] | 339 | (beep))))
|
|---|
| [12399] | 340 |
|
|---|
| 341 | (defcommand "Confirm Listener Input" (p)
|
|---|
| 342 | "Evaluate Listener Mode input between point and last prompt."
|
|---|
| 343 | (declare (ignore p))
|
|---|
| 344 | (if (point-at-prompt-p)
|
|---|
| [12599] | 345 | (progn
|
|---|
| 346 | (if (eq (character-attribute :lisp-syntax (previous-character (buffer-end-mark (current-buffer)))) :char-quote)
|
|---|
| 347 | (let* ((point (current-point)))
|
|---|
| 348 | (buffer-end point)
|
|---|
| 349 | (insert-character point #\newline))
|
|---|
| 350 | (send-input-region-to-lisp)))
|
|---|
| [12399] | 351 | (if (region-active-p)
|
|---|
| 352 | (let ((selected-region (current-region nil nil)))
|
|---|
| [12406] | 353 | (copy-region-to-input selected-region))
|
|---|
| [12399] | 354 | (let ((prior-region (input-region-containing-mark (current-point) (value input-regions))))
|
|---|
| 355 | (if prior-region
|
|---|
| [12406] | 356 | (copy-region-to-input prior-region)
|
|---|
| 357 | (copy-expression-at-point-to-input))))))
|
|---|
| [12399] | 358 |
|
|---|
| 359 |
|
|---|
| [736] | 360 | (defparameter *pop-string* ":POP
|
|---|
| 361 | " "what you have to type to exit a break loop")
|
|---|
| [597] | 362 |
|
|---|
| [697] | 363 | (defcommand "POP or Delete Forward" (p)
|
|---|
| 364 | "Send :POP if input-mark is at buffer's end, else delete forward character."
|
|---|
| [597] | 365 | (let* ((input-mark (value buffer-input-mark))
|
|---|
| [6705] | 366 | (point (current-point-for-deletion)))
|
|---|
| [7118] | 367 | (when point
|
|---|
| 368 | (if (and (null (next-character point))
|
|---|
| 369 | (null (next-character input-mark)))
|
|---|
| [8428] | 370 | (hemlock-ext:send-string-to-listener (current-buffer) *pop-string*)
|
|---|
| 371 | (delete-next-character-command p)))))
|
|---|
| [597] | 372 |
|
|---|
| [14721] | 373 |
|
|---|
| [595] | 374 | ;;;; General interactive commands used in eval and typescript buffers.
|
|---|
| 375 |
|
|---|
| [804] | 376 | (defhvar "Interactive History Length"
|
|---|
| 377 | "This is the length used for the history ring in interactive buffers.
|
|---|
| 378 | It must be set before turning on the mode."
|
|---|
| [14208] | 379 | :value 200)
|
|---|
| [804] | 380 |
|
|---|
| 381 | (defun input-region-containing-mark (m history-list)
|
|---|
| 382 | (dolist (pair history-list)
|
|---|
| 383 | (let* ((actual (car pair))
|
|---|
| 384 | (start (region-start actual))
|
|---|
| 385 | (end (region-end actual)))
|
|---|
| 386 | (when (and (mark>= m start)
|
|---|
| 387 | (mark<= m end)) ; sic: inclusive
|
|---|
| 388 | (return (or (cdr pair) (setf (cdr pair) (copy-region actual))))))))
|
|---|
| 389 |
|
|---|
| 390 |
|
|---|
| [595] | 391 | (defun get-interactive-input ()
|
|---|
| 392 | "Tries to return a region. When the point is not past the input mark, and
|
|---|
| 393 | the user has \"Unwedge Interactive Input Confirm\" set, the buffer is
|
|---|
| 394 | optionally fixed up, and nil is returned. Otherwise, an editor error is
|
|---|
| 395 | signalled. When a region is returned, the start is the current buffer's
|
|---|
| 396 | input mark, and the end is the current point moved to the end of the buffer."
|
|---|
| 397 | (let ((point (current-point))
|
|---|
| [12399] | 398 | (mark (value buffer-input-mark)))
|
|---|
| [595] | 399 | (cond
|
|---|
| [12399] | 400 | ((mark>= point mark)
|
|---|
| 401 | (buffer-end point)
|
|---|
| 402 | (let* ((input-region (region mark point))
|
|---|
| 403 | (string (region-to-string input-region))
|
|---|
| 404 | (ring (value interactive-history)))
|
|---|
| 405 | (when (and (or (zerop (ring-length ring))
|
|---|
| 406 | (string/= string (region-to-string (ring-ref ring 0))))
|
|---|
| 407 | (> (length string) (value minimum-interactive-input-length)))
|
|---|
| 408 | (ring-push (copy-region input-region) ring))
|
|---|
| 409 | input-region))
|
|---|
| 410 | (t
|
|---|
| 411 | (let* ((region (input-region-containing-mark point (value input-regions ))))
|
|---|
| 412 | (buffer-end point)
|
|---|
| 413 | (if region
|
|---|
| 414 | (progn
|
|---|
| 415 | (delete-region (region mark point))
|
|---|
| 416 | (insert-region point region))
|
|---|
| 417 | (beep))
|
|---|
| 418 | nil)))))
|
|---|
| [595] | 419 |
|
|---|
| 420 |
|
|---|
| 421 | (defhvar "Minimum Interactive Input Length"
|
|---|
| 422 | "When the number of characters in an interactive buffer exceeds this value,
|
|---|
| 423 | it is pushed onto the interactive history, otherwise it is lost forever."
|
|---|
| [14208] | 424 | :value 0)
|
|---|
| [595] | 425 |
|
|---|
| 426 |
|
|---|
| 427 | (defvar *previous-input-search-string* "ignore")
|
|---|
| 428 |
|
|---|
| 429 | (defvar *previous-input-search-pattern*
|
|---|
| 430 | ;; Give it a bogus string since you can't give it the empty string.
|
|---|
| 431 | (new-search-pattern :string-insensitive :forward "ignore"))
|
|---|
| 432 |
|
|---|
| 433 | (defun get-previous-input-search-pattern (string)
|
|---|
| 434 | (if (string= *previous-input-search-string* string)
|
|---|
| 435 | *previous-input-search-pattern*
|
|---|
| 436 | (new-search-pattern :string-insensitive :forward
|
|---|
| 437 | (setf *previous-input-search-string* string)
|
|---|
| 438 | *previous-input-search-pattern*)))
|
|---|
| 439 |
|
|---|
| 440 | (defcommand "Search Previous Interactive Input" (p)
|
|---|
| 441 | "Search backward through the interactive history using the current input as
|
|---|
| 442 | a search string. Consecutive invocations repeat the previous search."
|
|---|
| 443 | (declare (ignore p))
|
|---|
| 444 | (let* ((mark (value buffer-input-mark))
|
|---|
| 445 | (ring (value interactive-history))
|
|---|
| 446 | (point (current-point))
|
|---|
| 447 | (just-invoked (eq (last-command-type) :searching-interactive-input)))
|
|---|
| 448 | (when (mark<= point mark)
|
|---|
| 449 | (editor-error "Point not past input mark."))
|
|---|
| 450 | (when (zerop (ring-length ring))
|
|---|
| 451 | (editor-error "No previous input in this buffer."))
|
|---|
| 452 | (unless just-invoked
|
|---|
| 453 | (get-previous-input-search-pattern (region-to-string (region mark point))))
|
|---|
| 454 | (let ((found-it (find-previous-input ring just-invoked)))
|
|---|
| 455 | (unless found-it
|
|---|
| 456 | (editor-error "Couldn't find ~a." *previous-input-search-string*))
|
|---|
| 457 | (delete-region (region mark point))
|
|---|
| 458 | (insert-region point (ring-ref ring found-it))
|
|---|
| 459 | (setf (value searching-interactive-pointer) found-it))
|
|---|
| 460 | (setf (last-command-type) :searching-interactive-input)))
|
|---|
| 461 |
|
|---|
| 462 | (defun find-previous-input (ring againp)
|
|---|
| 463 | (let ((ring-length (ring-length ring))
|
|---|
| 464 | (base (if againp
|
|---|
| 465 | (+ (value searching-interactive-pointer) 1)
|
|---|
| 466 | 0)))
|
|---|
| 467 | (loop
|
|---|
| 468 | (when (= base ring-length)
|
|---|
| 469 | (if againp
|
|---|
| 470 | (setf base 0)
|
|---|
| 471 | (return nil)))
|
|---|
| 472 | (with-mark ((m (region-start (ring-ref ring base))))
|
|---|
| 473 | (when (find-pattern m *previous-input-search-pattern*)
|
|---|
| 474 | (return base)))
|
|---|
| 475 | (incf base))))
|
|---|
| 476 |
|
|---|
| 477 | (defcommand "Previous Interactive Input" (p)
|
|---|
| 478 | "Insert the previous input in an interactive mode (Listener or Typescript).
|
|---|
| 479 | If repeated, keep rotating the history. With prefix argument, rotate
|
|---|
| 480 | that many times."
|
|---|
| 481 | "Pop the *interactive-history* at the point."
|
|---|
| 482 | (let* ((point (current-point))
|
|---|
| 483 | (mark (value buffer-input-mark))
|
|---|
| 484 | (ring (value interactive-history))
|
|---|
| 485 | (length (ring-length ring))
|
|---|
| 486 | (p (or p 1)))
|
|---|
| [617] | 487 | (when (or (mark< point mark) (zerop length)) (editor-error "Can't get command history"))
|
|---|
| [595] | 488 | (cond
|
|---|
| 489 | ((eq (last-command-type) :interactive-history)
|
|---|
| [14208] | 490 | (let ((base (mod (+ (value interactive-pointer) p) length))
|
|---|
| 491 | (grab-start (value grabbed-input-start-mark)))
|
|---|
| 492 | (delete-region (region grab-start point))
|
|---|
| 493 | (insert-region grab-start (ring-ref ring base))
|
|---|
| [595] | 494 | (setf (value interactive-pointer) base)))
|
|---|
| 495 | (t
|
|---|
| 496 | (let ((base (mod (if (minusp p) p (1- p)) length))
|
|---|
| [14208] | 497 | (region (copy-region (region mark (buffer-end-mark (current-buffer)))))
|
|---|
| 498 | (grab-start (move-mark (value grabbed-input-start-mark) point)))
|
|---|
| 499 | (when (mark/= (region-start region) (region-end region))
|
|---|
| 500 | (ring-push region ring)
|
|---|
| 501 | (incf base))
|
|---|
| 502 | (insert-region grab-start (ring-ref ring base))
|
|---|
| [595] | 503 | (setf (value interactive-pointer) base)))))
|
|---|
| 504 | (setf (last-command-type) :interactive-history))
|
|---|
| 505 |
|
|---|
| 506 | (defcommand "Next Interactive Input" (p)
|
|---|
| 507 | "Rotate the interactive history backwards. The region is left around the
|
|---|
| 508 | inserted text. With prefix argument, rotate that many times."
|
|---|
| 509 | (previous-interactive-input-command (- (or p 1))))
|
|---|
| 510 |
|
|---|
| 511 | (defcommand "Kill Interactive Input" (p)
|
|---|
| 512 | "Kill any input to an interactive mode (Listener or Typescript)."
|
|---|
| 513 | (declare (ignore p))
|
|---|
| 514 | (let ((point (buffer-point (current-buffer)))
|
|---|
| 515 | (mark (value buffer-input-mark)))
|
|---|
| 516 | (when (mark< point mark) (editor-error))
|
|---|
| 517 | (kill-region (region mark point) :kill-backward)))
|
|---|
| 518 |
|
|---|
| 519 | (defcommand "Interactive Beginning of Line" (p)
|
|---|
| 520 | "If on line with current prompt, go to after it, otherwise do what
|
|---|
| 521 | \"Beginning of Line\" always does."
|
|---|
| 522 | "Go to after prompt when on prompt line."
|
|---|
| 523 | (let ((mark (value buffer-input-mark))
|
|---|
| 524 | (point (current-point)))
|
|---|
| 525 | (if (and (same-line-p point mark) (or (not p) (= p 1)))
|
|---|
| 526 | (move-mark point mark)
|
|---|
| 527 | (beginning-of-line-command p))))
|
|---|
| 528 |
|
|---|
| 529 | (defcommand "Reenter Interactive Input" (p)
|
|---|
| 530 | "Copies the form to the left of point to be after the interactive buffer's
|
|---|
| 531 | input mark. When the current region is active, it is copied instead."
|
|---|
| 532 | (declare (ignore p))
|
|---|
| 533 | (unless (hemlock-bound-p 'buffer-input-mark)
|
|---|
| 534 | (editor-error "Not in an interactive buffer."))
|
|---|
| 535 | (let ((point (current-point)))
|
|---|
| 536 | (let ((region (if (region-active-p)
|
|---|
| 537 | ;; Copy this, so moving point doesn't affect the region.
|
|---|
| 538 | (copy-region (current-region))
|
|---|
| 539 | (with-mark ((start point)
|
|---|
| 540 | (end point))
|
|---|
| 541 | (pre-command-parse-check start)
|
|---|
| 542 | (unless (form-offset start -1)
|
|---|
| 543 | (editor-error "Not after complete form."))
|
|---|
| 544 | (region (copy-mark start) (copy-mark end))))))
|
|---|
| 545 | (buffer-end point)
|
|---|
| [8428] | 546 | (push-new-buffer-mark point)
|
|---|
| [595] | 547 | (insert-region point region)
|
|---|
| 548 | (setf (last-command-type) :ephemerally-active))))
|
|---|
| 549 |
|
|---|
| 550 |
|
|---|
| [14721] | 551 |
|
|---|
| [595] | 552 | ;;; Other stuff.
|
|---|
| 553 |
|
|---|
| [597] | 554 | (defmode "Editor" :hidden t)
|
|---|
| [595] | 555 |
|
|---|
| 556 | (defcommand "Editor Mode" (p)
|
|---|
| [13186] | 557 | "Toggle \"Editor\" mode in the current buffer.
|
|---|
| 558 | When in editor mode, most lisp compilation and evaluation commands
|
|---|
| [595] | 559 | manipulate the editor process instead of the current eval server."
|
|---|
| 560 | (declare (ignore p))
|
|---|
| 561 | (setf (buffer-minor-mode (current-buffer) "Editor")
|
|---|
| 562 | (not (buffer-minor-mode (current-buffer) "Editor"))))
|
|---|
| 563 |
|
|---|
| 564 | (define-file-option "Editor" (buffer value)
|
|---|
| 565 | (declare (ignore value))
|
|---|
| 566 | (setf (buffer-minor-mode buffer "Editor") t))
|
|---|
| 567 |
|
|---|
| 568 |
|
|---|
| [6705] | 569 |
|
|---|
| [595] | 570 | (defun defun-region (mark)
|
|---|
| 571 | "This returns a region around the current or next defun with respect to mark.
|
|---|
| 572 | Mark is not used to form the region. If there is no appropriate top level
|
|---|
| 573 | form, this signals an editor-error. This calls PRE-COMMAND-PARSE-CHECK."
|
|---|
| 574 | (with-mark ((start mark)
|
|---|
| 575 | (end mark))
|
|---|
| 576 | (pre-command-parse-check start)
|
|---|
| 577 | (cond ((not (mark-top-level-form start end))
|
|---|
| 578 | (editor-error "No current or next top level form."))
|
|---|
| 579 | (t (region start end)))))
|
|---|
| 580 |
|
|---|
| [13186] | 581 | (defun current-form-region (&optional (error t))
|
|---|
| 582 | (if (region-active-p)
|
|---|
| 583 | (current-region)
|
|---|
| 584 | (let ((point (current-point)))
|
|---|
| 585 | (pre-command-parse-check point)
|
|---|
| 586 | (or (form-region-at-mark point)
|
|---|
| 587 | (and error (editor-error "No current expression"))))))
|
|---|
| 588 |
|
|---|
| [719] | 589 | (defun eval-region (region
|
|---|
| 590 | &key
|
|---|
| [7122] | 591 | (package (variable-value 'current-package :buffer (current-buffer)))
|
|---|
| [719] | 592 | (path (buffer-pathname (current-buffer))))
|
|---|
| [12859] | 593 | (ccl::application-ui-operation ccl:*application*
|
|---|
| 594 | :eval-selection
|
|---|
| 595 | (list package
|
|---|
| 596 | path
|
|---|
| 597 | (region-to-string region)
|
|---|
| 598 | (mark-absolute-position (region-start region)))))
|
|---|
| [719] | 599 |
|
|---|
| [14816] | 600 | (defvar *echo-expression-to-listener* nil "True if you want evaluated forms in an editor window to echo in listener, in addition to their evaluated result.")
|
|---|
| [12663] | 601 |
|
|---|
| [13186] | 602 | (defcommand "Editor Execute Defun" (p)
|
|---|
| [14816] | 603 | "Executes the current or next top-level form in the editor Lisp. Ensures the result is visible."
|
|---|
| [595] | 604 | (declare (ignore p))
|
|---|
| [14816] | 605 | (let* ((region (copy-region
|
|---|
| 606 | (if (region-active-p)
|
|---|
| 607 | (current-region)
|
|---|
| 608 | (defun-region (current-point)))))
|
|---|
| 609 | (form (when *echo-expression-to-listener* (region-to-string region)))
|
|---|
| [14917] | 610 | (doc (gui::top-listener-document))
|
|---|
| 611 | (buf (when doc (gui::hemlock-buffer doc))))
|
|---|
| [14816] | 612 | (when buf
|
|---|
| 613 | (let ((HI::*CURRENT-BUFFER* buf))
|
|---|
| 614 | (move-mark (current-point) (region-end (buffer-region buf)))))
|
|---|
| 615 | (when form (format (HEMLOCK-EXT:TOP-LISTENER-OUTPUT-STREAM) "~A~&" form))
|
|---|
| 616 | (eval-region region)))
|
|---|
| [595] | 617 |
|
|---|
| [13186] | 618 | (defcommand "Editor Execute Expression" (p)
|
|---|
| [14816] | 619 | "Executes the current region in the editor Lisp. Ensures the result is visible."
|
|---|
| [595] | 620 | (declare (ignore p))
|
|---|
| [14816] | 621 | (let* ((region (copy-region (current-form-region)))
|
|---|
| 622 | (form (when *echo-expression-to-listener* (region-to-string region)))
|
|---|
| [14917] | 623 | (doc (gui::top-listener-document))
|
|---|
| 624 | (buf (when doc (gui::hemlock-buffer doc))))
|
|---|
| [14816] | 625 | (when buf
|
|---|
| 626 | (let ((HI::*CURRENT-BUFFER* buf))
|
|---|
| 627 | (move-mark (current-point) (region-end (buffer-region buf)))))
|
|---|
| 628 | (when form (format (HEMLOCK-EXT:TOP-LISTENER-OUTPUT-STREAM) "~A~&" form))
|
|---|
| 629 | (eval-region region)))
|
|---|
| [11894] | 630 |
|
|---|
| [595] | 631 | (defcommand "Editor Re-evaluate Defvar" (p)
|
|---|
| 632 | "Evaluate the current or next top-level form if it is a DEFVAR. Treat the
|
|---|
| [12877] | 633 | form as if the variable is not bound."
|
|---|
| [595] | 634 | (declare (ignore p))
|
|---|
| 635 | (with-input-from-region (stream (defun-region (current-point)))
|
|---|
| 636 | (clear-echo-area)
|
|---|
| 637 | (in-lisp
|
|---|
| 638 | (let ((form (read stream)))
|
|---|
| 639 | (unless (eq (car form) 'defvar) (editor-error "Not a DEFVAR."))
|
|---|
| 640 | (makunbound (cadr form))
|
|---|
| 641 | (message "Evaluation returned ~S" (eval form))))))
|
|---|
| 642 |
|
|---|
| [6665] | 643 | (defun macroexpand-expression (expander)
|
|---|
| [13186] | 644 | (in-lisp
|
|---|
| 645 | (let* ((region (current-form-region))
|
|---|
| 646 | (expr (with-input-from-region (s region)
|
|---|
| 647 | (read s))))
|
|---|
| 648 | (let* ((*print-pretty* t)
|
|---|
| 649 | (expansion (funcall expander expr)))
|
|---|
| 650 | (format t "~&~s~&" expansion)))))
|
|---|
| [6665] | 651 |
|
|---|
| 652 | (defcommand "Editor Macroexpand-1 Expression" (p)
|
|---|
| [595] | 653 | "Show the macroexpansion of the current expression in the null environment.
|
|---|
| 654 | With an argument, use MACROEXPAND instead of MACROEXPAND-1."
|
|---|
| [6665] | 655 | (macroexpand-expression (if p 'macroexpand 'macroexpand-1)))
|
|---|
| [595] | 656 |
|
|---|
| [6665] | 657 | (defcommand "Editor Macroexpand Expression" (p)
|
|---|
| 658 | "Show the macroexpansion of the current expression in the null environment.
|
|---|
| 659 | With an argument, use MACROEXPAND-1 instead of MACROEXPAND."
|
|---|
| 660 | (macroexpand-expression (if p 'macroexpand-1 'macroexpand)))
|
|---|
| 661 |
|
|---|
| 662 |
|
|---|
| [595] | 663 | (defcommand "Editor Evaluate Expression" (p)
|
|---|
| 664 | "Prompt for an expression to evaluate in the editor Lisp."
|
|---|
| 665 | (declare (ignore p))
|
|---|
| 666 | (in-lisp
|
|---|
| 667 | (multiple-value-call #'message "=> ~@{~#[~;~S~:;~S, ~]~}"
|
|---|
| 668 | (eval (prompt-for-expression
|
|---|
| 669 | :prompt "Editor Eval: "
|
|---|
| 670 | :help "Expression to evaluate")))))
|
|---|
| 671 |
|
|---|
| 672 | (defcommand "Editor Evaluate Buffer" (p)
|
|---|
| 673 | "Evaluates the text in the current buffer in the editor Lisp."
|
|---|
| 674 | (declare (ignore p))
|
|---|
| [8428] | 675 | (message "Evaluating buffer in the editor ...")
|
|---|
| [595] | 676 | (with-input-from-region (stream (buffer-region (current-buffer)))
|
|---|
| [8428] | 677 | (in-lisp
|
|---|
| 678 | (do ((object (read stream nil lispbuf-eof)
|
|---|
| 679 | (read stream nil lispbuf-eof)))
|
|---|
| 680 | ((eq object lispbuf-eof))
|
|---|
| 681 | (eval object)))
|
|---|
| [595] | 682 | (message "Evaluation complete.")))
|
|---|
| 683 |
|
|---|
| 684 |
|
|---|
| 685 |
|
|---|
| 686 | (defcommand "Editor Compile File" (p)
|
|---|
| 687 | "Prompts for file to compile in the editor Lisp. Does not compare source
|
|---|
| 688 | and binary write dates. Does not check any buffer for that file for
|
|---|
| 689 | whether the buffer needs to be saved."
|
|---|
| 690 | (declare (ignore p))
|
|---|
| 691 | (let ((pn (prompt-for-file :default
|
|---|
| 692 | (buffer-default-pathname (current-buffer))
|
|---|
| 693 | :prompt "File to compile: ")))
|
|---|
| [8428] | 694 | (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))
|
|---|
| [595] | 695 |
|
|---|
| 696 |
|
|---|
| 697 | (defun older-or-non-existent-fasl-p (pathname &optional definitely)
|
|---|
| 698 | (let ((obj-pn (probe-file (compile-file-pathname pathname))))
|
|---|
| 699 | (or definitely
|
|---|
| 700 | (not obj-pn)
|
|---|
| 701 | (< (file-write-date obj-pn) (file-write-date pathname)))))
|
|---|
| 702 |
|
|---|
| 703 |
|
|---|
| 704 | (defcommand "Editor Compile Buffer File" (p)
|
|---|
| 705 | "Compile the file in the current buffer in the editor Lisp if its associated
|
|---|
| 706 | binary file (of type .fasl) is older than the source or doesn't exist. When
|
|---|
| 707 | the binary file is up to date, the user is asked if the source should be
|
|---|
| 708 | compiled anyway. When the prefix argument is supplied, compile the file
|
|---|
| 709 | without checking the binary file. When \"Compile Buffer File Confirm\" is
|
|---|
| 710 | set, this command will ask for confirmation when it otherwise would not."
|
|---|
| 711 | "Compile the file in the current buffer in the editor Lisp if the fasl file
|
|---|
| 712 | isn't up to date. When p, always do it."
|
|---|
| 713 | (let* ((buf (current-buffer))
|
|---|
| 714 | (pn (buffer-pathname buf)))
|
|---|
| 715 | (unless pn (editor-error "Buffer has no associated pathname."))
|
|---|
| 716 | (cond ((buffer-modified buf)
|
|---|
| 717 | (when (or (not (value compile-buffer-file-confirm))
|
|---|
| 718 | (prompt-for-y-or-n
|
|---|
| 719 | :default t :default-string "Y"
|
|---|
| 720 | :prompt (list "Save and compile file ~A? "
|
|---|
| 721 | (namestring pn))))
|
|---|
| 722 | (write-buffer-file buf pn)
|
|---|
| [8428] | 723 | (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))
|
|---|
| [595] | 724 | ((older-or-non-existent-fasl-p pn p)
|
|---|
| 725 | (when (or (not (value compile-buffer-file-confirm))
|
|---|
| 726 | (prompt-for-y-or-n
|
|---|
| 727 | :default t :default-string "Y"
|
|---|
| 728 | :prompt (list "Compile file ~A? " (namestring pn))))
|
|---|
| [8428] | 729 | (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))
|
|---|
| [595] | 730 | (t (when (or p
|
|---|
| 731 | (prompt-for-y-or-n
|
|---|
| 732 | :default t :default-string "Y"
|
|---|
| 733 | :prompt
|
|---|
| 734 | "Fasl file up to date, compile source anyway? "))
|
|---|
| [8428] | 735 | (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))))
|
|---|
| [595] | 736 |
|
|---|
| 737 |
|
|---|
| 738 |
|
|---|
| 739 |
|
|---|
| 740 |
|
|---|
| 741 |
|
|---|
| 742 | ;;;; Lisp documentation stuff.
|
|---|
| 743 |
|
|---|
| 744 | ;;; FUNCTION-TO-DESCRIBE is used in "Editor Describe Function Call" and
|
|---|
| 745 | ;;; "Describe Function Call".
|
|---|
| 746 | ;;;
|
|---|
| 747 | (defmacro function-to-describe (var error-name)
|
|---|
| 748 | `(cond ((not (symbolp ,var))
|
|---|
| 749 | (,error-name "~S is not a symbol." ,var))
|
|---|
| [6790] | 750 | ((special-operator-p ,var) ,var)
|
|---|
| [595] | 751 | ((macro-function ,var))
|
|---|
| [6790] | 752 | ((fboundp ,var))
|
|---|
| [595] | 753 | (t
|
|---|
| 754 | (,error-name "~S is not a function." ,var))))
|
|---|
| 755 |
|
|---|
| 756 | (defcommand "Editor Describe Function Call" (p)
|
|---|
| 757 | "Describe the most recently typed function name in the editor Lisp."
|
|---|
| 758 | (declare (ignore p))
|
|---|
| 759 | (with-mark ((mark1 (current-point))
|
|---|
| 760 | (mark2 (current-point)))
|
|---|
| 761 | (pre-command-parse-check mark1)
|
|---|
| 762 | (unless (backward-up-list mark1) (editor-error))
|
|---|
| 763 | (form-offset (move-mark mark2 (mark-after mark1)) 1)
|
|---|
| 764 | (with-input-from-region (s (region mark1 mark2))
|
|---|
| 765 | (in-lisp
|
|---|
| 766 | (let* ((sym (read s))
|
|---|
| 767 | (fun (function-to-describe sym editor-error)))
|
|---|
| [6790] | 768 | (with-pop-up-display (*standard-output* :title (format nil "~s" sym))
|
|---|
| [595] | 769 | (editor-describe-function fun sym)))))))
|
|---|
| 770 |
|
|---|
| 771 |
|
|---|
| 772 | (defcommand "Editor Describe Symbol" (p)
|
|---|
| 773 | "Describe the previous s-expression if it is a symbol in the editor Lisp."
|
|---|
| 774 | (declare (ignore p))
|
|---|
| 775 | (with-mark ((mark1 (current-point))
|
|---|
| 776 | (mark2 (current-point)))
|
|---|
| 777 | (mark-symbol mark1 mark2)
|
|---|
| 778 | (with-input-from-region (s (region mark1 mark2))
|
|---|
| [13186] | 779 | (let ((thing (in-lisp (read s))))
|
|---|
| [6773] | 780 | (if (symbolp thing)
|
|---|
| [6790] | 781 | (with-pop-up-display (*standard-output* :title (format nil "~s" thing))
|
|---|
| [6773] | 782 | (describe thing))
|
|---|
| 783 | (if (and (consp thing)
|
|---|
| 784 | (or (eq (car thing) 'quote)
|
|---|
| 785 | (eq (car thing) 'function))
|
|---|
| 786 | (symbolp (cadr thing)))
|
|---|
| [6790] | 787 | (with-pop-up-display (*standard-output* :title (format nil "~s" (cadr thing)))
|
|---|
| [6773] | 788 | (describe (cadr thing)))
|
|---|
| 789 | (editor-error "~S is not a symbol, or 'symbol, or #'symbol."
|
|---|
| 790 | thing)))))))
|
|---|
| [595] | 791 |
|
|---|
| 792 | ;;; MARK-SYMBOL moves mark1 and mark2 around the previous or current symbol.
|
|---|
| 793 | ;;; However, if the marks are immediately before the first constituent char
|
|---|
| 794 | ;;; of the symbol name, we use the next symbol since the marks probably
|
|---|
| 795 | ;;; correspond to the point, and Hemlock's cursor display makes it look like
|
|---|
| 796 | ;;; the point is within the symbol name. This also tries to ignore :prefix
|
|---|
| 797 | ;;; characters such as quotes, commas, etc.
|
|---|
| 798 | ;;;
|
|---|
| 799 | (defun mark-symbol (mark1 mark2)
|
|---|
| 800 | (pre-command-parse-check mark1)
|
|---|
| 801 | (with-mark ((tmark1 mark1)
|
|---|
| 802 | (tmark2 mark1))
|
|---|
| 803 | (cond ((and (form-offset tmark1 1)
|
|---|
| 804 | (form-offset (move-mark tmark2 tmark1) -1)
|
|---|
| 805 | (or (mark= mark1 tmark2)
|
|---|
| 806 | (and (find-attribute tmark2 :lisp-syntax
|
|---|
| 807 | #'(lambda (x) (not (eq x :prefix))))
|
|---|
| 808 | (mark= mark1 tmark2))))
|
|---|
| 809 | (form-offset mark2 1))
|
|---|
| 810 | (t
|
|---|
| 811 | (form-offset mark1 -1)
|
|---|
| 812 | (find-attribute mark1 :lisp-syntax
|
|---|
| 813 | #'(lambda (x) (not (eq x :prefix))))
|
|---|
| 814 | (form-offset (move-mark mark2 mark1) 1)))))
|
|---|
| 815 |
|
|---|
| 816 |
|
|---|
| 817 | (defcommand "Editor Describe" (p)
|
|---|
| 818 | "Call Describe on a Lisp object.
|
|---|
| 819 | Prompt for an expression which is evaluated to yield the object."
|
|---|
| 820 | (declare (ignore p))
|
|---|
| 821 | (in-lisp
|
|---|
| 822 | (let* ((exp (prompt-for-expression
|
|---|
| 823 | :prompt "Object: "
|
|---|
| 824 | :help "Expression to evaluate to get object to describe."))
|
|---|
| 825 | (obj (eval exp)))
|
|---|
| [6790] | 826 | (with-pop-up-display (*standard-output* :title (format nil "~s" exp))
|
|---|
| [595] | 827 | (describe obj)))))
|
|---|
| 828 | |
|---|
| 829 |
|
|---|
| 830 | (defcommand "Filter Region" (p)
|
|---|
| 831 | "Apply a Lisp function to each line of the region.
|
|---|
| 832 | An expression is prompted for which should evaluate to a Lisp function
|
|---|
| 833 | from a string to a string. The function must neither modify its argument
|
|---|
| 834 | nor modify the return value after it is returned."
|
|---|
| 835 | "Call prompt for a function, then call Filter-Region with it and the region."
|
|---|
| 836 | (declare (ignore p))
|
|---|
| 837 | (let* ((exp (prompt-for-expression
|
|---|
| 838 | :prompt "Function: "
|
|---|
| 839 | :help "Expression to evaluate to get function to use as filter."))
|
|---|
| 840 | (fun (in-lisp (eval exp)))
|
|---|
| 841 | (region (current-region)))
|
|---|
| 842 | (let* ((start (copy-mark (region-start region) :left-inserting))
|
|---|
| 843 | (end (copy-mark (region-end region) :left-inserting))
|
|---|
| 844 | (region (region start end))
|
|---|
| 845 | (undo-region (copy-region region)))
|
|---|
| 846 | (filter-region fun region)
|
|---|
| 847 | (make-region-undo :twiddle "Filter Region" region undo-region))))
|
|---|
