source: trunk/source/cocoa-ide/hemlock/src/lispmode.lisp @ 15291

Last change on this file since 15291 was 15291, checked in by gb, 8 years ago

cocoa-ide/app-delegate.lisp: move MAYBE-FIXUP-APPLICATION-MENU here,
split it off from INITIALIZE-USER-INTERFACE, call it in delegate's
#/applicationWillFinishLaunching: method

cf-utils.lisp: don't depend on read-time behavior of #_ in macroexpansions.

cocoa-application.lisp: try to nuke command-line args when this file
is loaded (so that Cocoa doesn't try to process things like '-e
\(require \"COCOA-APPLICATION\"\)'.)

cocoa-backtrace.lisp: in COUNT-STACK-DESCRIPTOR-FRAME, only count
frames that satisfy CCL::FUNCTION-FRAME-P. (I believe that this is
correct for some fairly subtle reason that I don't remember ...)

cocoa-editor.lisp,cocoa-listener.lisp: better support multiple views/windows
on the same buffer. (The listener support should more-or-less work, but
there are secondary listener-specific issues.

Add an item to a Hemlock text view's context menu which offers to duplicate
the current window; that creates a new window/view hierarchy that shares
the text view's buffer and document but maintains view-specific selection
state. Windows and views created via this menu item are functionally
equvalent to the original; if the shared document is modified, the Cocoa
document architecture will offer to save it (on those OSX versions that
trust the appliance owner/user to make this sort of decision ...) when the
last window sharing the document is closed. (The last window needn't be
the original.) Listeners have state (streams) that refer to the original
window/view and closing that window/view before closing secondary windows
doesn't work; we need to either change how listener streams work or make
it hard to close the original window when duplicates of it still exist,
but I haven't done this.

The HEMLOCK-VIEW for a text view/echo-area view is maintained in a slot;
the idea's to make it a bit easier to embed multiple text views (which
may refer to multiple buffers) in a window (where the concept of "the
window's HEMLOCK-VIEW" may not apply.)

hemlock/src/command.lisp: a buffer's mark-ring is just a field referenced
by a BUFFER structure, not the value of a buffer-local Hemlock variable.

hemlock/src/killcoms.lisp: mark-ring changes, don't put any reasonable
number of consecutive Ds on the kill ring.

hemlock/src/lispmode.lisp: don't loop forever at end/beginning of buffer
in %LIST-OFFSET macro. Provide a terse description of the error in most
EDITOR-ERROR calls in this file.

hemlock/src/morecoms.lisp: mark-ring changes.

hemlock/src/struct.lisp: move some fields (-point, -%mark, the mark-ring,
the active region indicator) from BUFFER to a new SELECTION-INFO struct
that BUFFER references; redefine traditional accessors to indirect through
the SELECTION-INFO. (Views can maintain their own SELECTION-INFO; view-based
operations temporarily install the view's SELECTION-INFO in the buffer.)

Add a TEXTSTORAGE slot to BUFFER; the idea (NYI) is that buffers can have
Cocoa textstorage associated with them independent of the buffer's DOCUMENT
object.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 86.8 KB
Line 
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|#")))))))
Note: See TracBrowser for help on using the repository browser.