[Cl-darcs-cvs] r8 - cl-darcs/trunk

[mhenoch at common-lisp.net]

Author: mhenoch
Date: Sun Jun 11 11:32:20 2006
New Revision: 8

Added:
   cl-darcs/trunk/equal.lisp
Log:
Forgot to add equal.lisp.


Added: cl-darcs/trunk/equal.lisp
==============================================================================
--- (empty file)
+++ cl-darcs/trunk/equal.lisp	Sun Jun 11 11:32:20 2006
@@ -0,0 +1,68 @@
+(in-package :darcs)
+
+(defun equal-list (predicate a b)
+  "Return true if lists A and B are equal according to PREDICATE.
+That is, they have the same length, and for each corresponding
+pair of elements PREDICATE returns true."
+  (and (= (length a) (length b))
+       (catch 'not-equal
+	 (mapc (lambda (x y)
+		 (unless (funcall predicate x y)
+		   (throw 'not-equal nil)))
+	       a b)
+	 t)))
+
+(defgeneric equal-patch (a b &optional really)
+  (:documentation "Return true if patches A and B are equal.
+If REALLY is false, consider named patches with the same name
+to be equal, regardless of content.")
+  (:method-combination and :most-specific-last))
+
+(defmethod equal-patch :around ((a patch) (b patch) &optional really)
+  "If there are no methods for comparing A and B, they are not equal."
+  (declare (ignore really))
+  (if (next-method-p)
+      (call-next-method)
+      nil))
+
+(defmethod equal-patch and ((a file-patch) (b file-patch) &optional really)
+  "Compare two file patches.
+Two file patches can be equal only if they are of the same type and
+patch the same file."
+  (declare (ignore really))
+  (and (eq (class-of a) (class-of b))
+       (equal (patch-filename a) (patch-filename b))))
+
+(defmethod equal-patch and ((a hunk-patch) (b hunk-patch) &optional really)
+  "Compare two hunk patches."
+  (declare (ignore really))
+  (flet ((compare (accessor)
+	   ;; We use equalp, to make it descend into the vaguely
+	   ;; string-like arrays.
+	   (equalp (funcall accessor a) (funcall accessor b))))
+    (and (compare #'hunk-line-number)
+	 (compare #'hunk-old-lines)
+	 (compare #'hunk-new-lines))))
+
+(defmethod equal-patch and ((a binary-patch) (b binary-patch) &optional really)
+  "Compare two binary patches."
+  (declare (ignore really))
+  (and (equalp (binary-oldhex a) (binary-oldhex b))
+       (equalp (binary-newhex a) (binary-newhex b))))
+
+(defmethod equal-patch and ((a token-replace-patch) (b token-replace-patch) &optional really)
+  "Compare two token replacing patches."
+  (declare (ignore really))
+  (flet ((compare (accessor)
+	   ;; Here we use string=.
+	   (string= (funcall accessor a) (funcall accessor b))))
+    (and (compare #'token-regexp) 
+	 (compare #'old-token)
+	 (compare #'new-token))))
+
+(defmethod equal-patch and ((a merger-patch) (b merger-patch) &optional really)
+  "Compare two merger patches."
+  (and (string= (merger-version a) (merger-version b))
+       (eql (merger-inverted a) (merger-inverted b))
+       (equal-patch (merger-first a) (merger-first b) really)
+       (equal-patch (merger-second a) (merger-second b) really)))