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