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

Contents of /src/hemlock/fill.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show 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 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/fill.lisp,v 1.4 1994/10/31 04:50:12 ram Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Bill Chiles
13 ;;;
14 ;;; This file contains the implementation of Auto Fill Mode. Also,
15 ;;; paragraph and region filling stuff is here.
16 ;;;
17
18 (in-package "HEMLOCK")
19
20
21 ;;; Fill Mode should be defined with some transparent bindings (linefeed and
22 ;;; return) but with some that are not (space), so until this is possible, we
23 ;;; kludge this effect by altering Auto Fill Linefeed and Auto Fill Return.
24 (defmode "Fill")
25
26
27
28 ;;;; -- Variables --
29
30 (defhvar "Fill Column"
31 "Used to determine at what column to force text to the next line."
32 :value 75)
33
34 (defhvar "Fill Prefix"
35 "String to put before each line when filling."
36 :value ())
37
38 (defhvar "Auto Fill Space Indent"
39 "When non-nil, uses \"Indent New Comment Line\" to break lines instead of
40 \"New Line\". However, if there is a fill prefix, it is still preferred."
41 :value nil)
42
43
44
45 ;;;; -- New Attributes --
46
47 (defattribute "Paragraph Delimiter"
48 "is a character that delimits a paragraph by beginning a line."
49 '(mod 2)
50 0)
51
52
53 ;;; (setf (character-attribute :paragraph-delimiter #\@) 1)
54 ;;; (setf (character-attribute :paragraph-delimiter #\\) 1)
55 ;;; (setf (character-attribute :paragraph-delimiter #\/) 1)
56 ;;; (setf (character-attribute :paragraph-delimiter #\-) 1)
57 ;;; (setf (character-attribute :paragraph-delimiter #\') 1)
58 ;;; (setf (character-attribute :paragraph-delimiter #\.) 1)
59 ;;; These are useful for making certain text formatting command lines
60 ;;; delimit paragraphs. Anyway, this is what EMACS documentation states,
61 ;;; and #\' and #\. are always paragraph delimiters (don't ask me).
62
63 (setf (character-attribute :paragraph-delimiter #\space) 1)
64 (setf (character-attribute :paragraph-delimiter #\linefeed) 1)
65 (setf (character-attribute :paragraph-delimiter #\formfeed) 1)
66 (setf (character-attribute :paragraph-delimiter #\tab) 1)
67 (setf (character-attribute :paragraph-delimiter #\newline) 1)
68
69
70
71 (defattribute "Sentence Closing Char"
72 "is a delimiting character that may follow a sentence terminator
73 such as quotation marks and parentheses."
74 '(mod 2)
75 0)
76
77
78 (setf (character-attribute :sentence-closing-char #\") 1)
79 (setf (character-attribute :sentence-closing-char #\') 1)
80 (setf (character-attribute :sentence-closing-char #\)) 1)
81 (setf (character-attribute :sentence-closing-char #\]) 1)
82 (setf (character-attribute :sentence-closing-char #\|) 1)
83 (setf (character-attribute :sentence-closing-char #\>) 1)
84
85
86 ;;;; -- Commands --
87
88 (defcommand "Auto Fill Mode" (p)
89 "Breaks lines between words at the right margin.
90 A positive argument turns Fill mode on, while zero or a negative
91 argument turns it off. With no arguments, it is toggled. When space
92 is typed, text that extends past the right margin is put on the next
93 line. The right column is controlled by Fill Column."
94 "Determine if in Fill mode or not and set the mode accordingly."
95 (setf (buffer-minor-mode (current-buffer) "Fill")
96 (if p
97 (plusp p)
98 (not (buffer-minor-mode (current-buffer) "Fill")))))
99
100
101 ;;; This command should not have a transparent binding since it sometimes does
102 ;;; not insert a spaces, and transparency would propagate to "Self Insert".
103 (defcommand "Auto Fill Space" (p)
104 "Insert space and a CRLF if text extends past margin.
105 If arg is 0, then may break line but will not insert the space.
106 If arg is positive, then inserts that many spaces without filling."
107 "Insert space and CRLF if text extends past margin.
108 If arg is 0, then may break line but will not insert the space.
109 If arg is positive, then inserts that many spaces without filling."
110 (let ((point (current-point)))
111 (check-fill-prefix (value fill-prefix) (value fill-column) point)
112 (cond ((and p (plusp p))
113 (dotimes (x p) (insert-character point #\space)))
114 ((and p (zerop p)) (%auto-fill-space point nil))
115 (t (%auto-fill-space point t)))))
116
117
118 (defcommand "Auto Fill Linefeed" (p)
119 "Does an immediate CRLF inserting Fill Prefix if it exists."
120 "Does an immediate CRLF inserting Fill Prefix if it exists."
121 (let ((point (current-point)))
122 (check-fill-prefix (value fill-prefix) (value fill-column) point)
123 (%auto-fill-space point nil)
124 ;; The remainder of this function should go away when
125 ;; transparent key bindings are per binding instead of
126 ;; per mode.
127 (multiple-value-bind (command t-bindings)
128 (get-command #k"Linefeed" :current)
129 (declare (ignore command)) ;command is this one, so don't invoke it
130 (dolist (c t-bindings) (funcall *invoke-hook* c p)))
131 (indent-new-line-command nil)))
132
133
134
135 (defcommand "Auto Fill Return" (p)
136 "Does an Auto Fill Space with a prefix argument of 0
137 followed by a newline."
138 "Does an Auto Fill Space with a prefix argument of 0
139 followed by a newline."
140 (let ((point (current-point)))
141 (check-fill-prefix (value fill-prefix) (value fill-column) point)
142 (%auto-fill-space point nil)
143 ;; The remainder of this function should go away when
144 ;; transparent key bindings are per binding instead of
145 ;; per mode.
146 (multiple-value-bind (command t-bindings)
147 (get-command #k"Return" :current)
148 (declare (ignore command)) ;command is this one, so don't invoke it
149 (dolist (c t-bindings) (funcall *invoke-hook* c p)))
150 (new-line-command nil)))
151
152
153
154 (defcommand "Fill Paragraph" (p)
155 "Fill this or next paragraph.
156 Point stays fixed, but text may move past it due to filling.
157 A paragraph is delimited by a blank line, a line beginning with a
158 special character (@,\,-,',and .), or it is begun with a line with at
159 least one whitespace character starting it. Prefixes are ignored or
160 skipped over before determining if a line starts or delimits a
161 paragraph."
162 "Fill this or next paragraph.
163 Point stays fixed, but text may move past it due to filling."
164 (let* ((prefix (value fill-prefix))
165 (prefix-len (length prefix))
166 (column (if p (abs p) (value fill-column)))
167 (point (current-point)))
168 (with-mark ((m point))
169 (let ((paragraphp (paragraph-offset m 1)))
170 (unless (or paragraphp
171 (and (last-line-p m)
172 (end-line-p m)
173 (not (blank-line-p (mark-line m)))))
174 (editor-error))
175 ;;
176 ;; start and end get deleted by the undo cleanup function
177 (let ((start (copy-mark m :right-inserting))
178 (end (copy-mark m :left-inserting)))
179 (%fill-paragraph-start start prefix prefix-len)
180 (let* ((region (region start end))
181 (undo-region (copy-region region)))
182 (fill-region region prefix column)
183 (make-region-undo :twiddle "Fill Paragraph" region undo-region)))))))
184
185
186 (defcommand "Fill Region" (p)
187 "Fill text from point to mark."
188 "Fill text from point to mark."
189 (let* ((region (current-region))
190 (prefix (value fill-prefix))
191 (column (if p (abs p) (value fill-column))))
192 (check-fill-prefix prefix column (current-point))
193 (check-region-query-size region)
194 (fill-region-by-paragraphs region prefix column)))
195
196
197
198 (defcommand "Set Fill Column" (p)
199 "Set Fill Column to current column or argument.
200 If argument is provided use its absolute value."
201 "Set Fill Column to current column or argument.
202 If argument is provided use its absolute value."
203 (let ((new-column (or (and p (abs p))
204 (mark-column (current-point)))))
205 (defhvar "Fill Column" "This buffer's fill column"
206 :value new-column :buffer (current-buffer))
207 (message "Fill Column = ~D" new-column)))
208
209
210 (defcommand "Set Fill Prefix" (p)
211 "Define Fill Prefix from the current line.
212 All of the current line up to point is the prefix. This may be
213 turned off by placing point at the beginning of a line when setting."
214 "Define Fill Prefix from the current line.
215 All of the current line up to point is the prefix. This may be
216 turned off by placing point at the beginning of a line when setting."
217 (declare (ignore p))
218 (let ((point (current-point)))
219 (with-mark ((mark point))
220 (line-start mark)
221 (let ((val (if (mark/= mark point) (region-to-string (region mark point)))))
222 (defhvar "Fill Prefix" "This buffer's fill prefix"
223 :value val :buffer (current-buffer))
224 (message "Fill Prefix now ~:[empty~;~:*~S~]" val)))))
225
226 (declaim (optimize (speed 2))); turn off byte compilation.
227
228 ;;;; -- Auto Filling --
229
230 ;;; %AUTO-FILL-SPACE takes a point and an argument indicating
231 ;;; whether it should insert a space or not. If point is past Fill
232 ;;; Column then text is filled. Usually the else clause of the if
233 ;;; will be executed. If the then clause is executed, then the first
234 ;;; branch of the COND will usually be executed. The first branch
235 ;;; handles the case of the end of a word extending past Fill Column
236 ;;; while the second handles whitespace preceded by non-whitespace
237 ;;; extending past the Fill Column. The last branch is for those who
238 ;;; like to whitespace out a blank line.
239
240 (defun %auto-fill-space (point insertp)
241 "Insert space, but CRLF if text extends past margin.
242 If arg is 0, then may break line but will not insert the space.
243 If arg is positive, then inserts that many spaces without filling."
244 (if (> (mark-column point) (value fill-column))
245 (with-mark ((mark1 point :left-inserting))
246 (let ((not-all-blank (reverse-find-attribute mark1 :whitespace #'zerop))
247 (prefix (value fill-prefix))
248 (column (value fill-column)))
249 (cond ((and not-all-blank (mark= point mark1))
250 (%auto-fill-word-past-column point mark1 insertp prefix column))
251 ((and not-all-blank (same-line-p mark1 point))
252 (delete-region (region mark1 point))
253 (if (> (mark-column point) column)
254 (%auto-fill-word-past-column point mark1 insertp prefix column)
255 (%filling-set-next-line point nil prefix)))
256 (t
257 (line-start mark1 (mark-line point))
258 (delete-region (region mark1 point))
259 (%filling-set-next-line point nil prefix)))))
260 (if insertp (insert-character point #\space))))
261
262
263
264 ;;; %AUTO-FILL-WORD-PAST-COLUMN takes a point, a second mark that is
265 ;;; mark= at the end of some word, and an indicator of whether a space
266 ;;; should be inserted or not. First, point is moved before the previous
267 ;;; "word." If the word is effectively the only word on the line, it
268 ;;; should not be moved down to the next line as it will leave a blank
269 ;;; line. The third branch handles when the typing began in the middle of
270 ;;; some line (that is, right in front of some word). Note that the else
271 ;;; clause is the usual case.
272
273 (defun %auto-fill-word-past-column (point mark1 insertp prefix column)
274 (let ((point-moved-p (reverse-find-attribute point :whitespace)))
275 (with-mark ((mark2 point :left-inserting))
276 (cond ((or (not point-moved-p)
277 (%auto-fill-blank-before-p point prefix))
278 (move-mark point mark1)
279 (%filling-set-next-line point nil prefix))
280 ((%auto-fill-line-as-region-p point mark2 column)
281 (if (and insertp
282 (not (or (end-line-p mark1)
283 (whitespace-attribute-p (next-character mark1)))))
284 (insert-character mark1 #\space))
285 (auto-fill-line-as-region point (move-mark mark2 point) prefix column)
286 (move-mark point mark1)
287 (if (and insertp (end-line-p point))
288 (insert-character point #\space)))
289 ((not (or (end-line-p mark1)
290 (whitespace-attribute-p (next-character mark1))))
291 (insert-character mark1 #\space)
292 (%filling-set-next-line point nil prefix)
293 (mark-after point)
294 (%auto-fill-clean-previous-line mark1 mark2))
295 (t
296 (%filling-set-next-line point insertp prefix)
297 (%auto-fill-clean-previous-line mark1 mark2))))))
298
299
300
301 ;;; AUTO-FILL-LINE-AS-REGION basically grabs a line as a region and fills
302 ;;; it. However, it knows about comments and makes auto filling a comment
303 ;;; line as a region look the same as a typical "back up a word and break
304 ;;; the line." When there is a comment, then region starts where the
305 ;;; comment starts instead of the beginning of the line, but the presence
306 ;;; of a prefix overrides all this.
307
308 (defun auto-fill-line-as-region (point mark prefix column)
309 (let* ((start (value comment-start))
310 (begin (value comment-begin))
311 (end (value comment-end)))
312 (line-start mark)
313 (cond ((and (not prefix) start (to-line-comment mark start))
314 (fill-region (region mark (line-end point))
315 (gen-comment-prefix mark start begin)
316 column)
317 (when end
318 (line-start point)
319 (do ()
320 ((mark>= mark point))
321 (if (not (to-comment-end mark end)) (insert-string mark end))
322 (line-offset mark 1 0))))
323 (t (fill-region (region mark (line-end point)) prefix column)))))
324
325
326
327 (defun %auto-fill-blank-before-p (point prefix)
328 "is true if whitespace only precedes point except for the prefix."
329 (or (blank-before-p point)
330 (with-mark ((temp point))
331 (reverse-find-attribute temp :whitespace #'zerop)
332 (<= (mark-column temp) (length prefix)))))
333
334
335
336 ;;; %AUTO-FILL-LINE-AS-REGION-P determines if the line point and mark2
337 ;;; sit on is so long that it might as well be filled as if it were a
338 ;;; region. Mark2 is mark= to point at the beginning of the last word on
339 ;;; the line and is then moved over the whitespace before point. If the
340 ;;; word end prior the last word on the line is on the same line and not
341 ;;; before column, then fill the line as a region.
342
343 (defun %auto-fill-line-as-region-p (point mark2 column)
344 (reverse-find-attribute mark2 :whitespace #'zerop)
345 (and (same-line-p mark2 point)
346 (> (mark-column mark2) column)))
347
348
349
350 (defun %auto-fill-clean-previous-line (mark1 mark2)
351 (when (line-offset mark1 -1)
352 (line-end mark1)
353 (move-mark mark2 mark1)
354 (unless (and (reverse-find-attribute mark1 :whitespace #'zerop)
355 (same-line-p mark1 mark2))
356 (line-start mark1 (mark-line mark2)))
357 (delete-region (region mark1 mark2))))
358
359
360
361 ;;; %FILLING-SET-NEXT-LINE gets a new blank line and sets it up with the
362 ;;; prefix and places the point correctly. The argument point must alias
363 ;;; (current-point).
364
365 (defun %filling-set-next-line (point insertp prefix)
366 (cond ((and (value auto-fill-space-indent) (not prefix))
367 (indent-new-comment-line-command nil))
368 (t (new-line-command nil)
369 (if prefix (insert-string point prefix))))
370 (if (not (find-attribute point :whitespace)) (line-end point))
371 (if insertp (insert-character point #\space)))
372
373
374
375 ;;;; -- Paragraph Filling --
376
377
378 ;;; %FILL-PARAGRAPH-START takes a mark that has just been moved
379 ;;; forward over some paragraph. After moving to the beginning of it, we
380 ;;; place the mark appropriately for filling the paragraph as a region.
381
382 (defun %fill-paragraph-start (mark prefix prefix-len)
383 (paragraph-offset mark -1)
384 (skip-prefix-if-here mark prefix prefix-len)
385 (if (text-blank-line-p mark)
386 (line-offset mark 1 0)
387 (line-start mark)))
388
389
390
391 ;;;; -- Region Filling --
392
393
394 ;;; FILL-REGION-BY-PARAGRAPHS finds paragraphs and uses region filling
395 ;;; primitives to fill them. Tmark2 is only used for the first paragraph; we
396 ;;; need a mark other than start in case start is in the middle of a paragraph
397 ;;; instead of between two.
398 ;;;
399 (defun fill-region-by-paragraphs (region &optional
400 (prefix (value fill-prefix))
401 (column (value fill-column)))
402 "Finds paragraphs in region and fills them as distinct regions using
403 FILL-REGION."
404 (with-mark ((start (region-start region) :left-inserting))
405 (with-mark ((tmark1 start :left-inserting)
406 (tmark2 start :left-inserting)) ;only used for first para.
407 (let ((region (region (copy-mark (region-start region)) ;deleted by undo.
408 (copy-mark (region-end region))))
409 (undo-region (copy-region region))
410 (end (region-end region))
411 (prefix-len (length prefix))
412 (paragraphp (paragraph-offset tmark1 1)))
413 (when paragraphp
414 (%fill-paragraph-start (move-mark tmark2 tmark1) prefix prefix-len)
415 (if (mark>= tmark2 start) (move-mark start tmark2))
416 (cond ((mark>= tmark1 end)
417 (fill-region-aux start end prefix prefix-len column))
418 (t
419 (fill-region-aux start tmark1 prefix prefix-len column)
420 (do ((paragraphp (mark-paragraph start tmark1)
421 (mark-paragraph start tmark1)))
422 ((not paragraphp))
423 (if (mark> start end)
424 (return)
425 (cond ((mark>= tmark1 end)
426 (fill-region-aux start end prefix
427 prefix-len column)
428 (return))
429 (t (fill-region-aux start tmark1
430 prefix prefix-len column))))))))
431 (make-region-undo :twiddle "Fill Region" region undo-region)))))
432
433 (defun fill-region (region &optional
434 (prefix (value fill-prefix))
435 (column (value fill-column)))
436 "Fills a region using the given prefix and column."
437 (let ((prefix (if (and prefix (string= prefix "")) () prefix)))
438 (with-mark ((start (region-start region) :left-inserting))
439 (check-fill-prefix prefix column start)
440 (fill-region-aux start (region-end region)
441 prefix (length prefix) column))))
442
443
444
445 ;;; FILL-REGION-AUX grinds over a region between fill-mark and
446 ;;; end-mark deleting blank lines and filling lines. For each line, the
447 ;;; extra whitespace between words is collapsed to one space, and at the
448 ;;; end and beginning of the line it is deleted. We do not return after
449 ;;; realizing that fill-mark is after end-mark if the line needs to be
450 ;;; broken; it may be the case that there are several filled line lengths
451 ;;; of material before end-mark on the current line.
452
453 (defun fill-region-aux (fill-mark end-mark prefix prefix-len column)
454 (if (and (start-line-p fill-mark) prefix)
455 (fill-region-prefix-line fill-mark prefix prefix-len))
456 (with-mark ((mark1 fill-mark :left-inserting)
457 (cmark fill-mark :left-inserting))
458 (do ((collapse-p t))
459 (nil)
460 (line-end fill-mark)
461 (line-start (move-mark mark1 fill-mark))
462 (skip-prefix-if-here mark1 prefix prefix-len)
463 (cond ((mark>= fill-mark end-mark)
464 (if (mark= fill-mark end-mark)
465 (fill-region-clear-eol fill-mark))
466 (cond ((> (mark-column end-mark) column)
467 (when collapse-p
468 (fill-region-collapse-whitespace cmark end-mark)
469 (setf collapse-p nil))
470 (fill-region-break-line fill-mark prefix
471 prefix-len end-mark column))
472 (t (return))))
473 ((blank-after-p mark1)
474 (fill-region-delete-blank-lines fill-mark end-mark prefix prefix-len)
475 (cond ((mark< fill-mark end-mark)
476 (if prefix
477 (fill-region-prefix-line fill-mark prefix prefix-len))
478 (fill-region-clear-bol fill-mark)
479 (move-mark cmark fill-mark))
480 (t (return)))
481 (setf collapse-p t))
482 (t (fill-region-clear-eol fill-mark)
483 (if collapse-p (fill-region-collapse-whitespace cmark fill-mark))
484 (cond ((> (mark-column fill-mark) column)
485 (fill-region-break-line fill-mark prefix
486 prefix-len end-mark column)
487 (setf collapse-p nil))
488 (t (fill-region-get-next-line fill-mark column
489 prefix prefix-len end-mark)
490 (move-mark cmark fill-mark)
491 (setf collapse-p t))))))
492 (move-mark fill-mark end-mark)))
493
494
495
496 ;;; FILL-REGION-BREAK-LINE breaks lines as close to the low side
497 ;;; column as possible. The first branch handles a word lying across
498 ;;; column while the second takes care of whitespace passing column. If
499 ;;; FILL-REGION-WORD-PAST-COLUMN encountered a single word stretching over
500 ;;; column, it would leave an extra opened line that needs to be cleaned up
501 ;;; or filled up.
502
503 (defun fill-region-break-line (fill-mark prefix prefix-length
504 end-mark column)
505 (with-mark ((mark1 fill-mark :left-inserting))
506 (move-to-column mark1 column)
507 (cond ((not (whitespace-attribute-p (next-character mark1)))
508 (if (not (find-attribute mark1 :whitespace))
509 (line-end mark1))
510 (move-mark fill-mark mark1)
511 (if (eq (fill-region-word-past-column fill-mark mark1 prefix)
512 :handled-oversized-word)
513 (if (mark>= fill-mark end-mark)
514 (delete-characters (line-start fill-mark)
515 prefix-length)
516 (delete-characters fill-mark 1))))
517 (t (move-mark fill-mark mark1)
518 (unless (and (reverse-find-attribute mark1 :whitespace #'zerop)
519 (same-line-p mark1 fill-mark))
520 (line-start mark1 (mark-line fill-mark)))
521 ;; forward find must move mark because of cond branch we are in.
522 (find-attribute fill-mark :whitespace #'zerop)
523 (unless (same-line-p mark1 fill-mark)
524 (line-end fill-mark (mark-line mark1)))
525 (delete-region (region mark1 fill-mark))
526 (insert-character fill-mark #\newline)
527 (if prefix (insert-string fill-mark prefix))))))
528
529
530
531 ;;; FILL-REGION-WORD-PAST-COLUMN takes a point and a second mark that
532 ;;; is mark= at the end of some word. First, point is moved before the
533 ;;; previous "word." If the word is effectively the only word on the line,
534 ;;; it should not be moved down to the next line as it will leave a blank
535 ;;; line.
536
537 (defun fill-region-word-past-column (point mark1 prefix)
538 (with-mark ((mark2 (copy-mark point :left-inserting)))
539 (let ((point-moved-p (reverse-find-attribute point :whitespace))
540 (hack-for-fill-region :handled-normal-case))
541 (cond ((or (not point-moved-p)
542 (%auto-fill-blank-before-p point prefix))
543 (setf hack-for-fill-region :handled-oversized-word)
544 (move-mark point mark1)
545 (fill-region-set-next-line point prefix))
546 (t (fill-region-set-next-line point prefix)
547 (%auto-fill-clean-previous-line mark1 mark2)))
548 hack-for-fill-region)))
549
550 (defun fill-region-set-next-line (point prefix)
551 (insert-character point #\newline)
552 (if prefix (insert-string point prefix))
553 (if (not (find-attribute point :whitespace)) (line-end point)))
554
555
556
557 ;;; FILL-REGION-GET-NEXT-LINE gets another line when the current one
558 ;;; is short of the fill column. It cleans extraneous whitespace from the
559 ;;; beginning of the next line to fill. To save typical redisplay the
560 ;;; length of the first word is added to the ending column of the current
561 ;;; line to see if it extends past the fill column; if it does, then the
562 ;;; fill-mark is left on the new line instead of merging the new line with
563 ;;; the current one. The fill-mark is left after a prefix (if there is one)
564 ;;; on a new line, before the first word brought up to the current line, or
565 ;;; after the end mark.
566
567 (defun fill-region-get-next-line (fill-mark column prefix prefix-len end-mark)
568 (let ((prev-end-pos (mark-column fill-mark))
569 (two-spaces-p (fill-region-insert-two-spaces-p fill-mark)))
570 (with-mark ((tmark fill-mark :left-inserting))
571 (fill-region-find-next-line fill-mark prefix prefix-len end-mark)
572 (move-mark tmark fill-mark)
573 (cond ((mark< fill-mark end-mark)
574 (skip-prefix-if-here tmark prefix prefix-len)
575 (fill-region-clear-bol tmark)
576 (let ((beginning-pos (mark-column tmark)))
577 (find-attribute tmark :whitespace)
578 (cond ((> (+ prev-end-pos (if two-spaces-p 2 1)
579 (- (mark-column tmark) beginning-pos))
580 column)
581 (if prefix
582 (fill-region-prefix-line fill-mark prefix prefix-len)))
583 (t
584 (if (and prefix
585 (%line-has-prefix-p fill-mark prefix prefix-len))
586 (delete-characters fill-mark prefix-len))
587 (delete-characters fill-mark -1)
588 (insert-character fill-mark #\space)
589 (if two-spaces-p (insert-character fill-mark #\space))))))
590 (t
591 (mark-after fill-mark))))))
592
593
594
595 ;;; FILL-REGION-FIND-NEXT-LINE finds the next non-blank line, modulo
596 ;;; fill prefixes, and deletes the intervening lines. Fill-mark is left at
597 ;;; the beginning of the next line.
598
599 (defun fill-region-find-next-line (fill-mark prefix prefix-len end-mark)
600 (line-offset fill-mark 1 0)
601 (when (mark< fill-mark end-mark)
602 (skip-prefix-if-here fill-mark prefix prefix-len)
603 (if (blank-after-p fill-mark)
604 (fill-region-delete-blank-lines fill-mark end-mark prefix prefix-len)
605 (line-start fill-mark))))
606
607
608
609 ;;; FILL-REGION-DELETE-BLANK-LINES deletes the blank line mark is on
610 ;;; and all successive blank lines. Mark is left at the beginning of the
611 ;;; first non-blank line by virtue of its placement and region deletions.
612
613 (defun fill-region-delete-blank-lines (mark end-mark prefix prefix-len)
614 (line-start mark)
615 (with-mark ((tmark mark :left-inserting))
616 (do ((linep (line-offset tmark 1 0) (line-offset tmark 1 0)))
617 ((not linep)
618 (move-mark tmark end-mark)
619 (delete-region (region mark tmark)))
620 (skip-prefix-if-here tmark prefix prefix-len)
621 (when (mark>= tmark end-mark)
622 (move-mark tmark end-mark)
623 (delete-region (region mark tmark))
624 (return))
625 (unless (blank-after-p tmark)
626 (line-start tmark)
627 (delete-region (region mark tmark))
628 (return)))))
629
630
631
632 ;;; FILL-REGION-CLEAR-BOL clears the initial whitespace on a line
633 ;;; known to be non-blank. Note that the fill prefix is not considered, so
634 ;;; the mark must have been moved over it already if there is one.
635
636 (defun fill-region-clear-bol (mark)
637 (with-mark ((tmark mark :left-inserting))
638 (find-attribute tmark :whitespace #'zerop)
639 (unless (mark= mark tmark)
640 (delete-region (region mark tmark)))))
641
642
643
644 ;;; FILL-REGION-COLLAPSE-WHITESPACE deletes extra whitespace between
645 ;;; blocks of non-whitespace characters from mark1 to mark2. Tabs are
646 ;;; converted into a single space. Mark2 must be on the same line as mark1
647 ;;; since there is no concern of newlines, prefixes on a new line, blank
648 ;;; lines between blocks of non-whitespace characters, etc.
649
650 (defun fill-region-collapse-whitespace (mark1 mark2)
651 (with-mark ((tmark mark1 :left-inserting))
652 ;; skip whitespace at beginning of line or single space between words
653 (find-attribute mark1 :whitespace #'zerop)
654 (unless (mark>= mark1 mark2)
655 (do ()
656 (nil)
657 (if (not (find-attribute mark1 :whitespace)) ;not end of buffer
658 (return))
659 (if (mark>= mark1 mark2) (return))
660 (if (char/= (next-character mark1) #\space)
661 ;; since only on one line, must be tab or space
662 (setf (next-character mark1) #\space))
663 (move-mark tmark mark1)
664 (if (mark= (mark-after mark1) mark2) (return))
665 (let ((char (next-character mark1)))
666 (when (and (fill-region-insert-two-spaces-p tmark)
667 (char= char #\space))
668 ;; if at the end of a sentence, don't blow away the second space
669 (if (mark= (mark-after mark1) mark2)
670 (return)
671 (setf char (next-character mark1))))
672 (when (whitespace-attribute-p char) ;more whitespace than necessary
673 (find-attribute (move-mark tmark mark1) :whitespace #'zerop)
674 (if (mark>= tmark mark2) (move-mark tmark mark2))
675 (delete-region (region mark1 tmark))))))))
676
677
678
679 ;;; FILL-REGION-CLEAR-EOL must check the result of
680 ;;; REVERSE-FIND-ATTRIBUTE because if fill-mark did not move, then we are
681 ;;; only whitespace away from the beginning of the buffer.
682
683 (defun fill-region-clear-eol (fill-mark)
684 (with-mark ((mark1 fill-mark :left-inserting))
685 (unless (and (reverse-find-attribute mark1 :whitespace #'zerop)
686 (same-line-p mark1 fill-mark))
687 (line-start mark1 (mark-line fill-mark)))
688 (delete-region (region mark1 fill-mark))))
689
690
691
692 (defun fill-region-prefix-line (fill-mark prefix prefix-length)
693 (if (%line-has-prefix-p fill-mark prefix prefix-length)
694 (character-offset fill-mark prefix-length)
695 (insert-string fill-mark prefix)))
696
697
698
699 (defun %line-has-prefix-p (mark prefix prefix-length)
700 (declare (simple-string prefix))
701 (if (>= (line-length (mark-line mark)) prefix-length)
702 (string= prefix (the simple-string (line-string (mark-line mark)))
703 :end2 prefix-length)))
704
705
706
707 ;;; FILL-REGION-INSERT-TWO-SPACES-P returns true if a sentence
708 ;;; terminator is followed by any number of "closing characters" such as
709 ;;; ",',),etc. If there is a sentence terminator at the end of the current
710 ;;; line, it must be assumed to be the end of a sentence as opposed to an
711 ;;; abbreviation. Why? Because EMACS does, and besides, what would Lisp
712 ;;; code be without heuristics.
713
714 (defun fill-region-insert-two-spaces-p (mark)
715 (do ((n 0 (1+ n)))
716 ((not (sentence-closing-char-attribute-p (previous-character mark)))
717 (cond ((sentence-terminator-attribute-p (previous-character mark))
718 (character-offset mark n))
719 (t (character-offset mark n) nil)))
720 (mark-before mark)))
721
722
723
724 (defun check-fill-prefix (prefix column mark)
725 (when prefix
726 (insert-character mark #\newline)
727 (insert-character mark #\newline)
728 (mark-before mark)
729 (insert-string mark prefix)
730 (let ((pos (mark-column mark)))
731 (declare (simple-string prefix))
732 (mark-after mark)
733 (delete-characters mark (- (+ (length prefix) 2)))
734 (if (>= pos column)
735 (editor-error
736 "The fill prefix length is longer than the fill column.")))))

  ViewVC Help
Powered by ViewVC 1.1.5