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

Contents of /src/hemlock/srccom.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: +0 -2 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/srccom.lisp,v 1.4 1994/10/31 04:50:12 ram Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Source comparison stuff for Hemlock.
13 ;;;
14 ;;; Written by Skef Wholey and Bill Chiles.
15 ;;;
16
17 (in-package "HEMLOCK")
18
19 (defhvar "Source Compare Ignore Extra Newlines"
20 "If T, Source Compare and Source Merge will treat all groups of newlines
21 as if they were a single newline. The default is T."
22 :value t)
23
24 (defhvar "Source Compare Ignore Case"
25 "If T, Source Compare and Source Merge will treat all letters as if they
26 were of the same case. The default is Nil."
27 :value nil)
28
29 (defhvar "Source Compare Ignore Indentation"
30 "This determines whether comparisons ignore initial whitespace on a line or
31 use the whole line."
32 :value nil)
33
34 (defhvar "Source Compare Number of Lines"
35 "This variable controls the number of lines Source Compare and Source Merge
36 will compare when resyncronizing after a difference has been encountered.
37 The default is 3."
38 :value 3)
39
40 (defhvar "Source Compare Default Destination"
41 "This is a sticky-default buffer name to offer when comparison commands prompt
42 for a results buffer."
43 :value "Differences")
44
45
46 (defcommand "Buffer Changes" (p)
47 "Generate a comparison of the current buffer with its file on disk."
48 "Generate a comparison of the current buffer with its file on disk."
49 (declare (ignore p))
50 (let ((buffer (current-buffer)))
51 (unless (buffer-pathname buffer)
52 (editor-error "No pathname associated with buffer."))
53 (let ((other-buffer (or (getstring "Buffer Changes File" *buffer-names*)
54 (make-buffer "Buffer Changes File")))
55 (result-buffer (or (getstring "Buffer Changes Result" *buffer-names*)
56 (make-buffer "Buffer Changes Result"))))
57 (visit-file-command nil (buffer-pathname buffer) other-buffer)
58 (delete-region (buffer-region result-buffer))
59 (compare-buffers-command nil buffer other-buffer result-buffer)
60 (delete-buffer other-buffer))))
61
62 ;;; "Compare Buffers" creates two temporary buffers when there is a prefix.
63 ;;; These get deleted when we're done. Buffer-a and Buffer-b are used for
64 ;;; names is banners in either case.
65 ;;;
66 (defcommand "Compare Buffers" (p &optional buffer-a buffer-b dest-buffer)
67 "Performs a source comparison on two specified buffers. If the prefix
68 argument is supplied, only compare the regions in the buffer."
69 "Performs a source comparison on two specified buffers, Buffer-A and
70 Buffer-B, putting the result of the comparison into the Dest-Buffer.
71 If the prefix argument is supplied, only compare the regions in the
72 buffer."
73 (srccom-choose-comparison-functions)
74 (multiple-value-bind (buffer-a buffer-b dest-point
75 delete-buffer-a delete-buffer-b)
76 (get-srccom-buffers "Compare buffer: " buffer-a buffer-b
77 dest-buffer p)
78 (with-output-to-mark (log dest-point)
79 (format log "Comparison of ~A and ~A.~%~%"
80 (buffer-name buffer-a) (buffer-name buffer-b))
81 (with-mark ((mark-a (buffer-start-mark (or delete-buffer-a buffer-a)))
82 (mark-b (buffer-start-mark (or delete-buffer-b buffer-b))))
83 (loop
84 (multiple-value-bind (diff-a diff-b)
85 (srccom-find-difference mark-a mark-b)
86 (when (null diff-a) (return nil))
87 (format log "**** Buffer ~A:~%" (buffer-name buffer-a))
88 (insert-region dest-point diff-a)
89 (format log "**** Buffer ~A:~%" (buffer-name buffer-b))
90 (insert-region dest-point diff-b)
91 (format log "***************~%~%")
92 (move-mark mark-a (region-end diff-a))
93 (move-mark mark-b (region-end diff-b))
94 (unless (line-offset mark-a 1) (return))
95 (unless (line-offset mark-b 1) (return)))))
96 (format log "Done.~%"))
97 (when delete-buffer-a
98 (delete-buffer delete-buffer-a)
99 (delete-buffer delete-buffer-b))))
100
101
102 ;;; "Merge Buffers" creates two temporary buffers when there is a prefix.
103 ;;; These get deleted when we're done. Buffer-a and Buffer-b are used for
104 ;;; names is banners in either case.
105 ;;;
106 (defcommand "Merge Buffers" (p &optional buffer-a buffer-b dest-buffer)
107 "Performs a source merge on two specified buffers. If the prefix
108 argument is supplied, only compare the regions in the buffer."
109 "Performs a source merge on two specified buffers, Buffer-A and Buffer-B,
110 putting the resulting text into the Dest-Buffer. If the prefix argument
111 is supplied, only compare the regions in the buffer."
112 (srccom-choose-comparison-functions)
113 (multiple-value-bind (buffer-a buffer-b dest-point
114 delete-buffer-a delete-buffer-b)
115 (get-srccom-buffers "Merge buffer: " buffer-a buffer-b
116 dest-buffer p)
117 (with-output-to-mark (stream dest-point)
118 (let ((region-a (buffer-region (or delete-buffer-a buffer-a))))
119 (with-mark ((temp-a (region-start region-a) :right-inserting)
120 (temp-b dest-point :right-inserting)
121 (mark-a (region-start region-a))
122 (mark-b (region-start
123 (buffer-region (or delete-buffer-b buffer-b)))))
124 (clear-echo-area)
125 (loop
126 (multiple-value-bind (diff-a diff-b)
127 (srccom-find-difference mark-a mark-b)
128 (when (null diff-a)
129 (insert-region dest-point (region temp-a (region-end region-a)))
130 (return nil))
131 ;; Copy the part that's the same.
132 (insert-region dest-point (region temp-a (region-start diff-a)))
133 ;; Put both versions in the buffer, and prompt for which one to use.
134 (move-mark temp-a dest-point)
135 (format stream "~%**** Buffer ~A (1):~%" (buffer-name buffer-a))
136 (insert-region dest-point diff-a)
137 (move-mark temp-b dest-point)
138 (format stream "~%**** Buffer ~A (2):~%" (buffer-name buffer-b))
139 (insert-region dest-point diff-b)
140 (command-case
141 (:prompt "Merge Buffers: "
142 :help "Type one of these characters to say how to merge:")
143 (#\1 "Use the text from buffer 1."
144 (delete-region (region temp-b dest-point))
145 (delete-characters temp-a)
146 (delete-region
147 (region temp-a
148 (line-start temp-b
149 (line-next (mark-line temp-a))))))
150 (#\2 "Use the text from buffer 2."
151 (delete-region (region temp-a temp-b))
152 (delete-characters temp-b)
153 (delete-region
154 (region temp-b
155 (line-start temp-a
156 (line-next (mark-line temp-b))))))
157 (#\b "Insert both versions with **** MERGE LOSSAGE **** around them."
158 (insert-string temp-a "
159 **** MERGE LOSSAGE ****")
160 (insert-string dest-point "
161 **** END OF MERGE LOSSAGE ****"))
162 (#\a "Align window at start of difference display."
163 (line-start
164 (move-mark
165 (window-display-start
166 (car (buffer-windows (line-buffer (mark-line temp-a)))))
167 temp-a))
168 (reprompt))
169 (:recursive-edit "Enter a recursive edit."
170 (with-mark ((save dest-point))
171 (do-recursive-edit)
172 (move-mark dest-point save))
173 (reprompt)))
174 (redisplay)
175 (move-mark mark-a (region-end diff-a))
176 (move-mark mark-b (region-end diff-b))
177 (move-mark temp-a mark-a)
178 (unless (line-offset mark-a 1) (return))
179 (unless (line-offset mark-b 1) (return))))))
180 (message "Done."))
181 (when delete-buffer-a
182 (delete-buffer delete-buffer-a)
183 (delete-buffer delete-buffer-b))))
184
185 (defun get-srccom-buffers (first-prompt buffer-a buffer-b dest-buffer p)
186 (unless buffer-a
187 (setf buffer-a (prompt-for-buffer :prompt first-prompt
188 :must-exist t
189 :default (current-buffer))))
190 (unless buffer-b
191 (setf buffer-b (prompt-for-buffer :prompt "With buffer: "
192 :must-exist t
193 :default (previous-buffer))))
194 (unless dest-buffer
195 (setf dest-buffer
196 (prompt-for-buffer :prompt "Putting results in buffer: "
197 :must-exist nil
198 :default-string
199 (value source-compare-default-destination))))
200 (if (stringp dest-buffer)
201 (setf dest-buffer (make-buffer dest-buffer))
202 (buffer-end (buffer-point dest-buffer)))
203 (setf (value source-compare-default-destination) (buffer-name dest-buffer))
204 (change-to-buffer dest-buffer)
205 (let* ((alt-buffer-a (if p (make-buffer (prin1-to-string (gensym)))))
206 (alt-buffer-b (if alt-buffer-a
207 (make-buffer (prin1-to-string (gensym))))))
208 (when alt-buffer-a
209 (ninsert-region (buffer-point alt-buffer-a)
210 (copy-region (if (mark< (buffer-point buffer-a)
211 (buffer-mark buffer-a))
212 (region (buffer-point buffer-a)
213 (buffer-mark buffer-a))
214 (region (buffer-mark buffer-a)
215 (buffer-point buffer-a)))))
216 (ninsert-region (buffer-point alt-buffer-b)
217 (copy-region (if (mark< (buffer-point buffer-b)
218 (buffer-mark buffer-b))
219 (region (buffer-point buffer-b)
220 (buffer-mark buffer-b))
221 (region (buffer-mark buffer-b)
222 (buffer-point buffer-b))))))
223 (values buffer-a buffer-b (current-point) alt-buffer-a alt-buffer-b)))
224 #|
225 (defun get-srccom-buffers (first-prompt buffer-a buffer-b dest-buffer p)
226 (unless buffer-a
227 (setf buffer-a (prompt-for-buffer :prompt first-prompt
228 :must-exist t
229 :default (current-buffer))))
230 (unless buffer-b
231 (setf buffer-b (prompt-for-buffer :prompt "With buffer: "
232 :must-exist t
233 :default (previous-buffer))))
234 (unless dest-buffer
235 (let* ((name (value source-compare-default-destination))
236 (temp-default (getstring name *buffer-names*))
237 (default (or temp-default (make-buffer name))))
238 (setf dest-buffer (prompt-for-buffer :prompt "Putting results in buffer: "
239 :must-exist nil
240 :default default))
241 ;; Delete the default buffer if it did already exist and was not chosen.
242 (unless (or (eq dest-buffer default) temp-default)
243 (delete-buffer default))))
244 (if (stringp dest-buffer)
245 (setf dest-buffer (make-buffer dest-buffer))
246 (buffer-end (buffer-point dest-buffer)))
247 (setf (value source-compare-default-destination) (buffer-name dest-buffer))
248 (change-to-buffer dest-buffer)
249 (let* ((alt-buffer-a (if p (make-buffer (prin1-to-string (gensym)))))
250 (alt-buffer-b (if alt-buffer-a
251 (make-buffer (prin1-to-string (gensym))))))
252 (when alt-buffer-a
253 (ninsert-region (buffer-point alt-buffer-a)
254 (copy-region (if (mark< (buffer-point buffer-a)
255 (buffer-mark buffer-a))
256 (region (buffer-point buffer-a)
257 (buffer-mark buffer-a))
258 (region (buffer-mark buffer-a)
259 (buffer-point buffer-a)))))
260 (ninsert-region (buffer-point alt-buffer-b)
261 (copy-region (if (mark< (buffer-point buffer-b)
262 (buffer-mark buffer-b))
263 (region (buffer-point buffer-b)
264 (buffer-mark buffer-b))
265 (region (buffer-mark buffer-b)
266 (buffer-point buffer-b))))))
267 (values buffer-a buffer-b (current-point) alt-buffer-a alt-buffer-b)))
268 |#
269
270
271 ;;;; Functions that find the differences between two buffers.
272
273 (defun srccom-find-difference (mark-a mark-b)
274 "Returns as multiple values two regions of text that are different in the
275 lines following Mark-A and Mark-B. If no difference is encountered, Nil
276 is returned."
277 (multiple-value-bind (diff-a diff-b)
278 (srccom-different-lines mark-a mark-b)
279 (when diff-a
280 (multiple-value-bind (same-a same-b)
281 (srccom-similar-lines diff-a diff-b)
282 (values (region diff-a same-a)
283 (region diff-b same-b))))))
284
285 ;;; These are set by SRCCOM-CHOOSE-COMPARISON-FUNCTIONS depending on something.
286 ;;;
287 (defvar *srccom-line=* nil)
288 (defvar *srccom-line-next* nil)
289
290 (defun srccom-different-lines (mark-a mark-b)
291 "Returns as multiple values two marks pointing to the first different lines
292 found after Mark-A and Mark-B. Nil is returned if no different lines are
293 found."
294 (do ((line-a (mark-line mark-a) (funcall *srccom-line-next* line-a))
295 (mark-a (copy-mark mark-a))
296 (line-b (mark-line mark-b) (funcall *srccom-line-next* line-b))
297 (mark-b (copy-mark mark-b)))
298 (())
299 (cond ((null line-a)
300 (return (if line-b
301 (values mark-a mark-b))))
302 ((null line-b)
303 (return (values mark-a mark-b))))
304 (line-start mark-a line-a)
305 (line-start mark-b line-b)
306 (unless (funcall *srccom-line=* line-a line-b)
307 (return (values mark-a mark-b)))))
308
309 (defun srccom-similar-lines (mark-a mark-b)
310 "Returns as multiple values two marks pointing to the first similar lines
311 found after Mark-A and Mark-B."
312 (do ((line-a (mark-line mark-a) (funcall *srccom-line-next* line-a))
313 (cmark-a (copy-mark mark-a))
314 (line-b (mark-line mark-b) (funcall *srccom-line-next* line-b))
315 (cmark-b (copy-mark mark-b))
316 (temp)
317 (window-size (value source-compare-number-of-lines)))
318 (())
319 ;; If we hit the end of one buffer, then the difference extends to the end
320 ;; of both buffers.
321 (if (or (null line-a) (null line-b))
322 (return
323 (values
324 (buffer-end-mark (line-buffer (mark-line mark-a)))
325 (buffer-end-mark (line-buffer (mark-line mark-b))))))
326 (line-start cmark-a line-a)
327 (line-start cmark-b line-b)
328 ;; Three cases:
329 ;; 1] Difference will be same length in A and B. If so, Line-A = Line-B.
330 ;; 2] Difference will be longer in A. If so, Line-A = something in B.
331 ;; 3] Difference will be longer in B. If so, Line-B = something in A.
332 (cond ((and (funcall *srccom-line=* line-a line-b)
333 (srccom-check-window line-a line-b window-size))
334 (return (values cmark-a cmark-b)))
335 ((and (setq temp (srccom-line-in line-a mark-b cmark-b))
336 (srccom-check-window line-a temp window-size))
337 (return (values cmark-a (line-start cmark-b temp))))
338 ((and (setq temp (srccom-line-in line-b mark-a cmark-a))
339 (srccom-check-window temp line-b window-size))
340 (return (values (line-start cmark-a temp) cmark-b))))))
341
342 (defun srccom-line-in (line start end)
343 "Checks to see if there is a Line Srccom-Line= to the given Line in the
344 region delimited by the Start and End marks. Returns that line if so, or
345 Nil if there is none."
346 (do ((current (mark-line start) (funcall *srccom-line-next* current))
347 (terminus (funcall *srccom-line-next* (mark-line end))))
348 ((eq current terminus) nil)
349 (if (funcall *srccom-line=* line current)
350 (return current))))
351
352 (defun srccom-check-window (line-a line-b count)
353 "Verifies that the Count lines following Line-A and Line-B are Srccom-Line=.
354 If so, returns T. Otherwise returns Nil."
355 (do ((line-a line-a (funcall *srccom-line-next* line-a))
356 (line-b line-b (funcall *srccom-line-next* line-b))
357 (index 0 (1+ index)))
358 ((= index count) t)
359 (if (not (funcall *srccom-line=* line-a line-b))
360 (return nil))))
361
362
363
364 ;;;; Functions that control the comparison of text.
365
366 ;;; SRCCOM-CHOOSE-COMPARISON-FUNCTIONS -- Internal.
367 ;;;
368 ;;; This initializes utility functions for comparison commands based on Hemlock
369 ;;; variables.
370 ;;;
371 (defun srccom-choose-comparison-functions ()
372 (setf *srccom-line=*
373 (if (value source-compare-ignore-case)
374 (if (value source-compare-ignore-indentation)
375 #'srccom-ignore-case-and-indentation-line=
376 #'srccom-case-insensitive-line=)
377 (if (value source-compare-ignore-indentation)
378 #'srccom-ignore-indentation-case-sensitive-line=
379 #'srccom-case-sensitive-line=)))
380 (setf *srccom-line-next*
381 (if (value source-compare-ignore-extra-newlines)
382 #'srccom-line-next-ignoring-extra-newlines
383 #'line-next)))
384 #|
385 (defun srccom-choose-comparison-functions ()
386 "This function should be called by a ``top level'' source compare utility
387 to initialize the lower-level functions that compare text."
388 (setf *srccom-line=*
389 (if (value source-compare-ignore-case)
390 #'srccom-case-insensitive-line=
391 #'srccom-case-sensitive-line=))
392 (setf *srccom-line-next*
393 (if (value source-compare-ignore-extra-newlines)
394 #'srccom-line-next-ignoring-extra-newlines
395 #'line-next)))
396 |#
397
398 ;;; SRCCOM-LINE-NEXT-IGNORING-EXTRA-NEWLINES -- Internal.
399 ;;;
400 ;;; This is the value of *srccom-line-next* when "Source Compare Ignore Extra
401 ;;; Newlines" is non-nil.
402 ;;;
403 (defun srccom-line-next-ignoring-extra-newlines (line)
404 (if (null line) nil
405 (do ((line (line-next line) (line-next line)))
406 ((or (null line) (not (blank-line-p line))) line))))
407
408 ;;; SRCCOM-IGNORE-CASE-AND-INDENTATION-LINE= -- Internal.
409 ;;; SRCCOM-CASE-INSENSITIVE-LINE= -- Internal.
410 ;;; SRCCOM-IGNORE-INDENTATION-CASE-SENSITIVE-LINE= -- Internal.
411 ;;; SRCCOM-CASE-SENSITIVE-LINE= -- Internal.
412 ;;;
413 ;;; These are the value of *srccom-line-=* depending on the orthogonal values
414 ;;; of "Source Compare Ignore Case" and "Source Compare Ignore Indentation".
415 ;;;
416 (macrolet ((def-line= (name test &optional ignore-indentation)
417 `(defun ,name (line-a line-b)
418 (or (eq line-a line-b) ; if they're both NIL
419 (and line-a
420 line-b
421 (let* ((chars-a (line-string line-a))
422 (len-a (length chars-a))
423 (chars-b (line-string line-b))
424 (len-b (length chars-b)))
425 (declare (simple-string chars-a chars-b))
426 (cond
427 ((and (= len-a len-b)
428 (,test chars-a chars-b)))
429 ,@(if ignore-indentation
430 `((t
431 (flet ((frob (chars len)
432 (dotimes (i len nil)
433 (let ((char (schar chars i)))
434 (unless
435 (or (char= char #\space)
436 (char= char #\tab))
437 (return i))))))
438 (let ((i (frob chars-a len-a))
439 (j (frob chars-b len-b)))
440 (if (and i j)
441 (,test chars-a chars-b
442 :start1 i :end1 len-a
443 :start2 j :end2 len-b)
444 )))))))))))))
445
446 (def-line= srccom-ignore-case-and-indentation-line= string-equal t)
447
448 (def-line= srccom-case-insensitive-line= string-equal)
449
450 (def-line= srccom-ignore-indentation-case-sensitive-line= string= t)
451
452 (def-line= srccom-case-sensitive-line= string=))
453
454 #|
455 ;;; SRCCOM-CASE-INSENSITIVE-LINE= -- Internal.
456 ;;;
457 ;;; Returns t if line-a and line-b contain STRING-EQUAL text.
458 ;;;
459 (defun srccom-case-insensitive-line= (line-a line-b)
460 (or (eq line-a line-b) ; if they're both NIL
461 (and line-a
462 line-b
463 (let ((chars-a (line-string line-a))
464 (chars-b (line-string line-b)))
465 (declare (simple-string chars-a chars-b))
466 (and (= (length chars-a) (length chars-b))
467 (string-equal chars-a chars-b))))))
468
469 ;;; SRCCOM-CASE-SENSITIVE-LINE= -- Internal.
470 ;;;
471 ;;; Returns t if line-a and line-b contain STRING= text.
472 ;;;
473 (defun srccom-case-sensitive-line= (line-a line-b)
474 (or (eq line-a line-b) ; if they're both NIL
475 (and line-a
476 line-b
477 (let ((chars-a (line-string line-a))
478 (chars-b (line-string line-b)))
479 (declare (simple-string chars-a chars-b))
480 (and (= (length chars-a) (length chars-b))
481 (string= chars-a chars-b))))))
482 |#

  ViewVC Help
Powered by ViewVC 1.1.5