| 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 | #+CMU (ext:file-comment
|
|---|
| 8 | "$Header$")
|
|---|
| 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 |
|
|---|
| 272 | ;;;; Functions that find the differences between two buffers.
|
|---|
| 273 |
|
|---|
| 274 | (defun srccom-find-difference (mark-a mark-b)
|
|---|
| 275 | "Returns as multiple values two regions of text that are different in the
|
|---|
| 276 | lines following Mark-A and Mark-B. If no difference is encountered, Nil
|
|---|
| 277 | is returned."
|
|---|
| 278 | (multiple-value-bind (diff-a diff-b)
|
|---|
| 279 | (srccom-different-lines mark-a mark-b)
|
|---|
| 280 | (when diff-a
|
|---|
| 281 | (multiple-value-bind (same-a same-b)
|
|---|
| 282 | (srccom-similar-lines diff-a diff-b)
|
|---|
| 283 | (values (region diff-a same-a)
|
|---|
| 284 | (region diff-b same-b))))))
|
|---|
| 285 |
|
|---|
| 286 | ;;; These are set by SRCCOM-CHOOSE-COMPARISON-FUNCTIONS depending on something.
|
|---|
| 287 | ;;;
|
|---|
| 288 | (defvar *srccom-line=* nil)
|
|---|
| 289 | (defvar *srccom-line-next* nil)
|
|---|
| 290 |
|
|---|
| 291 | (defun srccom-different-lines (mark-a mark-b)
|
|---|
| 292 | "Returns as multiple values two marks pointing to the first different lines
|
|---|
| 293 | found after Mark-A and Mark-B. Nil is returned if no different lines are
|
|---|
| 294 | found."
|
|---|
| 295 | (do ((line-a (mark-line mark-a) (funcall *srccom-line-next* line-a))
|
|---|
| 296 | (mark-a (copy-mark mark-a))
|
|---|
| 297 | (line-b (mark-line mark-b) (funcall *srccom-line-next* line-b))
|
|---|
| 298 | (mark-b (copy-mark mark-b)))
|
|---|
| 299 | (())
|
|---|
| 300 | (cond ((null line-a)
|
|---|
| 301 | (return (if line-b
|
|---|
| 302 | (values mark-a mark-b))))
|
|---|
| 303 | ((null line-b)
|
|---|
| 304 | (return (values mark-a mark-b))))
|
|---|
| 305 | (line-start mark-a line-a)
|
|---|
| 306 | (line-start mark-b line-b)
|
|---|
| 307 | (unless (funcall *srccom-line=* line-a line-b)
|
|---|
| 308 | (return (values mark-a mark-b)))))
|
|---|
| 309 |
|
|---|
| 310 | (defun srccom-similar-lines (mark-a mark-b)
|
|---|
| 311 | "Returns as multiple values two marks pointing to the first similar lines
|
|---|
| 312 | found after Mark-A and Mark-B."
|
|---|
| 313 | (do ((line-a (mark-line mark-a) (funcall *srccom-line-next* line-a))
|
|---|
| 314 | (cmark-a (copy-mark mark-a))
|
|---|
| 315 | (line-b (mark-line mark-b) (funcall *srccom-line-next* line-b))
|
|---|
| 316 | (cmark-b (copy-mark mark-b))
|
|---|
| 317 | (temp)
|
|---|
| 318 | (window-size (value source-compare-number-of-lines)))
|
|---|
| 319 | (())
|
|---|
| 320 | ;; If we hit the end of one buffer, then the difference extends to the end
|
|---|
| 321 | ;; of both buffers.
|
|---|
| 322 | (if (or (null line-a) (null line-b))
|
|---|
| 323 | (return
|
|---|
| 324 | (values
|
|---|
| 325 | (buffer-end-mark (line-buffer (mark-line mark-a)))
|
|---|
| 326 | (buffer-end-mark (line-buffer (mark-line mark-b))))))
|
|---|
| 327 | (line-start cmark-a line-a)
|
|---|
| 328 | (line-start cmark-b line-b)
|
|---|
| 329 | ;; Three cases:
|
|---|
| 330 | ;; 1] Difference will be same length in A and B. If so, Line-A = Line-B.
|
|---|
| 331 | ;; 2] Difference will be longer in A. If so, Line-A = something in B.
|
|---|
| 332 | ;; 3] Difference will be longer in B. If so, Line-B = something in A.
|
|---|
| 333 | (cond ((and (funcall *srccom-line=* line-a line-b)
|
|---|
| 334 | (srccom-check-window line-a line-b window-size))
|
|---|
| 335 | (return (values cmark-a cmark-b)))
|
|---|
| 336 | ((and (setq temp (srccom-line-in line-a mark-b cmark-b))
|
|---|
| 337 | (srccom-check-window line-a temp window-size))
|
|---|
| 338 | (return (values cmark-a (line-start cmark-b temp))))
|
|---|
| 339 | ((and (setq temp (srccom-line-in line-b mark-a cmark-a))
|
|---|
| 340 | (srccom-check-window temp line-b window-size))
|
|---|
| 341 | (return (values (line-start cmark-a temp) cmark-b))))))
|
|---|
| 342 |
|
|---|
| 343 | (defun srccom-line-in (line start end)
|
|---|
| 344 | "Checks to see if there is a Line Srccom-Line= to the given Line in the
|
|---|
| 345 | region delimited by the Start and End marks. Returns that line if so, or
|
|---|
| 346 | Nil if there is none."
|
|---|
| 347 | (do ((current (mark-line start) (funcall *srccom-line-next* current))
|
|---|
| 348 | (terminus (funcall *srccom-line-next* (mark-line end))))
|
|---|
| 349 | ((eq current terminus) nil)
|
|---|
| 350 | (if (funcall *srccom-line=* line current)
|
|---|
| 351 | (return current))))
|
|---|
| 352 |
|
|---|
| 353 | (defun srccom-check-window (line-a line-b count)
|
|---|
| 354 | "Verifies that the Count lines following Line-A and Line-B are Srccom-Line=.
|
|---|
| 355 | If so, returns T. Otherwise returns Nil."
|
|---|
| 356 | (do ((line-a line-a (funcall *srccom-line-next* line-a))
|
|---|
| 357 | (line-b line-b (funcall *srccom-line-next* line-b))
|
|---|
| 358 | (index 0 (1+ index)))
|
|---|
| 359 | ((= index count) t)
|
|---|
| 360 | (if (not (funcall *srccom-line=* line-a line-b))
|
|---|
| 361 | (return nil))))
|
|---|
| 362 |
|
|---|
| 363 |
|
|---|
| 364 | |
|---|
| 365 |
|
|---|
| 366 | ;;;; Functions that control the comparison of text.
|
|---|
| 367 |
|
|---|
| 368 | ;;; SRCCOM-CHOOSE-COMPARISON-FUNCTIONS -- Internal.
|
|---|
| 369 | ;;;
|
|---|
| 370 | ;;; This initializes utility functions for comparison commands based on Hemlock
|
|---|
| 371 | ;;; variables.
|
|---|
| 372 | ;;;
|
|---|
| 373 | (defun srccom-choose-comparison-functions ()
|
|---|
| 374 | (setf *srccom-line=*
|
|---|
| 375 | (if (value source-compare-ignore-case)
|
|---|
| 376 | (if (value source-compare-ignore-indentation)
|
|---|
| 377 | #'srccom-ignore-case-and-indentation-line=
|
|---|
| 378 | #'srccom-case-insensitive-line=)
|
|---|
| 379 | (if (value source-compare-ignore-indentation)
|
|---|
| 380 | #'srccom-ignore-indentation-case-sensitive-line=
|
|---|
| 381 | #'srccom-case-sensitive-line=)))
|
|---|
| 382 | (setf *srccom-line-next*
|
|---|
| 383 | (if (value source-compare-ignore-extra-newlines)
|
|---|
| 384 | #'srccom-line-next-ignoring-extra-newlines
|
|---|
| 385 | #'line-next)))
|
|---|
| 386 | #|
|
|---|
| 387 | (defun srccom-choose-comparison-functions ()
|
|---|
| 388 | "This function should be called by a ``top level'' source compare utility
|
|---|
| 389 | to initialize the lower-level functions that compare text."
|
|---|
| 390 | (setf *srccom-line=*
|
|---|
| 391 | (if (value source-compare-ignore-case)
|
|---|
| 392 | #'srccom-case-insensitive-line=
|
|---|
| 393 | #'srccom-case-sensitive-line=))
|
|---|
| 394 | (setf *srccom-line-next*
|
|---|
| 395 | (if (value source-compare-ignore-extra-newlines)
|
|---|
| 396 | #'srccom-line-next-ignoring-extra-newlines
|
|---|
| 397 | #'line-next)))
|
|---|
| 398 | |#
|
|---|
| 399 |
|
|---|
| 400 | ;;; SRCCOM-LINE-NEXT-IGNORING-EXTRA-NEWLINES -- Internal.
|
|---|
| 401 | ;;;
|
|---|
| 402 | ;;; This is the value of *srccom-line-next* when "Source Compare Ignore Extra
|
|---|
| 403 | ;;; Newlines" is non-nil.
|
|---|
| 404 | ;;;
|
|---|
| 405 | (defun srccom-line-next-ignoring-extra-newlines (line)
|
|---|
| 406 | (if (null line) nil
|
|---|
| 407 | (do ((line (line-next line) (line-next line)))
|
|---|
| 408 | ((or (null line) (not (blank-line-p line))) line))))
|
|---|
| 409 |
|
|---|
| 410 | ;;; SRCCOM-IGNORE-CASE-AND-INDENTATION-LINE= -- Internal.
|
|---|
| 411 | ;;; SRCCOM-CASE-INSENSITIVE-LINE= -- Internal.
|
|---|
| 412 | ;;; SRCCOM-IGNORE-INDENTATION-CASE-SENSITIVE-LINE= -- Internal.
|
|---|
| 413 | ;;; SRCCOM-CASE-SENSITIVE-LINE= -- Internal.
|
|---|
| 414 | ;;;
|
|---|
| 415 | ;;; These are the value of *srccom-line-=* depending on the orthogonal values
|
|---|
| 416 | ;;; of "Source Compare Ignore Case" and "Source Compare Ignore Indentation".
|
|---|
| 417 | ;;;
|
|---|
| 418 | (macrolet ((def-line= (name test &optional ignore-indentation)
|
|---|
| 419 | `(defun ,name (line-a line-b)
|
|---|
| 420 | (or (eq line-a line-b) ; if they're both NIL
|
|---|
| 421 | (and line-a
|
|---|
| 422 | line-b
|
|---|
| 423 | (let* ((chars-a (line-string line-a))
|
|---|
| 424 | (len-a (length chars-a))
|
|---|
| 425 | (chars-b (line-string line-b))
|
|---|
| 426 | (len-b (length chars-b)))
|
|---|
| 427 | (declare (simple-string chars-a chars-b))
|
|---|
| 428 | (cond
|
|---|
| 429 | ((and (= len-a len-b)
|
|---|
| 430 | (,test chars-a chars-b)))
|
|---|
| 431 | ,@(if ignore-indentation
|
|---|
| 432 | `((t
|
|---|
| 433 | (flet ((frob (chars len)
|
|---|
| 434 | (dotimes (i len nil)
|
|---|
| 435 | (let ((char (schar chars i)))
|
|---|
| 436 | (unless
|
|---|
| 437 | (or (char= char #\space)
|
|---|
| 438 | (char= char #\tab))
|
|---|
| 439 | (return i))))))
|
|---|
| 440 | (let ((i (frob chars-a len-a))
|
|---|
| 441 | (j (frob chars-b len-b)))
|
|---|
| 442 | (if (and i j)
|
|---|
| 443 | (,test chars-a chars-b
|
|---|
| 444 | :start1 i :end1 len-a
|
|---|
| 445 | :start2 j :end2 len-b)
|
|---|
| 446 | )))))))))))))
|
|---|
| 447 |
|
|---|
| 448 | (def-line= srccom-ignore-case-and-indentation-line= string-equal t)
|
|---|
| 449 |
|
|---|
| 450 | (def-line= srccom-case-insensitive-line= string-equal)
|
|---|
| 451 |
|
|---|
| 452 | (def-line= srccom-ignore-indentation-case-sensitive-line= string= t)
|
|---|
| 453 |
|
|---|
| 454 | (def-line= srccom-case-sensitive-line= string=))
|
|---|
| 455 |
|
|---|
| 456 | #|
|
|---|
| 457 | ;;; SRCCOM-CASE-INSENSITIVE-LINE= -- Internal.
|
|---|
| 458 | ;;;
|
|---|
| 459 | ;;; Returns t if line-a and line-b contain STRING-EQUAL text.
|
|---|
| 460 | ;;;
|
|---|
| 461 | (defun srccom-case-insensitive-line= (line-a line-b)
|
|---|
| 462 | (or (eq line-a line-b) ; if they're both NIL
|
|---|
| 463 | (and line-a
|
|---|
| 464 | line-b
|
|---|
| 465 | (let ((chars-a (line-string line-a))
|
|---|
| 466 | (chars-b (line-string line-b)))
|
|---|
| 467 | (declare (simple-string chars-a chars-b))
|
|---|
| 468 | (and (= (length chars-a) (length chars-b))
|
|---|
| 469 | (string-equal chars-a chars-b))))))
|
|---|
| 470 |
|
|---|
| 471 | ;;; SRCCOM-CASE-SENSITIVE-LINE= -- Internal.
|
|---|
| 472 | ;;;
|
|---|
| 473 | ;;; Returns t if line-a and line-b contain STRING= text.
|
|---|
| 474 | ;;;
|
|---|
| 475 | (defun srccom-case-sensitive-line= (line-a line-b)
|
|---|
| 476 | (or (eq line-a line-b) ; if they're both NIL
|
|---|
| 477 | (and line-a
|
|---|
| 478 | line-b
|
|---|
| 479 | (let ((chars-a (line-string line-a))
|
|---|
| 480 | (chars-b (line-string line-b)))
|
|---|
| 481 | (declare (simple-string chars-a chars-b))
|
|---|
| 482 | (and (= (length chars-a) (length chars-b))
|
|---|
| 483 | (string= chars-a chars-b))))))
|
|---|
| 484 | |#
|
|---|
