Update of /project/stamp/cvsroot/stamp In directory clnet:/tmp/cvs-serv28250

Modified Files: mel-extra.lisp Log Message: Mel-base uses declarations of `simple-base-string' that it probably shouldn't. Recent versions of SBCL don't seem to return simple base string in some contexts where mel-base wants them.

Fix this temporarily by redefining the offending mel-base functions.

--- /project/stamp/cvsroot/stamp/mel-extra.lisp 2007/01/04 06:13:08 1.1 +++ /project/stamp/cvsroot/stamp/mel-extra.lisp 2007/02/15 14:27:18 1.2 @@ -11,3 +11,50 @@ while c do (write-char c sink) finally (return (mel.folders.maildir::unique-message-name sink))))))

+(in-package :mel.folders.maildir) + +(declaim (inline uidify)) +(defun uidify (file) + (let ((uid-end (position #: file :from-end t))) + (if uid-end + (subseq file 0 uid-end) + file))) + +(defun find-message-file (folder uid) + (let ((uid (uidify uid))) + (declare (type string uid)) + (let ((cell (gethash uid (uid-cache folder)))) + (when cell + (case (car cell) + (:new (mel.filesystem:append-name (new-mail folder) (cdr cell))) + (:cur (mel.filesystem:append-name (current-mail folder) (cdr cell)))))))) + +(defmethod map-messages (fn (folder maildir-folder)) + (declare (optimize (speed 0) (safety 3))) + (or (and (folder-recent-p folder) + (slot-boundp folder 'selected-messages) + (selected-messages folder) + (progn (map nil fn (selected-messages folder)) (selected-messages folder))) + (setf (selected-messages folder) + (let ((messages nil)) + (flet ((push-message (file) + (let ((message (find-message folder file :if-does-not-exist :create))) + (push message messages) + message))) + (declare #-(or sbcl cmu)(dynamic-extent #'push-message)) + (let ((uid-cache (uid-cache folder))) + + (mel.filesystem:map-directory + (lambda (file) + (setf (gethash file uid-cache) (cons :new file)) + (funcall fn (push-message file))) + (namestring (truename (new-mail folder)))) + + (mel.filesystem:map-directory + (lambda (file) + (let ((uid (uidify file))) + (setf (gethash uid uid-cache) (cons :cur file)) + (funcall fn (push-message file)))) + (namestring (truename (current-mail folder)))))) + + (nreverse messages)))))