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

Contents of /src/hemlock/comments.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5