- cl-darcs-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[Cl-darcs-cvs] r17 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Jul '06

08 Jul '06

Author: mhenoch Date: Sat Jul 8 10:03:30 2006 New Revision: 17 Modified: cl-darcs/trunk/unwind.lisp Log: In put-before, handle case of empty patch list correctly. Modified: cl-darcs/trunk/unwind.lisp ============================================================================== --- cl-darcs/trunk/unwind.lisp (original) +++ cl-darcs/trunk/unwind.lisp Sat Jul 8 10:03:30 2006 @@ -73,11 +73,12 @@ and commuted through PATCHES, to finally give a list of patches whose context consists of P1. If any commutation fails, this operation fails as well." - (destructuring-bind (&optional p2-c p1-c) (commute (invert-patch p1) (car patches)) - (and p2-c p1-c - (commute p1 p2-c) - (let ((rest (put-before p1-c (cdr patches)))) - (and rest (cons p2-c rest)))))) + (when patches + (destructuring-bind (&optional p2-c p1-c) (commute (invert-patch p1) (car patches)) + (and p2-c p1-c + (commute p1 p2-c) + (let ((rest (put-before p1-c (cdr patches)))) + (and rest (cons p2-c rest))))))) (defun all-head-permutations (ps) "Return all possible permutations of PS.

1 0

[Cl-darcs-cvs] r16 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Jul '06

08 Jul '06

Author: mhenoch Date: Sat Jul 8 07:55:06 2006 New Revision: 16 Modified: cl-darcs/trunk/touching.lisp Log: Declare filename argument as ignored. Modified: cl-darcs/trunk/touching.lisp ============================================================================== --- cl-darcs/trunk/touching.lisp (original) +++ cl-darcs/trunk/touching.lisp Sat Jul 8 07:55:06 2006 @@ -25,6 +25,7 @@ (defmethod find-touching ((patch patch) filename) "This least specific method returns NIL." + (declare (ignore filename)) nil) (defmethod find-touching ((patch composite-patch) filename)

1 0

[Cl-darcs-cvs] r15 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Jun '06

24 Jun '06

Author: mhenoch Date: Sat Jun 24 15:26:19 2006 New Revision: 15 Modified: cl-darcs/trunk/prefs.lisp Log: Add add-to-preflist and set-default-repo. Modified: cl-darcs/trunk/prefs.lisp ============================================================================== --- cl-darcs/trunk/prefs.lisp (original) +++ cl-darcs/trunk/prefs.lisp Sat Jun 24 15:26:19 2006 @@ -67,7 +67,18 @@ :if-exists :supersede :if-does-not-exist :create) (dolist (pref preflist) - (format out "~A~%" pref)))) + (write-line pref out)))) + +(defun add-to-preflist (upath filename pref) + "Add PREF to preferences in FILENAME in repo UPATH. +Do nothing if it's already there." + (let ((prefs (get-preflist upath filename))) + (unless (member pref prefs :test #'string=) + (with-open-file (out (upath-subdir upath '("_darcs" "prefs") filename) + :direction :output + :if-exists :append + :if-does-not-exist :create) + (write-line pref out))))) (defun write-default-prefs (repopath) (default-boring repopath) @@ -105,3 +116,7 @@ "tiff" "pnm" "pbm" "pgm" "ppm" "bmp" "mng" "tar" "bz2" "z" "zip" "jar" "so" "a" "tgz" "mpg" "mpeg" "iso" "exe" "doc"))))) + +(defun set-default-repo (repopath repostring) + (set-preflist repopath "defaultrepo" (list repostring)) + (add-to-preflist repopath "repos" repostring))

1 0

[Cl-darcs-cvs] r14 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Jun '06

24 Jun '06

Author: mhenoch Date: Sat Jun 24 14:47:24 2006 New Revision: 14 Modified: cl-darcs/trunk/prefs.lisp Log: Add {get,set}-preflist, write-default-prefs. Modified: cl-darcs/trunk/prefs.lisp ============================================================================== --- cl-darcs/trunk/prefs.lisp (original) +++ cl-darcs/trunk/prefs.lisp Sat Jun 24 14:47:24 2006 @@ -19,19 +19,13 @@ (defun read-prefs (upath) "Read all preferences from repository at UPATH. Return an alist with strings." - (let ((stream (ignore-errors - (open-upath - (upath-subdir upath '("_darcs" "prefs") "prefs")))) - alist) - (when stream - (with-open-stream (in stream) - (loop for line = (read-line in nil) - while line - do (let ((pos (position #\Space line))) - (when pos - (let ((name (subseq line 0 pos)) - (value (subseq line (1+ pos)))) - (push (cons name value) alist))))))) + (let (alist) + (loop for line in (get-preflist upath "prefs") + do (let ((pos (position #\Space line))) + (when pos + (let ((name (subseq line 0 pos)) + (value (subseq line (1+ pos)))) + (push (cons name value) alist))))) alist)) (defun get-pref (upath prefname) @@ -46,9 +40,68 @@ (if entry (setf (cdr entry) value) (push (cons prefname value) prefs)) - (with-open-file (out (upath-subdir repopath '("_darcs" "prefs") "prefs") - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (dolist (pref prefs) - (format out "~A ~A~%" (car pref) (cdr pref)))))) + (set-preflist repopath "prefs" + (mapcar (lambda (p) (format nil "~A ~A" (car p) (cdr p))) prefs)))) + +(defun get-preflist (upath filename) + "Get list of lines in preference file named by FILENAME in repository UPATH." + (let ((stream (ignore-errors + (open-upath + (upath-subdir upath '("_darcs" "prefs") filename))))) + (when stream + (with-open-stream (in stream) + (flet ((unimportantp (line) + (or (zerop (length line)) + (char= (elt line 0) #\#) + (eql (search "v v v v v v v" line) 0) + (eql (search "*************" line) 0) + (eql (search "^ ^ ^ ^ ^ ^ ^" line) 0)))) + (loop for line = (read-line in nil) + while line + unless (unimportantp line) collect line)))))) + +(defun set-preflist (upath filename preflist) + "Set preferences in FILENAME in repo UPATH to PREFLIST." + (with-open-file (out (upath-subdir upath '("_darcs" "prefs") filename) + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (dolist (pref preflist) + (format out "~A~%" pref)))) + +(defun write-default-prefs (repopath) + (default-boring repopath) + (default-binaries repopath) + (set-preflist repopath "motd" ())) + +(defun default-boring (repopath) + (set-preflist repopath "boring" + '("# Boring file regexps:" + "\\.hi$" + "\\.o$" "\\.o\\.cmd$" + "# *.ko files aren't boring by default because they might" + "# be Korean translations rather than kernel modules." + "# \\.ko$" + "\\.ko\\.cmd$" "\\.mod\\.c$" + "(^|/)\\.tmp_versions($|/)" "(^|/)CVS($|/)" "(^|/)RCS($|/)" "~$" + "#(^|/)\\.[^/]" "(^|/)_darcs($|/)" + "\\.bak$" "\\.BAK$" "\\.orig$" "(^|/)vssver\\.scc$" + "\\.swp$" "(^|/)MT($|/)" + "(^|/)\\{arch\\}($|/)" "(^|/).arch-ids($|/)" + "(^|/)," "\\.class$" "\\.prof$" "(^|/)\\.DS_Store$" + "(^|/)BitKeeper($|/)" "(^|/)ChangeSet($|/)" + "(^|/)\\.svn($|/)" "\\.py[co]$" "\\#" "\\.cvsignore$" + "(^|/)Thumbs\\.db$" + "(^|/)autom4te\\.cache($|/)"))) + +(defun default-binaries (repopath) + (set-preflist + repopath "binaries" + (cons "# Binary file regexps:" + (mapcan (lambda (ext) + (list (format nil "\\.~A$" ext) + (format nil "\\.~A$" (string-upcase ext)))) + '("png" "gz" "pdf" "jpg" "jpeg" "gif" "tif" + "tiff" "pnm" "pbm" "pgm" "ppm" "bmp" "mng" + "tar" "bz2" "z" "zip" "jar" "so" "a" + "tgz" "mpg" "mpeg" "iso" "exe" "doc")))))

1 0

[Cl-darcs-cvs] r13 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Jun '06

24 Jun '06

Author: mhenoch Date: Sat Jun 24 11:59:17 2006 New Revision: 13 Modified: cl-darcs/trunk/apply-patch.lisp cl-darcs/trunk/unreadable-stream.lisp Log: Read lines the same way darcs does. Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Sat Jun 24 11:59:17 2006 @@ -33,7 +33,8 @@ (open ,filename-gensym :direction :input :if-does-not-exist :error - :element-type '(unsigned-byte 8)))) + :element-type '(unsigned-byte 8)) + :haskellish-lines t)) ;; Open a temporary file for writing. (with-temp-file (,outstreamvar :element-type '(unsigned-byte 8)) (progn ,@body) Modified: cl-darcs/trunk/unreadable-stream.lisp ============================================================================== --- cl-darcs/trunk/unreadable-stream.lisp (original) +++ cl-darcs/trunk/unreadable-stream.lisp Sat Jun 24 11:59:17 2006 @@ -19,8 +19,20 @@ (defclass unreadable-stream (trivial-gray-streams:trivial-gray-stream-mixin trivial-gray-streams:fundamental-binary-input-stream) - ((stream :initarg :base-stream) - (buffer :initform nil)) + ((stream + :initarg :base-stream + :documentation "The stream wrapped by this unreadable-stream.") + (haskellish-lines + :initarg :haskellish-lines :initform nil + :documentation "If true, read lines as Haskell would read them. +That is, a line is a (possibly empty) list of characters delimited +by either newlines or end-of-file. In particular, if the file ends +with a newline, it has an extra empty last line in Haskell mode. + +This flag affects only `read-binary-line'.") + + (buffer :initform nil) + (at-end-of-file :initform nil)) (:documentation "A wrapper for a binary input stream. Unlimited \"unreading\" is allowed through UNREAD-BYTE and UNREAD-SEQUENCE.")) @@ -101,6 +113,30 @@ ;; Otherwise, report that the sequence is full. end))) +(defmethod read-binary-line ((stream unreadable-stream) &optional (eof-error-p t) eof-value) + "If stream is in \"Haskell mode\", treat newlines at end of file accordingly." + (if (not (slot-value stream 'haskellish-lines)) + (call-next-method) + ;; The delimiter between lines is a newline or end-of-file. + ;; Thus, if we have just returned the last newline-terminated + ;; line and stand before EOF, we can't just return EOF since + ;; there is an zero-length line between the last newline and the + ;; EOF. + (if (null (slot-value stream 'at-end-of-file)) + ;; So we haven't read EOF yet. That means that we can + ;; return at least one more line (though it may be + ;; zero-length). + (multiple-value-bind (line delim) + (read-until 10 stream nil :eof) + ;; If EOF follows after that line, note it. + (when (eql delim :eof) + (setf (slot-value stream 'at-end-of-file) t)) + line) + ;; If we have already set the EOF flag, act accordingly. + (if eof-error-p + (error 'end-of-file :stream stream) + eof-value)))) + ;; This method is meant as an optimization, but it actually makes ;; things slower. Need to investigate why... #+nil

1 0

[Cl-darcs-cvs] r12 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Jun '06

24 Jun '06

Author: mhenoch Date: Sat Jun 24 09:54:12 2006 New Revision: 12 Modified: cl-darcs/trunk/util.lisp Log: Add comma to read-until docstring. Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Sat Jun 24 09:54:12 2006 @@ -72,7 +72,7 @@ (defun read-until (delimiters stream &optional (eof-error-p t) eof-value) "Read from STREAM until encountering DELIMITERS. -DELIMITERS is an atom or a list of atoms, or a predicate function. +DELIMITERS is an atom, or a list of atoms, or a predicate function. Returns two values: - vector of elements read

1 0

[Cl-darcs-cvs] r11 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Jun '06

24 Jun '06

Author: mhenoch Date: Sat Jun 24 07:24:23 2006 New Revision: 11 Modified: cl-darcs/trunk/unreadable-stream.lisp Log: Comment read-binary-line method of unreadable-stream. Modified: cl-darcs/trunk/unreadable-stream.lisp ============================================================================== --- cl-darcs/trunk/unreadable-stream.lisp (original) +++ cl-darcs/trunk/unreadable-stream.lisp Sat Jun 24 07:24:23 2006 @@ -101,7 +101,11 @@ ;; Otherwise, report that the sequence is full. end))) -#+nil (defmethod read-binary-line ((stream unreadable-stream) &optional (eof-error-p t) eof-value) +;; This method is meant as an optimization, but it actually makes +;; things slower. Need to investigate why... +#+nil +(defmethod read-binary-line :around ((stream unreadable-stream) &optional (eof-error-p t) eof-value) + "If possible, return a recently unread line." ;; If a line has been unread, we just return it. (with-slots (buffer) stream (let ((buffer-entry (car buffer)))

1 0

[Cl-darcs-cvs] r10 - cl-darcs/trunk
by mhenoch＠common-lisp.net 21 Jun '06

21 Jun '06

Author: mhenoch Date: Wed Jun 21 10:57:40 2006 New Revision: 10 Modified: cl-darcs/trunk/apply-patch.lisp Log: Correctly treat hunks in reverse order Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Wed Jun 21 10:57:40 2006 @@ -212,25 +212,30 @@ "Apply a list of patches, attempting to optimize for adjacent hunks." (dformat "~&Looking for adjacent hunks...") (loop while patches - do - (etypecase (car patches) - (hunk-patch - (let ((filename (patch-filename (car patches)))) - (loop while (and (typep (car patches) 'hunk-patch) - (equal (patch-filename (car patches)) filename)) - collect (car patches) into hunks - do (setf patches (cdr patches)) - finally (loop - (restart-case - (progn - (apply-hunk-list hunks repodir) - (return)) - (retry-hunks () - :report (lambda (stream) - (format stream "Retry patch ~A to ~A" hunks filename)))))))) - (patch - (apply-patch (car patches) repodir) - (setf patches (cdr patches)))))) + do + (etypecase (car patches) + (hunk-patch + (let ((filename (patch-filename (car patches))) + (line-number 0)) + (loop while (and (typep (car patches) 'hunk-patch) + (equal (patch-filename (car patches)) filename) + (>= (hunk-line-number (car patches)) line-number)) + collect (car patches) into hunks + do (setf line-number (+ + (hunk-line-number (car patches)) + (length (hunk-new-lines (car patches))))) + (setf patches (cdr patches)) + finally (loop + (restart-case + (progn + (apply-hunk-list hunks repodir) + (return)) + (retry-hunks () + :report (lambda (stream) + (format stream "Retry patch ~A to ~A" hunks filename)))))))) + (patch + (apply-patch (car patches) repodir) + (setf patches (cdr patches)))))) (defun apply-hunk-list (hunks repodir) "Apply HUNKS to REPODIR.

1 0

[Cl-darcs-cvs] r9 - cl-darcs/trunk
by mhenoch＠common-lisp.net 11 Jun '06

11 Jun '06

Author: mhenoch Date: Sun Jun 11 14:56:03 2006 New Revision: 9 Modified: cl-darcs/trunk/patchinfo.lisp Log: Fix invert-patchinfo - make it return the copy as well. Modified: cl-darcs/trunk/patchinfo.lisp ============================================================================== --- cl-darcs/trunk/patchinfo.lisp (original) +++ cl-darcs/trunk/patchinfo.lisp Sun Jun 11 14:56:03 2006 @@ -114,4 +114,5 @@ "Make a copy of PATCHINFO with the inverted flag toggled." (let ((copy (copy-patchinfo patchinfo))) (setf (patchinfo-inverted copy) - (not (patchinfo-inverted copy))))) + (not (patchinfo-inverted copy))) + copy))

1 0

[Cl-darcs-cvs] r8 - cl-darcs/trunk
by mhenoch＠common-lisp.net 11 Jun '06

11 Jun '06

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)))

1 0