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

Contents of /src/hemlock/comments.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Wed Aug 25 02:08:02 1993 UTC (20 years, 7 months ago) by ram
Branch: MAIN
Changes since 1.2: +2 -2 lines
Fix compiler warnings.
1 ram 1.1 ;;; -*- Log: Hemlock.Log; Package: Hemlock -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2 ;;; 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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 ram 1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/comments.lisp,v 1.3 1993/08/25 02:08:02 ram Exp $")
11 ram 1.2 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; Written by Bill Chiles
15     ;;;
16     ;;; This file contains the implementation of comment commands.
17    
18 ram 1.3 (in-package "HEMLOCK")
19 ram 1.1
20    
21    
22     ;;;; -- Variables --
23    
24     (defhvar "Comment Column"
25     "Colmun to start comments in."
26     :value 0)
27    
28     (defhvar "Comment Start"
29     "String that indicates the start of a comment."
30     :value nil)
31    
32     (defhvar "Comment End"
33     "String that ends comments. Nil indicates #\newline termination."
34     :value nil)
35    
36     (defhvar "Comment Begin"
37     "String that is inserted to begin a comment."
38     :value nil)
39    
40    
41     ;;;; -- Internal Specials --
42    
43     ;;; For the search pattern state specials, we just use " " as the comment
44     ;;; start and end if none exist, so we are able to make search patterns.
45     ;;; This is reasonable since any use of these will cause the patterns to be
46     ;;; made consistent with the actual start and end strings.
47    
48     (defvar *comment-start-pattern*
49     (new-search-pattern :string-insensitive :forward (or (value comment-start) " "))
50     "Search pattern to keep around for looking for comment starts.")
51    
52     (defvar *last-comment-start*
53     (or (value comment-start) " ")
54     "Previous comment start used to make *comment-start-pattern*.")
55    
56     (defvar *comment-end-pattern*
57     (new-search-pattern :string-insensitive :forward (or (value comment-end) " "))
58     "Search pattern to keep around for looking for comment ends.")
59    
60     (defvar *last-comment-end*
61     (or (value comment-end) " ")
62     "Previous comment end used to make *comment-end-pattern*.")
63    
64    
65     (eval-when (compile eval)
66     (defmacro get-comment-pattern (string kind) ;kind is either :start or :end
67     (let (pattern-var last-var)
68     (cond ((eq kind :start)
69     (setf pattern-var '*comment-start-pattern*)
70     (setf last-var '*last-comment-start*))
71     (t (setf pattern-var '*comment-end-pattern*)
72     (setf last-var '*last-comment-end*)))
73     `(cond ((string= (the simple-string ,string) (the simple-string ,last-var))
74     ,pattern-var)
75     (t (setf ,last-var ,string)
76     (new-search-pattern :string-insensitive :forward
77     ,string ,pattern-var)))))
78     ) ;eval-when
79    
80    
81    
82     ;;;; -- Commands --
83    
84     (defcommand "Set Comment Column" (p)
85     "Set Comment Column to current column or argument.
86     If argument is provided use its absolute value."
87     "Set Comment Column to current column or argument.
88     If argument is provided use its absolute value."
89     (let ((new-column (or (and p (abs p))
90     (mark-column (current-point)))))
91     (defhvar "Comment Column" "This buffer's column to start comments."
92     :value new-column :buffer (current-buffer))
93     (message "Comment Column = ~D" new-column)))
94    
95    
96     (defcommand "Indent for Comment" (p)
97     "Move to or create a comment. Moves to the start of an existing comment
98     and indents it to start in Comment Column. An existing double semicolon
99     comment is aligned like a line of code. An existing triple semicolon
100     comment or any that start in column 0 is not moved. With argument,
101     aligns any comments on the next argument lines but does not create any.
102     If characters extend past comment column, a space is added before
103     starting comment."
104     "Create comment or move to beginning of existing one aligning it."
105     (let* ((column (value comment-column))
106     (start (value comment-start))
107     (begin (value comment-begin))
108     (end (value comment-end)))
109     (unless (stringp start) (editor-error "No comment start string -- ~S." start))
110     (indent-for-comment (current-point) column start begin end (or p 1))))
111    
112    
113     (defcommand "Up Comment Line" (p)
114     "Equivalent to Previous Line followed by Indent for Comment (C-P ALT-;)."
115     "Equivalent to Previous Line followed by Indent for Comment (C-P ALT-;)."
116     (let ((column (value comment-column))
117     (start (value comment-start))
118     (begin (value comment-begin))
119     (end (value comment-end)))
120     (unless (stringp start) (editor-error "No comment start string -- ~S." start))
121     (change-comment-line (current-point) column start
122     begin end (or (and p (- p)) -1))))
123    
124     (defcommand "Down Comment Line" (p)
125     "Equivalent to Next Line followed by Indent for Comment (C-N ALT-;)."
126     "Equivalent to Next Line followed by Indent for Comment (C-N ALT-;)."
127     (let ((column (value comment-column))
128     (start (value comment-start))
129     (begin (value comment-begin))
130     (end (value comment-end)))
131     (unless (stringp start) (editor-error "No comment start string -- ~S." start))
132     (change-comment-line (current-point) column start begin end (or p 1))))
133    
134    
135     (defcommand "Kill Comment" (p)
136     "Kills the comment (if any) on the current line.
137     With argument, applies to specified number of lines, and moves past them."
138     "Kills the comment (if any) on the current line.
139     With argument, applies to specified number of lines, and moves past them."
140     (let ((start (value comment-start)))
141     (when start
142     (if (not (stringp start))
143     (editor-error "Comment start not string or nil -- ~S." start))
144     (kill-comment (current-point) start (or p 1)))))
145    
146    
147     (defcommand "Indent New Comment Line" (p)
148     "Inserts comment end and then starts a comment on a new line.
149     The indentation and number of additional comment-start characters are
150     copied from the previous line's comment. Acts like Linefeed, when done
151     while not inside a comment, assuming a comment is the last thing on a line."
152     "complete a current comment and start another a new line, copying indentation
153     and start characters. If no comment, call Linefeed command."
154     (let ((start (value comment-start))
155     (begin (value comment-begin))
156     (end (value comment-end))
157     (point (current-point)))
158     (with-mark ((tmark point :left-inserting))
159     (if start
160     (cond ((not (stringp start))
161     (editor-error "Comment start not string or nil -- ~S." start))
162     ((and (to-line-comment tmark start) (mark> point tmark))
163     (with-mark ((emark tmark))
164     (let ((endp (if end (to-comment-end emark end))))
165     (cond ((and endp (mark= emark point))
166     (insert-string point end)
167     (indent-new-comment-line point tmark start begin end))
168     ((and endp
169     (character-offset emark endp)
170     (mark>= point emark))
171     (indent-new-line-command p))
172     (t (delete-horizontal-space point)
173     (if end (insert-string point end))
174     (indent-new-comment-line point tmark
175     start begin end))))))
176     (t (indent-new-line-command p)))
177     (indent-new-line-command p)))))
178    
179    
180    
181     ;;;; -- Support Routines --
182    
183     (eval-when (compile eval)
184     (defmacro %do-comment-lines ((var number) mark1 &rest forms)
185     (let ((next-line-p (gensym)))
186     `(do ((,var (if (plusp ,number) ,number 0) (1- ,var))
187     (,next-line-p t))
188     ((or (zerop ,var) (not ,next-line-p))
189     (zerop ,var))
190     ,@forms
191     (setf ,next-line-p (line-offset ,mark1 1)))))
192     ) ;eval-when
193    
194    
195     ;;; CHANGE-COMMENT-LINE closes any comment on the current line, deleting
196     ;;; an empty comment. After offsetting by lines, a comment is either
197     ;;; aligned or created.
198     (defun change-comment-line (mark column start begin end lines)
199     (with-mark ((tmark1 mark :left-inserting)
200     (tmark2 mark))
201     (let ((start-len (to-line-comment mark start))
202     end-len)
203     (when start-len
204     (if end
205     (setf end-len (to-comment-end (move-mark tmark1 mark) end))
206     (line-end tmark1))
207     (character-offset (move-mark tmark2 mark) start-len)
208     (find-attribute tmark2 :whitespace #'zerop)
209     (cond ((mark>= tmark2 tmark1)
210     (if end-len (character-offset tmark1 end-len))
211     ;; even though comment is blank, the line might not be blank
212     ;; after it in languages that have comment terminators.
213     (when (blank-after-p tmark1)
214     (reverse-find-attribute mark :whitespace #'zerop)
215     (if (not (same-line-p mark tmark1))
216     (line-start mark (mark-line tmark1)))
217     (delete-region (region mark tmark1))))
218     ((and end (not end-len)) (insert-string tmark1 end))))
219     (if (line-offset mark lines)
220     (indent-for-comment mark column start begin end 1)
221     (editor-error)))))
222    
223    
224     (defun indent-for-comment (mark column start begin end times)
225     (with-mark ((tmark mark :left-inserting))
226     (if (= times 1)
227     (let ((start-len (to-line-comment tmark start)))
228     (cond (start-len
229     (align-comment tmark start start-len column)
230     (character-offset (move-mark mark tmark) start-len))
231     (t (comment-line mark column start begin end))))
232     (unless (%do-comment-lines (n times) mark
233     (let ((start-len (to-line-comment mark start)))
234     (if start-len (align-comment mark start start-len column))))
235     (buffer-end mark)
236     (editor-error)))))
237    
238    
239     ;;; KILL-COMMENT assumes a comment is the last thing on a line, so it does
240     ;;; not deal with comment-end. The Tao of EMACS.
241     (defun kill-comment (mark start times)
242     (with-mark ((tmark mark :left-inserting))
243     (if (= times 1)
244     (when (to-line-comment mark start)
245     (with-mark ((u-start mark)
246     (u-end (line-end (move-mark tmark mark))))
247     (rev-scan-char u-start :whitespace nil)
248     (let ((undo-region (copy-region (region u-start u-end))))
249     (ring-push (delete-and-save-region (region mark tmark))
250     *kill-ring*)
251     (delete-horizontal-space mark)
252     (make-region-undo :insert "Kill Comment" undo-region
253     (copy-mark mark :left-inserting)))))
254     (let* ((kill-region (delete-and-save-region (region mark tmark)))
255     (insert-mark (region-end kill-region))
256     ;; don't delete u-start and u-end since undo stuff handles that.
257     (u-start (line-start (copy-mark mark :left-inserting)))
258     (u-end (copy-mark mark :left-inserting))
259     (undo-region (copy-region (region u-start
260     (if (line-offset u-end times)
261     (line-start u-end)
262     (buffer-end u-end)))))
263     (n-times-p
264     (%do-comment-lines (n times) mark
265     (when (to-line-comment mark start)
266     (line-end (move-mark tmark mark))
267     (ninsert-region insert-mark
268     (delete-and-save-region (region mark tmark)))
269     (insert-character insert-mark #\newline)
270     (delete-horizontal-space mark)))))
271     (ring-push kill-region *kill-ring*)
272     (make-region-undo :twiddle "Kill Comment"
273     (region u-start u-end) undo-region)
274     (unless n-times-p
275     (buffer-end mark)
276     (editor-error))))))
277    
278     (defun comment-line (point column start begin end)
279     (let* ((open (or begin start))
280     (open-len (length (the simple-string open)))
281     (end-len (if end (length (the simple-string end)) 0))
282     (insert-len (+ open-len end-len)))
283     (line-end point)
284     (insert-string point open)
285     (if end (insert-string point end))
286     (character-offset point (- insert-len))
287     (adjust-comment point column)
288     (character-offset point open-len)))
289    
290    
291     (eval-when (compile eval)
292     (defmacro count-extra-last-chars (mark start-len start-char)
293     (let ((count (gensym))
294     (tmark (gensym)))
295     `(with-mark ((,tmark ,mark))
296     (character-offset ,tmark ,start-len)
297     (do ((,count 0 (1+ ,count)))
298     ((char/= (next-character ,tmark) ,start-char) ,count)
299     (mark-after ,tmark)))))
300     )
301    
302    
303     ;;; ALIGN-COMMENT sets a comment starting at mark to start in column
304     ;;; column. If the comment starts at the beginning of the line, it is not
305     ;;; moved. If the comment start is a single character and duplicated, then
306     ;;; it is indented as if it were code, and if it is triplicated, it is not
307     ;;; moved. If the comment is to be moved to column, then we check to see
308     ;;; if it is already there and preceded by whitespace.
309    
310     (defun align-comment (mark start start-len column)
311     (unless (start-line-p mark)
312     (case (count-extra-last-chars mark start-len (schar start (1- start-len)))
313     (1 (funcall (value indent-function) mark))
314     (2 )
315     (t (if (or (/= (mark-column mark) column)
316     (zerop (character-attribute
317     :whitespace (previous-character mark))))
318     (adjust-comment mark column))))))
319    
320    
321     ;;; ADJUST-COMMENT moves the comment starting at mark to start in column
322     ;;; column, inserting a space if the line extends past column.
323     (defun adjust-comment (mark column)
324     (delete-horizontal-space mark)
325     (let ((current-column (mark-column mark))
326     (spaces-per-tab (value spaces-per-tab))
327     tabs spaces next-tab-pos)
328     (cond ((= current-column column)
329     (if (/= column 0) (insert-character mark #\space)))
330     ((> current-column column) (insert-character mark #\space))
331     (t (multiple-value-setq (tabs spaces)
332     (floor current-column spaces-per-tab))
333     (setf next-tab-pos
334     (if (zerop spaces)
335     current-column
336     (+ current-column (- spaces-per-tab spaces))))
337     (cond ((= next-tab-pos column)
338     (insert-character mark #\tab))
339     ((> next-tab-pos column)
340     (dotimes (i (- column current-column))
341     (insert-character mark #\space)))
342     (t (multiple-value-setq (tabs spaces)
343     (floor (- column next-tab-pos) spaces-per-tab))
344     (dotimes (i (if (= current-column next-tab-pos)
345     tabs
346     (1+ tabs)))
347     (insert-character mark #\tab))
348     (dotimes (i spaces)
349     (insert-character mark #\space))))))))
350    
351    
352     ;;; INDENT-NEW-COMMENT-LINE makes a new line at point starting a comment
353     ;;; in the same way as the one at start-mark.
354     (defun indent-new-comment-line (point start-mark start begin end)
355     (new-line-command nil)
356     (insert-string point (gen-comment-prefix start-mark start begin))
357     (if end
358     (when (not (to-comment-end (move-mark start-mark point) end))
359     (insert-string start-mark end)
360     (if (mark= start-mark point)
361     ;; This occurs when nothing follows point on the line and
362     ;; both marks are left-inserting.
363     (character-offset
364     point (- (length (the simple-string end))))))))
365    
366    
367     ;;; GEN-COMMENT-PREFIX returns a string suitable for beginning a line
368     ;;; with a comment lined up with mark and starting the same as the comment
369     ;;; immediately following mark. This is used in the auto filling stuff too.
370     (defun gen-comment-prefix (mark start begin)
371     (let* ((start-len (length (the simple-string start)))
372     (last-char (schar start (1- start-len)))
373     (extra-start-chars (count-extra-last-chars mark start-len last-char))
374     (spaces-per-tab (value spaces-per-tab))
375     (begin-end (if begin
376     (subseq begin start-len (length (the simple-string begin)))
377     "")))
378     (multiple-value-bind (tabs spaces) (floor (mark-column mark) spaces-per-tab)
379     (concatenate 'simple-string
380     (make-string tabs :initial-element #\tab)
381     (make-string spaces :initial-element #\space)
382     start
383     (make-string extra-start-chars :initial-element last-char)
384     begin-end))))
385    
386    
387     ;;; TO-LINE-COMMENT moves mark to the first comment start character on its
388     ;;; line if there is a comment and returns the length of start, otherwise
389     ;;; nil is returned. Start must be a string. This is used by the auto
390     ;;; filling stuff too.
391     (defun to-line-comment (mark start)
392     (with-mark ((tmark mark))
393     (line-start tmark)
394     (let ((start-len (find-pattern tmark (get-comment-pattern start :start))))
395     (when (and start-len (same-line-p mark tmark))
396     (move-mark mark tmark)
397     start-len))))
398    
399    
400     ;;; TO-COMMENT-END moves mark to the first comment end character on its
401     ;;; line if end is there and returns the length of comment end, otherwise
402     ;;; mark is moved to the end of the line returning nil. This is used by
403     ;;; the auto filling stuff too.
404     (defun to-comment-end (mark end)
405     (with-mark ((tmark mark))
406     (let ((end-len (find-pattern tmark (get-comment-pattern end :end))))
407     (cond ((and end-len (same-line-p mark tmark))
408     (move-mark mark tmark)
409     end-len)
410     (t (line-end mark) nil)))))

  ViewVC Help
Powered by ViewVC 1.1.5