source: branches/event-ide/ccl/cocoa-ide/hemlock/src/lispmode.lisp @ 7929

Last change on this file since 7929 was 7929, checked in by gz, 13 years ago

Define a stream class for output to the listener and use it instead of the
pty as the output stream for listener repl's. This fixes the deadlock
with writing to the listener from the cocoa thread.

Some more API massaging: hemlock-ext:send-string-to-listener,
hemlock-ext:buffer-process-description.

Some more internal massaging: store the listener repl process object
in the document rather than buffer. Call ccl::housekeeping-loop rather
than duplicating it.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 70.3 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 Boolean slots that tell whether
44;;;        or not a line's begining and/or ending are quoted.
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 to ignore.  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)           ; (or t nil)
58  (ending-quoted nil)           ; (or t nil)
59  (ranges-to-ignore nil)        ; (or t 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
111                                               :char-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 prev-line-info)
206                   
207                   (not (eq (lisp-info-begins-quoted line-info) 
208                            (lisp-info-ending-quoted prev-line-info)))
209                   
210                   (not (eql (line-signature test-line)     
211                             (lisp-info-signature-slot line-info))))
212           
213           (move-to-position mark 0 test-line)
214           
215           (unless line-info
216             (setf line-info (make-lisp-info))
217             (setf (getf (line-plist test-line) 'lisp-info) line-info))
218           
219           (parse-lisp-line-info mark line-info prev-line-info))
220         
221         (when (eq end-line test-line)
222           (return nil))
223         
224         (setq prev-line-info line-info)
225         
226         (setq test-line (line-next test-line)))))))
227
228
229;;;; Parse block finders.
230
231(defhvar "Minimum Lines Parsed"
232  "The minimum number of lines before and after the point parsed by Lisp mode."
233  :value 50)
234(defhvar "Maximum Lines Parsed"
235  "The maximum number of lines before and after the point parsed by Lisp mode."
236  :value 500)
237(defhvar "Defun Parse Goal"
238  "Lisp mode parses the region obtained by skipping this many defuns forward
239   and backward from the point unless this falls outside of the range specified
240   by \"Minimum Lines Parsed\" and \"Maximum Lines Parsed\"."
241  :value 2)
242
243
244(macrolet ((frob (step end)
245             `(let ((min (value minimum-lines-parsed))
246                    (max (value maximum-lines-parsed))
247                    (goal (value defun-parse-goal))
248                    (last-defun nil))
249                (declare (fixnum min max goal))
250                (do ((line (mark-line mark) (,step line))
251                     (count 0 (1+ count)))
252                    ((null line)
253                     (,end mark))
254                  (declare (fixnum count))
255                  (when (char= (line-character line 0) #\()
256                    (setq last-defun line)
257                    (decf goal)
258                    (when (and (<= goal 0) (>= count min))
259                      (line-start mark line)
260                      (return)))
261                  (when (> count max)
262                    (line-start mark (or last-defun line))
263                    (return))))))
264
265  (defun start-of-parse-block (mark)
266    (frob line-previous buffer-start))
267
268  (defun end-of-parse-block (mark)
269    (frob line-next buffer-end)))
270
271;;;
272;;; START-OF-SEARCH-LINE
273
274(defun start-of-search-line (line)
275  "Set LINE to the begining line of the block of text to parse."
276  (with-mark ((mark (mark line 0)))
277    (funcall (value 'Parse-Start-Function) mark)
278    (setq line (mark-line mark))))
279
280;;;
281;;; END-OF-SEACH-LINE
282
283(defun end-of-search-line (line)
284  "Set LINE to the ending line of the block of text to parse."
285  (with-mark ((mark (mark line 0)))
286    (funcall (value 'Parse-End-Function) mark)
287    (setq line (mark-line mark))))
288
289
290;;;; PARSE-LISP-LINE-INFO.
291
292;;; PARSE-LISP-LINE-INFO -- Internal.
293;;;
294;;; This parses through the line doing the following things:
295;;;
296;;;      Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS.
297;;;
298;;;      Making all areas of the line that should be invalid (comments,
299;;;      char-quotes, and the inside of strings) and such be in
300;;;      RANGES-TO-IGNORE.
301;;;
302;;;      Set BEGINS-QUOTED and ENDING-QUOTED
303;;;
304(defun parse-lisp-line-info (mark line-info prev-line-info)
305  "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS,
306   RANGES-TO-INGORE, and ENDING-QUOTED."
307  (let ((net-open-parens 0)
308        (net-close-parens 0))
309    (declare (fixnum net-open-parens net-close-parens))
310   
311    ;; Re-set the slots necessary
312   
313    (setf (lisp-info-ranges-to-ignore line-info) nil)
314   
315    ;; The only way the current line begins quoted is when there
316    ;; is a previous line and it's ending was quoted.
317   
318    (setf (lisp-info-begins-quoted line-info)
319          (and prev-line-info 
320               (lisp-info-ending-quoted prev-line-info)))
321   
322    (if (lisp-info-begins-quoted line-info)
323        (deal-with-string-quote mark line-info)
324        (setf (lisp-info-ending-quoted line-info) nil))
325   
326    (unless (lisp-info-ending-quoted line-info)
327      (loop 
328        (unless (find-lisp-char mark)
329          (error "Expected at least a newline!"))
330
331        (ecase (character-attribute :lisp-syntax (next-character mark))
332         
333          (:open-paren
334           (setq net-open-parens (1+ net-open-parens))
335           (mark-after mark))
336         
337          (:close-paren
338           (if (zerop net-open-parens)
339               (setq net-close-parens (1+ net-close-parens))
340               (setq net-open-parens (1- net-open-parens)))
341           (mark-after mark))
342         
343          (:newline
344           (setf (lisp-info-ending-quoted line-info) nil)
345           (return t))
346         
347          (:comment
348           (push-range (cons (mark-charpos mark) (line-length (mark-line mark)))
349                       line-info)
350           (setf (lisp-info-ending-quoted line-info) nil)
351           (return t))
352         
353          (:char-quote
354           (mark-after mark)
355           (push-range (cons (mark-charpos mark) (1+ (mark-charpos mark)))
356                       line-info)
357           (mark-after mark))
358         
359          (:string-quote
360           (mark-after mark)
361           (unless (deal-with-string-quote mark line-info)
362             (setf (lisp-info-ending-quoted line-info) t)
363             (return t))))))
364   
365    (setf (lisp-info-net-open-parens line-info) net-open-parens)
366    (setf (lisp-info-net-close-parens line-info) net-close-parens)
367    (setf (lisp-info-signature-slot line-info) 
368          (line-signature (mark-line mark)))))
369
370
371
372;;;; String quote utilities.
373
374;;; VALID-STRING-QUOTE-P
375;;;
376(defmacro valid-string-quote-p (mark forwardp)
377  "Return T if the string-quote indicated by MARK is valid."
378  (let ((test-mark (gensym)))
379    `(with-mark ((,test-mark ,mark))
380       ,(unless forwardp
381          ;; TEST-MARK should always be right before the String-quote to be
382          ;; checked.
383          `(mark-before ,test-mark))
384       (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote)
385         (let ((slash-count 0))
386           (loop
387             (mark-before ,test-mark)
388             (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote)
389                 (incf slash-count)
390                 (return t)))
391           (not (oddp slash-count)))))))
392
393;;;
394;;; FIND-VALID-STRING-QUOTE
395
396(defmacro find-valid-string-quote (mark &key forwardp (cease-at-eol nil))
397  "Expand to a form that will leave MARK before a valid string-quote character,
398  in either a forward or backward direction, according to FORWARDP.  If
399  CEASE-AT-EOL is T then it will return nil if encountering the EOL before a
400  valid string-quote."
401  (let ((e-mark (gensym)))
402    `(with-mark ((,e-mark ,mark))
403       
404       (loop
405        (unless (scan-direction ,e-mark ,forwardp :lisp-syntax 
406                                ,(if cease-at-eol 
407                                     `(or :newline :string-quote)
408                                     `:string-quote))
409          (return nil))
410       
411        ,@(if cease-at-eol
412              `((when (test-char (direction-char ,e-mark ,forwardp) :lisp-syntax
413                                 :newline)
414                  (return nil))))
415       
416        (when (valid-string-quote-p ,e-mark ,forwardp)
417          (move-mark ,mark ,e-mark)
418          (return t))
419       
420        (neighbor-mark ,e-mark ,forwardp)))))
421
422;;;; DEAL-WITH-STRING-QUOTE.
423
424;;; DEAL-WITH-STRING-QUOTE
425;;;
426;;; Called when a string is begun (i.e. parse hits a #\").  It checks for a
427;;; matching quote on the line that MARK points to, and puts the appropriate
428;;; area in the RANGES-TO-IGNORE slot and leaves MARK pointing after this area.
429;;; The "appropriate area" is from MARK to the end of the line or the matching
430;;; string-quote, whichever comes first.
431;;;
432(defun deal-with-string-quote (mark info-struct)
433  "Alter the current line's info struct as necessary as due to encountering a
434   string quote character."
435  (with-mark ((e-mark mark))
436    (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t)
437           ;; If matching quote is on this line then mark the area between the
438           ;; first quote (MARK) and the matching quote as invalid by pushing
439           ;; its begining and ending into the IGNORE-RANGE.
440           (push-range (cons (mark-charpos mark) (mark-charpos e-mark))
441                       info-struct)
442           (setf (lisp-info-ending-quoted info-struct) nil)
443           (mark-after e-mark)
444           (move-mark mark e-mark))
445          ;; If the EOL has been hit before the matching quote then mark the
446          ;; area from MARK to the EOL as invalid.
447          (t
448           (push-range (cons (mark-charpos mark)
449                             (1+ (line-length (mark-line mark))))
450                       info-struct)
451           ;; The Ending is marked as still being quoted.
452           (setf (lisp-info-ending-quoted info-struct) t)
453           (line-end mark)
454           nil))))
455
456
457
458;;;; Character validity checking:
459
460;;; Find-Ignore-Region  --  Internal
461;;;
462;;;    If the character in the specified direction from Mark is in an ignore
463;;; region, then return the region and the line that the region is in as
464;;; values.  If there is no ignore region, then return NIL and the Mark-Line.
465;;; If the line is not parsed, or there is no character (because of being at
466;;; the buffer beginning or end), then return both values NIL.
467;;;
468(defun find-ignore-region (mark forwardp)
469  (flet ((scan (line pos)
470           (declare (fixnum pos))
471           (let ((info (getf (line-plist line) 'lisp-info)))
472             (if info
473                 (dolist (range (lisp-info-ranges-to-ignore info)
474                                (values nil line))
475                   (let ((start (car range))
476                         (end (cdr range)))
477                     (declare (fixnum start end))
478                     (when (and (>= pos start) (< pos end))
479                       (return (values range line)))))
480                 (values nil nil)))))
481    (let ((pos (mark-charpos mark))
482          (line (mark-line mark)))
483      (declare (fixnum pos))
484      (cond (forwardp (scan line pos))
485            ((> pos 0) (scan line (1- pos)))
486            (t
487             (let ((prev (line-previous line)))
488               (if prev
489                   (scan prev (line-length prev))
490                   (values nil nil))))))))
491
492
493;;; Valid-Spot  --  Public
494;;;
495(defun valid-spot (mark forwardp)
496  "Return true if the character pointed to by Mark is not in a quoted context,
497  false otherwise.  If Forwardp is true, we use the next character, otherwise
498  we use the previous."
499  (multiple-value-bind (region line)
500                       (find-ignore-region mark forwardp)
501    (and line (not region))))
502
503
504;;; Scan-Direction-Valid  --  Internal
505;;;
506;;;    Like scan-direction, but only stop on valid characters.
507;;;
508(defmacro scan-direction-valid (mark forwardp &rest forms)
509  (let ((n-mark (gensym))
510        (n-line (gensym))
511        (n-region (gensym))
512        (n-won (gensym)))
513    `(let ((,n-mark ,mark) (,n-won nil))
514       (loop
515         (multiple-value-bind (,n-region ,n-line)
516                              (find-ignore-region ,n-mark ,forwardp)
517           (unless ,n-line (return nil))
518           (if ,n-region
519               (move-to-position ,n-mark
520                                 ,(if forwardp
521                                      `(cdr ,n-region) 
522                                      `(car ,n-region))
523                                 ,n-line)
524               (when ,n-won (return t)))
525           ;;
526           ;; Peculiar condition when a quoting character terminates a line.
527           ;; The ignore region is off the end of the line causing %FORM-OFFSET
528           ;; to infinitely loop.
529           (when (> (mark-charpos ,n-mark) (line-length ,n-line))
530             (line-offset ,n-mark 1 0))
531           (unless (scan-direction ,n-mark ,forwardp ,@forms)
532             (return nil))
533           (setq ,n-won t))))))
534
535
536;;;; List offseting.
537
538;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built
539;;; with the same existing structure, with the altering of one variable.
540;;; This one variable being FORWARDP.
541;;;
542(defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) )
543  "Expand to code that will go forward one list either backward or forward,
544   according to the FORWARDP flag."
545  (let ((mark (gensym)))
546    `(let ((paren-count ,extra-parens))
547       (declare (fixnum paren-count))
548       (with-mark ((,mark ,actual-mark))
549         (loop
550           (scan-direction ,mark ,forwardp :lisp-syntax
551                           (or :close-paren :open-paren :newline))
552           (let ((ch (direction-char ,mark ,forwardp)))
553             (unless ch (return nil))
554             (when (valid-spot ,mark ,forwardp)
555               (case (character-attribute :lisp-syntax ch)
556                 (:close-paren
557                  (decf paren-count)
558                  ,(when forwardp
559                     ;; When going forward, an unmatching close-paren means the
560                     ;; end of list.
561                     `(when (<= paren-count 0)
562                        (neighbor-mark ,mark ,forwardp)
563                        (move-mark ,actual-mark ,mark)
564                        (return t))))
565                 (:open-paren
566                  (incf paren-count)
567                  ,(unless forwardp             ; Same as above only end of list
568                     `(when (>= paren-count 0)  ; is opening parens.
569                        (neighbor-mark ,mark ,forwardp)
570                        (move-mark ,actual-mark ,mark)
571                        (return t))))
572                 
573                 (:newline 
574                  ;; When a #\Newline is hit, then the matching paren must lie
575                  ;; on some other line so drop down into the multiple line
576                  ;; balancing function: QUEST-FOR-BALANCING-PAREN If no paren
577                  ;; seen yet, keep going.
578                  (cond ((zerop paren-count))
579                        ((quest-for-balancing-paren ,mark paren-count ,forwardp)
580                         (move-mark ,actual-mark ,mark)
581                         (return t))
582                        (t
583                         (return nil)))))))
584           
585           (neighbor-mark ,mark ,forwardp))))))
586
587;;;
588;;; QUEST-FOR-BALANCING-PAREN
589
590(defmacro quest-for-balancing-paren (mark paren-count forwardp)
591  "Expand to a form that finds the the balancing paren for however many opens or
592  closes are registered by Paren-Count."
593  `(let* ((line (mark-line ,mark)))
594     (loop
595       (setq line (neighbor-line line ,forwardp))
596       (unless line (return nil))
597       (let ((line-info (getf (line-plist line) 'lisp-info))
598             (unbal-paren ,paren-count))
599         (unless line-info (return nil))
600         
601         ,(if forwardp
602              `(decf ,paren-count (lisp-info-net-close-parens line-info))
603              `(incf ,paren-count (lisp-info-net-open-parens line-info)))
604         
605         (when ,(if forwardp
606                    `(<= ,paren-count 0)
607                    `(>= ,paren-count 0))
608           ,(if forwardp
609                `(line-start ,mark line)
610                `(line-end ,mark line))
611           (return (goto-correct-paren-char ,mark unbal-paren ,forwardp)))
612
613         ,(if forwardp
614              `(incf ,paren-count (lisp-info-net-open-parens line-info))
615              `(decf ,paren-count (lisp-info-net-close-parens line-info)))))))
616                   
617
618;;;
619;;; GOTO-CORRECT-PAREN-CHAR
620
621(defmacro goto-correct-paren-char (mark paren-count forwardp)
622  "Expand to a form that will leave MARK on the correct balancing paren matching
623   however many are indicated by COUNT." 
624  `(with-mark ((m ,mark))
625     (let ((count ,paren-count))
626       (loop
627         (scan-direction m ,forwardp :lisp-syntax 
628                         (or :close-paren :open-paren :newline))
629         (when (valid-spot m ,forwardp)
630           (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
631             (:close-paren 
632              (decf count)
633              ,(when forwardp
634                 `(when (zerop count)
635                    (neighbor-mark m ,forwardp)
636                    (move-mark ,mark m)
637                    (return t))))
638             
639             (:open-paren 
640              (incf count)
641              ,(unless forwardp
642                 `(when (zerop count)
643                    (neighbor-mark m ,forwardp)
644                    (move-mark ,mark m)
645                    (return t))))))
646         (neighbor-mark m ,forwardp)))))
647
648
649(defun list-offset (mark offset)
650  (if (plusp offset)
651      (dotimes (i offset t)
652        (unless (%list-offset mark t) (return nil)))
653      (dotimes (i (- offset) t)
654        (unless (%list-offset mark nil) (return nil)))))
655
656(defun forward-up-list (mark)
657  "Moves mark just past the closing paren of the immediately containing list."
658  (%list-offset mark t :extra-parens 1))
659
660(defun backward-up-list (mark)
661  "Moves mark just before the opening paren of the immediately containing list."
662  (%list-offset mark nil :extra-parens -1))
663
664
665
666;;;; Top level form location hacks (open parens beginning lines).
667
668;;; NEIGHBOR-TOP-LEVEL is used only in TOP-LEVEL-OFFSET.
669;;;
670(eval-when (:compile-toplevel :execute)
671(defmacro neighbor-top-level (line forwardp)
672  `(loop
673     (when (test-char (line-character ,line 0) :lisp-syntax :open-paren)
674       (return t))
675     (setf ,line ,(if forwardp `(line-next ,line) `(line-previous ,line)))
676     (unless ,line (return nil))))
677) ;eval-when
678
679(defun top-level-offset (mark offset)
680  "Go forward or backward offset number of top level forms.  Mark is
681   returned if offset forms exists, otherwise nil."
682  (declare (fixnum offset))
683  (let* ((line (mark-line mark))
684         (at-start (test-char (line-character line 0) :lisp-syntax :open-paren)))
685    (cond ((zerop offset) mark)
686          ((plusp offset)
687           (do ((offset (if at-start offset (1- offset))
688                        (1- offset)))
689               (nil)
690             (declare (fixnum offset))
691             (unless (neighbor-top-level line t) (return nil))
692             (when (zerop offset) (return (line-start mark line)))
693             (unless (setf line (line-next line)) (return nil))))
694          (t
695           (do ((offset (if (and at-start (start-line-p mark))
696                            offset
697                            (1+ offset))
698                        (1+ offset)))
699                (nil)
700             (declare (fixnum offset))
701             (unless (neighbor-top-level line nil) (return nil))
702             (when (zerop offset) (return (line-start mark line)))
703             (unless (setf line (line-previous line)) (return nil)))))))
704
705
706(defun mark-top-level-form (mark1 mark2)
707  "Moves mark1 and mark2 to the beginning and end of the current or next defun.
708   Mark1 one is used as a reference.  The marks may be altered even if
709   unsuccessful.  if successful, return mark2, else nil."
710  (let ((winp (cond ((inside-defun-p mark1)
711                     (cond ((not (top-level-offset mark1 -1)) nil)
712                           ((not (form-offset (move-mark mark2 mark1) 1)) nil)
713                           (t mark2)))
714                    ((start-defun-p mark1)
715                     (form-offset (move-mark mark2 mark1) 1))
716                    ((and (top-level-offset (move-mark mark2 mark1) -1)
717                          (start-defun-p mark2)
718                          (form-offset mark2 1)
719                          (same-line-p mark1 mark2))
720                     (form-offset (move-mark mark1 mark2) -1)
721                     mark2)
722                    ((top-level-offset mark1 1)
723                     (form-offset (move-mark mark2 mark1) 1)))))
724    (when winp
725      (when (blank-after-p mark2) (line-offset mark2 1 0))
726      mark2)))
727
728(defun inside-defun-p (mark)
729  "T if the current point is (supposedly) in a top level form."
730  (with-mark ((m mark))
731    (when (top-level-offset m -1)
732      (form-offset m 1)
733      (mark> m mark))))
734
735(defun start-defun-p (mark)
736  "Returns t if mark is sitting before an :open-paren at the beginning of a
737   line."
738  (and (start-line-p mark)
739       (test-char (next-character mark) :lisp-syntax :open-paren)))
740
741
742
743;;;; Form offseting.
744
745(defmacro %form-offset (mark forwardp)
746  `(with-mark ((m ,mark))
747     (when (scan-direction-valid m ,forwardp :lisp-syntax
748                                 (or :open-paren :close-paren
749                                     :char-quote :string-quote
750                                     :constituent))
751       (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
752         (:open-paren
753          (when ,(if forwardp `(list-offset m 1) `(mark-before m))
754            ,(unless forwardp
755               '(scan-direction m nil :lisp-syntax (not :prefix)))
756            (move-mark ,mark m)
757            t))
758         (:close-paren
759          (when ,(if forwardp `(mark-after m) `(list-offset m -1))
760            ,(unless forwardp
761               '(scan-direction m nil :lisp-syntax (not :prefix)))
762            (move-mark ,mark m)
763            t))
764         ((:constituent :char-quote)
765          (scan-direction-valid m ,forwardp :lisp-syntax
766                                (not (or :constituent :char-quote)))
767          ,(if forwardp
768               `(scan-direction-valid m t :lisp-syntax
769                                      (not (or :constituent :char-quote)))
770               `(scan-direction-valid m nil :lisp-syntax
771                                      (not (or :constituent :char-quote
772                                               :prefix))))
773          (move-mark ,mark m)
774          t)
775         (:string-quote
776          (cond ((valid-spot m ,(not forwardp))
777                 (neighbor-mark m ,forwardp)
778                 (when (scan-direction-valid m ,forwardp :lisp-syntax
779                                             :string-quote)
780                   (neighbor-mark m ,forwardp)
781                   (move-mark ,mark m)
782                   t))
783                (t (neighbor-mark m ,forwardp)
784                   (move-mark ,mark m)
785                   t)))))))
786
787
788(defun form-offset (mark offset)
789  "Move mark offset number of forms, after if positive, before if negative.
790   Mark is always moved.  If there weren't enough forms, returns nil instead of
791   mark."
792  (if (plusp offset)
793      (dotimes (i offset t)
794        (unless (%form-offset mark t) (return nil)))
795      (dotimes (i (- offset) t)
796        (unless (%form-offset mark nil) (return nil)))))
797
798
799
800;;;; Table of special forms with special indenting requirements.
801
802(defhvar "Indent Defanything"
803  "This is the number of special arguments implicitly assumed to be supplied
804   in calls to functions whose names begin with \"DEF\".  If set to NIL, this
805   feature is disabled."
806  :value 2)
807
808(defvar *special-forms* (make-hash-table :test #'equal))
809
810(defun defindent (fname args)
811  "Define Fname to have Args special arguments.  If args is null then remove
812   any special arguments information."
813  (check-type fname string)
814  (let ((fname (string-upcase fname)))
815    (cond ((null args) (remhash fname *special-forms*))
816          (t
817           (check-type args integer)
818           (setf (gethash fname *special-forms*) args)))))
819
820
821;;; Hemlock forms.
822;;;
823(defindent "with-mark" 1)
824(defindent "with-random-typeout" 1)
825(defindent "with-pop-up-display" 1)
826(defindent "defhvar" 1)
827(defindent "hlet" 1)
828(defindent "defcommand" 2)
829(defindent "defattribute" 1)
830(defindent "command-case" 1)
831(defindent "with-input-from-region" 1)
832(defindent "with-output-to-mark" 1)
833(defindent "do-strings" 1)
834(defindent "save-for-undo" 1)
835(defindent "do-alpha-chars" 1)
836(defindent "do-headers-buffers" 1)
837(defindent "do-headers-lines" 1)
838(defindent "with-headers-mark" 1)
839(defindent "frob" 1) ;cover silly FLET and MACROLET names for Rob and Bill.
840(defindent "with-writable-buffer" 1)
841
842;;; Common Lisp forms.
843;;;
844(defindent "block" 1)
845(defindent "case" 1)
846(defindent "catch" 1)
847(defindent "ccase" 1)                     
848(defindent "compiler-let" 1)
849(defindent "ctypecase" 1)
850(defindent "defconstant" 1)
851(defindent "define-compiler-macro" 2)
852(defindent "define-setf-method" 2)
853(defindent "destructuring-bind" 2)
854(defindent "defmacro" 2)
855(defindent "defpackage" 1)
856(defindent "defparameter" 1)
857(defindent "defstruct" 1)
858(defindent "deftype" 2)
859(defindent "defun" 2)
860(defindent "defvar" 1)
861(defindent "do" 2)
862(defindent "do*" 2)
863(defindent "do-all-symbols" 1)
864(defindent "do-external-symbols" 1)
865(defindent "do-symbols" 1)
866(defindent "dolist" 1)
867(defindent "dotimes" 1)
868(defindent "ecase" 1)
869(defindent "etypecase" 1)
870(defindent "eval-when" 1)
871(defindent "flet" 1)
872(defindent "if" 1)
873(defindent "labels" 1)
874(defindent "lambda" 1)
875(defindent "let" 1)
876(defindent "let*" 1)
877(defindent "locally" 0)
878(defindent "loop" 0)
879(defindent "macrolet" 1)
880(defindent "multiple-value-bind" 2)
881(defindent "multiple-value-call" 1)
882(defindent "multiple-value-prog1" 1)
883(defindent "multiple-value-setq" 1)
884(defindent "prog1" 1)
885(defindent "progv" 2)
886(defindent "progn" 0)
887(defindent "typecase" 1)
888(defindent "unless" 1)
889(defindent "unwind-protect" 1)
890(defindent "when" 1)
891(defindent "with-input-from-string" 1)
892(defindent "with-open-file" 1)
893(defindent "with-open-stream" 1)
894(defindent "with-output-to-string" 1)
895(defindent "with-package-iterator" 1)
896
897;;; Error/condition system forms.
898;;;
899(defindent "define-condition" 2)
900(defindent "handler-bind" 1)
901(defindent "handler-case" 1)
902(defindent "restart-bind" 1)
903(defindent "restart-case" 1)
904(defindent "with-simple-restart" 1)
905;;; These are for RESTART-CASE branch formatting.
906(defindent "store-value" 1)
907(defindent "use-value" 1)
908(defindent "muffle-warning" 1)
909(defindent "abort" 1)
910(defindent "continue" 1)
911
912;;; Debug-internals forms.
913;;;
914(defindent "do-debug-function-blocks" 1)
915(defindent "di:do-debug-function-blocks" 1)
916(defindent "do-debug-function-variables" 1)
917(defindent "di:do-debug-function-variables" 1)
918(defindent "do-debug-block-locations" 1)
919(defindent "di:do-debug-block-locations" 1)
920;;;
921;;; Debug-internals conditions
922;;; (define these to make uses of HANDLER-CASE indent branches correctly.)
923;;;
924(defindent "debug-condition" 1)
925(defindent "di:debug-condition" 1)
926(defindent "no-debug-info" 1)
927(defindent "di:no-debug-info" 1)
928(defindent "no-debug-function-returns" 1)
929(defindent "di:no-debug-function-returns" 1)
930(defindent "no-debug-blocks" 1)
931(defindent "di:no-debug-blocks" 1)
932(defindent "lambda-list-unavailable" 1)
933(defindent "di:lambda-list-unavailable" 1)
934(defindent "no-debug-variables" 1)
935(defindent "di:no-debug-variables" 1)
936(defindent "invalid-value" 1)
937(defindent "di:invalid-value" 1)
938(defindent "ambiguous-variable-name" 1)
939(defindent "di:ambiguous-variable-name" 1)
940(defindent "debug-error" 1)
941(defindent "di:debug-error" 1)
942(defindent "unhandled-condition" 1)
943(defindent "di:unhandled-condition" 1)
944(defindent "unknown-code-location" 1)
945(defindent "di:unknown-code-location" 1)
946(defindent "unknown-debug-variable" 1)
947(defindent "di:unknown-debug-variable" 1)
948(defindent "invalid-control-stack-pointer" 1)
949(defindent "di:invalid-control-stack-pointer" 1)
950(defindent "frame-function-mismatch" 1)
951(defindent "di:frame-function-mismatch" 1)
952
953
954;;; CLOS forms.
955;;;
956(defindent "with-slots" 1)
957(defindent "with-accessors" 2)
958(defindent "defclass" 2)
959(defindent "print-unreadable-object" 1)
960(defindent "defmethod" 2)
961(defindent "make-instance" 1)
962
963;;; System forms.
964;;;
965(defindent "rlet" 1)
966
967;;; Multiprocessing forms.
968(defindent "with-lock-grabbed" 1)
969(defindent "process-wait" 1)
970
971
972
973;;;; Indentation.
974
975;;; LISP-INDENTATION -- Internal Interface.
976
977(defun strip-package-prefix (string)
978  (let* ((p (position #\: string :from-end t)))
979    (if p
980      (subseq string (1+ p))
981      string)))
982;;;
983(defun lisp-indentation (mark)
984  "Compute number of spaces which mark should be indented according to
985   local context and lisp grinding conventions.  This assumes mark is at the
986   beginning of the line to be indented."
987  (with-mark ((m mark)
988              (temp mark))
989    ;; See if we are in a quoted context.
990    (unless (valid-spot m nil)
991      (return-from lisp-indentation (lisp-generic-indentation m)))
992    ;; Look for the paren that opens the containing form.
993    (unless (backward-up-list m)
994      (return-from lisp-indentation 0))
995    ;; Move after the paren, save the start, and find the form name.
996    (mark-after m)
997    (with-mark ((start m))
998      (unless (and (scan-char m :lisp-syntax
999                              (not (or :space :prefix :char-quote)))
1000                   (test-char (next-character m) :lisp-syntax :constituent))
1001        (return-from lisp-indentation (mark-column start)))
1002      (with-mark ((fstart m))
1003        (scan-char m :lisp-syntax (not :constituent))
1004        (let* ((fname (nstring-upcase
1005                       (strip-package-prefix (region-to-string (region fstart m)))))
1006               (special-args (or (gethash fname *special-forms*)
1007                                 (and (> (length fname) 2)
1008                                      (string= fname "DEF" :end1 3)
1009                                      (value indent-defanything)))))
1010          (declare (simple-string fname))
1011          ;; Now that we have the form name, did it have special syntax?
1012          (cond (special-args
1013                 (with-mark ((spec m))
1014                   (cond ((and (form-offset spec special-args)
1015                               (mark<= spec mark))
1016                          (1+ (mark-column start)))
1017                         ((skip-valid-space m)
1018                          (mark-column m))
1019                         (t
1020                          (+ (mark-column start) 3)))))
1021                ;; See if the user seems to have altered the editor's
1022                ;; indentation, and if so, try to adhere to it.  This usually
1023                ;; happens when you type in a quoted list constant that line
1024                ;; wraps.  You want all the items on successive lines to fall
1025                ;; under the first character after the opening paren, not as if
1026                ;; you are calling a function.
1027                ((and (form-offset temp -1)
1028                      (or (blank-before-p temp) (not (same-line-p temp fstart)))
1029                      (not (same-line-p temp mark)))
1030                 (unless (blank-before-p temp)
1031                   (line-start temp)
1032                   (find-attribute temp :space #'zerop))
1033                 (mark-column temp))
1034                ;; Appears to be a normal form.  Is the first arg on the same
1035                ;; line as the form name?
1036                ((skip-valid-space m)
1037                 (or (lisp-indentation-check-for-local-def
1038                      mark temp fstart start t)
1039                     (mark-column m)))
1040                ;; Okay, fall under the first character after the opening paren.
1041                (t
1042                 (or (lisp-indentation-check-for-local-def
1043                      mark temp fstart start nil)
1044                     (mark-column start)))))))))
1045
1046(defhvar "Lisp Indentation Local Definers"
1047  "Forms with syntax like LABELS, MACROLET, etc."
1048  :value '("LABELS" "MACROLET" "FLET"))
1049
1050;;; LISP-INDENTATION-CHECK-FOR-LOCAL-DEF -- Internal.
1051;;;
1052;;; This is a temporary hack to see how it performs.  When we are indenting
1053;;; what appears to be a function call, let's look for FLET or MACROLET to see
1054;;; if we really are indenting a local definition.  If we are, return the
1055;;; indentation for a DEFUN; otherwise, nil
1056;;;
1057;;; Mark is the argument to LISP-INDENTATION.  Start is just inside the paren
1058;;; of what looks like a function call.  If we are in an FLET, arg-list
1059;;; indicates whether the local function's arg-list has been entered, that is,
1060;;; whether we need to normally indent for a DEFUN body or indent specially for
1061;;; the arg-list.
1062;;;
1063(defun lisp-indentation-check-for-local-def (mark temp1 temp2 start arg-list)
1064  ;; We know this succeeds from LISP-INDENTATION.
1065  (backward-up-list (move-mark temp1 mark)) ;Paren for local definition.
1066  (cond ((and (backward-up-list temp1)      ;Paren opening the list of defs
1067              (form-offset (move-mark temp2 temp1) -1)
1068              (mark-before temp2)
1069              (backward-up-list temp1)      ;Paren for FLET or MACROLET.
1070              (mark= temp1 temp2))          ;Must be in first arg form.
1071         ;; See if the containing form is named FLET or MACROLET.
1072         (mark-after temp1)
1073         (unless (and (scan-char temp1 :lisp-syntax
1074                                 (not (or :space :prefix :char-quote)))
1075                      (test-char (next-character temp1) :lisp-syntax
1076                                 :constituent))
1077           (return-from lisp-indentation-check-for-local-def nil))
1078         (move-mark temp2 temp1)
1079         (scan-char temp2 :lisp-syntax (not :constituent))
1080         (let ((fname (nstring-upcase (region-to-string (region temp1 temp2)))))
1081           (cond ((not (member fname (value lisp-indentation-local-definers)
1082                               :test #'string=))
1083                  nil)
1084                 (arg-list
1085                  (1+ (mark-column start)))
1086                 (t
1087                  (+ (mark-column start) 3)))))))
1088
1089;;; LISP-GENERIC-INDENTATION -- Internal.
1090;;;
1091;;; LISP-INDENTATION calls this when mark is in a invalid spot, or quoted
1092;;; context.  If we are inside a string, we return the column one greater
1093;;; than the opening double quote.  Otherwise, we just use the indentation
1094;;; of the first preceding non-blank line.
1095;;;
1096(defun lisp-generic-indentation (mark)
1097  (with-mark ((m mark))
1098    (form-offset m -1)
1099    (cond ((eq (character-attribute :lisp-syntax (next-character m))
1100               :string-quote)
1101           (1+ (mark-column m)))
1102          (t
1103           (let* ((line (mark-line mark))
1104                  (prev (do ((line (line-previous line) (line-previous line)))
1105                            ((not (and line (blank-line-p line))) line))))
1106             (cond (prev
1107                    (line-start mark prev)
1108                    (find-attribute mark :space #'zerop)
1109                    (mark-column mark))
1110                   (t 0)))))))
1111
1112;;; Skip-Valid-Space  --  Internal
1113;;;
1114;;;    Skip over any space on the line Mark is on, stopping at the first valid
1115;;; non-space character.  If there is none on the line, return nil.
1116;;;
1117(defun skip-valid-space (mark)
1118  (loop
1119    (scan-char mark :lisp-syntax (not :space))
1120    (let ((val (character-attribute :lisp-syntax
1121                                    (next-character mark))))
1122      (cond ((eq val :newline) (return nil))
1123            ((valid-spot mark t) (return mark))))
1124    (mark-after mark)))
1125
1126;; (declaim (optimize (speed 0))); byte compile again
1127
1128
1129;;;; Indentation commands and hook functions.
1130
1131(defcommand "Defindent" (p)
1132  "Define the Lisp indentation for the current function.
1133  The indentation is a non-negative integer which is the number
1134  of special arguments for the form.  Examples: 2 for Do, 1 for Dolist.
1135  If a prefix argument is supplied, then delete the indentation information."
1136  "Do a defindent, man!"
1137  (with-mark ((m (current-point)))
1138    (pre-command-parse-check m)
1139    (unless (backward-up-list m) (editor-error))
1140    (mark-after m)
1141    (with-mark ((n m))
1142      (scan-char n :lisp-syntax (not :constituent))
1143      (let ((s (region-to-string (region m n))))
1144        (declare (simple-string s))
1145        (when (zerop (length s)) (editor-error))
1146        (if p
1147            (defindent s nil)
1148            (let ((i (prompt-for-integer
1149                      :prompt (format nil "Indentation for ~A: " s)
1150                      :help "Number of special arguments.")))
1151              (when (minusp i)
1152                (editor-error "Indentation must be non-negative."))
1153              (defindent s i))))))
1154  (indent-command nil))
1155
1156(defcommand "Indent Form" (p)
1157  "Indent Lisp code in the next form."
1158  "Indent Lisp code in the next form."
1159  (declare (ignore p))
1160  (let ((point (current-point)))
1161    (pre-command-parse-check point)
1162    (with-mark ((m point))
1163      (unless (form-offset m 1) (editor-error))
1164      (lisp-indent-region (region point m) "Indent Form"))))
1165
1166;;; LISP-INDENT-REGION -- Internal.
1167;;;
1168;;; This indents a region of Lisp code without doing excessive redundant
1169;;; computation.  We parse the entire region once, then scan through doing
1170;;; indentation on each line.  We forcibly reparse each line that we indent so
1171;;; that the list operations done to determine indentation of subsequent lines
1172;;; will work.  This is done undoably with save1, save2, buf-region, and
1173;;; undo-region.
1174;;;
1175(defun lisp-indent-region (region &optional (undo-text "Lisp region indenting"))  (let* ((start (region-start region))
1176         (end (region-end region))
1177         (buffer (hi::line-%buffer (mark-line start))))
1178    (with-mark ((m1 start)
1179                (m2 end))
1180      (funcall (value parse-start-function) m1)
1181      (funcall (value parse-end-function) m2)
1182      (parse-over-block (mark-line m1) (mark-line m2)))
1183    (hi::check-buffer-modification buffer start)
1184    (hi::check-buffer-modification buffer end)
1185    (let* ((first-line (mark-line start))
1186              (last-line (mark-line end))
1187              (prev (line-previous first-line))
1188              (prev-line-info
1189               (and prev (getf (line-plist prev) 'lisp-info)))
1190              (save1 (line-start (copy-mark start :right-inserting)))
1191              (save2 (line-end (copy-mark end :left-inserting)))
1192              (buf-region (region save1 save2))
1193              (undo-region (copy-region buf-region)))
1194         (with-mark ((bol start :left-inserting))
1195           (do ((line first-line (line-next line)))
1196               (nil)
1197             (line-start bol line)
1198             (ensure-lisp-indentation bol)
1199             (let ((line-info (getf (line-plist line) 'lisp-info)))
1200               (parse-lisp-line-info bol line-info prev-line-info)
1201               (setq prev-line-info line-info))
1202             (when (eq line last-line) (return nil))))
1203         (make-region-undo :twiddle undo-text buf-region undo-region))))
1204
1205;;; INDENT-FOR-LISP -- Internal.
1206;;;
1207;;; This is the value of "Indent Function" for "Lisp" mode.
1208;;;
1209(defun indent-for-lisp (mark)
1210  (line-start mark)
1211  (pre-command-parse-check mark)
1212  (ensure-lisp-indentation mark))
1213
1214(defun count-leading-whitespace (mark)
1215  (with-mark ((m mark))
1216    (line-start m)
1217    (do* ((p 0)
1218          (q 0 (1+ q))
1219          (tab-width (value spaces-per-tab)))
1220         ()
1221      (case (next-character m)
1222        (#\space (incf p))
1223        (#\tab (setq p (* tab-width (ceiling (1+ p) tab-width))))
1224        (t (return (values p q))))
1225      (character-offset m 1))))
1226
1227;;; Don't do anything if M's line is already correctly indented.
1228(defun ensure-lisp-indentation (m)
1229  (let* ((col (lisp-indentation m)))
1230    (multiple-value-bind (curcol curpos) (count-leading-whitespace m)
1231      (cond ((= curcol col) (setf (mark-charpos m) curpos))
1232            (t
1233             (delete-horizontal-space m)
1234             (indent-to-column m col))))))
1235
1236
1237
1238
1239;;;; Most "Lisp" mode commands.
1240
1241(defcommand "Beginning of Defun" (p)
1242  "Move the point to the beginning of a top-level form, collapsing the selection.
1243  with an argument, skips the previous p top-level forms."
1244  "Move the point to the beginning of a top-level form, collapsing the selection."
1245  (let ((point (current-point-collapsing-selection))
1246        (count (or p 1)))
1247    (pre-command-parse-check point)
1248    (if (minusp count)
1249        (end-of-defun-command (- count))
1250        (unless (top-level-offset point (- count))
1251          (editor-error)))))
1252
1253(defcommand "Select to Beginning of Defun" (p)
1254  "Move the point to the beginning of a top-level form, extending the selection.
1255  with an argument, skips the previous p top-level forms."
1256  "Move the point to the beginning of a top-level form, extending the selection."
1257  (let ((point (current-point-extending-selection))
1258        (count (or p 1)))
1259    (pre-command-parse-check point)
1260    (if (minusp count)
1261        (end-of-defun-command (- count))
1262        (unless (top-level-offset point (- count))
1263          (editor-error)))))
1264
1265;;; "End of Defun", with a positive p (the normal case), does something weird.
1266;;; Get a mark at the beginning of the defun, and then offset it forward one
1267;;; less top level form than we want.  This sets us up to use FORM-OFFSET which
1268;;; allows us to leave the point immediately after the defun.  If we used
1269;;; TOP-LEVEL-OFFSET one less than p on the mark at the end of the current
1270;;; defun, point would be left at the beginning of the p+1'st form instead of
1271;;; at the end of the p'th form.
1272;;;
1273(defcommand "End of Defun" (p)
1274  "Move the point to the end of a top-level form, collapsing the selection.
1275   With an argument, skips the next p top-level forms."
1276  "Move the point to the end of a top-level form, collapsing the selection."
1277  (let ((point (current-point-collapsing-selection))
1278        (count (or p 1)))
1279    (pre-command-parse-check point)
1280    (if (minusp count)
1281        (beginning-of-defun-command (- count))
1282        (with-mark ((m point)
1283                    (dummy point))
1284          (cond ((not (mark-top-level-form m dummy))
1285                 (editor-error "No current or next top level form."))
1286                (t 
1287                 (unless (top-level-offset m (1- count))
1288                   (editor-error "Not enough top level forms."))
1289                 ;; We might be one unparsed for away.
1290                 (pre-command-parse-check m)
1291                 (unless (form-offset m 1)
1292                   (editor-error "Not enough top level forms."))
1293                 (when (blank-after-p m) (line-offset m 1 0))
1294                 (move-mark point m)))))))
1295
1296(defcommand "Select to End of Defun" (p)
1297  "Move the point to the end of a top-level form, extending the selection.
1298   With an argument, skips the next p top-level forms."
1299  "Move the point to the end of a top-level form, extending the selection."
1300  (let ((point (current-point-extending-selection))
1301        (count (or p 1)))
1302    (pre-command-parse-check point)
1303    (if (minusp count)
1304        (beginning-of-defun-command (- count))
1305        (with-mark ((m point)
1306                    (dummy point))
1307          (cond ((not (mark-top-level-form m dummy))
1308                 (editor-error "No current or next top level form."))
1309                (t 
1310                 (unless (top-level-offset m (1- count))
1311                   (editor-error "Not enough top level forms."))
1312                 ;; We might be one unparsed for away.
1313                 (pre-command-parse-check m)
1314                 (unless (form-offset m 1)
1315                   (editor-error "Not enough top level forms."))
1316                 (when (blank-after-p m) (line-offset m 1 0))
1317                 (move-mark point m)))))))
1318
1319(defcommand "Forward List" (p)
1320  "Skip over the next Lisp list, collapsing the selection.
1321  With argument, skips the next p lists."
1322  "Skip over the next Lisp list, collapsing the selection."
1323  (let ((point (current-point-collapsing-selection))
1324        (count (or p 1)))
1325    (pre-command-parse-check point)
1326    (unless (list-offset point count) (editor-error))))
1327
1328(defcommand "Select Forward List" (p)
1329  "Skip over the next Lisp list, extending the selection.
1330  With argument, skips the next p lists."
1331  "Skip over the next Lisp list, extending the selection."
1332  (let ((point (current-point-extending-selection))
1333        (count (or p 1)))
1334    (pre-command-parse-check point)
1335    (unless (list-offset point count) (editor-error))))
1336
1337(defcommand "Backward List" (p)
1338  "Skip over the previous Lisp list, collapsing the selection.
1339  With argument, skips the previous p lists."
1340  "Skip over the previous Lisp list, collapsing the selection."
1341  (let ((point (current-point-collapsing-selection))
1342        (count (- (or p 1))))
1343    (pre-command-parse-check point)
1344    (unless (list-offset point count) (editor-error))))
1345
1346(defcommand "Select Backward List" (p)
1347  "Skip over the previous Lisp list, extending the selection.
1348  With argument, skips the previous p lists."
1349  "Skip over the previous Lisp list, extending the selection."
1350  (let ((point (current-point-extending-selection))
1351        (count (- (or p 1))))
1352    (pre-command-parse-check point)
1353    (unless (list-offset point count) (editor-error))))
1354
1355(defcommand "Forward Form" (p)
1356  "Skip over the next Form, collapsing the selection.
1357  With argument, skips the next p Forms."
1358  "Skip over the next Form, collapsing the selection."
1359  (let ((point (current-point-collapsing-selection))
1360        (count (or p 1)))
1361    (pre-command-parse-check point)
1362    (unless (form-offset point count) (editor-error))))
1363
1364(defcommand "Select Forward Form" (p)
1365  "Skip over the next Form, extending the selection.
1366  With argument, skips the next p Forms."
1367  "Skip over the next Form, extending the selection."
1368  (let ((point (current-point-extending-selection))
1369        (count (or p 1)))
1370    (pre-command-parse-check point)
1371    (unless (form-offset point count) (editor-error))))
1372
1373(defcommand "Backward Form" (p)
1374  "Skip over the previous Form, collapsing the selection.
1375  With argument, skips the previous p Forms."
1376  "Skip over the previous Form, collaspsing the selection."
1377  (let ((point (current-point-collapsing-selection))
1378        (count (- (or p 1))))
1379    (pre-command-parse-check point)
1380    (unless (form-offset point count) (editor-error))))
1381
1382(defcommand "Select Backward Form" (p)
1383  "Skip over the previous Form, extending the selection.
1384  With argument, skips the previous p Forms."
1385  "Skip over the previous Form, extending the selection."
1386  (let ((point (current-point-extending-selection))
1387        (count (- (or p 1))))
1388    (pre-command-parse-check point)
1389    (unless (form-offset point count) (editor-error))))
1390
1391(defcommand "Mark Form" (p)
1392  "Set the mark at the end of the next Form.
1393   With a positive argument, set the mark after the following p
1394   Forms. With a negative argument, set the mark before
1395   the preceding -p Forms."
1396  "Set the mark at the end of the next Form."
1397  (with-mark ((m (current-point)))
1398    (pre-command-parse-check m)
1399    (let ((count (or p 1))
1400          (mark (push-new-buffer-mark m t)))
1401      (if (form-offset m count)
1402          (move-mark mark m)
1403          (editor-error)))))
1404
1405(defcommand "Mark Defun" (p)
1406  "Puts the region around the next or containing top-level form.
1407   The point is left before the form and the mark is placed immediately
1408   after it."
1409  "Puts the region around the next or containing top-level form."
1410  (declare (ignore p))
1411  (let ((point (current-point)))
1412    (pre-command-parse-check point)
1413    (with-mark ((start point)
1414                (end point))
1415      (cond ((not (mark-top-level-form start end))
1416             (editor-error "No current or next top level form."))
1417            (t
1418             (move-mark point start)
1419             (move-mark (push-new-buffer-mark point t) end))))))
1420
1421(defcommand "Forward Kill Form" (p)
1422  "Kill the next Form.
1423   With a positive argument, kills the next p Forms.
1424   Kills backward with a negative argument."
1425  "Kill the next Form."
1426  (with-mark ((m1 (current-point))
1427              (m2 (current-point)))
1428    (pre-command-parse-check m1)
1429    (let ((count (or p 1)))
1430      (unless (form-offset m1 count) (editor-error))
1431      (if (minusp count)
1432          (kill-region (region m1 m2) :kill-backward)
1433          (kill-region (region m2 m1) :kill-forward)))))
1434
1435(defcommand "Backward Kill Form" (p)
1436  "Kill the previous Form.
1437  With a positive argument, kills the previous p Forms.
1438  Kills forward with a negative argument."
1439  "Kill the previous Form."
1440  (forward-kill-form-command (- (or p 1))))
1441
1442(defcommand "Extract Form" (p)
1443  "Replace the current containing list with the next form.  The entire affected
1444   area is pushed onto the kill ring.  If an argument is supplied, that many
1445   upward levels of list nesting is replaced by the next form."
1446  "Replace the current containing list with the next form.  The entire affected
1447   area is pushed onto the kill ring.  If an argument is supplied, that many
1448   upward levels of list nesting is replaced by the next form."
1449  (let ((point (current-point)))
1450    (pre-command-parse-check point)
1451    (with-mark ((form-start point :right-inserting)
1452                (form-end point))
1453      (unless (form-offset form-end 1) (editor-error))
1454      (form-offset (move-mark form-start form-end) -1)
1455      (with-mark ((containing-start form-start :left-inserting)
1456                  (containing-end form-end :left-inserting))
1457        (dotimes (i (or p 1))
1458          (unless (and (forward-up-list containing-end)
1459                       (backward-up-list containing-start))
1460            (editor-error)))
1461        (let ((r (copy-region (region form-start form-end))))
1462          (ring-push (delete-and-save-region
1463                      (region containing-start containing-end))
1464                     *kill-ring*)
1465          (ninsert-region point r)
1466          (move-mark point form-start))))))
1467
1468(defcommand "Extract List" (p)
1469  "Extract the current list.
1470  The current list replaces the surrounding list.  The entire affected
1471  area is pushed on the kill-ring.  With prefix argument, remove that
1472  many surrounding lists."
1473  "Replace the P containing lists with the current one."
1474  (let ((point (current-point)))
1475    (pre-command-parse-check point)
1476    (with-mark ((lstart point :right-inserting)
1477                (lend point))
1478      (if (eq (character-attribute :lisp-syntax (next-character lstart))
1479              :open-paren)
1480          (mark-after lend)
1481          (unless (backward-up-list lstart) (editor-error)))
1482      (unless (forward-up-list lend) (editor-error))
1483      (with-mark ((rstart lstart)
1484                  (rend lend))
1485        (dotimes (i (or p 1))
1486          (unless (and (forward-up-list rend) (backward-up-list rstart))
1487            (editor-error)))
1488        (let ((r (copy-region (region lstart lend))))
1489          (ring-push (delete-and-save-region (region rstart rend))
1490                     *kill-ring*)
1491          (ninsert-region point r)
1492          (move-mark point lstart))))))
1493
1494(defcommand "Transpose Forms" (p)
1495  "Transpose Forms immediately preceding and following the point.
1496  With a zero argument, tranposes the Forms at the point and the mark.
1497  With a positive argument, transposes the Form preceding the point
1498  with the p-th one following it.  With a negative argument, transposes the
1499  Form following the point with the p-th one preceding it."
1500  "Transpose Forms immediately preceding and following the point."
1501  (let ((point (current-point))
1502        (count (or p 1)))
1503    (pre-command-parse-check point)
1504    (if (zerop count)
1505        (let ((mark (current-mark)))
1506          (with-mark ((s1 mark :left-inserting)
1507                      (s2 point :left-inserting))
1508            (scan-char s1 :whitespace nil)
1509            (scan-char s2 :whitespace nil)
1510            (with-mark ((e1 s1 :right-inserting)
1511                        (e2 s2 :right-inserting))
1512              (unless (form-offset e1 1) (editor-error))
1513              (unless (form-offset e2 1) (editor-error))
1514              (ninsert-region s1 (delete-and-save-region (region s2 e2)))
1515              (ninsert-region s2 (delete-and-save-region (region s1 e1))))))
1516        (let ((fcount (if (plusp count) count 1))
1517              (bcount (if (plusp count) 1 count)))
1518          (with-mark ((s1 point :left-inserting)
1519                      (e2 point :right-inserting))
1520            (dotimes (i bcount)
1521              (unless (form-offset s1 -1) (editor-error)))
1522            (dotimes (i fcount)
1523              (unless (form-offset e2 1) (editor-error)))
1524            (with-mark ((e1 s1 :right-inserting)
1525                        (s2 e2 :left-inserting))
1526              (unless (form-offset e1 1) (editor-error))
1527              (unless (form-offset s2 -1) (editor-error))
1528              (ninsert-region s1 (delete-and-save-region (region s2 e2)))
1529              (ninsert-region s2 (delete-and-save-region (region s1 e1)))
1530              (move-mark point s2)))))))
1531
1532
1533(defcommand "Insert ()" (count)
1534  "Insert a pair of parentheses ().  With positive argument, puts
1535   parentheses around the next COUNT Forms, or previous COUNT forms, if
1536   COUNT is negative.  The point is positioned after the open parenthesis."
1537  "Insert a pair of parentheses ()."
1538  ;; TODO Form navigation is broken, so this is broken too -- it is
1539  ;; possible to put parens around more forms than there are in current
1540  ;; expression.  It works by moving past as many forms as there is, and
1541  ;; then each delimiting paren also counts as a form.
1542  (let ((point (current-point)))
1543    (pre-command-parse-check point)
1544    (cond (count
1545           (when (minusp count)
1546             (form-offset point count)
1547             (setq count (- count)))
1548           (insert-character point #\()
1549           (with-mark ((m point))
1550             (unless (form-offset m count)
1551               (editor-error "Could not find that many forms."))
1552             (insert-character m #\))))
1553          ;; The simple case with no prefix argument
1554          (t
1555           (insert-character point #\()
1556           (insert-character point #\))
1557           (mark-before point)))))
1558
1559
1560(defcommand "Move Over )" (p)
1561  "Move past the next close parenthesis, and start a new line.  Any
1562   indentation preceding the preceding the parenthesis is deleted, and the
1563   new line is indented.  If there is only whitespace preceding the close
1564   paren, the paren is moved to the end of the previous line. With prefix
1565   argument, this command moves past next closing paren and inserts space."
1566  "Move past the next close parenthesis, and start a new line."
1567  ;; TODO This is still not complete, because SCAN-CHAR finds the next
1568  ;; close-paren, but we need to find the next paren that closes current
1569  ;; expression.  This will have to be updated when form navigation is
1570  ;; fixed.
1571  (let ((point (current-point)))
1572    (pre-command-parse-check point)
1573    (with-mark ((m point :right-inserting))
1574      (cond ((scan-char m :lisp-syntax :close-paren)
1575             (cond ((same-line-p point m)
1576                    (delete-horizontal-space m))
1577                   (t
1578                    (move-mark point m)
1579                    (reverse-find-attribute point :whitespace #'zerop)
1580                    (delete-region (region point m))))
1581             (cond ((not p)
1582                    ;; Move to the previous line if current is empty
1583                    (when (zerop (mark-charpos m))
1584                      (delete-characters m -1))
1585                    (mark-after m)
1586                    (move-mark point m)
1587                    (indent-new-line-command 1))
1588                   (t
1589                    (mark-after m)
1590                    (move-mark point m)
1591                    (insert-character m #\space))))
1592            (t 
1593             (editor-error "Could not find closing paren."))))))
1594
1595
1596(defcommand "Forward Up List" (p)
1597  "Move forward past a one containing )."
1598  "Move forward past a one containing )."
1599  (let ((point (current-point-collapsing-selection))
1600        (count (or p 1)))
1601    (pre-command-parse-check point)
1602    (if (minusp count)
1603        (backward-up-list-command (- count))
1604        (with-mark ((m point))
1605          (dotimes (i count (move-mark point m))
1606            (unless (forward-up-list m) (editor-error)))))))
1607
1608
1609(defcommand "Backward Up List" (p)
1610  "Move backward past a one containing (."
1611  "Move backward past a one containing (."
1612  (let ((point (current-point-collapsing-selection))
1613        (count (or p 1)))
1614    (pre-command-parse-check point)
1615    (if (minusp count)
1616        (forward-up-list-command (- count))
1617        (with-mark ((m point))
1618          (dotimes (i count (move-mark point m))
1619            (unless (backward-up-list m) (editor-error)))))))
1620
1621
1622(defcommand "Down List" (p)
1623  "Move down a level in list structure.  With positive argument, moves down
1624   p levels.  With negative argument, moves down backward, but only one
1625   level."
1626  "Move down a level in list structure."
1627  (let ((point (current-point-collapsing-selection))
1628        (count (or p 1)))
1629    (pre-command-parse-check point)
1630    (with-mark ((m point))
1631      (cond ((plusp count)
1632             (loop repeat count
1633                   do (unless (and (scan-char m :lisp-syntax :open-paren)
1634                                   (mark-after m))
1635                        (editor-error))))
1636            (t
1637             (unless (and (rev-scan-char m :lisp-syntax :close-paren)
1638                          (mark-before m))
1639               (editor-error))))
1640      (move-mark point m))))
1641
1642
1643
1644;;;; Filling Lisp comments, strings, and indented text.
1645
1646(defhvar "Fill Lisp Comment Paragraph Confirm"
1647  "This determines whether \"Fill Lisp Comment Paragraph\" will prompt for
1648   confirmation to fill contiguous lines with the same initial whitespace when
1649   it is invoked outside of a comment or string."
1650  :value t)
1651
1652(defcommand "Fill Lisp Comment Paragraph" (p)
1653  "This fills a flushleft or indented Lisp comment.
1654   This also fills Lisp string literals using the proper indentation as a
1655   filling prefix.  When invoked outside of a comment or string, this tries
1656   to fill all contiguous lines beginning with the same initial, non-empty
1657   blankspace.  When filling a comment, the current line is used to determine a
1658   fill prefix by taking all the initial whitespace on the line, the semicolons,
1659   and any whitespace following the semicolons."
1660  "Fills a flushleft or indented Lisp comment."
1661  (declare (ignore p))
1662  (let ((point (current-point)))
1663    (pre-command-parse-check point)
1664    (with-mark ((start point)
1665                (end point)
1666                (m point))
1667      (let ((commentp (fill-lisp-comment-paragraph-prefix start end)))
1668        (cond (commentp
1669               (fill-lisp-comment-or-indented-text start end))
1670              ((and (not (valid-spot m nil))
1671                    (form-offset m -1)
1672                    (eq (character-attribute :lisp-syntax (next-character m))
1673                        :string-quote))
1674               (fill-lisp-string m))
1675              ((or (not (value fill-lisp-comment-paragraph-confirm))
1676                   (prompt-for-y-or-n
1677                    :prompt '("Not in a comment or string.  Fill contiguous ~
1678                               lines with the same initial whitespace? ")))
1679               (fill-lisp-comment-or-indented-text start end)))))))
1680
1681;;; FILL-LISP-STRING -- Internal.
1682;;;
1683;;; This fills the Lisp string containing mark as if it had been entered using
1684;;; Hemlock's Lisp string indentation, "Indent Function" for "Lisp" mode.  This
1685;;; assumes the area around mark has already been PRE-COMMAND-PARSE-CHECK'ed,
1686;;; and it ensures the string ends before doing any filling.  This function
1687;;; is undo'able.
1688;;;
1689(defun fill-lisp-string (mark)
1690  (with-mark ((end mark))
1691    (unless (form-offset end 1)
1692      (editor-error "Attempted to fill Lisp string, but it doesn't end?"))
1693    (let* ((mark (copy-mark mark :left-inserting))
1694           (end (copy-mark end :left-inserting))
1695           (string-region (region mark end))
1696           (undo-region (copy-region string-region))
1697           (hack (make-empty-region)))
1698      ;; Generate prefix.
1699      (indent-to-column (region-end hack) (1+ (mark-column mark)))
1700      ;; Skip opening double quote and fill string starting on its own line.
1701      (mark-after mark)
1702      (insert-character mark #\newline)
1703      (line-start mark)
1704      (setf (mark-kind mark) :right-inserting)
1705      (fill-region string-region (region-to-string hack))
1706      ;; Clean up inserted prefix on first line, delete inserted newline, and
1707      ;; move before the double quote for undo.
1708      (with-mark ((text mark :left-inserting))
1709        (find-attribute text :whitespace #'zerop)
1710        (delete-region (region mark text)))
1711      (delete-characters mark -1)
1712      (mark-before mark)
1713      ;; Save undo.
1714      (make-region-undo :twiddle "Fill Lisp Comment Paragraph"
1715                        string-region undo-region))))
1716
1717;;; FILL-LISP-COMMENT-OR-INDENTED-TEXT -- Internal.
1718;;;
1719;;; This fills all contiguous lines around start and end containing fill prefix
1720;;; designated by the region between start and end.  These marks can only be
1721;;; equal when there is no comment and no initial whitespace.  This is a bad
1722;;; situation since this function in that situation would fill the entire
1723;;; buffer into one paragraph.  This function is undo'able.
1724;;;
1725(defun fill-lisp-comment-or-indented-text (start end)
1726  (when (mark= start end)
1727    (editor-error "This command only fills Lisp comments, strings, or ~
1728                   indented text, but this line is flushleft."))
1729  ;;
1730  ;; Find comment block.
1731  (let* ((prefix (region-to-string (region start end)))
1732         (length (length prefix)))
1733    (declare (simple-string prefix))
1734    (flet ((frob (mark direction)
1735             (loop
1736               (let* ((line (line-string (mark-line mark)))
1737                      (line-len (length line)))
1738                 (declare (simple-string line))
1739                 (unless (string= line prefix :end1 (min line-len length))
1740                   (when (= direction -1)
1741                     (unless (same-line-p mark end) (line-offset mark 1 0)))
1742                   (return)))
1743               (unless (line-offset mark direction 0)
1744                 (when (= direction 1) (line-end mark))
1745                 (return)))))
1746      (frob start -1)
1747      (frob end 1))
1748    ;;
1749    ;; Do it undoable.
1750    (let* ((start1 (copy-mark start :right-inserting))
1751           (end2 (copy-mark end :left-inserting))
1752           (region (region start1 end2))
1753           (undo-region (copy-region region)))
1754      (fill-region region prefix)
1755      (make-region-undo :twiddle "Fill Lisp Comment Paragraph"
1756                        region undo-region))))
1757
1758;;; FILL-LISP-COMMENT-PARAGRAPH-PREFIX -- Internal.
1759;;;
1760;;; This sets start and end around the prefix to be used for filling.  We
1761;;; assume we are dealing with a comment.  If there is no ";", then we try to
1762;;; find some initial whitespace.  If there is a ";", we make sure the line is
1763;;; blank before it to eliminate ";"'s in the middle of a line of text.
1764;;; Finally, if we really have a comment instead of some indented text, we skip
1765;;; the ";"'s and any immediately following whitespace.  We allow initial
1766;;; whitespace, so we can fill strings with the same command.
1767;;;
1768(defun fill-lisp-comment-paragraph-prefix (start end)
1769  (line-start start)
1770  (let ((commentp t)) ; Assumes there's a comment.
1771    (unless (to-line-comment (line-start end) ";")
1772      (find-attribute end :whitespace #'zerop)
1773      #|(when (start-line-p end)
1774        (editor-error "No comment on line, and no initial whitespace."))|#
1775      (setf commentp nil))
1776    (when commentp
1777      (unless (blank-before-p end)
1778        (find-attribute (line-start end) :whitespace #'zerop)
1779        #|(when (start-line-p end)
1780          (editor-error "Semicolon preceded by unindented text."))|#
1781        (setf commentp nil)))
1782    (when commentp
1783      (find-attribute end :lisp-syntax #'(lambda (x) (not (eq x :comment))))
1784      (find-attribute end :whitespace #'zerop))
1785    commentp))
1786
1787
1788
1789;;;; "Lisp" mode.
1790
1791(defcommand "LISP Mode" (p)
1792  "Put current buffer in LISP mode." 
1793  "Put current buffer in LISP mode." 
1794  (declare (ignore p))
1795  (setf (buffer-major-mode (current-buffer)) "LISP"))
1796
1797
1798(defmode "Lisp" :major-p t :setup-function 'setup-lisp-mode)
1799
1800
1801(defun buffer-first-in-package-form (buffer)
1802  "Returns the package name referenced in the first apparent IN-PACKAGE
1803   form in buffer, or NIL if it can't find an IN-PACKAGE."
1804  (let* ((pattern (new-search-pattern :string-insensitive :forward "in-package" nil))
1805         (mark (copy-mark (buffer-start-mark buffer))))
1806    (with-mark ((start mark)
1807                (end mark))
1808      (loop
1809        (unless (find-pattern mark pattern)
1810          (return))
1811        (pre-command-parse-check mark)
1812        (when (valid-spot mark t)
1813          (move-mark end mark)
1814          (when (form-offset end 1)
1815            (move-mark start end)
1816            (when (backward-up-list start)
1817              (when (scan-char start :lisp-syntax :constituent)
1818                (let* ((s (nstring-upcase (region-to-string (region start end))))
1819                       (*package* (find-package "CL-USER")))
1820                  (unless (eq (ignore-errors (values (read-from-string s)))
1821                              'in-package)
1822                    (return)))
1823                (unless (form-offset end 1) (return))
1824                (move-mark start end)
1825                (form-offset start -1)
1826                (let* ((pkgname (ignore-errors (values (read-from-string (region-to-string (region start end)))))))
1827                  (return
1828                    (if pkgname
1829                      (values (ignore-errors (string pkgname))))))))))))))
1830
1831(defparameter *previous-in-package-search-pattern*
1832    (new-search-pattern :string-insensitive :backward "in-package" nil))
1833
1834(defun package-at-mark (start-mark)
1835  (let* ((pattern *previous-in-package-search-pattern*)
1836         (mark (copy-mark start-mark :temporary)))
1837    (with-mark ((start mark)
1838                (end mark)
1839                (list-end mark))
1840      (loop
1841        (unless (find-pattern mark pattern)
1842          (return))
1843        (pre-command-parse-check mark)
1844        (when (valid-spot mark t)
1845          (move-mark end mark)
1846          (when (form-offset end 1)
1847            (move-mark start end)
1848            (when (backward-up-list start)
1849              (move-mark list-end start)
1850              (unless (and (list-offset list-end 1)
1851                           (mark<= list-end start-mark))
1852                (return))
1853              (when (scan-char start :lisp-syntax :constituent)
1854                (unless (or (mark= mark start)
1855                            (let* ((s (nstring-upcase (region-to-string (region start end))))
1856                                   (*package* (find-package "CL-USER")))
1857                              (eq (ignore-errors (values (read-from-string s)))
1858                                  'in-package)))
1859                  (return))
1860                (unless (form-offset end 1) (format t "~& worse") (return 4))
1861                (move-mark start end)
1862                (form-offset start -1)
1863                (return
1864                  (if (eql (next-character start) #\")
1865                    (progn
1866                      (character-offset start 1)
1867                      (character-offset end -1)
1868                      (region-to-string (region start end)))
1869                    (let* ((pkgname (ignore-errors (values (read-from-string (region-to-string (region start end)))))))
1870                      (if pkgname
1871                        (values (ignore-errors (string pkgname)))))))))))))))
1872
1873(defun ensure-buffer-package (buffer)
1874  (or (variable-value 'current-package :buffer buffer)
1875      (setf (variable-value 'current-package :buffer buffer)
1876            (buffer-first-in-package-form buffer))))
1877
1878(defun buffer-package (buffer)
1879  (when (hemlock-bound-p 'current-package :buffer buffer)
1880    (let ((package-name (variable-value 'current-package :buffer buffer)))
1881      (find-package package-name))))
1882
1883(defun setup-lisp-mode (buffer)
1884  (unless (hemlock-bound-p 'current-package :buffer buffer)
1885    (defhvar "Current Package"
1886      "The package used for evaluation of Lisp in this buffer."
1887      :buffer buffer
1888      :value "CL-USER"
1889      :hooks (list 'package-name-change-hook))))
1890
1891
1892
1893
1894
1895;;;; Some mode variables to coordinate with other stuff.
1896
1897(defhvar "Auto Fill Space Indent"
1898  "When non-nil, uses \"Indent New Comment Line\" to break lines instead of
1899   \"New Line\"."
1900  :mode "Lisp" :value t)
1901
1902(defhvar "Comment Start"
1903  "String that indicates the start of a comment."
1904  :mode "Lisp" :value ";")
1905
1906(defhvar "Comment Begin"
1907  "String that is inserted to begin a comment."
1908  :mode "Lisp" :value "; ")
1909
1910(defhvar "Indent Function"
1911  "Indentation function which is invoked by \"Indent\" command.
1912   It must take one argument that is the prefix argument."
1913  :value 'indent-for-lisp
1914  :mode "Lisp")
1915
1916(defun string-to-arglist (string buffer &optional quiet-if-unknown)
1917  (multiple-value-bind (name error)
1918      (let* ((*package* (or
1919                         (find-package
1920                          (variable-value 'current-package :buffer buffer))
1921                         *package*)))
1922        (ignore-errors (values (read-from-string string))))
1923    (unless error
1924      (when (typep name 'symbol)
1925        (multiple-value-bind (arglist win)
1926            (ccl::arglist-string name)
1927          (if (or win (not quiet-if-unknown))
1928            (format nil "~S : ~A" name (if win (or arglist "()") "(unknown)"))))))))
1929
1930(defcommand "Current Function Arglist" (p)
1931  "Show arglist of function whose name precedes point."
1932  "Show arglist of function whose name precedes point."
1933  (declare (ignore p))
1934  (let ((point (current-point)))
1935    (pre-command-parse-check point)
1936    (with-mark ((mark1 point)
1937                (mark2 point))
1938      (when (backward-up-list mark1)
1939        (when (form-offset (move-mark mark2 (mark-after mark1)) 1)
1940          (let* ((fun-name (region-to-string (region mark1 mark2)))
1941                 (arglist-string (string-to-arglist fun-name (current-buffer))))
1942            (when arglist-string
1943              (message arglist-string))))))))
1944
1945(defcommand "Arglist On Space" (p)
1946  "Insert a space, then show the current function's arglist."
1947  "Insert a space, then show the current function's arglist."
1948  (declare (ignore p))
1949  (let ((point (current-point)))
1950    (insert-character point #\Space)
1951    (pre-command-parse-check point)
1952    (with-mark ((mark1 point)
1953                (mark2 point))
1954      (when (backward-up-list mark1)
1955        (when (form-offset (move-mark mark2 (mark-after mark1)) 1)
1956          (with-mark ((mark3 mark2))
1957            (do* ()
1958                 ((mark= mark3 point)
1959                  (let* ((fun-name (region-to-string (region mark1 mark2)))
1960                         (arglist-string
1961                          (string-to-arglist fun-name (current-buffer) t)))
1962                    (when arglist-string
1963                      (message arglist-string))))
1964              (if (ccl::whitespacep (next-character mark3))
1965                (mark-after mark3)
1966                (return nil)))))))))
1967
1968(hi:defcommand "Show Callers" (p)
1969  "Display a scrolling list of the callers of the symbol at point.
1970   Double-click a row to go to the caller's definition."
1971  (declare (ignore p))
1972  (with-mark ((mark1 (current-point))
1973              (mark2 (current-point)))
1974    (mark-symbol mark1 mark2)
1975    (with-input-from-region (s (region mark1 mark2))
1976      (let* ((symbol (read s)))
1977        (hemlock-ext:open-sequence-dialog
1978         :title (format nil "Callers of ~a" symbol)
1979         :sequence (ccl::callers symbol)
1980         :action #'edit-definition)))))
1981
1982;; Note this isn't necessarily called from hemlock, e.g. it might be called by cl:ed,
1983;; from any thread, or it might be called from a sequence dialog, etc.
1984(defun edit-definition (name)
1985  (flet ((get-source-alist (name)
1986           (mapcar #'(lambda (item) (cons name item))
1987                   (ccl::get-source-files-with-types&classes name))))
1988    (let* ((info (get-source-alist name)))
1989      (when (null info)
1990        (let* ((seen (list name))
1991               (found ())
1992               (pname (symbol-name name)))
1993          (dolist (pkg (list-all-packages))
1994            (let ((sym (find-symbol pname pkg)))
1995              (when (and sym (not (member sym seen)))
1996                (let ((new (get-source-alist sym)))
1997                  (when new
1998                    (setq info (nconc new info))
1999                    (push sym found)))
2000                (push sym seen))))
2001          (when found
2002            ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer).
2003            (loud-message "No definitions for ~s, using ~s instead"
2004                          name (if (cdr found) found (car found))))))
2005      (if info
2006        (if (cdr info)
2007          (hemlock-ext:open-sequence-dialog
2008           :title (format nil "Definitions of ~s" name)
2009           :sequence info
2010           :action #'(lambda (item) (hemlock-ext:edit-single-definition (car item) (cdr item)))
2011           :printer #'(lambda (item stream) (prin1 (cadr item) stream)))
2012          (hemlock-ext:edit-single-definition (caar info) (cdar info)))
2013        (editor-error "No known definitions for ~s" name)))))
2014
2015#||
2016(defcommand "Set Package Name" (p)
2017  (variable-value 'current-package :buffer buffer)
2018||#               
Note: See TracBrowser for help on using the repository browser.