/[cmucl]/src/hemlock/lispmode.lisp
ViewVC logotype

Contents of /src/hemlock/lispmode.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.2 - (hide annotations) (vendor branch)
Fri Jul 13 19:28:24 1990 UTC (23 years, 9 months ago) by ram
Changes since 1.1.1.1: +26 -0 lines
*** empty log message ***
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the Spice Lisp project at
5     ;;; Carnegie-Mellon University, and has been placed in the public domain.
6     ;;; Spice Lisp is currently incomplete and under active development.
7     ;;; If you want to use this code or any part of Spice Lisp, please contact
8     ;;; Scott Fahlman (FAHLMAN@CMUC).
9     ;;; **********************************************************************
10     ;;;
11     ;;; Hemlock LISP Mode commands
12     ;;;
13     ;;; Written by Ivan Vazquez and Bill Maddox.
14     ;;;
15    
16     (in-package "HEMLOCK")
17    
18    
19    
20     ;;;; #### VARIABLES ####
21     ;;;
22     ;;; These routines are used to define, for standard LISP mode, the start and end
23     ;;; of a block to parse. If these need to be changed for a minor mode that sits
24     ;;; on top of LISP mode, simply do a DEFHVAR with the minor mode and give the
25     ;;; name of the function to use instead of START-OF-PARSE-BLOCK and
26     ;;; END-OF-PARSE-BLOCK.
27     ;;;
28    
29     (defhvar "Parse Start Function"
30     "Take a mark and move it to the top of a block for paren parsing."
31     :value 'start-of-parse-block)
32    
33     (defhvar "Parse End Function"
34     "Take a mark and move it to the bottom of a block for paren parsing."
35     :value 'end-of-parse-block)
36    
37    
38     ;;;; #### STRUCTURES ####
39     ;;;
40     ;;; LISP-INFO is the structure used to store the data about the line in its Plist.
41     ;;;
42     ;;; -> BEGINS-QUOTED, ENDING-QUOTED are both Boolean slots that tell whether
43     ;;; or not a line's begining and/or ending are quoted.
44     ;;;
45     ;;; -> RANGES-TO-IGNORE is a list of cons cells, each having the form
46     ;;; ( [begining-charpos] [end-charpos] ) each of these cells indicating
47     ;;; a range to ignore. End is exclusive.
48     ;;;
49     ;;; -> NET-OPEN-PARENS, NET-CLOSE-PARENS integers that are the number of
50     ;;; unmatched opening and closing parens that there are on a line.
51     ;;;
52     ;;; -> SIGNATURE-SLOT ...
53     ;;;
54    
55     (defstruct (lisp-info (:constructor make-lisp-info ()))
56     (begins-quoted nil) ; (or t nil)
57     (ending-quoted nil) ; (or t nil)
58     (ranges-to-ignore nil) ; (or t nil)
59     (net-open-parens 0 :type fixnum)
60     (net-close-parens 0 :type fixnum)
61     (signature-slot))
62    
63    
64    
65     ;;;; #### MACROS ####
66     ;;;
67     ;;; The following Macros exist to make it easy to acces the Syntax primitives
68     ;;; without uglifying the code. They were originally written by Maddox.
69     ;;;
70    
71     (defmacro scan-char (mark attribute values)
72     `(find-attribute ,mark ',attribute ,(attr-predicate values)))
73    
74     (defmacro rev-scan-char (mark attribute values)
75     `(reverse-find-attribute ,mark ',attribute ,(attr-predicate values)))
76    
77     (defmacro test-char (char attribute values)
78     `(let ((x (character-attribute ',attribute ,char)))
79     ,(attr-predicate-aux values)))
80    
81     (eval-when (compile load eval)
82     (defun attr-predicate (values)
83     (cond ((eq values 't)
84     '#'plusp)
85     ((eq values 'nil)
86     '#'zerop)
87     (t `#'(lambda (x) ,(attr-predicate-aux values)))))
88    
89     (defun attr-predicate-aux (values)
90     (cond ((eq values t)
91     '(plusp x))
92     ((eq values nil)
93     '(zerop x))
94     ((symbolp values)
95     `(eq x ',values))
96     ((and (listp values) (member (car values) '(and or not)))
97     (cons (car values) (mapcar #'attr-predicate-aux (cdr values))))
98     (t (error "Illegal form in attribute pattern - ~S" values))))
99    
100     ); Eval-When (Compile Load Eval)
101    
102     ;;;
103     ;;; FIND-LISP-CHAR
104    
105     (defmacro find-lisp-char (mark)
106     "Move MARK to next :LISP-SYNTAX character, if one isn't found, return NIL."
107     `(find-attribute ,mark :lisp-syntax
108     #'(lambda (x)
109     (member x '(:open-paren :close-paren :newline :comment
110     :char-quote :string-quote)))))
111     ;;;
112     ;;; PUSH-RANGE
113    
114     (defmacro push-range (new-range info-struct)
115     "Insert NEW-RANGE into the LISP-INFO-RANGES-TO-IGNORE slot of the INFO-STRUCT."
116     `(when ,new-range
117     (setf (lisp-info-ranges-to-ignore ,info-struct)
118     (cons ,new-range (lisp-info-ranges-to-ignore ,info-struct)))))
119     ;;;
120     ;;; SCAN-DIRECTION
121    
122     (defmacro scan-direction (mark forwardp &rest forms)
123     "Expand to a form that scans either backward or forward according to Forwardp."
124     (if forwardp
125     `(scan-char ,mark ,@forms)
126     `(rev-scan-char ,mark ,@forms)))
127     ;;;
128     ;;; DIRECTION-CHAR
129    
130     (defmacro direction-char (mark forwardp)
131     "Expand to a form that returns either the previous or next character according
132     to Forwardp."
133     (if forwardp
134     `(next-character ,mark)
135     `(previous-character ,mark)))
136    
137     ;;;
138     ;;; NEIGHBOR-MARK
139    
140     (defmacro neighbor-mark (mark forwardp)
141     "Expand to a form that moves MARK either backward or forward one character,
142     depending on FORWARDP."
143     (if forwardp
144     `(mark-after ,mark)
145     `(mark-before ,mark)))
146    
147     ;;;
148     ;;; NEIGHBOR-LINE
149    
150     (defmacro neighbor-line (line forwardp)
151     "Expand to return the next or previous line, according to Forwardp."
152     (if forwardp
153     `(line-next ,line)
154     `(line-previous ,line)))
155    
156    
157     ;;;; #### PARSING FUNCTIONS ###
158     ;;;
159     ;;; PRE-COMMAND-PARSE-CHECK
160    
161     (defun pre-command-parse-check (mark &optional (fer-sure-parse nil))
162     "Parse the area before the command is actually executed."
163     (with-mark ((top mark)
164     (bottom mark))
165     (funcall (value parse-start-function) top)
166     (funcall (value parse-end-function) bottom)
167     (parse-over-block (mark-line top) (mark-line bottom) fer-sure-parse)))
168    
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    
232     (defhvar "Minimum Lines Parsed"
233     "The minimum number of lines before and after the point parsed by Lisp mode."
234     :value 50)
235     (defhvar "Maximum Lines Parsed"
236     "The maximum number of lines before and after the point parsed by Lisp mode."
237     :value 500)
238     (defhvar "Defun Parse Goal"
239     "Lisp mode parses the region obtained by skipping this many defuns forward
240     and backward from the point unless this falls outside of the range specified
241     by \"Minimum Lines Parsed\" and \"Maximum Lines Parsed\"."
242     :value 2)
243    
244    
245     (macrolet ((frob (step end)
246     `(let ((min (value minimum-lines-parsed))
247     (max (value maximum-lines-parsed))
248     (goal (value defun-parse-goal))
249     (last-defun nil))
250     (declare (fixnum min max goal))
251     (do ((line (mark-line mark) (,step line))
252     (count 0 (1+ count)))
253     ((null line)
254     (,end mark))
255     (declare (fixnum count))
256     (when (char= (line-character line 0) #\()
257     (setq last-defun line)
258     (decf goal)
259     (when (and (<= goal 0) (>= count min))
260     (line-start mark line)
261     (return)))
262     (when (> count max)
263     (line-start mark (or last-defun line))
264     (return))))))
265    
266     (defun start-of-parse-block (mark)
267     (frob line-previous buffer-start))
268    
269     (defun end-of-parse-block (mark)
270     (frob line-next buffer-end)))
271    
272     ;;;
273     ;;; START-OF-SEARCH-LINE
274    
275     (defun start-of-search-line (line)
276     "Set LINE to the begining line of the block of text to parse."
277     (with-mark ((mark (mark line 0)))
278     (funcall (value 'Parse-Start-Function) mark)
279     (setq line (mark-line mark))))
280    
281     ;;;
282     ;;; END-OF-SEACH-LINE
283    
284     (defun end-of-search-line (line)
285     "Set LINE to the ending line of the block of text to parse."
286     (with-mark ((mark (mark line 0)))
287     (funcall (value 'Parse-End-Function) mark)
288     (setq line (mark-line mark))))
289    
290    
291     ;;; PARSE-LISP-LINE-INFO parses through the line doing the following things:
292     ;;;
293     ;;; Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS.
294     ;;;
295     ;;; Making all areas of the line that should be invalid (comments,
296     ;;; char-quotes, and the inside of strings) and such be in
297     ;;; RANGES-TO-IGNORE.
298     ;;;
299     ;;; Set BEGINS-QUOTED and ENDING-QUOTED
300     ;;;
301    
302     (defun parse-lisp-line-info (mark line-info prev-line-info)
303     "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS,
304     RANGES-TO-INGORE, and ENDING-QUOTED."
305     (let ((net-open-parens 0)
306     (net-close-parens 0))
307     (declare (fixnum net-open-parens net-close-parens))
308    
309     ;; Re-set the slots necessary
310    
311     (setf (lisp-info-ranges-to-ignore line-info) nil)
312    
313     ;; The only way the current line begins quoted is when there
314     ;; is a previous line and it's ending was quoted.
315    
316     (setf (lisp-info-begins-quoted line-info)
317     (and prev-line-info
318     (lisp-info-ending-quoted prev-line-info)))
319    
320     (if (lisp-info-begins-quoted line-info)
321     (deal-with-string-quote mark line-info)
322     (setf (lisp-info-ending-quoted line-info) nil))
323    
324     (unless (lisp-info-ending-quoted line-info)
325     (loop
326     (find-lisp-char mark)
327     (ecase (character-attribute :lisp-syntax (next-character mark))
328    
329     (:open-paren
330     (setq net-open-parens (1+ net-open-parens))
331     (mark-after mark))
332    
333     (:close-paren
334     (if (zerop net-open-parens)
335     (setq net-close-parens (1+ net-close-parens))
336     (setq net-open-parens (1- net-open-parens)))
337     (mark-after mark))
338    
339     (:newline
340     (setf (lisp-info-ending-quoted line-info) nil)
341     (return t))
342    
343     (:comment
344     (push-range (cons (mark-charpos mark) (line-length (mark-line mark)))
345     line-info)
346     (setf (lisp-info-ending-quoted line-info) nil)
347     (return t))
348    
349     (:char-quote
350     (mark-after mark)
351     (push-range (cons (mark-charpos mark) (1+ (mark-charpos mark)))
352     line-info)
353     (mark-after mark))
354    
355     (:string-quote
356     (mark-after mark)
357     (unless (deal-with-string-quote mark line-info)
358     (setf (lisp-info-ending-quoted line-info) t)
359     (return t))))))
360    
361     (setf (lisp-info-net-open-parens line-info) net-open-parens)
362     (setf (lisp-info-net-close-parens line-info) net-close-parens)
363     (setf (lisp-info-signature-slot line-info)
364     (line-signature (mark-line mark)))))
365    
366     ;;;; #### STRING QUOTE UTILITIES ####
367     ;;;
368     ;;;
369    
370     ;;;
371     ;;; VALID-STRING-QUOTE-P
372    
373     (defmacro valid-string-quote-p (mark forwardp)
374     "Return T if the string-quote indicated by MARK is valid."
375     (let ((test-mark (gensym)))
376     `(with-mark ((,test-mark ,mark))
377    
378     ,(unless forwardp ; TEST-MARK should always be right before the
379     `(mark-before ,test-mark)) ; String-quote to be checked.
380    
381     (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote)
382    
383     (let ((slash-count 0))
384    
385     (loop
386     (mark-before ,test-mark)
387     (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote)
388     (incf slash-count)
389     (return t)))
390     (not (oddp slash-count)))))))
391    
392     ;;;
393     ;;; FIND-VALID-STRING-QUOTE
394    
395     (defmacro find-valid-string-quote (mark &key forwardp (cease-at-eol nil))
396     "Expand to a form that will leave MARK before a valid string-quote character,
397     in either a forward or backward direction, according to FORWARDP. If
398     CEASE-AT-EOL is T then it will return nil if encountering the EOL before a
399     valid string-quote."
400     (let ((e-mark (gensym)))
401     `(with-mark ((,e-mark ,mark))
402    
403     (loop
404     (unless (scan-direction ,e-mark ,forwardp :lisp-syntax
405     ,(if cease-at-eol
406     `(or :newline :string-quote)
407     `:string-quote))
408     (return nil))
409    
410     ,@(if cease-at-eol
411     `((when (test-char (direction-char ,e-mark ,forwardp) :lisp-syntax
412     :newline)
413     (return nil))))
414    
415     (when (valid-string-quote-p ,e-mark ,forwardp)
416     (move-mark ,mark ,e-mark)
417     (return t))
418    
419     (neighbor-mark ,e-mark ,forwardp)))))
420    
421     ;;; DEAL-WITH-STRING-QUOTE
422     ;;;
423     ;;; Called when a string is begun (i.e. parse hits a #\"). It checks for a
424     ;;; matching quote on the line that MARK points to, and puts the
425     ;;; appropriate area in the RANGES-TO-IGNORE slot and leaves MARK pointing
426     ;;; after this area. The "appropriate area" is from MARK to the end of the
427     ;;; line or the matching string-quote, whichever comes first.
428    
429     (defun deal-with-string-quote (mark info-struct)
430     "Alter the current line's info struct as necessary as due to encountering a
431     string quote character."
432     (with-mark ((e-mark mark))
433    
434     (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t)
435    
436     ;; If matching quote is on this line then mark the area between
437     ;; the first quote (MARK) and the matching quote as invalid by
438     ;; pushing its begining and ending into the IGNORE-RANGE.
439    
440     (push-range (cons (mark-charpos mark) (mark-charpos e-mark))
441     info-struct)
442    
443     (setf (lisp-info-ending-quoted info-struct) nil)
444     (mark-after e-mark)
445     (move-mark mark e-mark))
446    
447     ;; If the EOL has been hit before the matching quote then mark
448     ;; the area from MARK to the EOL as invalid.
449    
450     (t
451     (push-range (cons (mark-charpos mark) (1+ (line-length (mark-line mark))))
452     info-struct)
453    
454     ;; The Ending is marked as still being quoted.
455    
456     (setf (lisp-info-ending-quoted info-struct) t)
457     (line-end mark)
458     nil))))
459    
460    
461     ;;;; Character validity checking:
462    
463     ;;; Find-Ignore-Region -- Internal
464     ;;;
465     ;;; If the character in the specified direction from Mark is in an ignore
466     ;;; region, then return the region and the line that the region is in as
467     ;;; values. If there is no ignore region, then return NIL and the Mark-Line.
468     ;;; If the line is not parsed, or there is no character (because of being at
469     ;;; the buffer beginning or end), then return both values NIL.
470     ;;;
471     (defun find-ignore-region (mark forwardp)
472     (declare (fixnum pos))
473     (flet ((scan (line pos)
474     (declare (fixnum pos))
475     (let ((info (getf (line-plist line) 'lisp-info)))
476     (if info
477     (dolist (range (lisp-info-ranges-to-ignore info)
478     (values nil line))
479     (let ((start (car range))
480     (end (cdr range)))
481     (declare (fixnum start end))
482     (when (and (>= pos start) (< pos end))
483     (return (values range line)))))
484     (values nil nil)))))
485     (let ((pos (mark-charpos mark))
486     (line (mark-line mark)))
487     (declare (fixnum pos))
488     (cond (forwardp (scan line pos))
489     ((> pos 0) (scan line (1- pos)))
490     (t
491     (let ((prev (line-previous line)))
492     (if prev
493     (scan prev (line-length prev))
494     (values nil nil))))))))
495    
496    
497     ;;; Valid-Spot -- Public
498     ;;;
499     (defun valid-spot (mark forwardp)
500     "Return true if the character pointed to by Mark is not in a quoted context,
501     false otherwise. If Forwardp is true, we use the next character, otherwise
502     we use the previous."
503     (multiple-value-bind (region line)
504     (find-ignore-region mark forwardp)
505     (and line (not region))))
506    
507    
508     ;;; Scan-Direction-Valid -- Internal
509     ;;;
510     ;;; Like scan-direction, but only stop on valid characters.
511     ;;;
512     (defmacro scan-direction-valid (mark forwardp &rest forms)
513     (let ((n-mark (gensym))
514     (n-line (gensym))
515     (n-region (gensym))
516     (n-won (gensym)))
517     `(let ((,n-mark ,mark) (,n-won nil))
518     (loop
519     (multiple-value-bind (,n-region ,n-line)
520     (find-ignore-region ,n-mark ,forwardp)
521     (unless ,n-line (return nil))
522     (if ,n-region
523     (move-to-position ,n-mark
524     ,(if forwardp
525     `(cdr ,n-region)
526     `(car ,n-region))
527     ,n-line)
528     (when ,n-won (return t)))
529     ;;
530     ;; Peculiar condition when a quoting character terminates a line.
531     ;; The ignore region is off the end of the line causing %FORM-OFFSET
532     ;; to infinitely loop.
533     (when (> (mark-charpos ,n-mark) (line-length ,n-line))
534     (line-offset ,n-mark 1 0))
535     (unless (scan-direction ,n-mark ,forwardp ,@forms)
536     (return nil))
537     (setq ,n-won t))))))
538    
539    
540     ;;;; #### LIST-OFFSETING ####
541     ;;;
542     ;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built
543     ;;; with the same existing structure, with the altering of one variable.
544     ;;; This one variable being FORWARDP.
545     ;;;
546     (defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) )
547     "Expand to code that will go forward one list either backward or forward,
548     according to the FORWARDP flag."
549     (let ((mark (gensym)))
550     `(let ((paren-count ,extra-parens))
551     (declare (fixnum paren-count))
552     (with-mark ((,mark ,actual-mark))
553     (loop
554     (scan-direction ,mark ,forwardp :lisp-syntax
555     (or :close-paren :open-paren :newline))
556     (let ((ch (direction-char ,mark ,forwardp)))
557     (unless ch (return nil))
558     (when (valid-spot ,mark ,forwardp)
559     (case (character-attribute :lisp-syntax ch)
560     (:close-paren
561     (decf paren-count)
562     ,(when forwardp ; When going forward, an unmatching
563     `(when (<= paren-count 0) ; close-paren means the end of list.
564     (neighbor-mark ,mark ,forwardp)
565     (move-mark ,actual-mark ,mark)
566     (return t))))
567     (:open-paren
568     (incf paren-count)
569     ,(unless forwardp ; Same as above only end of list
570     `(when (>= paren-count 0) ; is opening parens.
571     (neighbor-mark ,mark ,forwardp)
572     (move-mark ,actual-mark ,mark)
573     (return t))))
574    
575     (:newline
576     ;; When a #\Newline is hit, then the matching paren must lie on
577     ;; some other line so drop down into the multiple line balancing
578     ;; function: QUEST-FOR-BALANCING-PAREN
579     ;; If no paren seen yet, keep going.
580     (cond ((zerop paren-count))
581     ((quest-for-balancing-paren ,mark paren-count ,forwardp)
582     (move-mark ,actual-mark ,mark)
583     (return t))
584     (t
585     (return nil)))))))
586    
587     (neighbor-mark ,mark ,forwardp))))))
588    
589     ;;;
590     ;;; QUEST-FOR-BALANCING-PAREN
591    
592     (defmacro quest-for-balancing-paren (mark paren-count forwardp)
593     "Expand to a form that finds the the balancing paren for however many opens or
594     closes are registered by Paren-Count."
595     `(let* ((line (mark-line ,mark)))
596     (loop
597     (setq line (neighbor-line line ,forwardp))
598     (unless line (return nil))
599     (let ((line-info (getf (line-plist line) 'lisp-info))
600     (unbal-paren ,paren-count))
601     (unless line-info (return nil))
602    
603     ,(if forwardp
604     `(decf ,paren-count (lisp-info-net-close-parens line-info))
605     `(incf ,paren-count (lisp-info-net-open-parens line-info)))
606    
607     (when ,(if forwardp
608     `(<= ,paren-count 0)
609     `(>= ,paren-count 0))
610     ,(if forwardp
611     `(line-start ,mark line)
612     `(line-end ,mark line))
613     (return (goto-correct-paren-char ,mark unbal-paren ,forwardp)))
614    
615     ,(if forwardp
616     `(incf ,paren-count (lisp-info-net-open-parens line-info))
617     `(decf ,paren-count (lisp-info-net-close-parens line-info)))))))
618    
619    
620     ;;;
621     ;;; GOTO-CORRECT-PAREN-CHAR
622    
623     (defmacro goto-correct-paren-char (mark paren-count forwardp)
624     "Expand to a form that will leave MARK on the correct balancing paren matching
625     however many are indicated by COUNT."
626     `(with-mark ((m ,mark))
627     (let ((count ,paren-count))
628     (loop
629     (scan-direction m ,forwardp :lisp-syntax
630     (or :close-paren :open-paren :newline))
631     (when (valid-spot m ,forwardp)
632     (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
633     (:close-paren
634     (decf count)
635     ,(when forwardp
636     `(when (zerop count)
637     (neighbor-mark m ,forwardp)
638     (move-mark ,mark m)
639     (return t))))
640    
641     (:open-paren
642     (incf count)
643     ,(unless forwardp
644     `(when (zerop count)
645     (neighbor-mark m ,forwardp)
646     (move-mark ,mark m)
647     (return t))))))
648     (neighbor-mark m ,forwardp)))))
649    
650    
651     (defun list-offset (mark offset)
652     (if (plusp offset)
653     (dotimes (i offset t)
654     (unless (%list-offset mark t) (return nil)))
655     (dotimes (i (- offset) t)
656     (unless (%list-offset mark nil) (return nil)))))
657    
658     (defun forward-up-list (mark)
659     "Moves mark just past the closing paren of the immediately containing list."
660     (%list-offset mark t :extra-parens 1))
661    
662     (defun backward-up-list (mark)
663     "Moves mark just before the opening paren of the immediately containing list."
664     (%list-offset mark nil :extra-parens -1))
665    
666    
667    
668     ;;;; Top level form location hacks (open parens beginning lines).
669    
670     ;;; NEIGHBOR-TOP-LEVEL is used only in TOP-LEVEL-OFFSET.
671     ;;;
672     (eval-when (compile eval)
673     (defmacro neighbor-top-level (line forwardp)
674     `(loop
675     (when (test-char (line-character ,line 0) :lisp-syntax :open-paren)
676     (return t))
677     (setf ,line ,(if forwardp `(line-next ,line) `(line-previous ,line)))
678     (unless ,line (return nil))))
679     ) ;eval-when
680    
681     (defun top-level-offset (mark offset)
682     "Go forward or backward offset number of top level forms. Mark is
683     returned if offset forms exists, otherwise nil."
684     (declare (fixnum offset))
685     (let* ((line (mark-line mark))
686     (at-start (test-char (line-character line 0) :lisp-syntax :open-paren)))
687     (cond ((zerop offset) mark)
688     ((plusp offset)
689     (do ((offset (if at-start offset (1- offset))
690     (1- offset)))
691     (nil)
692     (declare (fixnum offset))
693     (unless (neighbor-top-level line t) (return nil))
694     (when (zerop offset) (return (line-start mark line)))
695     (unless (setf line (line-next line)) (return nil))))
696     (t
697     (do ((offset (if (and at-start (start-line-p mark))
698     offset
699     (1+ offset))
700     (1+ offset)))
701     (nil)
702     (declare (fixnum offset))
703     (unless (neighbor-top-level line nil) (return nil))
704     (when (zerop offset) (return (line-start mark line)))
705     (unless (setf line (line-previous line)) (return nil)))))))
706    
707    
708     (defun mark-top-level-form (mark1 mark2)
709     "Moves mark1 and mark2 to the beginning and end of the current or next defun.
710     Mark1 one is used as a reference. The marks may be altered even if
711     unsuccessful. if successful, return mark2, else nil."
712     (let ((winp (cond ((inside-defun-p mark1)
713     (cond ((not (top-level-offset mark1 -1)) nil)
714     ((not (form-offset (move-mark mark2 mark1) 1)) nil)
715     (t mark2)))
716     ((start-defun-p mark1)
717     (form-offset (move-mark mark2 mark1) 1))
718     ((and (top-level-offset (move-mark mark2 mark1) -1)
719     (start-defun-p mark2)
720     (form-offset mark2 1)
721     (same-line-p mark1 mark2))
722     (form-offset (move-mark mark1 mark2) -1)
723     mark2)
724     ((top-level-offset mark1 1)
725     (form-offset (move-mark mark2 mark1) 1)))))
726     (when winp
727     (when (blank-after-p mark2) (line-offset mark2 1 0))
728     mark2)))
729    
730     (defun inside-defun-p (mark)
731     "T if the current point is (supposedly) in a top level form."
732     (with-mark ((m mark))
733     (when (top-level-offset m -1)
734     (form-offset m 1)
735     (mark> m mark))))
736    
737     (defun start-defun-p (mark)
738     "Returns t if mark is sitting before an :open-paren at the beginning of a
739     line."
740     (and (start-line-p mark)
741     (test-char (next-character mark) :lisp-syntax :open-paren)))
742    
743    
744    
745     ;;;; #### FORM OFFSETING ####
746    
747     (defmacro %form-offset (mark forwardp)
748     `(with-mark ((m ,mark))
749     (when (scan-direction-valid m ,forwardp :lisp-syntax
750     (or :open-paren :close-paren
751     :char-quote :string-quote
752     :constituent))
753     (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
754     (:open-paren
755     (when ,(if forwardp `(list-offset m 1) `(mark-before m))
756     ,(unless forwardp
757     '(scan-direction m nil :lisp-syntax (not :prefix)))
758     (move-mark ,mark m)
759     t))
760     (:close-paren
761     (when ,(if forwardp `(mark-after m) `(list-offset m -1))
762     ,(unless forwardp
763     '(scan-direction m nil :lisp-syntax (not :prefix)))
764     (move-mark ,mark m)
765     t))
766     ((:constituent :char-quote)
767     (scan-direction-valid m ,forwardp :lisp-syntax
768     (not (or :constituent :char-quote)))
769     ,(if forwardp
770     `(scan-direction-valid m t :lisp-syntax
771     (not (or :constituent :char-quote)))
772     `(scan-direction-valid m nil :lisp-syntax
773     (not (or :constituent :char-quote
774     :prefix))))
775     (move-mark ,mark m)
776     t)
777     (:string-quote
778     (cond ((valid-spot m ,(not forwardp))
779     (neighbor-mark m ,forwardp)
780     (when (scan-direction-valid m ,forwardp :lisp-syntax
781     :string-quote)
782     (neighbor-mark m ,forwardp)
783     (move-mark ,mark m)
784     t))
785     (t (neighbor-mark m ,forwardp)
786     (move-mark ,mark m)
787     t)))))))
788    
789    
790     (defun form-offset (mark offset)
791     "Move mark offset number of forms, after if positive, before if negative.
792     Mark is always moved. If there weren't enough forms, returns nil instead of
793     mark."
794     (if (plusp offset)
795     (dotimes (i offset t)
796     (unless (%form-offset mark t) (return nil)))
797     (dotimes (i (- offset) t)
798     (unless (%form-offset mark nil) (return nil)))))
799    
800    
801    
802     ;;; Table of special forms with special indenting requirements.
803    
804    
805     (defhvar "Indent Defanything"
806     "This is the number of special arguments implicitly assumed to be supplied
807     in calls to functions whose names begin with \"DEF\". If set to NIL, this
808     feature is disabled."
809     :value 2)
810    
811     (defvar *special-forms* (make-hash-table :test #'equal))
812    
813     (defun defindent (fname args)
814     "Define Fname to have Args special arguments. If args is null then remove
815     any special arguments information."
816     (check-type fname string)
817     (let ((fname (string-upcase fname)))
818     (cond ((null args) (remhash fname *special-forms*))
819     (t
820     (check-type args integer)
821     (setf (gethash fname *special-forms*) args)))))
822    
823    
824     ;;; Hemlock forms.
825     ;;;
826     (defindent "with-mark" 1)
827     (defindent "with-random-typeout" 1)
828     (defindent "with-pop-up-display" 1)
829     (defindent "defhvar" 1)
830     (defindent "hlet" 1)
831     (defindent "defcommand" 2)
832     (defindent "defattribute" 1)
833     (defindent "command-case" 1)
834     (defindent "with-input-from-region" 1)
835     (defindent "with-output-to-mark" 1)
836     (defindent "with-output-to-window" 1)
837     (defindent "do-strings" 1)
838     (defindent "save-for-undo" 1)
839     (defindent "do-alpha-chars" 1)
840     (defindent "do-headers-buffers" 1)
841     (defindent "do-headers-lines" 1)
842     (defindent "with-headers-mark" 1)
843     (defindent "frob" 1) ;cover silly FLET and MACROLET names for Rob and Bill.
844     (defindent "with-writable-buffer" 1)
845    
846     ;;; Common Lisp forms.
847     ;;;
848     (defindent "block" 1)
849     (defindent "case" 1)
850     (defindent "catch" 1)
851     (defindent "ccase" 1)
852     (defindent "compiler-let" 1)
853     (defindent "ctypecase" 1)
854     (defindent "defconstant" 1)
855     (defindent "define-setf-method" 2)
856     (defindent "defmacro" 2)
857     (defindent "defparameter" 1)
858     (defindent "defstruct" 1)
859     (defindent "deftype" 2)
860     (defindent "defun" 2)
861     (defindent "defvar" 1)
862     (defindent "do" 2)
863     (defindent "do*" 2)
864     (defindent "do-all-symbols" 1)
865     (defindent "do-external-symbols" 1)
866     (defindent "do-symbols" 1)
867     (defindent "dolist" 1)
868     (defindent "dotimes" 1)
869     (defindent "ecase" 1)
870     (defindent "etypecase" 1)
871     (defindent "eval-when" 1)
872     (defindent "flet" 1)
873     (defindent "labels" 1)
874     (defindent "lambda" 1)
875     (defindent "let" 1)
876     (defindent "let*" 1)
877     (defindent "loop" 0)
878     (defindent "macrolet" 1)
879     (defindent "multiple-value-bind" 2)
880     (defindent "multiple-value-call" 1)
881     (defindent "multiple-value-prog1" 1)
882     (defindent "multiple-value-setq" 1)
883     (defindent "prog1" 1)
884     (defindent "progv" 2)
885     (defindent "progn" 0)
886     (defindent "typecase" 1)
887     (defindent "unless" 1)
888     (defindent "unwind-protect" 1)
889     (defindent "when" 1)
890     (defindent "with-input-from-string" 1)
891     (defindent "with-open-file" 1)
892     (defindent "with-open-stream" 1)
893     (defindent "with-output-to-string" 1)
894    
895     ;;; Error/condition system forms.
896     ;;;
897     (defindent "define-condition" 2)
898     (defindent "handler-bind" 1)
899     (defindent "handler-case" 1)
900     (defindent "restart-bind" 1)
901     (defindent "restart-case" 1)
902     (defindent "with-simple-restart" 1)
903     ;;; These are for RESTART-CASE branch formatting.
904     (defindent "store-value" 1)
905     (defindent "use-value" 1)
906     (defindent "muffle-warning" 1)
907     (defindent "abort" 1)
908     (defindent "continue" 1)
909    
910     ;;; Xlib forms.
911     ;;;
912     (defindent "with-gcontext" 1)
913     (defindent "xlib:with-gcontext" 1)
914     (defindent "with-state" 1)
915     (defindent "xlib:with-state" 1)
916     (defindent "with-display" 1)
917     (defindent "xlib:with-display" 1)
918     (defindent "with-event-queue" 1)
919     (defindent "xlib:with-event-queue" 1)
920     (defindent "with-server-grabbed" 1)
921     (defindent "xlib:with-server-grabbed" 1)
922     (defindent "event-case" 1)
923     (defindent "xlib:event-case" 1)
924    
925     ;;; CLOS forms.
926     ;;;
927     (defindent "with-slots" 1)
928     (defindent "with-slots*" 2)
929     (defindent "with-accessors*" 2)
930     (defindent "defclass" 2)
931    
932     ;;; System forms.
933     ;;;
934     (defindent "alien-bind" 1)
935     (defindent "def-c-record" 1)
936     (defindent "defrecord" 1)
937    
938    
939    
940     ;;; Compute number of spaces which mark should be indented according to
941     ;;; local context and lisp grinding conventions.
942    
943     (defun lisp-indentation (mark)
944     (with-mark ((m mark)
945     (temp mark))
946     (unless (valid-spot m nil)
947     (return-from lisp-indentation
948     (lisp-generic-indentation m)))
949     (unless (backward-up-list m)
950     (return-from lisp-indentation 0))
951     (mark-after m)
952     (with-mark ((start m))
953     (unless (and (scan-char m :lisp-syntax (not (or :space :prefix :char-quote)))
954     (test-char (next-character m) :lisp-syntax :constituent))
955     (return-from lisp-indentation (mark-column start)))
956     (with-mark ((fstart m))
957     (scan-char m :lisp-syntax (not :constituent))
958     (let* ((fname (nstring-upcase (region-to-string (region fstart m))))
959     (special-args (or (gethash fname *special-forms*)
960     (and (> (length fname) 2)
961     (string= fname "DEF" :end1 3)
962     (value indent-defanything)))))
963     (declare (simple-string fname))
964     (cond (special-args
965     (with-mark ((spec m))
966     (cond ((and (form-offset spec special-args)
967     (mark<= spec mark))
968     (1+ (mark-column start)))
969     ((skip-valid-space m)
970     (mark-column m))
971     (t
972     (+ (mark-column start) 3)))))
973     ((and (form-offset temp -1)
974     (or (blank-before-p temp)
975     (not (same-line-p temp fstart)))
976     (not (same-line-p temp mark)))
977     (unless (blank-before-p temp)
978     (line-start temp)
979     (find-attribute temp :space #'zerop))
980     (mark-column temp))
981     ((skip-valid-space m)
982     (mark-column m))
983     (t
984     (mark-column start))))))))
985    
986     (defun lisp-generic-indentation (mark)
987     (let* ((line (mark-line mark))
988     (prev (do ((line (line-previous line) (line-previous line)))
989     ((or (null line) (not (blank-line-p line))) line))))
990     (cond (prev
991     (line-start mark prev)
992     (find-attribute mark :space #'zerop)
993     (mark-column mark))
994     (t 0))))
995    
996     ;;; Skip-Valid-Space -- Internal
997     ;;;
998     ;;; Skip over any space on the line Mark is on, stopping at the first valid
999     ;;; non-space character. If there is none on the line, return nil.
1000     ;;;
1001     (defun skip-valid-space (mark)
1002     (loop
1003     (scan-char mark :lisp-syntax (not :space))
1004     (let ((val (character-attribute :lisp-syntax
1005     (next-character mark))))
1006     (cond ((eq val :newline) (return nil))
1007     ((valid-spot mark t) (return mark))))
1008     (mark-after mark)))
1009    
1010    
1011     ;;;; LISP Mode commands
1012    
1013     (defcommand "Defindent" (p)
1014     "Define the Lisp indentation for the current function.
1015     The indentation is a non-negative integer which is the number
1016     of special arguments for the form. Examples: 2 for Do, 1 for Dolist.
1017     If a prefix argument is supplied, then delete the indentation information."
1018     "Do a defindent, man!"
1019     (with-mark ((m (current-point)))
1020     (pre-command-parse-check m)
1021     (unless (backward-up-list m) (editor-error))
1022     (mark-after m)
1023     (with-mark ((n m))
1024     (scan-char n :lisp-syntax (not :constituent))
1025     (let ((s (region-to-string (region m n))))
1026     (declare (simple-string s))
1027     (when (zerop (length s)) (editor-error))
1028     (if p
1029     (defindent s nil)
1030     (let ((i (prompt-for-integer
1031     :prompt (format nil "Indentation for ~A: " s)
1032     :help "Number of special arguments.")))
1033     (when (minusp i)
1034     (editor-error "Indentation must be non-negative."))
1035     (defindent s i))))))
1036     (indent-command ()))
1037    
1038     (defcommand "Beginning of Defun" (p)
1039     "Move the point to the beginning of a top-level form.
1040     with an argument, skips the previous p top-level forms."
1041     "Move the point to the beginning of a top-level form."
1042     (let ((point (current-point))
1043     (count (or p 1)))
1044     (pre-command-parse-check point)
1045     (if (minusp count)
1046     (end-of-defun-command (- count))
1047     (unless (top-level-offset point (- count))
1048     (editor-error)))))
1049    
1050     ;;; "End of Defun", with a positive p (the normal case), does something weird.
1051     ;;; Get a mark at the beginning of the defun, and then offset it forward one
1052     ;;; less top level form than we want. This sets us up to use FORM-OFFSET which
1053     ;;; allows us to leave the point immediately after the defun. If we used
1054     ;;; TOP-LEVEL-OFFSET one less than p on the mark at the end of the current
1055     ;;; defun, point would be left at the beginning of the p+1'st form instead of
1056     ;;; at the end of the p'th form.
1057     ;;;
1058     (defcommand "End of Defun" (p)
1059     "Move the point to the end of a top-level form.
1060     With an argument, skips the next p top-level forms."
1061     "Move the point to the end of a top-level form."
1062     (let ((point (current-point))
1063     (count (or p 1)))
1064     (pre-command-parse-check point)
1065     (if (minusp count)
1066     (beginning-of-defun-command (- count))
1067     (with-mark ((m point)
1068     (dummy point))
1069     (cond ((not (mark-top-level-form m dummy))
1070     (editor-error "No current or next top level form."))
1071     (t
1072     (unless (top-level-offset m (1- count))
1073     (editor-error "Not enough top level forms."))
1074     ;; We might be one unparsed for away.
1075     (pre-command-parse-check m)
1076     (unless (form-offset m 1)
1077     (editor-error "Not enough top level forms."))
1078     (when (blank-after-p m) (line-offset m 1 0))
1079     (move-mark point m)))))))
1080    
1081     (defcommand "Forward List" (p)
1082     "Skip over the next Lisp list.
1083     With argument, skips the next p lists."
1084     "Skip over the next Lisp list."
1085     (let ((point (current-point))
1086     (count (or p 1)))
1087     (pre-command-parse-check point)
1088     (unless (list-offset point count) (editor-error))))
1089    
1090     (defcommand "Backward List" (p)
1091     "Skip over the previous Lisp list.
1092     With argument, skips the previous p lists."
1093     "Skip over the previous Lisp list."
1094     (let ((point (current-point))
1095     (count (- (or p 1))))
1096     (pre-command-parse-check point)
1097     (unless (list-offset point count) (editor-error))))
1098    
1099     (defcommand "Forward Form" (p)
1100     "Skip over the next Form.
1101     With argument, skips the next p Forms."
1102     "Skip over the next Form."
1103     (let ((point (current-point))
1104     (count (or p 1)))
1105     (pre-command-parse-check point)
1106     (unless (form-offset point count) (editor-error))))
1107    
1108     (defcommand "Backward Form" (p)
1109     "Skip over the previous Form.
1110     With argument, skips the previous p Forms."
1111     "Skip over the previous Form."
1112     (let ((point (current-point))
1113     (count (- (or p 1))))
1114     (pre-command-parse-check point)
1115     (unless (form-offset point count) (editor-error))))
1116    
1117     (defcommand "Mark Form" (p)
1118     "Set the mark at the end of the next Form.
1119     With a positive argument, set the mark after the following p
1120     Forms. With a negative argument, set the mark before
1121     the preceding -p Forms."
1122     "Set the mark at the end of the next Form."
1123     (with-mark ((m (current-point)))
1124     (pre-command-parse-check m)
1125     (let ((count (or p 1))
1126     (mark (push-buffer-mark (copy-mark m) t)))
1127     (if (form-offset m count)
1128     (move-mark mark m)
1129     (editor-error)))))
1130    
1131     (defcommand "Mark Defun" (p)
1132     "Puts the region around the next or containing top-level form.
1133     The point is left before the form and the mark is placed immediately
1134     after it."
1135     "Puts the region around the next or containing top-level form."
1136     (declare (ignore p))
1137     (let ((point (current-point)))
1138     (pre-command-parse-check point)
1139     (with-mark ((start point)
1140     (end point))
1141     (cond ((not (mark-top-level-form start end))
1142     (editor-error "No current or next top level form."))
1143     (t
1144     (move-mark point start)
1145     (move-mark (push-buffer-mark (copy-mark point) t) end))))))
1146    
1147     (defcommand "Forward Kill Form" (p)
1148     "Kill the next Form.
1149     With a positive argument, kills the next p Forms.
1150     Kills backward with a negative argument."
1151     "Kill the next Form."
1152     (with-mark ((m1 (current-point))
1153     (m2 (current-point)))
1154     (pre-command-parse-check m1)
1155     (let ((count (or p 1)))
1156     (unless (form-offset m1 count) (editor-error))
1157     (if (minusp count)
1158     (kill-region (region m1 m2) :kill-backward)
1159     (kill-region (region m2 m1) :kill-forward)))))
1160    
1161     (defcommand "Backward Kill Form" (p)
1162     "Kill the previous Form.
1163     With a positive argument, kills the previous p Forms.
1164     Kills forward with a negative argument."
1165     "Kill the previous Form."
1166     (forward-kill-form-command (- (or p 1))))
1167    
1168 ram 1.1.1.2 (defcommand "Extract Form" (p)
1169     "Replace the current containing list with the next form. The entire affected
1170     area is pushed onto the kill ring. If an argument is supplied, that many
1171     upward levels of list nesting is replaced by the next form."
1172     "Replace the current containing list with the next form. The entire affected
1173     area is pushed onto the kill ring. If an argument is supplied, that many
1174     upward levels of list nesting is replaced by the next form."
1175     (let ((point (current-point)))
1176     (pre-command-parse-check point)
1177     (with-mark ((form-start point :right-inserting)
1178     (form-end point))
1179     (unless (form-offset form-end 1) (editor-error))
1180     (form-offset (move-mark form-start form-end) -1)
1181     (with-mark ((containing-start form-start :left-inserting)
1182     (containing-end form-end :left-inserting))
1183     (dotimes (i (or p 1))
1184     (unless (and (forward-up-list containing-end)
1185     (backward-up-list containing-start))
1186     (editor-error)))
1187     (let ((r (copy-region (region form-start form-end))))
1188     (ring-push (delete-and-save-region
1189     (region containing-start containing-end))
1190     *kill-ring*)
1191     (ninsert-region point r)
1192     (move-mark point form-start))))))
1193    
1194 ram 1.1 (defcommand "Extract List" (p)
1195     "Extract the current list.
1196     The current list replaces the surrounding list. The entire affected
1197     area is pushed on the kill-ring. With prefix argument, remove that
1198     many surrounding lists."
1199     "Replace the P containing lists with the current one."
1200     (let ((point (current-point)))
1201     (pre-command-parse-check point)
1202     (with-mark ((lstart point :right-inserting)
1203     (lend point))
1204     (if (eq (character-attribute :lisp-syntax (next-character lstart))
1205     :open-paren)
1206     (mark-after lend)
1207     (unless (backward-up-list lstart) (editor-error)))
1208     (unless (forward-up-list lend) (editor-error))
1209     (with-mark ((rstart lstart)
1210     (rend lend))
1211     (dotimes (i (or p 1))
1212     (unless (and (forward-up-list rend) (backward-up-list rstart))
1213     (editor-error)))
1214     (let ((r (copy-region (region lstart lend))))
1215     (ring-push (delete-and-save-region (region rstart rend))
1216     *kill-ring*)
1217     (ninsert-region point r)
1218     (move-mark point lstart))))))
1219    
1220     (defcommand "Transpose Forms" (p)
1221     "Transpose Forms immediately preceding and following the point.
1222     With a zero argument, tranposes the Forms at the point and the mark.
1223     With a positive argument, transposes the Form preceding the point
1224     with the p-th one following it. With a negative argument, transposes the
1225     Form following the point with the p-th one preceding it."
1226     "Transpose Forms immediately preceding and following the point."
1227     (let ((point (current-point))
1228     (count (or p 1)))
1229     (pre-command-parse-check point)
1230     (if (zerop count)
1231     (let ((mark (current-mark)))
1232     (with-mark ((s1 mark :left-inserting)
1233     (s2 point :left-inserting))
1234     (scan-char s1 :whitespace nil)
1235     (scan-char s2 :whitespace nil)
1236     (with-mark ((e1 s1 :right-inserting)
1237     (e2 s2 :right-inserting))
1238     (unless (form-offset e1 1) (editor-error))
1239     (unless (form-offset e2 1) (editor-error))
1240     (ninsert-region s1 (delete-and-save-region (region s2 e2)))
1241     (ninsert-region s2 (delete-and-save-region (region s1 e1))))))
1242     (let ((fcount (if (plusp count) count 1))
1243     (bcount (if (plusp count) 1 count)))
1244     (with-mark ((s1 point :left-inserting)
1245     (e2 point :right-inserting))
1246     (dotimes (i bcount)
1247     (unless (form-offset s1 -1) (editor-error)))
1248     (dotimes (i fcount)
1249     (unless (form-offset e2 1) (editor-error)))
1250     (with-mark ((e1 s1 :right-inserting)
1251     (s2 e2 :left-inserting))
1252     (unless (form-offset e1 1) (editor-error))
1253     (unless (form-offset s2 -1) (editor-error))
1254     (ninsert-region s1 (delete-and-save-region (region s2 e2)))
1255     (ninsert-region s2 (delete-and-save-region (region s1 e1)))
1256     (move-mark point s2)))))))
1257    
1258    
1259     (defcommand "Indent Form" (p)
1260     "Indent Lisp code in the next form."
1261     "Indent Lisp code in the next form."
1262     (declare (ignore p))
1263     (let ((point (current-point)))
1264     (pre-command-parse-check point)
1265     (with-mark ((m point))
1266     (unless (form-offset m 1) (editor-error))
1267     (lisp-indent-region (region point m) "Indent Form"))))
1268    
1269     ;;; LISP-INDENT-REGION indents a region of Lisp code without doing excessive
1270     ;;; redundant computation. We parse the entire region once, then scan through
1271     ;;; doing indentation on each line. We forcibly reparse each line that we
1272     ;;; indent so that the list operations done to determine indentation of
1273     ;;; subsequent lines will work. This is done undoably with save1, save2,
1274     ;;; buf-region, and undo-region.
1275     ;;;
1276     (defun lisp-indent-region (region &optional (undo-text "Lisp region indenting"))
1277     (check-region-query-size region)
1278     (let ((start (region-start region))
1279     (end (region-end region)))
1280     (with-mark ((m1 start)
1281     (m2 end))
1282     (funcall (value parse-start-function) m1)
1283     (funcall (value parse-end-function) m2)
1284     (parse-over-block (mark-line m1) (mark-line m2)))
1285     (let* ((first-line (mark-line start))
1286     (last-line (mark-line end))
1287     (prev (line-previous first-line))
1288     (prev-line-info
1289     (and prev (getf (line-plist prev) 'lisp-info)))
1290     (save1 (line-start (copy-mark start :right-inserting)))
1291     (save2 (line-end (copy-mark end :left-inserting)))
1292     (buf-region (region save1 save2))
1293     (undo-region (copy-region buf-region)))
1294     (with-mark ((bol start :left-inserting))
1295     (do ((line first-line (line-next line)))
1296     (nil)
1297     (line-start bol line)
1298     (insert-lisp-indentation bol)
1299     (let ((line-info (getf (line-plist line) 'lisp-info)))
1300     (parse-lisp-line-info bol line-info prev-line-info)
1301     (setq prev-line-info line-info))
1302     (when (eq line last-line) (return nil))))
1303     (make-region-undo :twiddle undo-text buf-region undo-region))))
1304    
1305     ;;; INDENT-FOR-LISP is the value of "Indent Function" for "Lisp" mode.
1306     ;;;
1307     (defun indent-for-lisp (mark)
1308     (line-start mark)
1309     (pre-command-parse-check mark)
1310     (insert-lisp-indentation mark))
1311    
1312     (defun insert-lisp-indentation (m)
1313     (delete-horizontal-space m)
1314     (funcall (value indent-with-tabs) m (lisp-indentation m)))
1315    
1316    
1317     (defcommand "Insert ()" (p)
1318     "Insert a pair of parentheses ().
1319     With positive argument, puts parentheses around the next p
1320     Forms. The point is positioned after the open parenthesis."
1321     "Insert a pair of parentheses ()."
1322     (let ((point (current-point))
1323     (count (or p 0)))
1324     (pre-command-parse-check point)
1325     (cond ((not (minusp count))
1326     (insert-character point #\()
1327     (with-mark ((tmark point))
1328     (unless (form-offset tmark count) (editor-error))
1329     (cond ((mark= tmark point)
1330     (insert-character point #\))
1331     (mark-before point))
1332     (t (insert-character tmark #\))))))
1333     (t (editor-error)))))
1334    
1335    
1336     (defcommand "Move Over )" (p)
1337     "Move past the next close parenthesis, and start a new line.
1338     Any indentation preceding the preceding the parenthesis is deleted,
1339     and the new line is indented."
1340     "Move past the next close parenthesis, and start a new line."
1341     (declare (ignore p))
1342     (let ((point (current-point)))
1343     (pre-command-parse-check point)
1344     (with-mark ((m point))
1345     (cond ((scan-char m :lisp-syntax :close-paren)
1346     (delete-horizontal-space m)
1347     (mark-after m)
1348     (move-mark point m)
1349     (indent-new-line-command 1))
1350     (t (editor-error))))))
1351    
1352    
1353     (defcommand "Forward Up List" (p)
1354     "Move forward past a one containing )."
1355     "Move forward past a one containing )."
1356     (let ((point (current-point))
1357     (count (or p 1)))
1358     (pre-command-parse-check point)
1359     (if (minusp count)
1360     (backward-up-list-command (- count))
1361     (with-mark ((m point))
1362     (dotimes (i count (move-mark point m))
1363     (unless (forward-up-list m) (editor-error)))))))
1364    
1365    
1366     (defcommand "Backward Up List" (p)
1367     "Move backward past a one containing (."
1368     "Move backward past a one containing (."
1369     (let ((point (current-point))
1370     (count (or p 1)))
1371     (pre-command-parse-check point)
1372     (if (minusp count)
1373     (forward-up-list-command (- count))
1374     (with-mark ((m point))
1375     (dotimes (i count (move-mark point m))
1376     (unless (backward-up-list m) (editor-error)))))))
1377    
1378    
1379     (defcommand "Down List" (p)
1380     "Move down a level in list structure.
1381     With argument, moves down p levels."
1382     "Move down a level in list structure."
1383     (let ((point (current-point))
1384     (count (or p 1)))
1385     (pre-command-parse-check point)
1386     (with-mark ((m point))
1387     (dotimes (i count (move-mark point m))
1388     (unless (and (scan-char m :lisp-syntax :open-paren)
1389     (mark-after m))
1390     (editor-error))))))
1391    
1392    
1393    
1394     ;;;; "Lisp Mode".
1395    
1396     (defcommand "LISP Mode" (p)
1397     "Put current buffer in LISP mode."
1398     "Put current buffer in LISP mode."
1399     (declare (ignore p))
1400     (setf (buffer-major-mode (current-buffer)) "LISP"))
1401    
1402    
1403     (defmode "Lisp" :major-p t :setup-function 'setup-lisp-mode)
1404    
1405     (defun setup-lisp-mode (buffer)
1406     (unless (hemlock-bound-p 'current-package :buffer buffer)
1407     (defhvar "Current Package"
1408     "The package used for evaluation of Lisp in this buffer."
1409     :buffer buffer
1410     :value "USER")))
1411    
1412    
1413    
1414     ;;;; Matching parenthesis display.
1415    
1416     (defhvar "Paren Pause Period"
1417     "This is how long commands that deal with \"brackets\" shows the cursor at
1418     the matching \"bracket\" for this number of seconds."
1419     :value 0.5)
1420    
1421     (defcommand "Lisp Insert )" (p)
1422     "Inserts a \")\" and briefly positions the cursor at the matching \"(\"."
1423     "Inserts a \")\" and briefly positions the cursor at the matching \"(\"."
1424     (declare (ignore p))
1425     (let ((point (current-point)))
1426     (insert-character point #\))
1427     (pre-command-parse-check point)
1428     (when (valid-spot point nil)
1429     (with-mark ((m point))
1430     (if (list-offset m -1)
1431     (let ((pause (value paren-pause-period))
1432     (win (current-window)))
1433     (if pause
1434     (unless (show-mark m win pause)
1435     (clear-echo-area)
1436     (message "~A" (line-string (mark-line m))))
1437     (unless (displayed-p m (current-window))
1438     (clear-echo-area)
1439     (message "~A" (line-string (mark-line m))))))
1440     (editor-error))))))
1441    
1442     ;;; Since we use paren highlighting in Lisp mode, we do not want paren
1443     ;;; flashing too.
1444     ;;;
1445     (defhvar "Paren Pause Period"
1446     "This is how long commands that deal with \"brackets\" shows the cursor at
1447     the matching \"bracket\" for this number of seconds."
1448     :value nil
1449     :mode "Lisp")
1450     ;;;
1451     (defhvar "Highlight Open Parens"
1452     "When non-nil, causes open parens to be displayed in a different font when
1453     the cursor is directly to the right of the corresponding close paren."
1454     :value t
1455     :mode "Lisp")
1456    
1457    
1458    
1459     ;;;; Some mode variables to coordinate with other stuff.
1460    
1461     (defhvar "Auto Fill Space Indent"
1462     "When non-nil, uses \"Indent New Comment Line\" to break lines instead of
1463     \"New Line\"."
1464     :mode "Lisp" :value t)
1465    
1466     (defhvar "Comment Start"
1467     "String that indicates the start of a comment."
1468     :mode "Lisp" :value ";")
1469    
1470     (defhvar "Comment Begin"
1471     "String that is inserted to begin a comment."
1472     :mode "Lisp" :value "; ")
1473    
1474     (defhvar "Indent Function"
1475     "Indentation function which is invoked by \"Indent\" command.
1476     It must take one argument that is the prefix argument."
1477     :value 'indent-for-lisp
1478     :mode "Lisp")

  ViewVC Help
Powered by ViewVC 1.1.5