| 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 | #+CMU (ext:file-comment
|
|---|
| 8 | "$Header$")
|
|---|
| 9 | ;;;
|
|---|
| 10 | ;;; **********************************************************************
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; Hemlock LISP Mode commands
|
|---|
| 13 | ;;;
|
|---|
| 14 | ;;; Written by Ivan Vazquez and Bill Maddox.
|
|---|
| 15 | ;;;
|
|---|
| 16 |
|
|---|
| 17 | (in-package :hemlock)
|
|---|
| 18 |
|
|---|
| 19 | ;; (declaim (optimize (speed 2))); turn off byte compilation.
|
|---|
| 20 |
|
|---|
| 21 | |
|---|
| 22 |
|
|---|
| 23 | ;;;; Variables and lisp-info structure.
|
|---|
| 24 |
|
|---|
| 25 | ;;; These routines are used to define, for standard LISP mode, the start and end
|
|---|
| 26 | ;;; of a block to parse. If these need to be changed for a minor mode that sits
|
|---|
| 27 | ;;; on top of LISP mode, simply do a DEFHVAR with the minor mode and give the
|
|---|
| 28 | ;;; name of the function to use instead of START-OF-PARSE-BLOCK and
|
|---|
| 29 | ;;; END-OF-PARSE-BLOCK.
|
|---|
| 30 | ;;;
|
|---|
| 31 |
|
|---|
| 32 | (defhvar "Parse Start Function"
|
|---|
| 33 | "Take a mark and move it to the top of a block for paren parsing."
|
|---|
| 34 | :value 'start-of-parse-block)
|
|---|
| 35 |
|
|---|
| 36 | (defhvar "Parse End Function"
|
|---|
| 37 | "Take a mark and move it to the bottom of a block for paren parsing."
|
|---|
| 38 | :value 'end-of-parse-block)
|
|---|
| 39 |
|
|---|
| 40 |
|
|---|
| 41 | ;;; LISP-INFO is the structure used to store the data about the line in its
|
|---|
| 42 | ;;; Plist.
|
|---|
| 43 | ;;;
|
|---|
| 44 | ;;; -> BEGINS-QUOTED, ENDING-QUOTED are both slots that tell whether or not
|
|---|
| 45 | ;;; a line's begining and/or ending are quoted, and if so, how.
|
|---|
| 46 | ;;;
|
|---|
| 47 | ;;; -> RANGES-TO-IGNORE is a list of cons cells, each having the form
|
|---|
| 48 | ;;; ( [begining-charpos] [end-charpos] ) each of these cells indicating
|
|---|
| 49 | ;;; a range where :lisp-syntax attributes are ignored. End is exclusive.
|
|---|
| 50 | ;;;
|
|---|
| 51 | ;;; -> NET-OPEN-PARENS, NET-CLOSE-PARENS integers that are the number of
|
|---|
| 52 | ;;; unmatched opening and closing parens that there are on a line.
|
|---|
| 53 | ;;;
|
|---|
| 54 | ;;; -> SIGNATURE-SLOT ...
|
|---|
| 55 | ;;;
|
|---|
| 56 |
|
|---|
| 57 | (defstruct (lisp-info (:constructor make-lisp-info ()))
|
|---|
| 58 | (begins-quoted nil) ; nil or quote char attribute or comment nesting depth
|
|---|
| 59 | (ending-quoted nil) ; nil or quote char attribute or comment nesting depth
|
|---|
| 60 | (ranges-to-ignore nil)
|
|---|
| 61 | (net-open-parens 0 :type fixnum)
|
|---|
| 62 | (net-close-parens 0 :type fixnum)
|
|---|
| 63 | (signature-slot))
|
|---|
| 64 |
|
|---|
| 65 |
|
|---|
| 66 | |
|---|
| 67 |
|
|---|
| 68 | ;;;; Macros.
|
|---|
| 69 |
|
|---|
| 70 | ;;; The following Macros exist to make it easy to acces the Syntax primitives
|
|---|
| 71 | ;;; without uglifying the code. They were originally written by Maddox.
|
|---|
| 72 | ;;;
|
|---|
| 73 |
|
|---|
| 74 | (defmacro scan-char (mark attribute values)
|
|---|
| 75 | `(find-attribute ,mark ',attribute ,(attr-predicate values)))
|
|---|
| 76 |
|
|---|
| 77 | (defmacro rev-scan-char (mark attribute values)
|
|---|
| 78 | `(reverse-find-attribute ,mark ',attribute ,(attr-predicate values)))
|
|---|
| 79 |
|
|---|
| 80 | (defmacro test-char (char attribute values)
|
|---|
| 81 | `(let ((x (character-attribute ',attribute ,char)))
|
|---|
| 82 | ,(attr-predicate-aux values)))
|
|---|
| 83 |
|
|---|
| 84 | (eval-when (:compile-toplevel :execute :load-toplevel)
|
|---|
| 85 | (defun attr-predicate (values)
|
|---|
| 86 | (cond ((eq values 't)
|
|---|
| 87 | '#'plusp)
|
|---|
| 88 | ((eq values 'nil)
|
|---|
| 89 | '#'zerop)
|
|---|
| 90 | (t `#'(lambda (x) ,(attr-predicate-aux values)))))
|
|---|
| 91 |
|
|---|
| 92 | (defun attr-predicate-aux (values)
|
|---|
| 93 | (cond ((eq values t)
|
|---|
| 94 | '(plusp x))
|
|---|
| 95 | ((eq values nil)
|
|---|
| 96 | '(zerop x))
|
|---|
| 97 | ((symbolp values)
|
|---|
| 98 | `(eq x ',values))
|
|---|
| 99 | ((and (listp values) (member (car values) '(and or not)))
|
|---|
| 100 | (cons (car values) (mapcar #'attr-predicate-aux (cdr values))))
|
|---|
| 101 | (t (error "Illegal form in attribute pattern - ~S" values))))
|
|---|
| 102 |
|
|---|
| 103 | ); Eval-When
|
|---|
| 104 |
|
|---|
| 105 | ;;;
|
|---|
| 106 | ;;; FIND-LISP-CHAR
|
|---|
| 107 |
|
|---|
| 108 | (defmacro find-lisp-char (mark)
|
|---|
| 109 | "Move MARK to next :LISP-SYNTAX character, if one isn't found, return NIL."
|
|---|
| 110 | `(find-attribute ,mark :lisp-syntax
|
|---|
| 111 | #'(lambda (x)
|
|---|
| 112 | (member x '(:open-paren :close-paren :newline :comment :prefix-dispatch
|
|---|
| 113 | :char-quote :symbol-quote :string-quote)))))
|
|---|
| 114 | ;;;
|
|---|
| 115 | ;;; PUSH-RANGE
|
|---|
| 116 |
|
|---|
| 117 | (defmacro push-range (new-range info-struct)
|
|---|
| 118 | "Insert NEW-RANGE into the LISP-INFO-RANGES-TO-IGNORE slot of the INFO-STRUCT."
|
|---|
| 119 | `(when ,new-range
|
|---|
| 120 | (setf (lisp-info-ranges-to-ignore ,info-struct)
|
|---|
| 121 | (cons ,new-range (lisp-info-ranges-to-ignore ,info-struct)))))
|
|---|
| 122 | ;;;
|
|---|
| 123 | ;;; SCAN-DIRECTION
|
|---|
| 124 |
|
|---|
| 125 | (defmacro scan-direction (mark forwardp &rest forms)
|
|---|
| 126 | "Expand to a form that scans either backward or forward according to Forwardp."
|
|---|
| 127 | (if forwardp
|
|---|
| 128 | `(scan-char ,mark ,@forms)
|
|---|
| 129 | `(rev-scan-char ,mark ,@forms)))
|
|---|
| 130 | ;;;
|
|---|
| 131 | ;;; DIRECTION-CHAR
|
|---|
| 132 |
|
|---|
| 133 | (defmacro direction-char (mark forwardp)
|
|---|
| 134 | "Expand to a form that returns either the previous or next character according
|
|---|
| 135 | to Forwardp."
|
|---|
| 136 | (if forwardp
|
|---|
| 137 | `(next-character ,mark)
|
|---|
| 138 | `(previous-character ,mark)))
|
|---|
| 139 |
|
|---|
| 140 | ;;;
|
|---|
| 141 | ;;; NEIGHBOR-MARK
|
|---|
| 142 |
|
|---|
| 143 | (defmacro neighbor-mark (mark forwardp)
|
|---|
| 144 | "Expand to a form that moves MARK either backward or forward one character,
|
|---|
| 145 | depending on FORWARDP."
|
|---|
| 146 | (if forwardp
|
|---|
| 147 | `(mark-after ,mark)
|
|---|
| 148 | `(mark-before ,mark)))
|
|---|
| 149 |
|
|---|
| 150 | ;;;
|
|---|
| 151 | ;;; NEIGHBOR-LINE
|
|---|
| 152 |
|
|---|
| 153 | (defmacro neighbor-line (line forwardp)
|
|---|
| 154 | "Expand to return the next or previous line, according to Forwardp."
|
|---|
| 155 | (if forwardp
|
|---|
| 156 | `(line-next ,line)
|
|---|
| 157 | `(line-previous ,line)))
|
|---|
| 158 |
|
|---|
| 159 | |
|---|
| 160 |
|
|---|
| 161 | ;;;; Parsing functions.
|
|---|
| 162 |
|
|---|
| 163 | ;;; PRE-COMMAND-PARSE-CHECK -- Public.
|
|---|
| 164 | ;;;
|
|---|
| 165 | (defun pre-command-parse-check (mark &optional (fer-sure-parse nil))
|
|---|
| 166 | "Parse the area before the command is actually executed."
|
|---|
| 167 | (with-mark ((top mark)
|
|---|
| 168 | (bottom mark))
|
|---|
| 169 | (funcall (value parse-start-function) top)
|
|---|
| 170 | (funcall (value parse-end-function) bottom)
|
|---|
| 171 | (parse-over-block (mark-line top) (mark-line bottom) fer-sure-parse)))
|
|---|
| 172 |
|
|---|
| 173 | ;;; PARSE-OVER-BLOCK
|
|---|
| 174 | ;;;
|
|---|
| 175 | (defun parse-over-block (start-line end-line &optional (fer-sure-parse nil))
|
|---|
| 176 | "Parse over an area indicated from END-LINE to START-LINE."
|
|---|
| 177 | (let ((test-line start-line)
|
|---|
| 178 | prev-line-info)
|
|---|
| 179 |
|
|---|
| 180 | (with-mark ((mark (mark test-line 0)))
|
|---|
| 181 |
|
|---|
| 182 | ; Set the pre-begining and post-ending lines to delimit the range
|
|---|
| 183 | ; of action any command will take. This means set the lisp-info of the
|
|---|
| 184 | ; lines immediately before and after the block to Nil.
|
|---|
| 185 |
|
|---|
| 186 | (when (line-previous start-line)
|
|---|
| 187 | (setf (getf (line-plist (line-previous start-line)) 'lisp-info) nil))
|
|---|
| 188 | (when (line-next end-line)
|
|---|
| 189 | (setf (getf (line-plist (line-next end-line)) 'lisp-info) nil))
|
|---|
| 190 |
|
|---|
| 191 | (loop
|
|---|
| 192 | (let ((line-info (getf (line-plist test-line) 'lisp-info)))
|
|---|
| 193 |
|
|---|
| 194 | ;; Reparse the line when any of the following are true:
|
|---|
| 195 | ;;
|
|---|
| 196 | ;; FER-SURE-PARSE is T
|
|---|
| 197 | ;;
|
|---|
| 198 | ;; LINE-INFO or PREV-LINE-INFO are Nil.
|
|---|
| 199 | ;;
|
|---|
| 200 | ;; If the line begins quoted and the previous one wasn't
|
|---|
| 201 | ;; ended quoted.
|
|---|
| 202 | ;;
|
|---|
| 203 | ;; The Line's signature slot is invalid (the line has changed).
|
|---|
| 204 | ;;
|
|---|
| 205 |
|
|---|
| 206 | (when (or fer-sure-parse
|
|---|
| 207 | (not line-info)
|
|---|
| 208 | (not (eq (lisp-info-begins-quoted line-info)
|
|---|
| 209 | (let ((prev (and prev-line-info (lisp-info-ending-quoted prev-line-info))))
|
|---|
| 210 | (and (not (eq prev :char-quote)) prev))))
|
|---|
| 211 | (not (eql (line-signature test-line)
|
|---|
| 212 | (lisp-info-signature-slot line-info))))
|
|---|
| 213 |
|
|---|
| 214 | (move-to-position mark 0 test-line)
|
|---|
| 215 |
|
|---|
| 216 | (unless line-info
|
|---|
| 217 | (setf line-info (make-lisp-info))
|
|---|
| 218 | (setf (getf (line-plist test-line) 'lisp-info) line-info))
|
|---|
| 219 |
|
|---|
| 220 | (parse-lisp-line-info mark line-info prev-line-info))
|
|---|
| 221 |
|
|---|
| 222 | (when (eq end-line test-line)
|
|---|
| 223 | (return nil))
|
|---|
| 224 |
|
|---|
| 225 | (setq prev-line-info line-info)
|
|---|
| 226 |
|
|---|
| 227 | (setq test-line (line-next test-line)))))))
|
|---|
| 228 |
|
|---|
| 229 | |
|---|
| 230 |
|
|---|
| 231 | ;;;; Parse block finders.
|
|---|
| 232 |
|
|---|
| 233 |
|
|---|
| 234 | (defun start-of-parse-block (mark)
|
|---|
| 235 | (buffer-start mark))
|
|---|
| 236 |
|
|---|
| 237 | (defun end-of-parse-block (mark)
|
|---|
| 238 | (buffer-end mark))
|
|---|
| 239 |
|
|---|
| 240 | ;;;
|
|---|
| 241 | ;;; START-OF-SEARCH-LINE
|
|---|
| 242 |
|
|---|
| 243 | (defun start-of-search-line (line)
|
|---|
| 244 | "Set LINE to the begining line of the block of text to parse."
|
|---|
| 245 | (with-mark ((mark (mark line 0)))
|
|---|
| 246 | (funcall (value 'Parse-Start-Function) mark)
|
|---|
| 247 | (setq line (mark-line mark))))
|
|---|
| 248 |
|
|---|
| 249 | ;;;
|
|---|
| 250 | ;;; END-OF-SEACH-LINE
|
|---|
| 251 |
|
|---|
| 252 | (defun end-of-search-line (line)
|
|---|
| 253 | "Set LINE to the ending line of the block of text to parse."
|
|---|
| 254 | (with-mark ((mark (mark line 0)))
|
|---|
| 255 | (funcall (value 'Parse-End-Function) mark)
|
|---|
| 256 | (setq line (mark-line mark))))
|
|---|
| 257 |
|
|---|
| 258 | |
|---|
| 259 |
|
|---|
| 260 | ;;;; PARSE-LISP-LINE-INFO.
|
|---|
| 261 |
|
|---|
| 262 | ;;; PARSE-LISP-LINE-INFO -- Internal.
|
|---|
| 263 | ;;;
|
|---|
| 264 | ;;; This parses through the line doing the following things:
|
|---|
| 265 | ;;;
|
|---|
| 266 | ;;; Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS.
|
|---|
| 267 | ;;;
|
|---|
| 268 | ;;; Making all areas of the line that should be invalid (comments,
|
|---|
| 269 | ;;; char-quotes, and the inside of strings) and such be in
|
|---|
| 270 | ;;; RANGES-TO-IGNORE.
|
|---|
| 271 | ;;;
|
|---|
| 272 | ;;; Set BEGINS-QUOTED and ENDING-QUOTED
|
|---|
| 273 | ;;;
|
|---|
| 274 | (defun parse-lisp-line-info (mark line-info prev-line-info)
|
|---|
| 275 | "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS,
|
|---|
| 276 | RANGES-TO-INGORE, and ENDING-QUOTED."
|
|---|
| 277 | (let ((net-open-parens 0)
|
|---|
| 278 | (net-close-parens 0))
|
|---|
| 279 | (declare (fixnum net-open-parens net-close-parens))
|
|---|
| 280 |
|
|---|
| 281 | ;; Re-set the slots necessary
|
|---|
| 282 |
|
|---|
| 283 | (setf (lisp-info-ranges-to-ignore line-info) nil)
|
|---|
| 284 |
|
|---|
| 285 | (setf (lisp-info-ending-quoted line-info) nil)
|
|---|
| 286 |
|
|---|
| 287 | ;; The only way the current line begins quoted is when there
|
|---|
| 288 | ;; is a previous line and it's ending was quoted.
|
|---|
| 289 |
|
|---|
| 290 | (setf (lisp-info-begins-quoted line-info)
|
|---|
| 291 | (and prev-line-info
|
|---|
| 292 | (let ((prev (lisp-info-ending-quoted prev-line-info)))
|
|---|
| 293 | (and (not (eq prev :char-quote)) prev))))
|
|---|
| 294 |
|
|---|
| 295 | (assert (eq (hi::mark-buffer mark) (current-buffer)))
|
|---|
| 296 |
|
|---|
| 297 | (when (lisp-info-begins-quoted line-info)
|
|---|
| 298 | (deal-with-quote (lisp-info-begins-quoted line-info) mark line-info))
|
|---|
| 299 |
|
|---|
| 300 | (unless (lisp-info-ending-quoted line-info)
|
|---|
| 301 | (loop
|
|---|
| 302 |
|
|---|
| 303 | (unless (find-lisp-char mark)
|
|---|
| 304 | (error "Expected at least a newline!"))
|
|---|
| 305 | (case (character-attribute :lisp-syntax (next-character mark))
|
|---|
| 306 |
|
|---|
| 307 | (:open-paren
|
|---|
| 308 | (setq net-open-parens (1+ net-open-parens))
|
|---|
| 309 | (mark-after mark))
|
|---|
| 310 |
|
|---|
| 311 | (:close-paren
|
|---|
| 312 | (if (zerop net-open-parens)
|
|---|
| 313 | (setq net-close-parens (1+ net-close-parens))
|
|---|
| 314 | (setq net-open-parens (1- net-open-parens)))
|
|---|
| 315 | (mark-after mark))
|
|---|
| 316 |
|
|---|
| 317 | (:newline
|
|---|
| 318 | (setf (lisp-info-ending-quoted line-info) nil)
|
|---|
| 319 | (return t))
|
|---|
| 320 |
|
|---|
| 321 | (:comment
|
|---|
| 322 | (push-range (cons (mark-charpos mark) (line-length (mark-line mark)))
|
|---|
| 323 | line-info)
|
|---|
| 324 | (setf (lisp-info-ending-quoted line-info) nil)
|
|---|
| 325 | (return t))
|
|---|
| 326 |
|
|---|
| 327 | (:char-quote
|
|---|
| 328 | (mark-after mark)
|
|---|
| 329 | (let* ((charpos (mark-charpos mark))
|
|---|
| 330 | (nextpos (1+ charpos))
|
|---|
| 331 | (linelen (line-length (mark-line mark))))
|
|---|
| 332 | (when (< linelen nextpos)
|
|---|
| 333 | (setf (lisp-info-ending-quoted line-info) :char-quote)
|
|---|
| 334 | (return t))
|
|---|
| 335 | (push-range (cons charpos nextpos) line-info)
|
|---|
| 336 | (mark-after mark)))
|
|---|
| 337 |
|
|---|
| 338 | (:prefix-dispatch
|
|---|
| 339 | (mark-after mark)
|
|---|
| 340 | (when (test-char (next-character mark) :lisp-syntax :symbol-quote)
|
|---|
| 341 | (mark-after mark)
|
|---|
| 342 | (unless (deal-with-quote 1 mark line-info (- (mark-charpos mark) 2))
|
|---|
| 343 | (return t))))
|
|---|
| 344 |
|
|---|
| 345 | (:symbol-quote
|
|---|
| 346 | (mark-after mark)
|
|---|
| 347 | (unless (deal-with-quote :symbol-quote mark line-info)
|
|---|
| 348 | (return t)))
|
|---|
| 349 |
|
|---|
| 350 | (:string-quote
|
|---|
| 351 | (mark-after mark)
|
|---|
| 352 | (unless (deal-with-quote :string-quote mark line-info)
|
|---|
| 353 | (return t)))
|
|---|
| 354 |
|
|---|
| 355 | (t (ERROR "character attribute of: ~s is ~s, at ~s"
|
|---|
| 356 | (next-character mark)
|
|---|
| 357 | (character-attribute :lisp-syntax (next-character mark))
|
|---|
| 358 | mark)))))
|
|---|
| 359 | (setf (lisp-info-net-open-parens line-info) net-open-parens)
|
|---|
| 360 | (setf (lisp-info-net-close-parens line-info) net-close-parens)
|
|---|
| 361 | (setf (lisp-info-ranges-to-ignore line-info)
|
|---|
| 362 | (nreverse (lisp-info-ranges-to-ignore line-info)))
|
|---|
| 363 | (setf (lisp-info-signature-slot line-info)
|
|---|
| 364 | (line-signature (mark-line mark)))))
|
|---|
| 365 |
|
|---|
| 366 |
|
|---|
| 367 | |
|---|
| 368 |
|
|---|
| 369 | ;;;; String/symbol quote utilities.
|
|---|
| 370 |
|
|---|
| 371 | ;;; VALID-QUOTE-P
|
|---|
| 372 | ;;;
|
|---|
| 373 | (defmacro valid-quote-p (quote mark forwardp)
|
|---|
| 374 | "Return T if the string-quote indicated by MARK is valid."
|
|---|
| 375 | `(and (eq (character-attribute :lisp-syntax (direction-char ,mark ,forwardp)) ,quote)
|
|---|
| 376 | (not (char-quoted-at-mark-p ,mark ,forwardp))))
|
|---|
| 377 |
|
|---|
| 378 | (defun char-quoted-at-mark-p (mark forwardp)
|
|---|
| 379 | (unless forwardp
|
|---|
| 380 | (unless (mark-before mark)
|
|---|
| 381 | (return-from char-quoted-at-mark-p nil)))
|
|---|
| 382 | (loop for count upfrom 0
|
|---|
| 383 | do (unless (test-char (previous-character mark) :lisp-syntax :char-quote)
|
|---|
| 384 | (character-offset mark count) ;; go back to where started
|
|---|
| 385 | (unless forwardp
|
|---|
| 386 | (mark-after mark))
|
|---|
| 387 | (return (oddp count)))
|
|---|
| 388 | do (mark-before mark)))
|
|---|
| 389 |
|
|---|
| 390 | ;;;
|
|---|
| 391 | ;;; FIND-VALID-QUOTE
|
|---|
| 392 |
|
|---|
| 393 | (defmacro find-valid-quote (quote mark &key forwardp (cease-at-eol nil))
|
|---|
| 394 | "Expand to a form that will leave MARK before a valid string-quote character,
|
|---|
| 395 | in either a forward or backward direction, according to FORWARDP. If
|
|---|
| 396 | CEASE-AT-EOL is T then it will return nil if encountering the EOL before a
|
|---|
| 397 | valid string-quote."
|
|---|
| 398 | (let ((e-mark (gensym))
|
|---|
| 399 | (pred (gensym)))
|
|---|
| 400 | `(with-mark ((,e-mark ,mark))
|
|---|
| 401 | (let ((,pred ,(if cease-at-eol
|
|---|
| 402 | `#'(lambda (x) (or (eq x :newline) (eq x ,quote)))
|
|---|
| 403 | `#'(lambda (x) (eq x ,quote)))))
|
|---|
| 404 |
|
|---|
| 405 | (loop
|
|---|
| 406 | (unless (,(if forwardp 'find-attribute 'reverse-find-attribute)
|
|---|
| 407 | ,e-mark :lisp-syntax ,pred)
|
|---|
| 408 | (return nil))
|
|---|
| 409 |
|
|---|
| 410 | ,@(if cease-at-eol
|
|---|
| 411 | `((when (test-char (direction-char ,e-mark ,forwardp) :lisp-syntax
|
|---|
| 412 | :newline)
|
|---|
| 413 | (return nil))))
|
|---|
| 414 |
|
|---|
| 415 | (when (valid-quote-p ,quote ,e-mark ,forwardp)
|
|---|
| 416 | (move-mark ,mark ,e-mark)
|
|---|
| 417 | (return t))
|
|---|
| 418 |
|
|---|
| 419 | (neighbor-mark ,e-mark ,forwardp))))))
|
|---|
| 420 | |
|---|
| 421 |
|
|---|
| 422 | ;;; DEAL-WITH-QUOTE
|
|---|
| 423 | ;;;
|
|---|
| 424 | ;;; Called when a quoted area is begun (i.e. parse hits a #\" or #\|). It checks for a
|
|---|
| 425 | ;;; matching quote on the line that MARK points to, and puts the appropriate
|
|---|
| 426 | ;;; area in the RANGES-TO-IGNORE slot and leaves MARK pointing after this area.
|
|---|
| 427 | ;;; The "appropriate area" is from MARK to the end of the line or the matching
|
|---|
| 428 | ;;; string-quote, whichever comes first.
|
|---|
| 429 | ;;;
|
|---|
| 430 |
|
|---|
| 431 | (defun deal-with-quote (quote mark info-struct &optional (start (mark-charpos mark)))
|
|---|
| 432 | "Alter the current line's info struct as necessary as due to encountering a
|
|---|
| 433 | string or symbol quote character."
|
|---|
| 434 | (if (fixnump quote) ;; nesting multi-line comments
|
|---|
| 435 | (loop
|
|---|
| 436 | (unless (and (scan-char mark :lisp-syntax (or :newline :symbol-quote))
|
|---|
| 437 | (test-char (next-character mark) :lisp-syntax :symbol-quote))
|
|---|
| 438 | (line-end mark)
|
|---|
| 439 | (push-range (cons start (mark-charpos mark)) info-struct)
|
|---|
| 440 | (setf (lisp-info-ending-quoted info-struct) quote)
|
|---|
| 441 | (return nil))
|
|---|
| 442 | (if (prog1 (test-char (previous-character mark) :lisp-syntax :prefix-dispatch) (mark-after mark))
|
|---|
| 443 | (incf quote)
|
|---|
| 444 | (when (test-char (next-character mark) :lisp-syntax :prefix-dispatch)
|
|---|
| 445 | (mark-after mark)
|
|---|
| 446 | (decf quote)
|
|---|
| 447 | (when (<= quote 0)
|
|---|
| 448 | (push-range (cons start (mark-charpos mark)) info-struct)
|
|---|
| 449 | (setf (lisp-info-ending-quoted info-struct) nil)
|
|---|
| 450 | (return mark)))))
|
|---|
| 451 | (cond ((find-valid-quote quote mark :forwardp t :cease-at-eol t)
|
|---|
| 452 | ;; If matching quote is on this line then mark the area between the
|
|---|
| 453 | ;; first quote (MARK) and the matching quote as invalid by pushing
|
|---|
| 454 | ;; its begining and ending into the IGNORE-RANGE.
|
|---|
| 455 | (push-range (cons start (mark-charpos mark)) info-struct)
|
|---|
| 456 | (mark-after mark))
|
|---|
| 457 | ;; If the EOL has been hit before the matching quote then mark the
|
|---|
| 458 | ;; area from MARK to the EOL as invalid.
|
|---|
| 459 | (t
|
|---|
| 460 | (line-end mark)
|
|---|
| 461 | (push-range (cons start (mark-charpos mark)) info-struct)
|
|---|
| 462 | ;; The Ending is marked as still being quoted.
|
|---|
| 463 | (setf (lisp-info-ending-quoted info-struct) quote)
|
|---|
| 464 | nil))))
|
|---|
| 465 |
|
|---|
| 466 | ;;;; Character validity checking:
|
|---|
| 467 |
|
|---|
| 468 | ;;; Find-Ignore-Region -- Internal
|
|---|
| 469 | ;;;
|
|---|
| 470 | ;;; If the character in the specified direction from Mark is in an ignore
|
|---|
| 471 | ;;; region, then return the region and the line that the region is in as
|
|---|
| 472 | ;;; values. If there is no ignore region, then return NIL and the Mark-Line.
|
|---|
| 473 | ;;; If the line is not parsed, or there is no character (because of being at
|
|---|
| 474 | ;;; the buffer beginning or end), then return both values NIL.
|
|---|
| 475 | ;;;
|
|---|
| 476 | (defun find-ignore-region (mark forwardp)
|
|---|
| 477 | (flet ((scan (line pos)
|
|---|
| 478 | (declare (fixnum pos))
|
|---|
| 479 | (let ((info (getf (line-plist line) 'lisp-info)))
|
|---|
| 480 | (if info
|
|---|
| 481 | (dolist (range (lisp-info-ranges-to-ignore info)
|
|---|
| 482 | ;; if mark is at end of line, should check ending-quoted so can quote the newline...
|
|---|
| 483 | (values nil line))
|
|---|
| 484 | (let ((start (car range))
|
|---|
| 485 | (end (cdr range)))
|
|---|
| 486 | (declare (fixnum start end))
|
|---|
| 487 | (when (and (>= pos start) (< pos end))
|
|---|
| 488 | (return (values range line)))))
|
|---|
| 489 | (values nil nil)))))
|
|---|
| 490 | (let ((pos (mark-charpos mark))
|
|---|
| 491 | (line (mark-line mark)))
|
|---|
| 492 | (declare (fixnum pos))
|
|---|
| 493 | (cond (forwardp (scan line pos))
|
|---|
| 494 | ((> pos 0) (scan line (1- pos)))
|
|---|
| 495 | (t
|
|---|
| 496 | (let ((prev (line-previous line)))
|
|---|
| 497 | (if prev
|
|---|
| 498 | (scan prev (line-length prev))
|
|---|
| 499 | (values nil nil))))))))
|
|---|
| 500 |
|
|---|
| 501 |
|
|---|
| 502 | ;;; Valid-Spot -- Public
|
|---|
| 503 | ;;;
|
|---|
| 504 | (defun valid-spot (mark forwardp)
|
|---|
| 505 | "Return true if the character pointed to by Mark is not in a quoted context,
|
|---|
| 506 | false otherwise. If Forwardp is true, we use the next character, otherwise
|
|---|
| 507 | we use the previous."
|
|---|
| 508 | (if (and (not forwardp)
|
|---|
| 509 | (null (previous-character mark)))
|
|---|
| 510 | t ;beginning of buffer always a valid spot
|
|---|
| 511 | (multiple-value-bind (region line)
|
|---|
| 512 | (find-ignore-region mark forwardp)
|
|---|
| 513 | (and line (not region)))))
|
|---|
| 514 |
|
|---|
| 515 | ;;; Scan-Direction-Valid -- Internal
|
|---|
| 516 | ;;;
|
|---|
| 517 | ;;; Like scan-direction, but only stop on valid characters.
|
|---|
| 518 | ;;;
|
|---|
| 519 | (defmacro scan-direction-valid (mark forwardp &rest forms)
|
|---|
| 520 | (let ((n-mark (gensym))
|
|---|
| 521 | (n-line (gensym))
|
|---|
| 522 | (n-region (gensym))
|
|---|
| 523 | (n-won (gensym)))
|
|---|
| 524 | `(let ((,n-mark ,mark) (,n-won nil))
|
|---|
| 525 | (loop
|
|---|
| 526 | (multiple-value-bind (,n-region ,n-line)
|
|---|
| 527 | (find-ignore-region ,n-mark ,forwardp)
|
|---|
| 528 | (unless ,n-line (return nil))
|
|---|
| 529 | (if ,n-region
|
|---|
| 530 | (move-to-position ,n-mark
|
|---|
| 531 | ,(if forwardp
|
|---|
| 532 | `(cdr ,n-region)
|
|---|
| 533 | `(car ,n-region))
|
|---|
| 534 | ,n-line)
|
|---|
| 535 | (when ,n-won (return t)))
|
|---|
| 536 | ;;
|
|---|
| 537 | ;; Peculiar condition when a quoting character terminates a line.
|
|---|
| 538 | ;; The ignore region is off the end of the line causing %FORM-OFFSET
|
|---|
| 539 | ;; to infinitely loop.
|
|---|
| 540 | (when (> (mark-charpos ,n-mark) (line-length ,n-line))
|
|---|
| 541 | #+gz (break "This shouldn't happen any more")
|
|---|
| 542 | (line-offset ,n-mark 1 0))
|
|---|
| 543 | (unless (scan-direction ,n-mark ,forwardp ,@forms)
|
|---|
| 544 | (return nil))
|
|---|
| 545 | (setq ,n-won t))))))
|
|---|
| 546 |
|
|---|
| 547 | |
|---|
| 548 |
|
|---|
| 549 | ;;;; List offseting.
|
|---|
| 550 |
|
|---|
| 551 | ;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built
|
|---|
| 552 | ;;; with the same existing structure, with the altering of one variable.
|
|---|
| 553 | ;;; This one variable being FORWARDP.
|
|---|
| 554 | ;;;
|
|---|
| 555 | (defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) )
|
|---|
| 556 | "Expand to code that will go forward one list either backward or forward,
|
|---|
| 557 | according to the FORWARDP flag."
|
|---|
| 558 | (let ((mark (gensym)))
|
|---|
| 559 | `(with-mark ((,mark ,actual-mark))
|
|---|
| 560 | (if (valid-spot ,mark ,forwardp)
|
|---|
| 561 | (let ((paren-count ,extra-parens))
|
|---|
| 562 | (declare (fixnum paren-count))
|
|---|
| 563 | (loop
|
|---|
| 564 | (unless (scan-direction-valid ,mark ,forwardp :lisp-syntax
|
|---|
| 565 | (or :close-paren :open-paren :newline))
|
|---|
| 566 | (return nil))
|
|---|
| 567 | (let ((ch (direction-char ,mark ,forwardp)))
|
|---|
| 568 | (unless ch (return nil))
|
|---|
| 569 | (case (character-attribute :lisp-syntax ch)
|
|---|
| 570 | (:close-paren
|
|---|
| 571 | (decf paren-count)
|
|---|
| 572 | ,(when forwardp
|
|---|
| 573 | ;; When going forward, an unmatching close-paren means the
|
|---|
| 574 | ;; end of list.
|
|---|
| 575 | `(when (<= paren-count 0)
|
|---|
| 576 | (neighbor-mark ,mark ,forwardp)
|
|---|
| 577 | (move-mark ,actual-mark ,mark)
|
|---|
| 578 | (return t))))
|
|---|
| 579 | (:open-paren
|
|---|
| 580 | (incf paren-count)
|
|---|
| 581 | ,(unless forwardp ; Same as above only end of list
|
|---|
| 582 | `(when (>= paren-count 0) ; is opening parens.
|
|---|
| 583 | (neighbor-mark ,mark ,forwardp)
|
|---|
| 584 | (move-mark ,actual-mark ,mark)
|
|---|
| 585 | (return t))))
|
|---|
| 586 |
|
|---|
| 587 | (:newline
|
|---|
| 588 | ;; When a #\Newline is hit, then the matching paren must lie
|
|---|
| 589 | ;; on some other line so drop down into the multiple line
|
|---|
| 590 | ;; balancing function: QUEST-FOR-BALANCING-PAREN If no paren
|
|---|
| 591 | ;; seen yet, keep going.
|
|---|
| 592 | (cond ((zerop paren-count))
|
|---|
| 593 | ((quest-for-balancing-paren ,mark paren-count ,forwardp)
|
|---|
| 594 | (move-mark ,actual-mark ,mark)
|
|---|
| 595 | (return t))
|
|---|
| 596 | (t
|
|---|
| 597 | (return nil))))))
|
|---|
| 598 | (neighbor-mark ,mark ,forwardp)))
|
|---|
| 599 | ;; We're inside a comment or a string. Try anyway.
|
|---|
| 600 | (when ,(if forwardp
|
|---|
| 601 | `(%forward-list-at-mark ,mark ,extra-parens t)
|
|---|
| 602 | `(%backward-list-at-mark ,mark ,extra-parens t))
|
|---|
| 603 | (move-mark ,actual-mark ,mark))))))
|
|---|
| 604 |
|
|---|
| 605 | ;;;
|
|---|
| 606 | ;;; QUEST-FOR-BALANCING-PAREN
|
|---|
| 607 |
|
|---|
| 608 | (defmacro quest-for-balancing-paren (mark paren-count forwardp)
|
|---|
| 609 | "Expand to a form that finds the the balancing paren for however many opens or
|
|---|
| 610 | closes are registered by Paren-Count."
|
|---|
| 611 | `(let* ((line (mark-line ,mark)))
|
|---|
| 612 | (loop
|
|---|
| 613 | (setq line (neighbor-line line ,forwardp))
|
|---|
| 614 | (unless line (return nil))
|
|---|
| 615 | (let ((line-info (getf (line-plist line) 'lisp-info))
|
|---|
| 616 | (unbal-paren ,paren-count))
|
|---|
| 617 | (unless line-info (return nil))
|
|---|
| 618 |
|
|---|
| 619 | ,(if forwardp
|
|---|
| 620 | `(decf ,paren-count (lisp-info-net-close-parens line-info))
|
|---|
| 621 | `(incf ,paren-count (lisp-info-net-open-parens line-info)))
|
|---|
| 622 |
|
|---|
| 623 | (when ,(if forwardp
|
|---|
| 624 | `(<= ,paren-count 0)
|
|---|
| 625 | `(>= ,paren-count 0))
|
|---|
| 626 | ,(if forwardp
|
|---|
| 627 | `(line-start ,mark line)
|
|---|
| 628 | `(line-end ,mark line))
|
|---|
| 629 | (return (goto-correct-paren-char ,mark unbal-paren ,forwardp)))
|
|---|
| 630 |
|
|---|
| 631 | ,(if forwardp
|
|---|
| 632 | `(incf ,paren-count (lisp-info-net-open-parens line-info))
|
|---|
| 633 | `(decf ,paren-count (lisp-info-net-close-parens line-info)))))))
|
|---|
| 634 |
|
|---|
| 635 |
|
|---|
| 636 | ;;;
|
|---|
| 637 | ;;; GOTO-CORRECT-PAREN-CHAR
|
|---|
| 638 |
|
|---|
| 639 | (defmacro goto-correct-paren-char (mark paren-count forwardp)
|
|---|
| 640 | "Expand to a form that will leave MARK on the correct balancing paren matching
|
|---|
| 641 | however many are indicated by COUNT."
|
|---|
| 642 | `(with-mark ((m ,mark))
|
|---|
| 643 | (let ((count ,paren-count))
|
|---|
| 644 | (loop
|
|---|
| 645 | (scan-direction m ,forwardp :lisp-syntax
|
|---|
| 646 | (or :close-paren :open-paren :newline))
|
|---|
| 647 | (when (valid-spot m ,forwardp)
|
|---|
| 648 | (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
|
|---|
| 649 | (:close-paren
|
|---|
| 650 | (decf count)
|
|---|
| 651 | ,(when forwardp
|
|---|
| 652 | `(when (zerop count)
|
|---|
| 653 | (neighbor-mark m ,forwardp)
|
|---|
| 654 | (move-mark ,mark m)
|
|---|
| 655 | (return t))))
|
|---|
| 656 |
|
|---|
| 657 | (:open-paren
|
|---|
| 658 | (incf count)
|
|---|
| 659 | ,(unless forwardp
|
|---|
| 660 | `(when (zerop count)
|
|---|
| 661 | (neighbor-mark m ,forwardp)
|
|---|
| 662 | (move-mark ,mark m)
|
|---|
| 663 | (return t))))))
|
|---|
| 664 | (neighbor-mark m ,forwardp)))))
|
|---|
| 665 |
|
|---|
| 666 |
|
|---|
| 667 | (defun list-offset (mark offset)
|
|---|
| 668 | (if (plusp offset)
|
|---|
| 669 | (dotimes (i offset t)
|
|---|
| 670 | (unless (%list-offset mark t) (return nil)))
|
|---|
| 671 | (dotimes (i (- offset) t)
|
|---|
| 672 | (unless (%list-offset mark nil) (return nil)))))
|
|---|
| 673 |
|
|---|
| 674 | (defun forward-up-list (mark)
|
|---|
| 675 | "Moves mark just past the closing paren of the immediately containing list."
|
|---|
| 676 | (%list-offset mark t :extra-parens 1))
|
|---|
| 677 |
|
|---|
| 678 | (defun backward-up-list (mark)
|
|---|
| 679 | "Moves mark just before the opening paren of the immediately containing list."
|
|---|
| 680 | (%list-offset mark nil :extra-parens -1))
|
|---|
| 681 |
|
|---|
| 682 |
|
|---|
| 683 | |
|---|
| 684 |
|
|---|
| 685 | ;;;; Top level form location hacks (open parens beginning lines).
|
|---|
| 686 |
|
|---|
| 687 | ;;; NEIGHBOR-TOP-LEVEL is used only in TOP-LEVEL-OFFSET.
|
|---|
| 688 | ;;;
|
|---|
| 689 | (eval-when (:compile-toplevel :execute)
|
|---|
| 690 | (defmacro neighbor-top-level (line forwardp)
|
|---|
| 691 | `(loop
|
|---|
| 692 | (when (test-char (line-character ,line 0) :lisp-syntax :open-paren)
|
|---|
| 693 | (return t))
|
|---|
| 694 | (setf ,line ,(if forwardp `(line-next ,line) `(line-previous ,line)))
|
|---|
| 695 | (unless ,line (return nil))))
|
|---|
| 696 | ) ;eval-when
|
|---|
| 697 |
|
|---|
| 698 | (defun top-level-offset (mark offset)
|
|---|
| 699 | "Go forward or backward offset number of top level forms. Mark is
|
|---|
| 700 | returned if offset forms exists, otherwise nil."
|
|---|
| 701 | (declare (fixnum offset))
|
|---|
| 702 | (let* ((line (mark-line mark))
|
|---|
| 703 | (at-start (test-char (line-character line 0) :lisp-syntax :open-paren)))
|
|---|
| 704 | (cond ((zerop offset) mark)
|
|---|
| 705 | ((plusp offset)
|
|---|
| 706 | (do ((offset (if at-start offset (1- offset))
|
|---|
| 707 | (1- offset)))
|
|---|
| 708 | (nil)
|
|---|
| 709 | (declare (fixnum offset))
|
|---|
| 710 | (unless (neighbor-top-level line t) (return nil))
|
|---|
| 711 | (when (zerop offset) (return (line-start mark line)))
|
|---|
| 712 | (unless (setf line (line-next line)) (return nil))))
|
|---|
| 713 | (t
|
|---|
| 714 | (do ((offset (if (and at-start (start-line-p mark))
|
|---|
| 715 | offset
|
|---|
| 716 | (1+ offset))
|
|---|
| 717 | (1+ offset)))
|
|---|
| 718 | (nil)
|
|---|
| 719 | (declare (fixnum offset))
|
|---|
| 720 | (unless (neighbor-top-level line nil) (return nil))
|
|---|
| 721 | (when (zerop offset) (return (line-start mark line)))
|
|---|
| 722 | (unless (setf line (line-previous line)) (return nil)))))))
|
|---|
| 723 |
|
|---|
| 724 |
|
|---|
| 725 | (defun mark-top-level-form (mark1 mark2)
|
|---|
| 726 | "Moves mark1 and mark2 to the beginning and end of the current or next defun.
|
|---|
| 727 | Mark1 one is used as a reference. The marks may be altered even if
|
|---|
| 728 | unsuccessful. if successful, return mark2, else nil."
|
|---|
| 729 | (let ((winp (cond ((inside-defun-p mark1)
|
|---|
| 730 | (cond ((not (top-level-offset mark1 -1)) nil)
|
|---|
| 731 | ((not (form-offset (move-mark mark2 mark1) 1)) nil)
|
|---|
| 732 | (t mark2)))
|
|---|
| 733 | ((start-defun-p mark1)
|
|---|
| 734 | (form-offset (move-mark mark2 mark1) 1))
|
|---|
| 735 | ((and (top-level-offset (move-mark mark2 mark1) -1)
|
|---|
| 736 | (start-defun-p mark2)
|
|---|
| 737 | (form-offset mark2 1)
|
|---|
| 738 | (same-line-p mark1 mark2))
|
|---|
| 739 | (form-offset (move-mark mark1 mark2) -1)
|
|---|
| 740 | mark2)
|
|---|
| 741 | ((top-level-offset mark1 1)
|
|---|
| 742 | (form-offset (move-mark mark2 mark1) 1)))))
|
|---|
| 743 | (when winp
|
|---|
| 744 | (when (blank-after-p mark2) (line-offset mark2 1 0))
|
|---|
| 745 | mark2)))
|
|---|
| 746 |
|
|---|
| 747 | (defun inside-defun-p (mark)
|
|---|
| 748 | "T if the current point is (supposedly) in a top level form."
|
|---|
| 749 | (with-mark ((m mark))
|
|---|
| 750 | (when (top-level-offset m -1)
|
|---|
| 751 | (form-offset m 1)
|
|---|
| 752 | (mark> m mark))))
|
|---|
| 753 |
|
|---|
| 754 | (defun start-defun-p (mark)
|
|---|
| 755 | "Returns t if mark is sitting before an :open-paren at the beginning of a
|
|---|
| 756 | line."
|
|---|
| 757 | (and (start-line-p mark)
|
|---|
| 758 | (test-char (next-character mark) :lisp-syntax :open-paren)))
|
|---|
| 759 |
|
|---|
| 760 | ;;;; Form offseting.
|
|---|
| 761 |
|
|---|
| 762 | ;; Heuristic versions, for navigating inside comments, doesn't make use of line info
|
|---|
| 763 |
|
|---|
| 764 | (defun unparsed-form-offset (mark forwardp)
|
|---|
| 765 | ;; TODO: if called in "invalid" spot, arrange to stay within bounds of current invalid region.
|
|---|
| 766 | ;; For now, just stop at #||# boundaries, as first approximation.
|
|---|
| 767 | (if forwardp
|
|---|
| 768 | (forward-form mark t)
|
|---|
| 769 | (backward-form mark t)))
|
|---|
| 770 |
|
|---|
| 771 | (defun forward-form (mark &optional in-comment-p)
|
|---|
| 772 | ;; If in-comment-p is true, tries not to go past a |#.
|
|---|
| 773 | (with-mark ((m mark))
|
|---|
| 774 | (when (and (scan-char m :lisp-syntax (or :open-paren :close-paren :prefix-dispatch
|
|---|
| 775 | :symbol-quote :string-quote :char-quote
|
|---|
| 776 | :comment :constituent))
|
|---|
| 777 | (%forward-form-at-mark m in-comment-p))
|
|---|
| 778 | (move-mark mark m))))
|
|---|
| 779 |
|
|---|
| 780 | (defun backward-form (mark &optional in-comment-p)
|
|---|
| 781 | ;; If in-comment-p is true, tries not to go past a #|.
|
|---|
| 782 | (with-mark ((m mark))
|
|---|
| 783 | (when (%backward-form-at-mark m in-comment-p)
|
|---|
| 784 | (loop while (test-char (previous-character m) :lisp-syntax (or :prefix :prefix-dispatch)) do (mark-before m))
|
|---|
| 785 | (move-mark mark m))))
|
|---|
| 786 |
|
|---|
| 787 | (defun %forward-form-at-mark (mark in-comment-p)
|
|---|
| 788 | ;; Warning: moves mark even if returns nil (hence the % in name).
|
|---|
| 789 | (case (character-attribute :lisp-syntax (next-character mark))
|
|---|
| 790 | (:open-paren
|
|---|
| 791 | (mark-after mark)
|
|---|
| 792 | (%forward-list-at-mark mark 1))
|
|---|
| 793 | (:close-paren
|
|---|
| 794 | nil)
|
|---|
| 795 | (:char-quote
|
|---|
| 796 | (%forward-symbol-at-mark mark in-comment-p))
|
|---|
| 797 | (:symbol-quote
|
|---|
| 798 | (mark-after mark)
|
|---|
| 799 | (unless (and in-comment-p (test-char (next-character mark) :lisp-syntax :prefix-dispatch))
|
|---|
| 800 | (mark-before mark)
|
|---|
| 801 | (%forward-symbol-at-mark mark in-comment-p)))
|
|---|
| 802 | (:prefix-dispatch
|
|---|
| 803 | (mark-after mark)
|
|---|
| 804 | (case (character-attribute :lisp-syntax (next-character mark))
|
|---|
| 805 | (:symbol-quote
|
|---|
| 806 | (mark-after mark)
|
|---|
| 807 | (%forward-nesting-comment-at-mark mark 1))
|
|---|
| 808 | (:prefix
|
|---|
| 809 | (mark-after mark)
|
|---|
| 810 | (%forward-form-at-mark mark in-comment-p))
|
|---|
| 811 | (t
|
|---|
| 812 | (mark-before mark)
|
|---|
| 813 | (%forward-symbol-at-mark mark in-comment-p))))
|
|---|
| 814 | (:string-quote
|
|---|
| 815 | (%forward-string-at-mark mark))
|
|---|
| 816 | (:constituent
|
|---|
| 817 | (%forward-symbol-at-mark mark in-comment-p))
|
|---|
| 818 | (:comment
|
|---|
| 819 | (%forward-comments-at-mark mark))
|
|---|
| 820 | (t
|
|---|
| 821 | (mark-after mark)
|
|---|
| 822 | (%forward-form-at-mark mark in-comment-p))))
|
|---|
| 823 |
|
|---|
| 824 | (defun %backward-form-at-mark (mark in-comment-p)
|
|---|
| 825 | ;; Warning: moves mark even if returns nil (hence the % in name).
|
|---|
| 826 | (let* ((char (previous-character mark))
|
|---|
| 827 | (attrib (character-attribute :lisp-syntax char)))
|
|---|
| 828 | (when char
|
|---|
| 829 | (mark-before mark)
|
|---|
| 830 | (when (char-quoted-at-mark-p mark t)
|
|---|
| 831 | (setq attrib :constituent))
|
|---|
| 832 | (case attrib
|
|---|
| 833 | (:open-paren
|
|---|
| 834 | nil)
|
|---|
| 835 | (:close-paren
|
|---|
| 836 | (%backward-list-at-mark mark 1))
|
|---|
| 837 | (:char-quote ;;; can only happen if starting right after an unquoted char-quote
|
|---|
| 838 | (%backward-symbol-at-mark mark in-comment-p))
|
|---|
| 839 | (:symbol-quote
|
|---|
| 840 | (unless (and in-comment-p (test-char (previous-character mark) :lisp-syntax :prefix-dispatch))
|
|---|
| 841 | (mark-after mark)
|
|---|
| 842 | (%backward-symbol-at-mark mark in-comment-p)))
|
|---|
| 843 | (:prefix-dispatch
|
|---|
| 844 | (if (test-char (previous-character mark) :lisp-syntax :symbol-quote)
|
|---|
| 845 | (progn
|
|---|
| 846 | (mark-before mark)
|
|---|
| 847 | (%backward-nesting-comment-at-mark mark 1))
|
|---|
| 848 | (progn
|
|---|
| 849 | (mark-after mark)
|
|---|
| 850 | (%backward-symbol-at-mark mark in-comment-p))))
|
|---|
| 851 | (:string-quote
|
|---|
| 852 | (mark-after mark)
|
|---|
| 853 | (%backward-string-at-mark mark))
|
|---|
| 854 | (:constituent
|
|---|
| 855 | (mark-after mark)
|
|---|
| 856 | (%backward-symbol-at-mark mark in-comment-p))
|
|---|
| 857 | (:prefix
|
|---|
| 858 | (loop while (test-char (previous-character mark) :lisp-syntax :prefix) do (mark-before mark))
|
|---|
| 859 | mark)
|
|---|
| 860 | (:comment
|
|---|
| 861 | (loop while (test-char (previous-character mark) :lisp-syntax :comment) do (mark-before mark))
|
|---|
| 862 | mark)
|
|---|
| 863 | ;; TODO: it would be nice to skip over ;; comments if starting outside one, i.e. if encounter a newline
|
|---|
| 864 | ;; before a form starts.
|
|---|
| 865 | (t (%backward-form-at-mark mark in-comment-p))))))
|
|---|
| 866 |
|
|---|
| 867 | (defun %forward-symbol-at-mark (mark in-comment-p)
|
|---|
| 868 | ;; Warning: moves mark even if returns nil (hence the % in name).
|
|---|
| 869 | (loop
|
|---|
| 870 | (unless (scan-char mark :lisp-syntax (not (or :constituent :prefix-dispatch)))
|
|---|
| 871 | (return (buffer-end mark)))
|
|---|
| 872 | (case (character-attribute :lisp-syntax (next-character mark))
|
|---|
| 873 | (:symbol-quote
|
|---|
| 874 | (mark-after mark)
|
|---|
| 875 | (when (and in-comment-p (test-char (next-character mark) :lisp-syntax :prefix-dispatch))
|
|---|
| 876 | (return (mark-before mark)))
|
|---|
| 877 | (unless (loop
|
|---|
| 878 | (unless (scan-char mark :lisp-syntax (or :char-quote :symbol-quote))
|
|---|
| 879 | (return nil))
|
|---|
| 880 | (when (test-char (next-character mark) :lisp-syntax :symbol-quote)
|
|---|
| 881 | (return t))
|
|---|
| 882 | (unless (character-offset mark 2)
|
|---|
| 883 | (return nil)))
|
|---|
| 884 | (return nil))
|
|---|
| 885 | (mark-after mark))
|
|---|
| 886 | (:char-quote
|
|---|
| 887 | (unless (character-offset mark 2)
|
|---|
| 888 | (return nil)))
|
|---|
| 889 | (t (return mark)))))
|
|---|
| 890 |
|
|---|
| 891 | (defun %backward-symbol-at-mark (mark in-comment-p)
|
|---|
| 892 | (loop
|
|---|
| 893 | (unless (rev-scan-char mark :lisp-syntax (not (or :constituent :prefix-dispatch :char-quote)))
|
|---|
| 894 | (buffer-start mark)
|
|---|
| 895 | (return mark))
|
|---|
| 896 | (mark-before mark)
|
|---|
| 897 | (if (char-quoted-at-mark-p mark t)
|
|---|
| 898 | (mark-before mark)
|
|---|
| 899 | (let* ((char (next-character mark)))
|
|---|
| 900 | (case (character-attribute :lisp-syntax char)
|
|---|
| 901 | (:symbol-quote
|
|---|
| 902 | (when (and in-comment-p (test-char (previous-character mark) :lisp-syntax :prefix-dispatch))
|
|---|
| 903 | (return (mark-after mark)))
|
|---|
| 904 | (unless (loop
|
|---|
| 905 | (unless (rev-scan-char mark :lisp-syntax :symbol-quote)
|
|---|
| 906 | (return nil))
|
|---|
| 907 | (mark-before mark)
|
|---|
| 908 | (unless (char-quoted-at-mark-p mark t)
|
|---|
| 909 | (return t))
|
|---|
| 910 | (mark-before mark))
|
|---|
| 911 | (return nil)))
|
|---|
| 912 | (t (mark-after mark)
|
|---|
| 913 | (return mark)))))))
|
|---|
| 914 |
|
|---|
| 915 | (defun %forward-nesting-comment-at-mark (mark nesting)
|
|---|
| 916 | ;; Warning: moves mark even if returns nil (hence the % in name).
|
|---|
| 917 | (loop
|
|---|
| 918 | (unless (scan-char mark :lisp-syntax :symbol-quote)
|
|---|
| 919 | (return nil))
|
|---|
| 920 | (let ((prev (previous-character mark)))
|
|---|
| 921 | (mark-after mark)
|
|---|
| 922 | (cond ((test-char prev :lisp-syntax :prefix-dispatch)
|
|---|
| 923 | (incf nesting))
|
|---|
| 924 | ((test-char (next-character mark) :lisp-syntax :prefix-dispatch)
|
|---|
| 925 | (mark-after mark)
|
|---|
| 926 | (when (<= (decf nesting) 0)
|
|---|
| 927 | (return mark)))))))
|
|---|
| 928 |
|
|---|
| 929 | (defun %backward-nesting-comment-at-mark (mark nesting)
|
|---|
| 930 | ;; Warning: moves mark even if returns nil (hence the % in name).
|
|---|
| 931 | (loop
|
|---|
| 932 | (unless (rev-scan-char mark :lisp-syntax :symbol-quote)
|
|---|
| 933 | (return nil))
|
|---|
| 934 | (let ((next (next-character mark)))
|
|---|
| 935 | (mark-before mark)
|
|---|
| 936 | (cond ((test-char next :lisp-syntax :prefix-dispatch)
|
|---|
| 937 | (incf nesting))
|
|---|
| 938 | ((test-char (previous-character mark) :lisp-syntax :prefix-dispatch)
|
|---|
| 939 | (mark-before mark)
|
|---|
| 940 | (when (<= (decf nesting) 0)
|
|---|
| 941 | (return mark)))))))
|
|---|
| 942 |
|
|---|
| 943 |
|
|---|
| 944 | (defun %scan-to-form (m forwardp)
|
|---|
| 945 | (if forwardp
|
|---|
| 946 | ;; Stop at :prefix-dispatch if it is not followed by :prefix. If it's followed by :prefix,
|
|---|
| 947 | ;; assume it has the semantics of :prefix and skip it.
|
|---|
| 948 | (loop while (scan-direction-valid m t :lisp-syntax
|
|---|
| 949 | (or :open-paren :close-paren
|
|---|
| 950 | :char-quote :string-quote :symbol-quote
|
|---|
| 951 | :prefix-dispatch :constituent))
|
|---|
| 952 | do (unless (and (test-char (next-character m) :lisp-syntax :prefix-dispatch)
|
|---|
| 953 | (mark-after m))
|
|---|
| 954 | (return t))
|
|---|
| 955 | do (unless (test-char (next-character m) :lisp-syntax :prefix)
|
|---|
| 956 | (mark-before m)
|
|---|
| 957 | (return t)))
|
|---|
| 958 | (scan-direction-valid m nil :lisp-syntax
|
|---|
| 959 | (or :open-paren :close-paren
|
|---|
| 960 | :char-quote :string-quote :symbol-quote
|
|---|
| 961 | :prefix-dispatch :constituent))))
|
|---|
| 962 |
|
|---|
| 963 | ;; %FORM-OFFSET
|
|---|
| 964 |
|
|---|
| 965 | (defmacro %form-offset (mark forwardp)
|
|---|
| 966 | `(if (valid-spot ,mark ,forwardp)
|
|---|
| 967 | (with-mark ((m ,mark))
|
|---|
| 968 | (when (%scan-to-form m ,forwardp)
|
|---|
| 969 | (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
|
|---|
| 970 | (:open-paren
|
|---|
| 971 | (when ,(if forwardp `(list-offset m 1) `(mark-before m))
|
|---|
| 972 | ,(unless forwardp
|
|---|
| 973 | '(scan-direction m nil :lisp-syntax (not (or :prefix-dispatch :prefix))))
|
|---|
| 974 | (move-mark ,mark m)
|
|---|
| 975 | t))
|
|---|
| 976 | (:close-paren
|
|---|
| 977 | (when ,(if forwardp `(mark-after m) `(list-offset m -1))
|
|---|
| 978 | ,(unless forwardp
|
|---|
| 979 | '(scan-direction m nil :lisp-syntax (not (or :prefix-dispatch :prefix))))
|
|---|
| 980 | (move-mark ,mark m)
|
|---|
| 981 | t))
|
|---|
| 982 | ((:constituent :char-quote :symbol-quote :prefix-dispatch)
|
|---|
| 983 | ,(if forwardp
|
|---|
| 984 | `(scan-direction-valid m t :lisp-syntax
|
|---|
| 985 | (not (or :constituent :char-quote :symbol-quote :prefix-dispatch)))
|
|---|
| 986 | `(scan-direction-valid m nil :lisp-syntax
|
|---|
| 987 | (not (or :constituent :char-quote :symbol-quote :prefix-dispatch
|
|---|
| 988 | :prefix))))
|
|---|
| 989 | (move-mark ,mark m)
|
|---|
| 990 | t)
|
|---|
| 991 | (:string-quote
|
|---|
| 992 | (neighbor-mark m ,forwardp)
|
|---|
| 993 | (when (scan-direction-valid m ,forwardp :lisp-syntax
|
|---|
| 994 | :string-quote)
|
|---|
| 995 | (neighbor-mark m ,forwardp)
|
|---|
| 996 | (move-mark ,mark m)
|
|---|
| 997 | t)))))
|
|---|
| 998 | ;; Inside a comment or a string. Switch to heuristic method.
|
|---|
| 999 | (unparsed-form-offset ,mark ,forwardp)))
|
|---|
| 1000 |
|
|---|
| 1001 | (defun %forward-list-at-mark (mark nesting &optional in-comment-p)
|
|---|
| 1002 | ;; Warning: moves mark even if returns nil (hence the % in name).
|
|---|
| 1003 | (loop
|
|---|
| 1004 | (unless (scan-char mark :lisp-syntax (or :open-paren :close-paren :prefix-dispatch
|
|---|
| 1005 | :symbol-quote :string-quote :char-quote :comment))
|
|---|
| 1006 | (return nil))
|
|---|
| 1007 | (case (character-attribute :lisp-syntax (next-character mark))
|
|---|
| 1008 | (:open-paren
|
|---|
| 1009 | (mark-after mark)
|
|---|
| 1010 | (incf nesting))
|
|---|
| 1011 | (:close-paren
|
|---|
| 1012 | (mark-after mark)
|
|---|
| 1013 | (when (<= (decf nesting) 0)
|
|---|
| 1014 | (return (and (eql nesting 0) mark))))
|
|---|
| 1015 | (t
|
|---|
| 1016 | (unless (%forward-form-at-mark mark in-comment-p)
|
|---|
| 1017 | (return nil))))))
|
|---|
| 1018 |
|
|---|
| 1019 | (defun %backward-list-at-mark (mark nesting &optional in-comment-p)
|
|---|
| 1020 | ;; Warning: moves mark even if returns nil (hence the % in name).
|
|---|
| 1021 | (loop
|
|---|
| 1022 | (unless (rev-scan-char mark :lisp-syntax (or :open-paren :close-paren :prefix-dispatch
|
|---|
| 1023 | :symbol-quote :string-quote :comment))
|
|---|
| 1024 | (return nil))
|
|---|
| 1025 | (mark-before mark)
|
|---|
| 1026 | (if (char-quoted-at-mark-p mark t)
|
|---|
| 1027 | (mark-before mark)
|
|---|
| 1028 | (case (character-attribute :lisp-syntax (next-character mark))
|
|---|
| 1029 | (:close-paren
|
|---|
| 1030 | (incf nesting))
|
|---|
| 1031 | (:open-paren
|
|---|
| 1032 | (when (<= (decf nesting) 0)
|
|---|
| 1033 | (return mark)))
|
|---|
| 1034 | (t
|
|---|
| 1035 | ;(mark-after mark)
|
|---|
| 1036 | (unless (%backward-form-at-mark mark in-comment-p)
|
|---|
| 1037 | (return nil)))))))
|
|---|
| 1038 |
|
|---|
| 1039 | (defun %forward-string-at-mark (mark)
|
|---|
| 1040 | ;; Warning: moves mark even if returns nil (hence the % in name).
|
|---|
| 1041 | (mark-after mark)
|
|---|
| 1042 | (loop
|
|---|
| 1043 | (unless (scan-char mark :lisp-syntax (or :char-quote :string-quote))
|
|---|
| 1044 | (return nil))
|
|---|
| 1045 | (unless (test-char (next-character mark) :lisp-syntax :char-quote)
|
|---|
| 1046 | (return (mark-after mark)))
|
|---|
| 1047 | (character-offset mark 2)))
|
|---|
| 1048 |
|
|---|
| 1049 |
|
|---|
| 1050 | (defun %backward-string-at-mark (mark)
|
|---|
| 1051 | ;; Warning: moves mark even if returns nil (hence the % in name).
|
|---|
| 1052 | (mark-before mark)
|
|---|
| 1053 | (loop
|
|---|
| 1054 | (unless (rev-scan-char mark :lisp-syntax :string-quote)
|
|---|
| 1055 | (return nil))
|
|---|
| 1056 | (mark-before mark)
|
|---|
| 1057 | (unless (char-quoted-at-mark-p mark t)
|
|---|
| 1058 | (return mark))
|
|---|
| 1059 | (mark-before mark)))
|
|---|
| 1060 |
|
|---|
| 1061 | (defun %forward-comments-at-mark (mark)
|
|---|
| 1062 | ;; Warning: moves mark even if returns nil (hence the % in name).
|
|---|
| 1063 | (with-mark ((m mark))
|
|---|
| 1064 | (loop
|
|---|
| 1065 | (line-end m)
|
|---|
| 1066 | (mark-after m)
|
|---|
| 1067 | (move-mark mark m)
|
|---|
| 1068 | (unless (and (scan-char m :lisp-syntax (not :space))
|
|---|
| 1069 | (test-char (next-character m) :lisp-syntax :comment))
|
|---|
| 1070 | (return mark)))))
|
|---|
| 1071 |
|
|---|
| 1072 | (defun form-offset (mark offset)
|
|---|
| 1073 | "Move mark offset number of forms, after if positive, before if negative.
|
|---|
| 1074 | Mark is always moved. If there weren't enough forms, returns nil instead of
|
|---|
| 1075 | mark."
|
|---|
| 1076 | (if (plusp offset)
|
|---|
| 1077 | (dotimes (i offset t)
|
|---|
| 1078 | (unless (%form-offset mark t) (return nil)))
|
|---|
| 1079 | (dotimes (i (- offset) t)
|
|---|
| 1080 | (unless (%form-offset mark nil) (return nil)))))
|
|---|
| 1081 |
|
|---|
| 1082 | ;; Return region for the "current form" at mark.
|
|---|
| 1083 | ;; TODO: See also mark-nearest-form, should merge them
|
|---|
| 1084 | (defun form-region-at-mark (mark)
|
|---|
| 1085 | (with-mark ((bwd-start mark)
|
|---|
| 1086 | (bwd-end mark)
|
|---|
| 1087 | (fwd-start mark)
|
|---|
| 1088 | (fwd-end mark))
|
|---|
| 1089 | (let* ((fwd (and (or (and (char-quoted-at-mark-p mark t) ;; back-up so get whole character
|
|---|
| 1090 | (mark-before fwd-end))
|
|---|
| 1091 | (test-char (next-character mark) :lisp-syntax
|
|---|
| 1092 | (or :open-paren :string-quote
|
|---|
| 1093 | :char-quote :symbol-quote :constituent :prefix-dispatch
|
|---|
| 1094 | :prefix)))
|
|---|
| 1095 | (form-offset fwd-end 1)
|
|---|
| 1096 | (form-offset (move-mark fwd-start fwd-end) -1)
|
|---|
| 1097 | (mark<= fwd-start mark)))
|
|---|
| 1098 | (bwd (and (or (char-quoted-at-mark-p mark nil)
|
|---|
| 1099 | (test-char (previous-character mark) :lisp-syntax
|
|---|
| 1100 | (or :close-paren :string-quote
|
|---|
| 1101 | :char-quote :symbol-quote :constituent :prefix-dispatch)))
|
|---|
| 1102 | ;; Special case - if at an open paren, always select forward because that's
|
|---|
| 1103 | ;; the matching paren that's highlighted.
|
|---|
| 1104 | (not (and fwd (test-char (next-character mark) :lisp-syntax :open-paren)))
|
|---|
| 1105 | ;; Also prefer string over anything but close paren.
|
|---|
| 1106 | (not (and fwd (test-char (next-character mark) :lisp-syntax :string-quote)
|
|---|
| 1107 | (not (test-char (previous-character mark) :lisp-syntax :close-paren))))
|
|---|
| 1108 | (form-offset bwd-start -1)
|
|---|
| 1109 | (form-offset (move-mark bwd-end bwd-start) 1)
|
|---|
| 1110 | (mark<= mark bwd-end))))
|
|---|
| 1111 | (if bwd
|
|---|
| 1112 | (when (or (not fwd) ;; back is only option
|
|---|
| 1113 | (and (mark= bwd-start fwd-start) (mark= bwd-end fwd-end)) ;; or they're the same
|
|---|
| 1114 | (and (mark= bwd-start fwd-end) ;; or had to skip prefix chars to get to forward
|
|---|
| 1115 | (test-char (next-character fwd-start) :lisp-syntax (or :prefix :prefix-dispatch))))
|
|---|
| 1116 | (region bwd-start bwd-end))
|
|---|
| 1117 | (if fwd
|
|---|
| 1118 | (region fwd-start fwd-end))))))
|
|---|
| 1119 |
|
|---|
| 1120 | ;; Return region for the current word at mark, or nil if there isn't one.
|
|---|
| 1121 | (defun word-region-at-mark (mark)
|
|---|
| 1122 | (with-mark ((fwd mark)
|
|---|
| 1123 | (bwd mark))
|
|---|
| 1124 | (or (find-attribute fwd :word-delimiter)
|
|---|
| 1125 | (buffer-end fwd))
|
|---|
| 1126 | (or (reverse-find-attribute bwd :word-delimiter)
|
|---|
| 1127 | (buffer-start bwd))
|
|---|
| 1128 | (unless (mark= bwd fwd)
|
|---|
| 1129 | ;; Special-case for keywords (and gensyms)
|
|---|
| 1130 | (when (eq (previous-character bwd) #\:)
|
|---|
| 1131 | (mark-before bwd)
|
|---|
| 1132 | (when (test-char (previous-character bwd) :lisp-syntax :constituent)
|
|---|
| 1133 | (mark-after bwd))) ;; oops, never mind
|
|---|
| 1134 | ;; Special-case for stuff like #_foo.
|
|---|
| 1135 | (when (test-char (previous-character bwd) :lisp-syntax :prefix-dispatch)
|
|---|
| 1136 | ;; let :prefix-dispatch take on the attribute of the following char, which is a word constituent
|
|---|
| 1137 | (mark-before bwd))
|
|---|
| 1138 | (region bwd fwd))))
|
|---|
| 1139 |
|
|---|
| 1140 | ;;;; Table of special forms with special indenting requirements.
|
|---|
| 1141 |
|
|---|
| 1142 | (defhvar "Indent Defanything"
|
|---|
| 1143 | "This is the number of special arguments implicitly assumed to be supplied
|
|---|
| 1144 | in calls to functions whose names begin with \"DEF\". If set to NIL, this
|
|---|
| 1145 | feature is disabled."
|
|---|
| 1146 | :value 2)
|
|---|
| 1147 |
|
|---|
| 1148 | (defhvar "Indent With-anything"
|
|---|
| 1149 | "This is the number of special arguments implicitly assumed to be supplied
|
|---|
| 1150 | in calls to functions whose names begin with \"WITH-\". If set to NIL, this
|
|---|
| 1151 | feature is disabled."
|
|---|
| 1152 | :value 1)
|
|---|
| 1153 |
|
|---|
| 1154 | (defvar *special-forms* (make-hash-table :test #'equal))
|
|---|
| 1155 |
|
|---|
| 1156 | (defun defindent (fname args)
|
|---|
| 1157 | "Define Fname to have Args special arguments. If args is null then remove
|
|---|
| 1158 | any special arguments information."
|
|---|
| 1159 | (check-type fname string)
|
|---|
| 1160 | (let ((fname (string-upcase fname)))
|
|---|
| 1161 | (cond ((null args) (remhash fname *special-forms*))
|
|---|
| 1162 | (t
|
|---|
| 1163 | (check-type args integer)
|
|---|
| 1164 | (setf (gethash fname *special-forms*) args)))))
|
|---|
| 1165 |
|
|---|
| 1166 |
|
|---|
| 1167 | ;;; Hemlock forms.
|
|---|
| 1168 | ;;;
|
|---|
| 1169 | (defindent "defhvar" 1)
|
|---|
| 1170 | (defindent "hlet" 1)
|
|---|
| 1171 | (defindent "defcommand" 2)
|
|---|
| 1172 | (defindent "defattribute" 1)
|
|---|
| 1173 | (defindent "command-case" 1)
|
|---|
| 1174 | (defindent "do-strings" 1)
|
|---|
| 1175 | (defindent "save-for-undo" 1)
|
|---|
| 1176 | (defindent "do-alpha-chars" 1)
|
|---|
| 1177 | (defindent "do-headers-buffers" 1)
|
|---|
| 1178 | (defindent "do-headers-lines" 1)
|
|---|
| 1179 | (defindent "frob" 1) ;cover silly FLET and MACROLET names for Rob and Bill.
|
|---|
| 1180 | (defindent "modifying-buffer" 1)
|
|---|
| 1181 |
|
|---|
| 1182 | ;;; Common Lisp forms.
|
|---|
| 1183 | ;;;
|
|---|
| 1184 | (defindent "block" 1)
|
|---|
| 1185 | (defindent "return-from" 1)
|
|---|
| 1186 | (defindent "case" 1)
|
|---|
| 1187 | (defindent "catch" 1)
|
|---|
| 1188 | (defindent "ccase" 1)
|
|---|
| 1189 | (defindent "compiler-let" 1)
|
|---|
| 1190 | (defindent "ctypecase" 1)
|
|---|
| 1191 | (defindent "defconstant" 1)
|
|---|
| 1192 | (defindent "define-compiler-macro" 2)
|
|---|
| 1193 | (defindent "define-setf-method" 2)
|
|---|
| 1194 | (defindent "destructuring-bind" 2)
|
|---|
| 1195 | (defindent "defmacro" 2)
|
|---|
| 1196 | (defindent "defpackage" 1)
|
|---|
| 1197 | (defindent "defparameter" 1)
|
|---|
| 1198 | (defindent "defstruct" 1)
|
|---|
| 1199 | (defindent "deftype" 2)
|
|---|
| 1200 | (defindent "defun" 2)
|
|---|
| 1201 | (defindent "defvar" 1)
|
|---|
| 1202 | (defindent "do" 2)
|
|---|
| 1203 | (defindent "do*" 2)
|
|---|
| 1204 | (defindent "do-all-symbols" 1)
|
|---|
| 1205 | (defindent "do-external-symbols" 1)
|
|---|
| 1206 | (defindent "do-symbols" 1)
|
|---|
| 1207 | (defindent "dolist" 1)
|
|---|
| 1208 | (defindent "dotimes" 1)
|
|---|
| 1209 | (defindent "ecase" 1)
|
|---|
| 1210 | (defindent "etypecase" 1)
|
|---|
| 1211 | (defindent "eval-when" 1)
|
|---|
| 1212 | (defindent "flet" 1)
|
|---|
| 1213 | (defindent "if" 1)
|
|---|
| 1214 | (defindent "labels" 1)
|
|---|
| 1215 | (defindent "lambda" 1)
|
|---|
| 1216 | (defindent "let" 1)
|
|---|
| 1217 | (defindent "let*" 1)
|
|---|
| 1218 | (defindent "locally" 0)
|
|---|
| 1219 | (defindent "loop" 0)
|
|---|
| 1220 | (defindent "macrolet" 1)
|
|---|
| 1221 | (defindent "multiple-value-bind" 2)
|
|---|
| 1222 | (defindent "multiple-value-call" 1)
|
|---|
| 1223 | (defindent "multiple-value-prog1" 1)
|
|---|
| 1224 | (defindent "multiple-value-setq" 1)
|
|---|
| 1225 | (defindent "prog" 1)
|
|---|
| 1226 | (defindent "prog*" 1)
|
|---|
| 1227 | (defindent "prog1" 0)
|
|---|
| 1228 | (defindent "prog2" 0)
|
|---|
| 1229 | (defindent "progv" 2)
|
|---|
| 1230 | (defindent "progn" 0)
|
|---|
| 1231 | (defindent "typecase" 1)
|
|---|
| 1232 | (defindent "unless" 1)
|
|---|
| 1233 | (defindent "unwind-protect" 1)
|
|---|
| 1234 | (defindent "when" 1)
|
|---|
| 1235 |
|
|---|
| 1236 | ;; CCL extensions
|
|---|
| 1237 | (defindent "iterate" 2)
|
|---|
| 1238 | (defindent "rlet" 1)
|
|---|
| 1239 | (defindent "rletz" 1)
|
|---|
| 1240 | (defindent "let-globally" 1)
|
|---|
| 1241 |
|
|---|
| 1242 | ;;; Error/condition system forms.
|
|---|
| 1243 | ;;;
|
|---|
| 1244 | (defindent "define-condition" 2)
|
|---|
| 1245 | (defindent "handler-bind" 1)
|
|---|
| 1246 | (defindent "handler-case" 1)
|
|---|
| 1247 | (defindent "restart-bind" 1)
|
|---|
| 1248 | (defindent "restart-case" 1)
|
|---|
| 1249 | ;;; These are for RESTART-CASE branch formatting.
|
|---|
| 1250 | (defindent "store-value" 1)
|
|---|
| 1251 | (defindent "use-value" 1)
|
|---|
| 1252 | (defindent "muffle-warning" 1)
|
|---|
| 1253 | (defindent "abort" 1)
|
|---|
| 1254 | (defindent "continue" 1)
|
|---|
| 1255 | ;;; This is for DEFGENERIC method formatting
|
|---|
| 1256 | (defindent "method" 1)
|
|---|
| 1257 |
|
|---|
| 1258 | ;;; Common library extensions
|
|---|
| 1259 | (defindent "if-let" 1)
|
|---|
| 1260 | (defindent "if-let*" 1)
|
|---|
| 1261 | (defindent "when-let" 1)
|
|---|
| 1262 | (defindent "when-let*" 1)
|
|---|
| 1263 |
|
|---|
| 1264 | #|
|
|---|
| 1265 | ;;; Debug-internals forms.
|
|---|
| 1266 | ;;;
|
|---|
| 1267 | (defindent "do-debug-function-blocks" 1)
|
|---|
| 1268 | (defindent "di:do-debug-function-blocks" 1)
|
|---|
| 1269 | (defindent "do-debug-function-variables" 1)
|
|---|
| 1270 | (defindent "di:do-debug-function-variables" 1)
|
|---|
| 1271 | (defindent "do-debug-block-locations" 1)
|
|---|
| 1272 | (defindent "di:do-debug-block-locations" 1)
|
|---|
| 1273 | ;;;
|
|---|
| 1274 | ;;; Debug-internals conditions
|
|---|
| 1275 | ;;; (define these to make uses of HANDLER-CASE indent branches correctly.)
|
|---|
| 1276 | ;;;
|
|---|
| 1277 | (defindent "debug-condition" 1)
|
|---|
| 1278 | (defindent "di:debug-condition" 1)
|
|---|
| 1279 | (defindent "no-debug-info" 1)
|
|---|
| 1280 | (defindent "di:no-debug-info" 1)
|
|---|
| 1281 | (defindent "no-debug-function-returns" 1)
|
|---|
| 1282 | (defindent "di:no-debug-function-returns" 1)
|
|---|
| 1283 | (defindent "no-debug-blocks" 1)
|
|---|
| 1284 | (defindent "di:no-debug-blocks" 1)
|
|---|
| 1285 | (defindent "lambda-list-unavailable" 1)
|
|---|
| 1286 | (defindent "di:lambda-list-unavailable" 1)
|
|---|
| 1287 | (defindent "no-debug-variables" 1)
|
|---|
| 1288 | (defindent "di:no-debug-variables" 1)
|
|---|
| 1289 | (defindent "invalid-value" 1)
|
|---|
| 1290 | (defindent "di:invalid-value" 1)
|
|---|
| 1291 | (defindent "ambiguous-variable-name" 1)
|
|---|
| 1292 | (defindent "di:ambiguous-variable-name" 1)
|
|---|
| 1293 | (defindent "debug-error" 1)
|
|---|
| 1294 | (defindent "di:debug-error" 1)
|
|---|
| 1295 | (defindent "unhandled-condition" 1)
|
|---|
| 1296 | (defindent "di:unhandled-condition" 1)
|
|---|
| 1297 | (defindent "unknown-code-location" 1)
|
|---|
| 1298 | (defindent "di:unknown-code-location" 1)
|
|---|
| 1299 | (defindent "unknown-debug-variable" 1)
|
|---|
| 1300 | (defindent "di:unknown-debug-variable" 1)
|
|---|
| 1301 | (defindent "invalid-control-stack-pointer" 1)
|
|---|
| 1302 | (defindent "di:invalid-control-stack-pointer" 1)
|
|---|
| 1303 | (defindent "frame-function-mismatch" 1)
|
|---|
| 1304 | (defindent "di:frame-function-mismatch" 1)
|
|---|
| 1305 | |#
|
|---|
| 1306 |
|
|---|
| 1307 | ;;; CLOS forms.
|
|---|
| 1308 | ;;;
|
|---|
| 1309 | (defindent "with-accessors" 2)
|
|---|
| 1310 | (defindent "defclass" 2)
|
|---|
| 1311 | (defindent "print-unreadable-object" 1)
|
|---|
| 1312 | (defindent "defmethod" 2)
|
|---|
| 1313 | (defindent "make-instance" 1)
|
|---|
| 1314 |
|
|---|
| 1315 | ;;; System forms.
|
|---|
| 1316 | ;;;
|
|---|
| 1317 |
|
|---|
| 1318 | ;;; Multiprocessing forms.
|
|---|
| 1319 | (defindent "process-wait" 1)
|
|---|
| 1320 | (defindent "process-run-function" 1)
|
|---|
| 1321 |
|
|---|
| 1322 | |
|---|
| 1323 |
|
|---|
| 1324 | ;;;; Indentation.
|
|---|
| 1325 |
|
|---|
| 1326 | ;;; LISP-INDENTATION -- Internal Interface.
|
|---|
| 1327 |
|
|---|
| 1328 | (defun strip-package-prefix (string)
|
|---|
| 1329 | (let* ((p (position #\: string :from-end t)))
|
|---|
| 1330 | (if p
|
|---|
| 1331 | (subseq string (1+ p))
|
|---|
| 1332 | string)))
|
|---|
| 1333 | ;;;
|
|---|
| 1334 | (defun lisp-indentation (mark)
|
|---|
| 1335 | "Compute number of spaces which mark should be indented according to
|
|---|
| 1336 | local context and lisp grinding conventions. This assumes mark is at the
|
|---|
| 1337 | beginning of the line to be indented."
|
|---|
| 1338 | (with-mark ((m mark)
|
|---|
| 1339 | (temp mark))
|
|---|
| 1340 | ;; See if we are in a quoted context.
|
|---|
| 1341 | (unless (valid-spot m nil)
|
|---|
| 1342 | (return-from lisp-indentation (lisp-generic-indentation m)))
|
|---|
| 1343 | ;; Look for the paren that opens the containing form.
|
|---|
| 1344 | (unless (backward-up-list m)
|
|---|
| 1345 | (return-from lisp-indentation 0))
|
|---|
| 1346 | ;; Move after the paren, save the start, and find the form name.
|
|---|
| 1347 | (mark-after m)
|
|---|
| 1348 | (with-mark ((start m))
|
|---|
| 1349 | (unless (and (scan-char m :lisp-syntax
|
|---|
| 1350 | (not (or :space :prefix :prefix-dispatch :char-quote)))
|
|---|
| 1351 | (test-char (next-character m) :lisp-syntax :constituent))
|
|---|
| 1352 | (return-from lisp-indentation (mark-column start)))
|
|---|
| 1353 | (with-mark ((fstart m))
|
|---|
| 1354 | (scan-char m :lisp-syntax (not :constituent))
|
|---|
| 1355 | (let* ((fname (nstring-upcase
|
|---|
| 1356 | (strip-package-prefix (region-to-string (region fstart m)))))
|
|---|
| 1357 | (special-args (or (gethash fname *special-forms*)
|
|---|
| 1358 | (and (> (length fname) 2)
|
|---|
| 1359 | (string= fname "DEF" :end1 3)
|
|---|
| 1360 | (value indent-defanything))
|
|---|
| 1361 | (and (> (length fname) 4)
|
|---|
| 1362 | (string= fname "WITH-" :end1 5)
|
|---|
| 1363 | (value indent-with-anything)))))
|
|---|
| 1364 | (declare (simple-string fname))
|
|---|
| 1365 | ;; Now that we have the form name, did it have special syntax?
|
|---|
| 1366 | (cond (special-args
|
|---|
| 1367 | (with-mark ((spec m))
|
|---|
| 1368 | (cond ((and (form-offset spec special-args)
|
|---|
| 1369 | (mark<= spec mark))
|
|---|
| 1370 | (1+ (mark-column start)))
|
|---|
| 1371 | ((skip-valid-space m)
|
|---|
| 1372 | (mark-column m))
|
|---|
| 1373 | (t
|
|---|
| 1374 | (+ (mark-column start) 3)))))
|
|---|
| 1375 | ;; See if the user seems to have altered the editor's
|
|---|
| 1376 | ;; indentation, and if so, try to adhere to it. This usually
|
|---|
| 1377 | ;; happens when you type in a quoted list constant that line
|
|---|
| 1378 | ;; wraps. You want all the items on successive lines to fall
|
|---|
| 1379 | ;; under the first character after the opening paren, not as if
|
|---|
| 1380 | ;; you are calling a function.
|
|---|
| 1381 | ((and (form-offset temp -1)
|
|---|
| 1382 | (or (blank-before-p temp) (not (same-line-p temp fstart)))
|
|---|
| 1383 | (not (same-line-p temp mark)))
|
|---|
| 1384 | (unless (blank-before-p temp)
|
|---|
| 1385 | (line-start temp)
|
|---|
| 1386 | (find-attribute temp :space #'zerop))
|
|---|
| 1387 | (mark-column temp))
|
|---|
| 1388 | ;; Appears to be a normal form. Is the first arg on the same
|
|---|
| 1389 | ;; line as the form name?
|
|---|
| 1390 | ((skip-valid-space m)
|
|---|
| 1391 | (or (lisp-indentation-check-for-local-def
|
|---|
| 1392 | mark temp fstart start t)
|
|---|
| 1393 | (mark-column m)))
|
|---|
| 1394 | ;; Okay, fall under the first character after the opening paren.
|
|---|
| 1395 | (t
|
|---|
| 1396 | (or (lisp-indentation-check-for-local-def
|
|---|
| 1397 | mark temp fstart start nil)
|
|---|
| 1398 | (mark-column start)))))))))
|
|---|
| 1399 |
|
|---|
| 1400 | (defhvar "Lisp Indentation Local Definers"
|
|---|
| 1401 | "Forms with syntax like LABELS, MACROLET, etc."
|
|---|
| 1402 | :value '("LABELS" "MACROLET" "FLET"))
|
|---|
| 1403 |
|
|---|
| 1404 | ;;; LISP-INDENTATION-CHECK-FOR-LOCAL-DEF -- Internal.
|
|---|
| 1405 | ;;;
|
|---|
| 1406 | ;;; This is a temporary hack to see how it performs. When we are indenting
|
|---|
| 1407 | ;;; what appears to be a function call, let's look for FLET or MACROLET to see
|
|---|
| 1408 | ;;; if we really are indenting a local definition. If we are, return the
|
|---|
| 1409 | ;;; indentation for a DEFUN; otherwise, nil
|
|---|
| 1410 | ;;;
|
|---|
| 1411 | ;;; Mark is the argument to LISP-INDENTATION. Start is just inside the paren
|
|---|
| 1412 | ;;; of what looks like a function call. If we are in an FLET, arg-list
|
|---|
| 1413 | ;;; indicates whether the local function's arg-list has been entered, that is,
|
|---|
| 1414 | ;;; whether we need to normally indent for a DEFUN body or indent specially for
|
|---|
| 1415 | ;;; the arg-list.
|
|---|
| 1416 | ;;;
|
|---|
| 1417 | (defun lisp-indentation-check-for-local-def (mark temp1 temp2 start arg-list)
|
|---|
| 1418 | ;; We know this succeeds from LISP-INDENTATION.
|
|---|
| 1419 | (backward-up-list (move-mark temp1 mark)) ;Paren for local definition.
|
|---|
| 1420 | (cond ((and (backward-up-list temp1) ;Paren opening the list of defs
|
|---|
| 1421 | (form-offset (move-mark temp2 temp1) -1)
|
|---|
| 1422 | (mark-before temp2)
|
|---|
| 1423 | (backward-up-list temp1) ;Paren for FLET or MACROLET.
|
|---|
| 1424 | (mark= temp1 temp2)) ;Must be in first arg form.
|
|---|
| 1425 | ;; See if the containing form is named FLET or MACROLET.
|
|---|
| 1426 | (mark-after temp1)
|
|---|
| 1427 | (unless (and (scan-char temp1 :lisp-syntax
|
|---|
| 1428 | (not (or :space :prefix :prefix-dispatch :char-quote)))
|
|---|
| 1429 | (test-char (next-character temp1) :lisp-syntax
|
|---|
| 1430 | :constituent))
|
|---|
| 1431 | (return-from lisp-indentation-check-for-local-def nil))
|
|---|
| 1432 | (move-mark temp2 temp1)
|
|---|
| 1433 | (scan-char temp2 :lisp-syntax (not :constituent))
|
|---|
| 1434 | (let ((fname (nstring-upcase (region-to-string (region temp1 temp2)))))
|
|---|
| 1435 | (cond ((not (member fname (value lisp-indentation-local-definers)
|
|---|
| 1436 | :test #'string=))
|
|---|
| 1437 | nil)
|
|---|
| 1438 | (arg-list
|
|---|
| 1439 | (1+ (mark-column start)))
|
|---|
| 1440 | (t
|
|---|
| 1441 | (+ (mark-column start) 3)))))))
|
|---|
| 1442 |
|
|---|
| 1443 | ;;; LISP-GENERIC-INDENTATION -- Internal.
|
|---|
| 1444 | ;;;
|
|---|
| 1445 | ;;; LISP-INDENTATION calls this when mark is in a invalid spot, or quoted
|
|---|
| 1446 | ;;; context. If we are inside a string, we return the column one greater
|
|---|
| 1447 | ;;; than the opening double quote. Otherwise, we just use the indentation
|
|---|
| 1448 | ;;; of the first preceding non-blank line.
|
|---|
| 1449 | ;;;
|
|---|
| 1450 | (defun lisp-generic-indentation (mark)
|
|---|
| 1451 | (with-mark ((m mark))
|
|---|
| 1452 | (form-offset m -1)
|
|---|
| 1453 | (cond ((eq (character-attribute :lisp-syntax (next-character m))
|
|---|
| 1454 | :string-quote)
|
|---|
| 1455 | (1+ (mark-column m)))
|
|---|
| 1456 | (t
|
|---|
| 1457 | (let* ((line (mark-line mark))
|
|---|
| 1458 | (prev (do ((line (line-previous line) (line-previous line)))
|
|---|
| 1459 | ((not (and line (blank-line-p line))) line))))
|
|---|
| 1460 | (cond (prev
|
|---|
| 1461 | (line-start mark prev)
|
|---|
| 1462 | (find-attribute mark :space #'zerop)
|
|---|
| 1463 | (mark-column mark))
|
|---|
| 1464 | (t 0)))))))
|
|---|
| 1465 |
|
|---|
| 1466 | ;;; Skip-Valid-Space -- Internal
|
|---|
| 1467 | ;;;
|
|---|
| 1468 | ;;; Skip over any space on the line Mark is on, stopping at the first valid
|
|---|
| 1469 | ;;; non-space character. If there is none on the line, return nil.
|
|---|
| 1470 | ;;;
|
|---|
| 1471 | (defun skip-valid-space (mark)
|
|---|
| 1472 | (loop
|
|---|
| 1473 | (scan-char mark :lisp-syntax (not :space))
|
|---|
| 1474 | (let ((val (character-attribute :lisp-syntax
|
|---|
| 1475 | (next-character mark))))
|
|---|
| 1476 | (cond ((eq val :newline) (return nil))
|
|---|
| 1477 | ((valid-spot mark t) (return mark))))
|
|---|
| 1478 | (mark-after mark)))
|
|---|
| 1479 |
|
|---|
| 1480 | ;; (declaim (optimize (speed 0))); byte compile again
|
|---|
| 1481 |
|
|---|
| 1482 | |
|---|
| 1483 |
|
|---|
| 1484 | ;;;; Indentation commands and hook functions.
|
|---|
| 1485 |
|
|---|
| 1486 | (defcommand "Defindent" (p)
|
|---|
| 1487 | "Define the Lisp indentation for the current function.
|
|---|
| 1488 | The indentation is a non-negative integer which is the number
|
|---|
| 1489 | of special arguments for the form. Examples: 2 for Do, 1 for Dolist.
|
|---|
| 1490 | If a prefix argument is supplied, then delete the indentation information."
|
|---|
| 1491 | "Do a defindent, man!"
|
|---|
| 1492 | (with-mark ((m (current-point)))
|
|---|
| 1493 | (pre-command-parse-check m)
|
|---|
| 1494 | (unless (backward-up-list m) (editor-error))
|
|---|
| 1495 | (mark-after m)
|
|---|
| 1496 | (with-mark ((n m))
|
|---|
| 1497 | (scan-char n :lisp-syntax (not :constituent))
|
|---|
| 1498 | (let ((s (region-to-string (region m n))))
|
|---|
| 1499 | (declare (simple-string s))
|
|---|
| 1500 | (when (zerop (length s)) (editor-error))
|
|---|
| 1501 | (if p
|
|---|
| 1502 | (defindent s nil)
|
|---|
| 1503 | (let ((i (prompt-for-integer
|
|---|
| 1504 | :prompt (format nil "Indentation for ~A: " s)
|
|---|
| 1505 | :help "Number of special arguments.")))
|
|---|
| 1506 | (when (minusp i)
|
|---|
| 1507 | (editor-error "Indentation must be non-negative."))
|
|---|
| 1508 | (defindent s i))))))
|
|---|
| 1509 | (indent-command nil))
|
|---|
| 1510 |
|
|---|
| 1511 | (defcommand "Indent Form" (p)
|
|---|
| 1512 | "Indent Lisp code in the next form, unless point is to the right of
|
|---|
| 1513 | a closing parenthesis, in which case the previous form will be
|
|---|
| 1514 | indented."
|
|---|
| 1515 | "Indent Lisp code in the next form."
|
|---|
| 1516 | (declare (ignore p))
|
|---|
| 1517 | (let ((point (current-point))
|
|---|
| 1518 | (offset 1))
|
|---|
| 1519 | (pre-command-parse-check point)
|
|---|
| 1520 | (when (eql (previous-character point) #\))
|
|---|
| 1521 | (setq offset -1))
|
|---|
| 1522 | (with-mark ((m point))
|
|---|
| 1523 | (unless (form-offset m offset) (editor-error))
|
|---|
| 1524 | (when (minusp offset)
|
|---|
| 1525 | (rotatef point m))
|
|---|
| 1526 | (lisp-indent-region (region point m) "Indent Form"))))
|
|---|
| 1527 |
|
|---|
| 1528 | ;;; LISP-INDENT-REGION -- Internal.
|
|---|
| 1529 | ;;;
|
|---|
| 1530 | ;;; This indents a region of Lisp code without doing excessive redundant
|
|---|
| 1531 | ;;; computation. We parse the entire region once, then scan through doing
|
|---|
| 1532 | ;;; indentation on each line. We forcibly reparse each line that we indent so
|
|---|
| 1533 | ;;; that the list operations done to determine indentation of subsequent lines
|
|---|
| 1534 | ;;; will work. This is done undoably with save1, save2, buf-region, and
|
|---|
| 1535 | ;;; undo-region.
|
|---|
| 1536 | ;;;
|
|---|
| 1537 | (defun lisp-indent-region (region &optional (undo-text "Lisp region indenting"))
|
|---|
| 1538 | (let* ((start (region-start region))
|
|---|
| 1539 | (end (region-end region))
|
|---|
| 1540 | (buffer (hi::line-%buffer (mark-line start))))
|
|---|
| 1541 | (with-mark ((m1 start)
|
|---|
| 1542 | (m2 end))
|
|---|
| 1543 | (funcall (value parse-start-function) m1)
|
|---|
| 1544 | (funcall (value parse-end-function) m2)
|
|---|
| 1545 | (parse-over-block (mark-line m1) (mark-line m2)))
|
|---|
| 1546 | (hi::check-buffer-modification buffer start)
|
|---|
| 1547 | (hi::check-buffer-modification buffer end)
|
|---|
| 1548 | (let* ((first-line (mark-line start))
|
|---|
| 1549 | (last-line (mark-line end))
|
|---|
| 1550 | (prev (line-previous first-line))
|
|---|
| 1551 | (prev-line-info
|
|---|
| 1552 | (and prev (getf (line-plist prev) 'lisp-info)))
|
|---|
| 1553 | (save1 (line-start (copy-mark start :right-inserting)))
|
|---|
| 1554 | (save2 (line-end (copy-mark end :left-inserting)))
|
|---|
| 1555 | (buf-region (region save1 save2))
|
|---|
| 1556 | (undo-region (copy-region buf-region)))
|
|---|
| 1557 | (with-mark ((bol start :left-inserting))
|
|---|
| 1558 | (do ((line first-line (line-next line)))
|
|---|
| 1559 | (nil)
|
|---|
| 1560 | (line-start bol line)
|
|---|
| 1561 | (ensure-lisp-indentation bol)
|
|---|
| 1562 | (let ((line-info (getf (line-plist line) 'lisp-info)))
|
|---|
| 1563 | (parse-lisp-line-info bol line-info prev-line-info)
|
|---|
| 1564 | (setq prev-line-info line-info))
|
|---|
| 1565 | (when (eq line last-line) (return nil))))
|
|---|
| 1566 | (make-region-undo :twiddle undo-text buf-region undo-region))))
|
|---|
| 1567 |
|
|---|
| 1568 | ;;; INDENT-FOR-LISP -- Internal.
|
|---|
| 1569 | ;;;
|
|---|
| 1570 | ;;; This is the value of "Indent Function" for "Lisp" mode.
|
|---|
| 1571 | ;;;
|
|---|
| 1572 | (defun indent-for-lisp (mark)
|
|---|
| 1573 | (line-start mark)
|
|---|
| 1574 | (pre-command-parse-check mark)
|
|---|
| 1575 | (ensure-lisp-indentation mark))
|
|---|
| 1576 |
|
|---|
| 1577 | (defun count-leading-whitespace (mark)
|
|---|
| 1578 | (with-mark ((m mark))
|
|---|
| 1579 | (line-start m)
|
|---|
| 1580 | (do* ((p 0)
|
|---|
| 1581 | (q 0 (1+ q))
|
|---|
| 1582 | (tab-width (value spaces-per-tab)))
|
|---|
| 1583 | ()
|
|---|
| 1584 | (case (next-character m)
|
|---|
| 1585 | (#\space (incf p))
|
|---|
| 1586 | (#\tab (setq p (* tab-width (ceiling (1+ p) tab-width))))
|
|---|
| 1587 | (t (return (values p q))))
|
|---|
| 1588 | (character-offset m 1))))
|
|---|
| 1589 |
|
|---|
| 1590 | ;;; Don't do anything if M's line is already correctly indented.
|
|---|
| 1591 | (defun ensure-lisp-indentation (m)
|
|---|
| 1592 | (let* ((col (lisp-indentation m)))
|
|---|
| 1593 | (multiple-value-bind (curcol curpos) (count-leading-whitespace m)
|
|---|
| 1594 | (cond ((= curcol col) (setf (mark-charpos m) curpos))
|
|---|
| 1595 | (t
|
|---|
| 1596 | (delete-horizontal-space m)
|
|---|
| 1597 | (indent-to-column m col))))))
|
|---|
| 1598 |
|
|---|
| 1599 |
|
|---|
| 1600 |
|
|---|
| 1601 | |
|---|
| 1602 |
|
|---|
| 1603 | ;;;; Most "Lisp" mode commands.
|
|---|
| 1604 |
|
|---|
| 1605 | (defcommand "Beginning of Defun" (p)
|
|---|
| 1606 | "Move the point to the beginning of a top-level form, collapsing the selection.
|
|---|
| 1607 | with an argument, skips the previous p top-level forms."
|
|---|
| 1608 | "Move the point to the beginning of a top-level form, collapsing the selection."
|
|---|
| 1609 | (let ((point (current-point-collapsing-selection))
|
|---|
| 1610 | (count (or p 1)))
|
|---|
| 1611 | (pre-command-parse-check point)
|
|---|
| 1612 | (if (minusp count)
|
|---|
| 1613 | (end-of-defun-command (- count))
|
|---|
| 1614 | (unless (top-level-offset point (- count))
|
|---|
| 1615 | (editor-error)))))
|
|---|
| 1616 |
|
|---|
| 1617 | (defcommand "Select to Beginning of Defun" (p)
|
|---|
| 1618 | "Move the point to the beginning of a top-level form, extending the selection.
|
|---|
| 1619 | with an argument, skips the previous p top-level forms."
|
|---|
| 1620 | "Move the point to the beginning of a top-level form, extending the selection."
|
|---|
| 1621 | (let ((point (current-point-for-selection-start))
|
|---|
| 1622 | (count (or p 1)))
|
|---|
| 1623 | (pre-command-parse-check point)
|
|---|
| 1624 | (if (minusp count)
|
|---|
| 1625 | (end-of-defun-command (- count))
|
|---|
| 1626 | (unless (top-level-offset point (- count))
|
|---|
| 1627 | (editor-error)))))
|
|---|
| 1628 |
|
|---|
| 1629 | ;;; "End of Defun", with a positive p (the normal case), does something weird.
|
|---|
| 1630 | ;;; Get a mark at the beginning of the defun, and then offset it forward one
|
|---|
| 1631 | ;;; less top level form than we want. This sets us up to use FORM-OFFSET which
|
|---|
| 1632 | ;;; allows us to leave the point immediately after the defun. If we used
|
|---|
| 1633 | ;;; TOP-LEVEL-OFFSET one less than p on the mark at the end of the current
|
|---|
| 1634 | ;;; defun, point would be left at the beginning of the p+1'st form instead of
|
|---|
| 1635 | ;;; at the end of the p'th form.
|
|---|
| 1636 | ;;;
|
|---|
| 1637 | (defcommand "End of Defun" (p)
|
|---|
| 1638 | "Move the point to the end of a top-level form, collapsing the selection.
|
|---|
| 1639 | With an argument, skips the next p top-level forms."
|
|---|
| 1640 | "Move the point to the end of a top-level form, collapsing the selection."
|
|---|
| 1641 | (let ((point (current-point-collapsing-selection))
|
|---|
| 1642 | (count (or p 1)))
|
|---|
| 1643 | (pre-command-parse-check point)
|
|---|
| 1644 | (if (minusp count)
|
|---|
| 1645 | (beginning-of-defun-command (- count))
|
|---|
| 1646 | (with-mark ((m point)
|
|---|
| 1647 | (dummy point))
|
|---|
| 1648 | (cond ((not (mark-top-level-form m dummy))
|
|---|
| 1649 | (editor-error "No current or next top level form."))
|
|---|
| 1650 | (t
|
|---|
| 1651 | (unless (top-level-offset m (1- count))
|
|---|
| 1652 | (editor-error "Not enough top level forms."))
|
|---|
| 1653 | ;; We might be one unparsed for away.
|
|---|
| 1654 | (pre-command-parse-check m)
|
|---|
| 1655 | (unless (form-offset m 1)
|
|---|
| 1656 | (editor-error "Not enough top level forms."))
|
|---|
| 1657 | (when (blank-after-p m) (line-offset m 1 0))
|
|---|
| 1658 | (move-mark point m)))))))
|
|---|
| 1659 |
|
|---|
| 1660 | (defcommand "Select to End of Defun" (p)
|
|---|
| 1661 | "Move the point to the end of a top-level form, extending the selection.
|
|---|
| 1662 | With an argument, skips the next p top-level forms."
|
|---|
| 1663 | "Move the point to the end of a top-level form, extending the selection."
|
|---|
| 1664 | (let ((point (current-point-for-selection-end))
|
|---|
| 1665 | (count (or p 1)))
|
|---|
| 1666 | (pre-command-parse-check point)
|
|---|
| 1667 | (if (minusp count)
|
|---|
| 1668 | (beginning-of-defun-command (- count))
|
|---|
| 1669 | (with-mark ((m point)
|
|---|
| 1670 | (dummy point))
|
|---|
| 1671 | (cond ((not (mark-top-level-form m dummy))
|
|---|
| 1672 | (editor-error "No current or next top level form."))
|
|---|
| 1673 | (t
|
|---|
| 1674 | (unless (top-level-offset m (1- count))
|
|---|
| 1675 | (editor-error "Not enough top level forms."))
|
|---|
| 1676 | ;; We might be one unparsed for away.
|
|---|
| 1677 | (pre-command-parse-check m)
|
|---|
| 1678 | (unless (form-offset m 1)
|
|---|
| 1679 | (editor-error "Not enough top level forms."))
|
|---|
| 1680 | (when (blank-after-p m) (line-offset m 1 0))
|
|---|
| 1681 | (move-mark point m)))))))
|
|---|
| 1682 |
|
|---|
| 1683 | (defcommand "Forward List" (p)
|
|---|
| 1684 | "Skip over the next Lisp list, collapsing the selection.
|
|---|
| 1685 | With argument, skips the next p lists."
|
|---|
| 1686 | "Skip over the next Lisp list, collapsing the selection."
|
|---|
| 1687 | (or (collapse-if-selection :direction :forward)
|
|---|
| 1688 | (let ((point (current-point-collapsing-selection))
|
|---|
| 1689 | (count (or p 1)))
|
|---|
| 1690 | (pre-command-parse-check point)
|
|---|
| 1691 | (unless (list-offset point count) (editor-error "No next list.")))))
|
|---|
| 1692 |
|
|---|
| 1693 | (defcommand "Select Forward List" (p)
|
|---|
| 1694 | "Skip over the next Lisp list, extending the selection.
|
|---|
| 1695 | With argument, skips the next p lists."
|
|---|
| 1696 | "Skip over the next Lisp list, extending the selection."
|
|---|
| 1697 | (let ((point (current-point-for-selection-end))
|
|---|
| 1698 | (count (or p 1)))
|
|---|
| 1699 | (pre-command-parse-check point)
|
|---|
| 1700 | (unless (list-offset point count) (editor-error "No next list."))))
|
|---|
| 1701 |
|
|---|
| 1702 | (defcommand "Backward List" (p)
|
|---|
| 1703 | "Skip over the previous Lisp list, collapsing the selection.
|
|---|
| 1704 | With argument, skips the previous p lists."
|
|---|
| 1705 | "Skip over the previous Lisp list, collapsing the selection."
|
|---|
| 1706 | (or (collapse-if-selection :direction :backward)
|
|---|
| 1707 | (let ((point (current-point-collapsing-selection))
|
|---|
| 1708 | (count (- (or p 1))))
|
|---|
| 1709 | (pre-command-parse-check point)
|
|---|
| 1710 | (unless (list-offset point count) (editor-error "No previous list.")))))
|
|---|
| 1711 |
|
|---|
| 1712 | (defcommand "Select Backward List" (p)
|
|---|
| 1713 | "Skip over the previous Lisp list, extending the selection.
|
|---|
| 1714 | With argument, skips the previous p lists."
|
|---|
| 1715 | "Skip over the previous Lisp list, extending the selection."
|
|---|
| 1716 | (let ((point (current-point-for-selection-start))
|
|---|
| 1717 | (count (- (or p 1))))
|
|---|
| 1718 | (pre-command-parse-check point)
|
|---|
| 1719 | (unless (list-offset point count) (editor-error "No previous list."))))
|
|---|
| 1720 |
|
|---|
| 1721 | (defcommand "Forward Form" (p)
|
|---|
| 1722 | "Skip over the next Form, collapsing the selection.
|
|---|
| 1723 | With argument, skips the next p Forms."
|
|---|
| 1724 | "Skip over the next Form, collapsing the selection."
|
|---|
| 1725 | (or (collapse-if-selection :direction :forward)
|
|---|
| 1726 | (let ((point (current-point-collapsing-selection))
|
|---|
| 1727 | (count (or p 1)))
|
|---|
| 1728 | (pre-command-parse-check point)
|
|---|
| 1729 | (unless (form-offset point count) (editor-error "No next form.")))))
|
|---|
| 1730 |
|
|---|
| 1731 | (defcommand "Select Forward Form" (p)
|
|---|
| 1732 | "Skip over the next Form, extending the selection.
|
|---|
| 1733 | With argument, skips the next p Forms."
|
|---|
| 1734 | "Skip over the next Form, extending the selection."
|
|---|
| 1735 | (let ((point (current-point-for-selection-end))
|
|---|
| 1736 | (count (or p 1)))
|
|---|
| 1737 | (pre-command-parse-check point)
|
|---|
| 1738 | (unless (form-offset point count) (editor-error "No next form."))))
|
|---|
| 1739 |
|
|---|
| 1740 | (defcommand "Backward Form" (p)
|
|---|
| 1741 | "Skip over the previous Form, collapsing the selection.
|
|---|
| 1742 | With argument, skips the previous p Forms."
|
|---|
| 1743 | "Skip over the previous Form, collapsing the selection."
|
|---|
| 1744 | (or (collapse-if-selection :direction :backward)
|
|---|
| 1745 | (let ((point (current-point-collapsing-selection))
|
|---|
| 1746 | (count (- (or p 1))))
|
|---|
| 1747 | (pre-command-parse-check point)
|
|---|
| 1748 | (unless (form-offset point count) (editor-error "No previous form.")))))
|
|---|
| 1749 |
|
|---|
| 1750 | (defcommand "Select Backward Form" (p)
|
|---|
| 1751 | "Skip over the previous Form, extending the selection.
|
|---|
| 1752 | With argument, skips the previous p Forms."
|
|---|
| 1753 | "Skip over the previous Form, extending the selection."
|
|---|
| 1754 | (let ((point (current-point-for-selection-start))
|
|---|
| 1755 | (count (- (or p 1))))
|
|---|
| 1756 | (pre-command-parse-check point)
|
|---|
| 1757 | (unless (form-offset point count) (editor-error "No previous form."))))
|
|---|
| 1758 |
|
|---|
| 1759 | (defcommand "Mark Form" (p)
|
|---|
| 1760 | "Set the mark at the end of the next Form.
|
|---|
| 1761 | With a positive argument, set the mark after the following p
|
|---|
| 1762 | Forms. With a negative argument, set the mark before
|
|---|
| 1763 | the preceding -p Forms."
|
|---|
| 1764 | "Set the mark at the end of the next Form."
|
|---|
| 1765 | (with-mark ((m (current-point)))
|
|---|
| 1766 | (pre-command-parse-check m)
|
|---|
| 1767 | (let ((count (or p 1))
|
|---|
| 1768 | (mark (push-new-buffer-mark m t)))
|
|---|
| 1769 | (if (form-offset m count)
|
|---|
| 1770 | (move-mark mark m)
|
|---|
| 1771 | (editor-error "No next form.")))))
|
|---|
| 1772 |
|
|---|
| 1773 | (defcommand "Mark Defun" (p)
|
|---|
| 1774 | "Puts the region around the next or containing top-level form.
|
|---|
| 1775 | The point is left before the form and the mark is placed immediately
|
|---|
| 1776 | after it."
|
|---|
| 1777 | "Puts the region around the next or containing top-level form."
|
|---|
| 1778 | (declare (ignore p))
|
|---|
| 1779 | (let ((point (current-point)))
|
|---|
| 1780 | (pre-command-parse-check point)
|
|---|
| 1781 | (with-mark ((start point)
|
|---|
| 1782 | (end point))
|
|---|
| 1783 | (cond ((not (mark-top-level-form start end))
|
|---|
| 1784 | (editor-error "No current or next top level form."))
|
|---|
| 1785 | (t
|
|---|
| 1786 | (move-mark point start)
|
|---|
| 1787 | (move-mark (push-new-buffer-mark point t) end))))))
|
|---|
| 1788 |
|
|---|
| 1789 | (defcommand "Forward Kill Form" (p)
|
|---|
| 1790 | "Kill the next Form.
|
|---|
| 1791 | With a positive argument, kills the next p Forms.
|
|---|
| 1792 | Kills backward with a negative argument."
|
|---|
| 1793 | "Kill the next Form."
|
|---|
| 1794 | (with-mark ((m1 (current-point))
|
|---|
| 1795 | (m2 (current-point)))
|
|---|
| 1796 | (pre-command-parse-check m1)
|
|---|
| 1797 | (let ((count (or p 1)))
|
|---|
| 1798 | (unless (form-offset m1 count) (editor-error "No ~a form." (if (minusp count) "previous" "next")))
|
|---|
| 1799 | (if (minusp count)
|
|---|
| 1800 | (kill-region (region m1 m2) :kill-backward)
|
|---|
| 1801 | (kill-region (region m2 m1) :kill-forward)))))
|
|---|
| 1802 |
|
|---|
| 1803 | (defcommand "Backward Kill Form" (p)
|
|---|
| 1804 | "Kill the previous Form.
|
|---|
| 1805 | With a positive argument, kills the previous p Forms.
|
|---|
| 1806 | Kills forward with a negative argument."
|
|---|
| 1807 | "Kill the previous Form."
|
|---|
| 1808 | (forward-kill-form-command (- (or p 1))))
|
|---|
| 1809 |
|
|---|
| 1810 | (defcommand "Extract Form" (p)
|
|---|
| 1811 | "Replace the current containing list with the next form. The entire affected
|
|---|
| 1812 | area is pushed onto the kill ring. If an argument is supplied, that many
|
|---|
| 1813 | upward levels of list nesting is replaced by the next form."
|
|---|
| 1814 | "Replace the current containing list with the next form. The entire affected
|
|---|
| 1815 | area is pushed onto the kill ring. If an argument is supplied, that many
|
|---|
| 1816 | upward levels of list nesting is replaced by the next form."
|
|---|
| 1817 | (let ((point (current-point)))
|
|---|
| 1818 | (pre-command-parse-check point)
|
|---|
| 1819 | (with-mark ((form-start point :right-inserting)
|
|---|
| 1820 | (form-end point))
|
|---|
| 1821 | (unless (form-offset form-end 1) (editor-error "No next form."))
|
|---|
| 1822 | (form-offset (move-mark form-start form-end) -1)
|
|---|
| 1823 | (with-mark ((containing-start form-start :left-inserting)
|
|---|
| 1824 | (containing-end form-end :left-inserting))
|
|---|
| 1825 | (dotimes (i (or p 1))
|
|---|
| 1826 | (unless (and (forward-up-list containing-end)
|
|---|
| 1827 | (backward-up-list containing-start))
|
|---|
| 1828 | (editor-error "No containing list.")))
|
|---|
| 1829 | (let ((r (copy-region (region form-start form-end))))
|
|---|
| 1830 | (ring-push (delete-and-save-region
|
|---|
| 1831 | (region containing-start containing-end))
|
|---|
| 1832 | *kill-ring*)
|
|---|
| 1833 | (ninsert-region point r)
|
|---|
| 1834 | (move-mark point form-start))))))
|
|---|
| 1835 |
|
|---|
| 1836 | (defcommand "Extract List" (p)
|
|---|
| 1837 | "Extract the current list.
|
|---|
| 1838 | The current list replaces the surrounding list. The entire affected
|
|---|
| 1839 | area is pushed on the kill-ring. With prefix argument, remove that
|
|---|
| 1840 | many surrounding lists."
|
|---|
| 1841 | "Replace the P containing lists with the current one."
|
|---|
| 1842 | (let ((point (current-point)))
|
|---|
| 1843 | (pre-command-parse-check point)
|
|---|
| 1844 | (with-mark ((lstart point :right-inserting)
|
|---|
| 1845 | (lend point))
|
|---|
| 1846 | (if (eq (character-attribute :lisp-syntax (next-character lstart))
|
|---|
| 1847 | :open-paren)
|
|---|
| 1848 | (mark-after lend)
|
|---|
| 1849 | (unless (backward-up-list lstart) (editor-error "No containing list.")))
|
|---|
| 1850 | (unless (forward-up-list lend) (editor-error "No containing list."))
|
|---|
| 1851 | (with-mark ((rstart lstart)
|
|---|
| 1852 | (rend lend))
|
|---|
| 1853 | (dotimes (i (or p 1))
|
|---|
| 1854 | (unless (and (forward-up-list rend) (backward-up-list rstart))
|
|---|
| 1855 | (editor-error)))
|
|---|
| 1856 | (let ((r (copy-region (region lstart lend))))
|
|---|
| 1857 | (ring-push (delete-and-save-region (region rstart rend))
|
|---|
| 1858 | *kill-ring*)
|
|---|
| 1859 | (ninsert-region point r)
|
|---|
| 1860 | (move-mark point lstart))))))
|
|---|
| 1861 |
|
|---|
| 1862 | (defcommand "Transpose Forms" (p)
|
|---|
| 1863 | "Transpose Forms immediately preceding and following the point.
|
|---|
| 1864 | With a zero argument, tranposes the Forms at the point and the mark.
|
|---|
| 1865 | With a positive argument, transposes the Form preceding the point
|
|---|
| 1866 | with the p-th one following it. With a negative argument, transposes the
|
|---|
| 1867 | Form following the point with the p-th one preceding it."
|
|---|
| 1868 | "Transpose Forms immediately preceding and following the point."
|
|---|
| 1869 | (let ((point (current-point))
|
|---|
| 1870 | (count (or p 1)))
|
|---|
| 1871 | (pre-command-parse-check point)
|
|---|
| 1872 | (if (zerop count)
|
|---|
| 1873 | (let ((mark (current-mark)))
|
|---|
| 1874 | (with-mark ((s1 mark :left-inserting)
|
|---|
| 1875 | (s2 point :left-inserting))
|
|---|
| 1876 | (scan-char s1 :whitespace nil)
|
|---|
| 1877 | (scan-char s2 :whitespace nil)
|
|---|
| 1878 | (with-mark ((e1 s1 :right-inserting)
|
|---|
| 1879 | (e2 s2 :right-inserting))
|
|---|
| 1880 | (unless (form-offset e1 1) (editor-error "No next form."))
|
|---|
| 1881 | (unless (form-offset e2 1) (editor-error "No next form."))
|
|---|
| 1882 | (ninsert-region s1 (delete-and-save-region (region s2 e2)))
|
|---|
| 1883 | (ninsert-region s2 (delete-and-save-region (region s1 e1))))))
|
|---|
| 1884 | (let ((fcount (if (plusp count) count 1))
|
|---|
| 1885 | (bcount (if (plusp count) 1 count)))
|
|---|
| 1886 | (with-mark ((s1 point :left-inserting)
|
|---|
| 1887 | (e2 point :right-inserting))
|
|---|
| 1888 | (dotimes (i bcount)
|
|---|
| 1889 | (unless (form-offset s1 -1) (editor-error "No previous form.")))
|
|---|
| 1890 | (dotimes (i fcount)
|
|---|
| 1891 | (unless (form-offset e2 1) (editor-error "No next form.")))
|
|---|
| 1892 | (with-mark ((e1 s1 :right-inserting)
|
|---|
| 1893 | (s2 e2 :left-inserting))
|
|---|
| 1894 | (unless (form-offset e1 1) (editor-error))
|
|---|
| 1895 | (unless (form-offset s2 -1) (editor-error))
|
|---|
| 1896 | (ninsert-region s1 (delete-and-save-region (region s2 e2)))
|
|---|
| 1897 | (ninsert-region s2 (delete-and-save-region (region s1 e1)))
|
|---|
| 1898 | (move-mark point s2)))))))
|
|---|
| 1899 |
|
|---|
| 1900 |
|
|---|
| 1901 | (defcommand "Insert ()" (count)
|
|---|
| 1902 | "Insert a pair of parentheses (). With positive argument, puts
|
|---|
| 1903 | parentheses around the next COUNT Forms, or previous COUNT forms, if
|
|---|
| 1904 | COUNT is negative. The point is positioned after the open parenthesis."
|
|---|
| 1905 | "Insert a pair of parentheses ()."
|
|---|
| 1906 | ;; TODO Form navigation is broken, so this is broken too -- it is
|
|---|
| 1907 | ;; possible to put parens around more forms than there are in current
|
|---|
| 1908 | ;; expression. It works by moving past as many forms as there is, and
|
|---|
| 1909 | ;; then each delimiting paren also counts as a form.
|
|---|
| 1910 | (let ((point (current-point)))
|
|---|
| 1911 | (pre-command-parse-check point)
|
|---|
| 1912 | (cond (count
|
|---|
| 1913 | (when (minusp count)
|
|---|
| 1914 | (form-offset point count)
|
|---|
| 1915 | (setq count (- count)))
|
|---|
| 1916 | (insert-character point #\()
|
|---|
| 1917 | (with-mark ((m point))
|
|---|
| 1918 | (unless (form-offset m count)
|
|---|
| 1919 | (editor-error "Could not find that many forms."))
|
|---|
| 1920 | (insert-character m #\))))
|
|---|
| 1921 | ;; The simple case with no prefix argument
|
|---|
| 1922 | (t
|
|---|
| 1923 | (insert-character point #\()
|
|---|
| 1924 | (insert-character point #\))
|
|---|
| 1925 | (mark-before point)))))
|
|---|
| 1926 |
|
|---|
| 1927 |
|
|---|
| 1928 | (defcommand "Move Over )" (p)
|
|---|
| 1929 | "Move past the next close parenthesis, and start a new line. Any
|
|---|
| 1930 | indentation preceding the preceding the parenthesis is deleted, and the
|
|---|
| 1931 | new line is indented. If there is only whitespace preceding the close
|
|---|
| 1932 | paren, the paren is moved to the end of the previous line. With prefix
|
|---|
| 1933 | argument, this command moves past next closing paren and inserts space."
|
|---|
| 1934 | "Move past the next close parenthesis, and start a new line."
|
|---|
| 1935 | ;; TODO This is still not complete, because SCAN-CHAR finds the next
|
|---|
| 1936 | ;; close-paren, but we need to find the next paren that closes current
|
|---|
| 1937 | ;; expression. This will have to be updated when form navigation is
|
|---|
| 1938 | ;; fixed.
|
|---|
| 1939 | (let ((point (current-point)))
|
|---|
| 1940 | (pre-command-parse-check point)
|
|---|
| 1941 | (with-mark ((m point :right-inserting))
|
|---|
| 1942 | (cond ((scan-char m :lisp-syntax :close-paren)
|
|---|
| 1943 | (cond ((same-line-p point m)
|
|---|
| 1944 | (delete-horizontal-space m))
|
|---|
| 1945 | (t
|
|---|
| 1946 | (move-mark point m)
|
|---|
| 1947 | (reverse-find-attribute point :whitespace #'zerop)
|
|---|
| 1948 | (delete-region (region point m))))
|
|---|
| 1949 | (cond ((not p)
|
|---|
| 1950 | ;; Move to the previous line if current is empty
|
|---|
| 1951 | (when (zerop (mark-charpos m))
|
|---|
| 1952 | (delete-characters m -1))
|
|---|
| 1953 | (mark-after m)
|
|---|
| 1954 | (move-mark point m)
|
|---|
| 1955 | (indent-new-line-command 1))
|
|---|
| 1956 | (t
|
|---|
| 1957 | (mark-after m)
|
|---|
| 1958 | (move-mark point m)
|
|---|
| 1959 | (insert-character m #\space))))
|
|---|
| 1960 | (t
|
|---|
| 1961 | (editor-error "Could not find closing paren."))))))
|
|---|
| 1962 |
|
|---|
| 1963 |
|
|---|
| 1964 | (defcommand "Forward Up List" (p)
|
|---|
| 1965 | "Move forward past a one containing )."
|
|---|
| 1966 | "Move forward past a one containing )."
|
|---|
| 1967 | (or (collapse-if-selection :direction :forward)
|
|---|
| 1968 | (let ((point (current-point-collapsing-selection))
|
|---|
| 1969 | (count (or p 1)))
|
|---|
| 1970 | (pre-command-parse-check point)
|
|---|
| 1971 | (if (minusp count)
|
|---|
| 1972 | (backward-up-list-command (- count))
|
|---|
| 1973 | (with-mark ((m point))
|
|---|
| 1974 | (dotimes (i count (move-mark point m))
|
|---|
| 1975 | (unless (forward-up-list m) (editor-error "No containing list."))))))))
|
|---|
| 1976 |
|
|---|
| 1977 | (defcommand "Backward Up List" (p)
|
|---|
| 1978 | "Move backward past a one containing (."
|
|---|
| 1979 | "Move backward past a one containing (."
|
|---|
| 1980 | (or (collapse-if-selection :direction :backward)
|
|---|
| 1981 | (let ((point (current-point-collapsing-selection))
|
|---|
| 1982 | (count (or p 1)))
|
|---|
| 1983 | (pre-command-parse-check point)
|
|---|
| 1984 | (if (minusp count)
|
|---|
| 1985 | (forward-up-list-command (- count))
|
|---|
| 1986 | (with-mark ((m point))
|
|---|
| 1987 | (dotimes (i count (move-mark point m))
|
|---|
| 1988 | (unless (backward-up-list m) (editor-error "No containing list."))))))))
|
|---|
| 1989 |
|
|---|
| 1990 |
|
|---|
| 1991 | (defcommand "Down List" (p)
|
|---|
| 1992 | "Move down a level in list structure. With positive argument, moves down
|
|---|
| 1993 | p levels. With negative argument, moves down backward, but only one
|
|---|
| 1994 | level."
|
|---|
| 1995 | "Move down a level in list structure."
|
|---|
| 1996 | (let ((point (current-point-collapsing-selection))
|
|---|
| 1997 | (count (or p 1)))
|
|---|
| 1998 | (pre-command-parse-check point)
|
|---|
| 1999 | (with-mark ((m point))
|
|---|
| 2000 | (cond ((plusp count)
|
|---|
| 2001 | (loop repeat count
|
|---|
| 2002 | do (unless (and (scan-char m :lisp-syntax :open-paren)
|
|---|
| 2003 | (mark-after m))
|
|---|
| 2004 | (editor-error "No embedded list."))))
|
|---|
| 2005 | (t
|
|---|
| 2006 | (unless (and (rev-scan-char m :lisp-syntax :close-paren)
|
|---|
| 2007 | (mark-before m))
|
|---|
| 2008 | (editor-error "No embedded list."))))
|
|---|
| 2009 | (move-mark point m))))
|
|---|
| 2010 |
|
|---|
| 2011 |
|
|---|
| 2012 | |
|---|
| 2013 |
|
|---|
| 2014 | ;;;; Filling Lisp comments, strings, and indented text.
|
|---|
| 2015 |
|
|---|
| 2016 | (defhvar "Fill Lisp Comment Paragraph Confirm"
|
|---|
| 2017 | "This determines whether \"Fill Lisp Comment Paragraph\" will prompt for
|
|---|
| 2018 | confirmation to fill contiguous lines with the same initial whitespace when
|
|---|
| 2019 | it is invoked outside of a comment or string."
|
|---|
| 2020 | :value t)
|
|---|
| 2021 |
|
|---|
| 2022 | (defcommand "Fill Lisp Comment Paragraph" (p)
|
|---|
| 2023 | "This fills a flushleft or indented Lisp comment.
|
|---|
| 2024 | This also fills Lisp string literals using the proper indentation as a
|
|---|
| 2025 | filling prefix. When invoked outside of a comment or string, this tries
|
|---|
| 2026 | to fill all contiguous lines beginning with the same initial, non-empty
|
|---|
| 2027 | blankspace. When filling a comment, the current line is used to determine a
|
|---|
| 2028 | fill prefix by taking all the initial whitespace on the line, the semicolons,
|
|---|
| 2029 | and any whitespace following the semicolons."
|
|---|
| 2030 | "Fills a flushleft or indented Lisp comment."
|
|---|
| 2031 | (declare (ignore p))
|
|---|
| 2032 | (let ((point (current-point)))
|
|---|
| 2033 | (pre-command-parse-check point)
|
|---|
| 2034 | (with-mark ((start point)
|
|---|
| 2035 | (end point)
|
|---|
| 2036 | (m point))
|
|---|
| 2037 | (let ((commentp (fill-lisp-comment-paragraph-prefix start end)))
|
|---|
| 2038 | (cond (commentp
|
|---|
| 2039 | (fill-lisp-comment-or-indented-text start end))
|
|---|
| 2040 | ((and (not (valid-spot m nil))
|
|---|
| 2041 | (form-offset m -1)
|
|---|
| 2042 | (eq (character-attribute :lisp-syntax (next-character m))
|
|---|
| 2043 | :string-quote))
|
|---|
| 2044 | (fill-lisp-string m))
|
|---|
| 2045 | ((or (not (value fill-lisp-comment-paragraph-confirm))
|
|---|
| 2046 | (prompt-for-y-or-n
|
|---|
| 2047 | :prompt '("Not in a comment or string. Fill contiguous ~
|
|---|
| 2048 | lines with the same initial whitespace? ")))
|
|---|
| 2049 | (fill-lisp-comment-or-indented-text start end)))))))
|
|---|
| 2050 |
|
|---|
| 2051 | ;;; FILL-LISP-STRING -- Internal.
|
|---|
| 2052 | ;;;
|
|---|
| 2053 | ;;; This fills the Lisp string containing mark as if it had been entered using
|
|---|
| 2054 | ;;; Hemlock's Lisp string indentation, "Indent Function" for "Lisp" mode. This
|
|---|
| 2055 | ;;; assumes the area around mark has already been PRE-COMMAND-PARSE-CHECK'ed,
|
|---|
| 2056 | ;;; and it ensures the string ends before doing any filling. This function
|
|---|
| 2057 | ;;; is undo'able.
|
|---|
| 2058 | ;;;
|
|---|
| 2059 | (defun fill-lisp-string (mark)
|
|---|
| 2060 | (with-mark ((end mark))
|
|---|
| 2061 | (unless (form-offset end 1)
|
|---|
| 2062 | (editor-error "Attempted to fill Lisp string, but it doesn't end?"))
|
|---|
| 2063 | (let* ((mark (copy-mark mark :left-inserting))
|
|---|
| 2064 | (end (copy-mark end :left-inserting))
|
|---|
| 2065 | (string-region (region mark end))
|
|---|
| 2066 | (undo-region (copy-region string-region))
|
|---|
| 2067 | (hack (make-empty-region)))
|
|---|
| 2068 | ;; Generate prefix.
|
|---|
| 2069 | (indent-to-column (region-end hack) (1+ (mark-column mark)))
|
|---|
| 2070 | ;; Skip opening double quote and fill string starting on its own line.
|
|---|
| 2071 | (mark-after mark)
|
|---|
| 2072 | (insert-character mark #\newline)
|
|---|
| 2073 | (line-start mark)
|
|---|
| 2074 | (setf (mark-kind mark) :right-inserting)
|
|---|
| 2075 | (fill-region string-region (region-to-string hack))
|
|---|
| 2076 | ;; Clean up inserted prefix on first line, delete inserted newline, and
|
|---|
| 2077 | ;; move before the double quote for undo.
|
|---|
| 2078 | (with-mark ((text mark :left-inserting))
|
|---|
| 2079 | (find-attribute text :whitespace #'zerop)
|
|---|
| 2080 | (delete-region (region mark text)))
|
|---|
| 2081 | (delete-characters mark -1)
|
|---|
| 2082 | (mark-before mark)
|
|---|
| 2083 | ;; Save undo.
|
|---|
| 2084 | (make-region-undo :twiddle "Fill Lisp Comment Paragraph"
|
|---|
| 2085 | string-region undo-region))))
|
|---|
| 2086 |
|
|---|
| 2087 | ;;; FILL-LISP-COMMENT-OR-INDENTED-TEXT -- Internal.
|
|---|
| 2088 | ;;;
|
|---|
| 2089 | ;;; This fills all contiguous lines around start and end containing fill prefix
|
|---|
| 2090 | ;;; designated by the region between start and end. These marks can only be
|
|---|
| 2091 | ;;; equal when there is no comment and no initial whitespace. This is a bad
|
|---|
| 2092 | ;;; situation since this function in that situation would fill the entire
|
|---|
| 2093 | ;;; buffer into one paragraph. This function is undo'able.
|
|---|
| 2094 | ;;;
|
|---|
| 2095 | (defun fill-lisp-comment-or-indented-text (start end)
|
|---|
| 2096 | (when (mark= start end)
|
|---|
| 2097 | (editor-error "This command only fills Lisp comments, strings, or ~
|
|---|
| 2098 | indented text, but this line is flushleft."))
|
|---|
| 2099 | ;;
|
|---|
| 2100 | ;; Find comment block.
|
|---|
| 2101 | (let* ((prefix (region-to-string (region start end)))
|
|---|
| 2102 | (length (length prefix)))
|
|---|
| 2103 | (declare (simple-string prefix))
|
|---|
| 2104 | (flet ((frob (mark direction)
|
|---|
| 2105 | (loop
|
|---|
| 2106 | (let* ((line (line-string (mark-line mark)))
|
|---|
| 2107 | (line-len (length line)))
|
|---|
| 2108 | (declare (simple-string line))
|
|---|
| 2109 | (unless (string= line prefix :end1 (min line-len length))
|
|---|
| 2110 | (when (= direction -1)
|
|---|
| 2111 | (unless (same-line-p mark end) (line-offset mark 1 0)))
|
|---|
| 2112 | (return)))
|
|---|
| 2113 | (unless (line-offset mark direction 0)
|
|---|
| 2114 | (when (= direction 1) (line-end mark))
|
|---|
| 2115 | (return)))))
|
|---|
| 2116 | (frob start -1)
|
|---|
| 2117 | (frob end 1))
|
|---|
| 2118 | ;;
|
|---|
| 2119 | ;; Do it undoable.
|
|---|
| 2120 | (let* ((start1 (copy-mark start :right-inserting))
|
|---|
| 2121 | (end2 (copy-mark end :left-inserting))
|
|---|
| 2122 | (region (region start1 end2))
|
|---|
| 2123 | (undo-region (copy-region region)))
|
|---|
| 2124 | (fill-region region prefix)
|
|---|
| 2125 | (make-region-undo :twiddle "Fill Lisp Comment Paragraph"
|
|---|
| 2126 | region undo-region))))
|
|---|
| 2127 |
|
|---|
| 2128 | ;;; FILL-LISP-COMMENT-PARAGRAPH-PREFIX -- Internal.
|
|---|
| 2129 | ;;;
|
|---|
| 2130 | ;;; This sets start and end around the prefix to be used for filling. We
|
|---|
| 2131 | ;;; assume we are dealing with a comment. If there is no ";", then we try to
|
|---|
| 2132 | ;;; find some initial whitespace. If there is a ";", we make sure the line is
|
|---|
| 2133 | ;;; blank before it to eliminate ";"'s in the middle of a line of text.
|
|---|
| 2134 | ;;; Finally, if we really have a comment instead of some indented text, we skip
|
|---|
| 2135 | ;;; the ";"'s and any immediately following whitespace. We allow initial
|
|---|
| 2136 | ;;; whitespace, so we can fill strings with the same command.
|
|---|
| 2137 | ;;;
|
|---|
| 2138 | (defun fill-lisp-comment-paragraph-prefix (start end)
|
|---|
| 2139 | (line-start start)
|
|---|
| 2140 | (let ((commentp t)) ; Assumes there's a comment.
|
|---|
| 2141 | (unless (to-line-comment (line-start end) ";")
|
|---|
| 2142 | (find-attribute end :whitespace #'zerop)
|
|---|
| 2143 | #|(when (start-line-p end)
|
|---|
| 2144 | (editor-error "No comment on line, and no initial whitespace."))|#
|
|---|
| 2145 | (setf commentp nil))
|
|---|
| 2146 | (when commentp
|
|---|
| 2147 | (unless (blank-before-p end)
|
|---|
| 2148 | (find-attribute (line-start end) :whitespace #'zerop)
|
|---|
| 2149 | #|(when (start-line-p end)
|
|---|
| 2150 | (editor-error "Semicolon preceded by unindented text."))|#
|
|---|
| 2151 | (setf commentp nil)))
|
|---|
| 2152 | (when commentp
|
|---|
| 2153 | (find-attribute end :lisp-syntax #'(lambda (x) (not (eq x :comment))))
|
|---|
| 2154 | (find-attribute end :whitespace #'zerop))
|
|---|
| 2155 | commentp))
|
|---|
| 2156 |
|
|---|
| 2157 |
|
|---|
| 2158 | |
|---|
| 2159 |
|
|---|
| 2160 | ;;;; "Lisp" mode.
|
|---|
| 2161 |
|
|---|
| 2162 | (defcommand "LISP Mode" (p)
|
|---|
| 2163 | "Put current buffer in LISP mode."
|
|---|
| 2164 | "Put current buffer in LISP mode."
|
|---|
| 2165 | (declare (ignore p))
|
|---|
| 2166 | (setf (buffer-major-mode (current-buffer)) "LISP"))
|
|---|
| 2167 |
|
|---|
| 2168 |
|
|---|
| 2169 | (defmode "Lisp" :major-p t :setup-function 'setup-lisp-mode)
|
|---|
| 2170 |
|
|---|
| 2171 |
|
|---|
| 2172 | (defun buffer-first-in-package-form (buffer)
|
|---|
| 2173 | "Returns the package name referenced in the first apparent IN-PACKAGE
|
|---|
| 2174 | form in buffer, or NIL if it can't find an IN-PACKAGE."
|
|---|
| 2175 | (let* ((pattern (new-search-pattern :string-insensitive :forward "in-package" nil))
|
|---|
| 2176 | (mark (copy-mark (buffer-start-mark buffer))))
|
|---|
| 2177 | (with-mark ((start mark)
|
|---|
| 2178 | (end mark))
|
|---|
| 2179 | (loop
|
|---|
| 2180 | (unless (find-pattern mark pattern)
|
|---|
| 2181 | (return))
|
|---|
| 2182 | (pre-command-parse-check mark)
|
|---|
| 2183 | (when (valid-spot mark t)
|
|---|
| 2184 | (move-mark end mark)
|
|---|
| 2185 | (when (form-offset end 1)
|
|---|
| 2186 | (move-mark start end)
|
|---|
| 2187 | (when (backward-up-list start)
|
|---|
| 2188 | (when (scan-char start :lisp-syntax :constituent)
|
|---|
| 2189 | (let* ((s (nstring-upcase (region-to-string (region start end))))
|
|---|
| 2190 | (*package* (find-package "CL-USER")))
|
|---|
| 2191 | (unless (eq (ignore-errors (values (read-from-string s)))
|
|---|
| 2192 | 'in-package)
|
|---|
| 2193 | (return)))
|
|---|
| 2194 | (unless (form-offset end 1) (return))
|
|---|
| 2195 | (move-mark start end)
|
|---|
| 2196 | (form-offset start -1)
|
|---|
| 2197 | (let* ((pkgname (ignore-errors (values (read-from-string (region-to-string (region start end)))))))
|
|---|
| 2198 | (return
|
|---|
| 2199 | (if pkgname
|
|---|
| 2200 | (values (ignore-errors (string pkgname))))))))))))))
|
|---|
| 2201 |
|
|---|
| 2202 | (defparameter *previous-in-package-search-pattern*
|
|---|
| 2203 | (new-search-pattern :string-insensitive :backward "in-package" nil))
|
|---|
| 2204 |
|
|---|
| 2205 | (defun package-at-mark (start-mark &optional return-mark)
|
|---|
| 2206 | (let* ((pattern *previous-in-package-search-pattern*)
|
|---|
| 2207 | (mark (copy-mark start-mark :temporary)))
|
|---|
| 2208 | (with-mark ((start mark)
|
|---|
| 2209 | (end mark)
|
|---|
| 2210 | (list-end mark))
|
|---|
| 2211 | (loop for i from 0 do
|
|---|
| 2212 | (tagbody ; I'm not proud of this
|
|---|
| 2213 | (unless (find-pattern mark pattern)
|
|---|
| 2214 | (return))
|
|---|
| 2215 | (pre-command-parse-check mark)
|
|---|
| 2216 | (when (valid-spot mark t)
|
|---|
| 2217 | (move-mark end mark)
|
|---|
| 2218 | (when (form-offset end 1)
|
|---|
| 2219 | (move-mark start end)
|
|---|
| 2220 | (when (backward-up-list start)
|
|---|
| 2221 | (move-mark list-end start)
|
|---|
| 2222 | (unless (and (list-offset list-end 1)
|
|---|
| 2223 | (mark<= list-end start-mark))
|
|---|
| 2224 | (go again))
|
|---|
| 2225 | (when (scan-char start :lisp-syntax :constituent)
|
|---|
| 2226 | (unless (or (mark= mark start)
|
|---|
| 2227 | (let* ((s (nstring-upcase (region-to-string (region start end))))
|
|---|
| 2228 | (*package* (find-package "CL-USER")))
|
|---|
| 2229 | (eq (ignore-errors (values (read-from-string s)))
|
|---|
| 2230 | 'in-package)))
|
|---|
| 2231 | (go again))
|
|---|
| 2232 | (unless (form-offset end 1) (go again))
|
|---|
| 2233 | (move-mark start end)
|
|---|
| 2234 | (unless (form-offset start -1) (go again))
|
|---|
| 2235 | (return
|
|---|
| 2236 | (if (eql (next-character start) #\")
|
|---|
| 2237 | (progn
|
|---|
| 2238 | (character-offset start 1)
|
|---|
| 2239 | (character-offset end -1)
|
|---|
| 2240 | (when return-mark (move-mark return-mark list-end))
|
|---|
| 2241 | (region-to-string (region start end)))
|
|---|
| 2242 | (let* ((pkgname (ignore-errors (read-from-string (region-to-string (region start end))))))
|
|---|
| 2243 | (when (and pkgname (setq pkgname (ignore-errors (string pkgname))))
|
|---|
| 2244 | (when return-mark (move-mark return-mark list-end))
|
|---|
| 2245 | pkgname))))))))
|
|---|
| 2246 | again)))))
|
|---|
| 2247 |
|
|---|
| 2248 | (defun ensure-buffer-package (buffer)
|
|---|
| 2249 | (or (variable-value 'current-package :buffer buffer)
|
|---|
| 2250 | (setf (variable-value 'current-package :buffer buffer)
|
|---|
| 2251 | (buffer-first-in-package-form buffer))))
|
|---|
| 2252 |
|
|---|
| 2253 | (defun buffer-package (buffer)
|
|---|
| 2254 | (when (hemlock-bound-p 'current-package :buffer buffer)
|
|---|
| 2255 | (let ((package-name (variable-value 'current-package :buffer buffer)))
|
|---|
| 2256 | (find-package package-name))))
|
|---|
| 2257 |
|
|---|
| 2258 | (defun setup-lisp-mode (buffer)
|
|---|
| 2259 | (unless (hemlock-bound-p 'current-package :buffer buffer)
|
|---|
| 2260 | (defhvar "Current Package"
|
|---|
| 2261 | "The package used for evaluation of Lisp in this buffer."
|
|---|
| 2262 | :buffer buffer
|
|---|
| 2263 | :value nil
|
|---|
| 2264 | :hooks (list 'package-name-change-hook)))
|
|---|
| 2265 | (unless (hemlock-bound-p 'default-package :buffer buffer)
|
|---|
| 2266 | (defhvar "Default Package"
|
|---|
| 2267 | "The package to use if the current package doesn't exist or isn't set."
|
|---|
| 2268 | :buffer buffer
|
|---|
| 2269 | :value (package-name *package*))))
|
|---|
| 2270 |
|
|---|
| 2271 |
|
|---|
| 2272 |
|
|---|
| 2273 |
|
|---|
| 2274 | |
|---|
| 2275 |
|
|---|
| 2276 | ;;;; Some mode variables to coordinate with other stuff.
|
|---|
| 2277 |
|
|---|
| 2278 | (defhvar "Auto Fill Space Indent"
|
|---|
| 2279 | "When non-nil, uses \"Indent New Comment Line\" to break lines instead of
|
|---|
| 2280 | \"New Line\"."
|
|---|
| 2281 | :mode "Lisp" :value t)
|
|---|
| 2282 |
|
|---|
| 2283 | (defhvar "Comment Start"
|
|---|
| 2284 | "String that indicates the start of a comment."
|
|---|
| 2285 | :mode "Lisp" :value ";")
|
|---|
| 2286 |
|
|---|
| 2287 | (defhvar "Comment Begin"
|
|---|
| 2288 | "String that is inserted to begin a comment."
|
|---|
| 2289 | :mode "Lisp" :value "; ")
|
|---|
| 2290 |
|
|---|
| 2291 | (defhvar "Indent Function"
|
|---|
| 2292 | "Indentation function which is invoked by \"Indent\" command.
|
|---|
| 2293 | It must take one argument that is the prefix argument."
|
|---|
| 2294 | :value 'indent-for-lisp
|
|---|
| 2295 | :mode "Lisp")
|
|---|
| 2296 |
|
|---|
| 2297 | (defun string-to-arglist (string buffer &optional quiet-if-unknown)
|
|---|
| 2298 | (multiple-value-bind (name error)
|
|---|
| 2299 | (let* ((*package* (or
|
|---|
| 2300 | (find-package
|
|---|
| 2301 | (variable-value 'current-package :buffer buffer))
|
|---|
| 2302 | *package*)))
|
|---|
| 2303 | (ignore-errors (values (read-from-string string))))
|
|---|
| 2304 | (unless error
|
|---|
| 2305 | (when (typep name 'symbol)
|
|---|
| 2306 | (multiple-value-bind (arglist win)
|
|---|
| 2307 | (ccl::arglist-string name)
|
|---|
| 2308 | (if (or win (not quiet-if-unknown))
|
|---|
| 2309 | (format nil "~S : ~A" name (if win (or arglist "()") "(unknown)"))))))))
|
|---|
| 2310 |
|
|---|
| 2311 | (defcommand "Current Function Arglist" (p)
|
|---|
| 2312 | "Show arglist of function whose name precedes point."
|
|---|
| 2313 | "Show arglist of function whose name precedes point."
|
|---|
| 2314 | (declare (ignore p))
|
|---|
| 2315 | (let ((point (current-point)))
|
|---|
| 2316 | (pre-command-parse-check point)
|
|---|
| 2317 | (with-mark ((mark1 point)
|
|---|
| 2318 | (mark2 point))
|
|---|
| 2319 | (when (backward-up-list mark1)
|
|---|
| 2320 | (when (form-offset (move-mark mark2 (mark-after mark1)) 1)
|
|---|
| 2321 | (let* ((fun-name (region-to-string (region mark1 mark2)))
|
|---|
| 2322 | (arglist-string (string-to-arglist fun-name (current-buffer))))
|
|---|
| 2323 | (when arglist-string
|
|---|
| 2324 | (message "~a" arglist-string))))))))
|
|---|
| 2325 |
|
|---|
| 2326 | (defcommand "Arglist On Space" (p)
|
|---|
| 2327 | "Insert a space, then show the current function's arglist."
|
|---|
| 2328 | "Insert a space, then show the current function's arglist."
|
|---|
| 2329 | (declare (ignore p))
|
|---|
| 2330 | (let ((point (current-point-for-insertion)))
|
|---|
| 2331 | (insert-character point #\Space)
|
|---|
| 2332 | (pre-command-parse-check point)
|
|---|
| 2333 | (with-mark ((m point))
|
|---|
| 2334 | (when (backward-up-list m)
|
|---|
| 2335 | (when (and (scan-char m :lisp-syntax :open-paren)
|
|---|
| 2336 | (mark-after m))
|
|---|
| 2337 | (with-mark ((n m))
|
|---|
| 2338 | (forward-form n)
|
|---|
| 2339 | (let* ((fun-name (region-to-string (region m n)))
|
|---|
| 2340 | (arglist-string (string-to-arglist fun-name (current-buffer) t)))
|
|---|
| 2341 | (when arglist-string
|
|---|
| 2342 | (message "~a" arglist-string)))))))))
|
|---|
| 2343 |
|
|---|
| 2344 | (hi:defcommand "Show Callers" (p)
|
|---|
| 2345 | "Display a scrolling list of the callers of the symbol at point.
|
|---|
| 2346 | Double-click a row to go to the caller's definition."
|
|---|
| 2347 | (declare (ignore p))
|
|---|
| 2348 | (with-mark ((mark1 (current-point))
|
|---|
| 2349 | (mark2 (current-point)))
|
|---|
| 2350 | (let* ((*package* (or (find-package (package-at-mark mark1)) *package*)))
|
|---|
| 2351 | (mark-symbol mark1 mark2)
|
|---|
| 2352 | (with-input-from-region (s (region mark1 mark2))
|
|---|
| 2353 | (let* ((symbol (read s)))
|
|---|
| 2354 | (hemlock-ext:open-sequence-dialog
|
|---|
| 2355 | :title (format nil "Callers of ~a" symbol)
|
|---|
| 2356 | :sequence (ccl::callers symbol)
|
|---|
| 2357 | :action #'edit-definition))))))
|
|---|
| 2358 |
|
|---|
| 2359 | #||
|
|---|
| 2360 | (defcommand "Set Package Name" (p)
|
|---|
| 2361 | (variable-value 'current-package :buffer buffer)
|
|---|
| 2362 | ||#
|
|---|
| 2363 |
|
|---|
| 2364 | (defcommand "Insert Sharp Comment" (p)
|
|---|
| 2365 | "Inserts #| |# around the selection and puts point between them."
|
|---|
| 2366 | (declare (ignore p))
|
|---|
| 2367 | (multiple-value-bind (start end) (buffer-selection-range (current-buffer))
|
|---|
| 2368 | (let ((point (current-point)))
|
|---|
| 2369 | (cond ((= start end)
|
|---|
| 2370 | (insert-string point "#|")
|
|---|
| 2371 | (insert-character point #\newline)
|
|---|
| 2372 | (insert-character point #\newline)
|
|---|
| 2373 | (insert-string point "|#")
|
|---|
| 2374 | (character-offset point -3))
|
|---|
| 2375 | (t
|
|---|
| 2376 | (with-mark ((start-mark point :left-inserting)
|
|---|
| 2377 | (end-mark point :left-inserting))
|
|---|
| 2378 | (move-to-absolute-position start-mark start)
|
|---|
| 2379 | (move-to-absolute-position end-mark end)
|
|---|
| 2380 | (insert-string start-mark "#|
|
|---|
| 2381 | ")
|
|---|
| 2382 | (insert-string end-mark "
|
|---|
| 2383 | |#")))))))
|
|---|
