From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 22 Apr 2000 01:54:37 +0000 (+0000)
Subject: First attempt at a parser for IMAP server responses.
X-Git-Tag: 20090517-FFI~3994
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4b14e45f6f34a1f466a68d724e242b88133ba6f8;p=mit-scheme.git

First attempt at a parser for IMAP server responses.
---

diff --git a/v7/src/imail/compile.scm b/v7/src/imail/compile.scm
index c5a1f1c8c..7b0fde759 100644
--- a/v7/src/imail/compile.scm
+++ b/v7/src/imail/compile.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: compile.scm,v 1.5 2000/04/18 21:44:45 cph Exp $
+;;; $Id: compile.scm,v 1.6 2000/04/22 01:53:42 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -31,6 +31,7 @@
 		"imail-rmail"
 		"imail-umail"
 		"imail-util"
+		"imap-response"
 		"imap-syntax"
 		"parser"
 		"rexp"
diff --git a/v7/src/imail/ed-ffi.scm b/v7/src/imail/ed-ffi.scm
index 3bb7a97b3..b62e07169 100644
--- a/v7/src/imail/ed-ffi.scm
+++ b/v7/src/imail/ed-ffi.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: ed-ffi.scm,v 1.7 2000/04/18 21:44:46 cph Exp $
+;;; $Id: ed-ffi.scm,v 1.8 2000/04/22 01:53:43 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -28,6 +28,7 @@
     ("imail-top"	(edwin imail)		edwin-syntax-table)
     ("imail-umail"	(edwin imail)		system-global-syntax-table)
     ("imail-util"	(edwin imail)		system-global-syntax-table)
+    ("imap-response"	(edwin imail imap-response) system-global-syntax-table)
     ("imap-syntax"	(edwin imail imap-syntax) system-global-syntax-table)
     ("parser"		(edwin imail parser)	system-global-syntax-table)
     ("rexp"		(edwin imail rexp)	system-global-syntax-table)
diff --git a/v7/src/imail/fake-env.scm b/v7/src/imail/fake-env.scm
index 09d9d31b9..d4b5df9cc 100644
--- a/v7/src/imail/fake-env.scm
+++ b/v7/src/imail/fake-env.scm
@@ -6,6 +6,7 @@
 			       (in-package (package/environment package)
 				 (make-environment)))))))
   (new-child '(EDWIN) 'IMAIL)
+  (new-child '(EDWIN IMAIL) 'IMAP-response)
   (new-child '(EDWIN IMAIL) 'IMAP-SYNTAX)
   (new-child '(EDWIN IMAIL) 'PARSER)
   (new-child '(EDWIN IMAIL) 'REXP)
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index d6751f6bf..61b91ba2e 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.15 2000/04/18 21:50:34 cph Exp $
+;;; $Id: imail.pkg,v 1.16 2000/04/22 01:53:45 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -116,32 +116,19 @@
   (files "imap-syntax")
   (parent (edwin imail))
   (export (edwin imail)
-	  imap:char-set:achar
+	  imap:atom-char?
 	  imap:char-set:atom-char
-	  imap:char-set:list-wildcards
-	  imap:char-set:quoted-specials
-	  imap:match:achar+
-	  imap:match:astring
-	  imap:match:atom
-	  imap:match:bchar+
-	  imap:match:date
-	  imap:match:literal
-	  imap:match:number
-	  imap:match:nz-number
-	  imap:match:quoted-string
-	  imap:match:search-key
-	  imap:match:search-program
-	  imap:match:section
-	  imap:match:section-text
-	  imap:match:set
-	  imap:match:string
-	  imap:parse:enc-mailbox
-	  imap:parse:mailboxlist
-	  imap:parse:messagelist
-	  imap:parse:messagepart
-	  imap:parse:server
-	  imap:parse:simple-message
-	  imap:parse:uidvalidity))
+	  imap:char-set:tag-char
+	  imap:char-set:text-char
+	  imap:match:tag
+	  imap:quoted-char?
+	  imap:quoted-special?))
+
+(define-package (edwin imail imap-response)
+  (files "imap-response")
+  (parent (edwin imail))
+  (export (edwin imail)
+	  imap:read-server-response))
 
 (define-package (edwin imail)
   (files "imail-util"
diff --git a/v7/src/imail/imap-response.scm b/v7/src/imail/imap-response.scm
new file mode 100644
index 000000000..964067a64
--- /dev/null
+++ b/v7/src/imail/imap-response.scm
@@ -0,0 +1,308 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: imap-response.scm,v 1.1 2000/04/22 01:53:46 cph Exp $
+;;;
+;;; Copyright (c) 2000 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; IMAP Server Response Parser
+
+(declare (usual-integrations))
+
+;;;; IMAP response reader
+
+(define (imap:read-server-response port)
+  (let ((tag (read-string char-set:space port)))
+    (if (eof-object? tag)
+	tag
+	(begin
+	  (discard-known-char #\space port)
+	  (let ((response
+		 (cond ((string=? "+" tag)
+			(cons 'CONTINUE (read-response-text port)))
+		       ((string=? "*" tag)
+			(read-untagged-response port))
+		       ((let ((end (string-length tag)))
+			  (let ((index (imap:match:tag tag 0 end)))
+			    (and index
+				 (fix:= index end))))
+			(read-tagged-response tag port))
+		       (else
+			(error "Malformed server response:" tag)))))
+	    (discard-known-char #\newline port)
+	    response)))))
+
+(define (read-untagged-response port)
+  (let ((x (read-atom port)))
+    (if (atom-is-number? x)
+	(let ((n (string->number x))
+	      (x (intern (read-atom port))))
+	  (case x
+	    ((EXISTS RECENT EXPUNGE) (list x n))
+	    ((FETCH) (read-fetch-response port))
+	    (else (error "Malformed response code:" x))))
+	(let ((x (intern x)))
+	  (cons x
+		(case x
+		  ((OK NO BAD) (cons #f (read-response-text port)))
+		  ((PREAUTH BYE) (read-response-text port))
+		  ((FLAGS) (read-flags-response port))
+		  ((MAILBOX) (read-mailbox-response port))
+		  ((LIST LSUB) (read-list-response port))
+		  ((SEARCH) (read-search-response port))
+		  ((STATUS) (read-status-response port))
+		  ((CAPABILITY) (read-capability-response port))
+		  (else (error "Malformed response code:" x))))))))
+
+(define (read-tagged-response tag port)
+  (let ((x (intern (read-atom port))))
+    (if (memq x '(OK NO BAD))
+	(cons* x tag (read-response-text port))
+	(error "Malformed response code:" x))))
+
+(define (read-response-text port)
+  (discard-known-char #\space port)
+  (let ((code
+	 (and (char=? #\[ (peek-char port))
+	      (let ((code (read-bracket-list port)))
+		(discard-known-char #\space port)
+		code))))
+    (list code
+	  (if (char=? #\= (peek-char port))
+	      (read-mime2-text port)
+	      (list (read-text port))))))
+
+(define (read-fetch-response port)
+  (discard-known-char #\space port)
+  (read-list port))
+
+(define (read-flags-response port)
+  (discard-known-char #\space port)
+  (read-list port read-flag))
+
+(define (read-mailbox-response port)
+  (discard-known-char #\space port)
+  (list (read-text port)))
+
+(define (read-list-response port)
+  (let ((flags (read-flags-response port)))
+    (discard-known-char #\space port)
+    (let ((delim (read-nstring port)))
+      (discard-known-char #\space port)
+      (list flags delim (read-astring port)))))
+
+(define (read-search-response port)
+  (read-open-list read-nz-number port))
+
+(define (read-status-response port)
+  (discard-known-char #\space port)
+  (let ((mailbox (read-astring port)))
+    (discard-known-char #\space port)
+    (list mailbox
+	  (read-list port
+		     (lambda (port)
+		       (let ((name (read-atom port)))
+			 (discard-known-char #\space port)
+			 (cons name (read-number port))))))))
+
+(define (read-capability-response port)
+  (read-open-list read-atom port))
+
+(define (read-generic port)
+  (let ((char (peek-char-no-eof port)))
+    (cond ((char=? #\" char) (read-quoted port))
+	  ((char=? #\{ char) (read-literal port))
+	  ((char=? #\( char) (cons 'LIST (read-list port)))
+	  ((char=? #\[ char) (cons 'BRACKET-LIST (read-bracket-list port)))
+	  ((char=? #\\ char) (read-pflag port))
+	  ((imap:atom-char? char)
+	   (let ((atom (read-atom port)))
+	     (if (atom-is-number? atom)
+		 (string->number atom)
+		 atom)))
+	  (else (error "Illegal IMAP syntax:" char)))))
+
+(define (read-astring port)
+  (let ((char (peek-char-no-eof port)))
+    (cond ((char=? #\" char) (read-quoted port))
+	  ((char=? #\{ char) (read-literal port))
+	  ((imap:atom-char? char) (read-atom port))
+	  (else (error "Illegal astring syntax:" char)))))
+
+(define (read-nstring port)
+  (let ((v (read-astring port)))
+    (if (and (string? v) (not (string-ci=? "NIL" v)))
+	(error "Illegal nstring:" v)
+	v)))
+
+(define (read-quoted port)
+  (discard-known-char #\" port)
+  (let ((port* (make-accumulator-output-port))
+	(lose (lambda () (error "Malformed quoted string."))))
+    (let loop ()
+      (let ((char (read-char-no-eof port)))
+	(cond ((imap:quoted-char? char)
+	       (write-char char port*)
+	       (loop))
+	      ((char=? #\" char)
+	       (list 'QUOTED (get-output-from-accumulator port*)))
+	      ((char=? #\\ char)
+	       (let ((char (read-char-no-eof char)))
+		 (if (imap:quoted-special? char)
+		     (begin
+		       (write-char char port*)
+		       (loop))
+		     (lose))))
+	      (else (lose)))))))
+
+(define (read-literal port)
+  (discard-known-char #\{ port)
+  (let ((n (read-number port)))
+    (discard-known-char #\} port)
+    (discard-known-char #\newline port)
+    (let ((s (make-string n)))
+      (let loop ((i 0) (j 0))
+	(cond ((fix:< i n)
+	       (let ((char (read-char-no-eof port)))
+		 (string-set! s j char)
+		 (loop (fix:+ i (if (char=? char #\newline) 2 1))
+		       (fix:+ j 1))))
+	      ((fix:< j n)
+	       (set-string-length! s j))))
+      (list 'LITERAL s))))
+
+(define (read-list port #!optional read-item)
+  (read-closed-list #\( #\)
+		    (if (default-object? read-item) read-generic read-item)
+		    port))
+
+(define (read-bracket-list port #!optional read-item)
+  (read-closed-list #\[ #\]
+		    (if (default-object? read-item) read-generic read-item)
+		    port))
+
+(define (read-closed-list open close read-item port)
+  (discard-known-char open port)
+  (if (char=? close (peek-char-no-eof port))
+      (begin
+	(read-char port)
+	'())
+      (let loop ((items (list (read-item port))))
+	(let ((char (read-char-no-eof port)))
+	  (cond ((char=? char #\space) (loop (cons (read-item port) items)))
+		((char=? char close) (reverse! items))
+		(else (error "Illegal list delimiter:" char)))))))
+
+(define (read-open-list read-item port)
+  (let loop ((items '()))
+    (let ((char (peek-char-no-eof port)))
+      (cond ((char=? char #\space)
+	     (read-char port)
+	     (loop (cons (read-item port) items)))
+	    ((char=? char #\newline)
+	     (reverse! items))
+	    (else
+	     (error "Illegal list delimiter:" char))))))
+
+(define (read-pflag port)
+  (discard-known-char #\\ port)
+  (if (char=? #\* (peek-char-no-eof port))
+      (begin
+	(read-char port)
+	"\\*")
+      (string-append "\\" (read-atom port))))
+
+(define (read-flag port)
+  (if (char=? #\\ (peek-char-no-eof port))
+      (begin
+	(read-char port)
+	(string-append "\\" (read-atom port)))
+      (read-atom port)))
+
+(define (non-null-string-reader constituents)
+  (let ((delimiters (char-set-invert constituents)))
+    (lambda (port)
+      (let ((s (read-string delimiters port)))
+	(if (string-null? s)
+	    (error "Empty string.")
+	    s)))))
+
+(define read-number
+  (let ((reader (non-null-string-reader char-set:numeric)))
+    (lambda (port)
+      (string->number (reader port)))))
+
+(define (read-nz-number port)
+  (let ((n (read-number port)))
+    (if (> n 0)
+	n
+	(error "Zero not allowed here."))))
+
+(define read-tag
+  (non-null-string-reader imap:char-set:tag-char))
+
+(define read-atom
+  (non-null-string-reader imap:char-set:atom-char))
+
+(define read-text
+  (non-null-string-reader imap:char-set:text-char))
+
+(define (read-mime2-text port)
+  (discard-known-char #\= port)
+  (discard-known-char #\? port)
+  (let ((charset (read-mime2-token port)))
+    (discard-known-char #\? port)
+    (let ((encoding (read-mime2-token port)))
+      (discard-known-char #\? port)
+      (let ((encoded-text (read-mime2-encoded-text port)))
+	(discard-known-char #\? port)
+	(discard-known-char #\= port)
+	(list charset encoding encoded-text)))))
+
+(define read-mime2-token
+  (non-null-string-reader
+   (char-set-difference char-set:graphic
+			(string->char-set " ()<>@,;:\"/[]?.="))))
+
+(define read-mime2-encoded-text
+  (non-null-string-reader
+   (char-set-difference char-set:graphic
+			(string->char-set " ?"))))
+
+(define atom-is-number?
+  (let ((char-set:not-numeric (char-set-invert char-set:numeric)))
+    (lambda (atom)
+      (string-find-next-char-in-set atom char-set:not-numeric))))
+
+(define char-set:space
+  (char-set #\space))
+
+(define (read-char-no-eof port)
+  (let ((char (read-char port)))
+    (if (eof-object? char)
+	(error "Unexpected end of file:" port))
+    char))
+
+(define (peek-char-no-eof port)
+  (let ((char (peek-char port)))
+    (if (eof-object? char)
+	(error "Unexpected end of file:" port))
+    char))
+
+(define (discard-known-char char port)
+  (let ((char* (read-char-no-eof port)))
+    (if (not (char=? char char*))
+	(error "Missing newline in literal:" char*))))
\ No newline at end of file
diff --git a/v7/src/imail/imap-syntax.scm b/v7/src/imail/imap-syntax.scm
index 22b3d2241..7dc4a3610 100644
--- a/v7/src/imail/imap-syntax.scm
+++ b/v7/src/imail/imap-syntax.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imap-syntax.scm,v 1.1 2000/04/18 21:30:57 cph Exp $
+;;; $Id: imap-syntax.scm,v 1.2 2000/04/22 01:53:48 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -38,28 +38,79 @@
 (define imap:char-set:quoted-specials
   (char-set #\" #\\))
 
+(define (imap:quoted-special? char)
+  (char-set-member? imap:char-set:quoted-specials char))
+
 (define imap:char-set:list-wildcards
   (char-set #\% #\*))
 
+(define imap:char-set:char
+  (ascii-range->char-set #x01 #x80))
+
+(define imap:char-set:ctl
+  (char-set-union (ascii-range->char-set #x00 #x20)
+		  (char-set #\rubout)))
+
 (define imap:char-set:atom-char
-  (char-set-invert
-   (char-set-union (char-set #\( #\) #\{ #\space #\rubout)
-		   imap:char-set:quoted-specials
-		   imap:char-set:list-wildcards
-		   (ascii-range->char-set #x00 #x20))))
+  (char-set-difference imap:char-set:char
+		       (char-set-union (char-set #\( #\) #\{ #\space)
+				       imap:char-set:ctl
+				       imap:char-set:list-wildcards
+				       imap:char-set:quoted-specials)))
+
+(define (imap:atom-char? char)
+  (char-set-member? imap:char-set:atom-char char))
+
+(define imap:char-set:text-char
+  (char-set-difference imap:char-set:char
+		       (char-set #\return #\linefeed)))
+
+(define imap:char-set:quoted-char
+  (char-set-difference imap:char-set:text-char
+		       imap:char-set:quoted-specials))
+
+(define (imap:quoted-char? char)
+  (char-set-member? imap:char-set:quoted-char char))
 
+(define imap:char-set:base64
+  (char-set-union char-set:alphanumeric
+		  (char-set #\+ #\/)))
+
+(define imap:char-set:tag-char
+  (char-set-difference imap:char-set:atom-char
+		       (char-set #\+)))
+
 (define imap:match:atom
   (rexp-matcher (rexp+ imap:char-set:atom-char)))
 
+(define imap:match:text
+  (rexp-matcher (rexp+ imap:char-set:text-char)))
+
+(define imap:match:tag
+  (rexp-matcher (rexp+ imap:char-set:tag-char)))
+
+(define imap:match:base64
+  (rexp-matcher
+   (rexp-sequence
+    (rexp* imap:char-set:base64
+	   imap:char-set:base64
+	   imap:char-set:base64
+	   imap:char-set:base64)
+    (rexp-optional
+     (rexp-alternatives
+      (rexp-sequence imap:char-set:base64
+		     imap:char-set:base64
+		     "==")
+      (rexp-sequence imap:char-set:base64
+		     imap:char-set:base64
+		     imap:char-set:base64
+		     "="))))))
+
 (define imap:match:quoted-string
   (rexp-matcher
    (rexp-sequence "\""
 		  (rexp* (rexp-alternatives
-			  (char-set-difference
-			   (char-set-difference
-			    (ascii-range->char-set #x01 #x80)
-			    (char-set #\return #\linefeed))
-			   imap:char-set:quoted-specials)
+			  imap:char-set:quoted-char
 			  (rexp-sequence "\\" imap:char-set:quoted-specials)))
 		  "\"")))
 
@@ -81,7 +132,7 @@
 (define imap:match:astring
   (alternatives-matcher imap:match:atom
 			imap:match:string))
-
+
 (define imap:match:number
   (rexp-matcher (rexp+ char-set:numeric)))
 
@@ -89,7 +140,7 @@
   (rexp-matcher
    (rexp-sequence (char-set-difference char-set:numeric (char-set #\0))
 		  (rexp* char-set:numeric))))
-
+
 (define imap:match:date
   (let ((date-text
 	 (rexp-matcher
@@ -278,5 +329,213 @@
 
 (define imap:parse:simple-message
   (sequence-parser imap:parse:enc-mailbox
-		   (noise-parser (ci-string-matcher "/;uid="))
-		   (simple-parser imap:match:nz-number 'UID)))
\ No newline at end of file
+		   (optional-parser
+		    (noise-parser (ci-string-matcher "/;uid="))
+		    (simple-parser imap:match:nz-number 'UID))))
+
+;;;; Mailbox-name encoding (modified UTF-7)
+
+(define (imap:encode-mailbox-name string start end)
+  (let ((n
+	 (let loop ((start start) (n 0))
+	   (let ((index
+		  (substring-find-next-char-in-set
+		   string start end imap:char-set:mailbox-name-encoded)))
+	     (if index
+		 (let ((n (fix:+ n (fix:+ (fix:- index start) 2))))
+		   (let ((index*
+			  (or (substring-find-next-char-in-set
+			       string (fix:+ index 1) end
+			       imap:char-set:mailbox-name-unencoded)
+			      end)))
+		     (loop index*
+			   (fix:+ n
+				  (let ((m (fix:- index* index)))
+				    (if (and (fix:= m 1)
+					     (char=? (string-ref string index)
+						     #\&))
+					0
+					(integer-ceiling (fix:* 8 m) 6)))))))
+		 (fix:+ n (fix:- end start)))))))
+    (let ((s (make-string n)))
+      (let loop ((start start) (j 0))
+	(let ((index
+	       (substring-find-next-char-in-set
+		string start end imap:char-set:mailbox-name-encoded)))
+	  (if index
+	      (let ((j (substring-move! string start index s j)))
+		(string-set! s j #\&)
+		(let ((j (fix:+ j 1))
+		      (index*
+		       (or (substring-find-next-char-in-set
+			    string (fix:+ index 1) end
+			    imap:char-set:mailbox-name-unencoded)
+			   end)))
+		  (let ((j
+			 (if (and (fix:= (fix:- index* index) 1)
+				  (char=? (string-ref string index) #\&))
+			     j
+			     (encode-mailbox-name-1 string index index* s j))))
+		    (string-set! s j #\-)
+		    (loop index* (fix:+ j 1))))))))
+      s)))
+
+(define (imap:decode-mailbox-name string start end)
+  (let ((lose
+	 (lambda ()
+	   (error "Malformed encoded mailbox name:"
+		  (substring string start end)))))
+    (let ((n
+	   (let loop ((start start) (n 0))
+	     (let ((index (substring-find-next-char string start end #\&)))
+	       (if index
+		   (let ((index*
+			  (substring-find-next-char string (fix:+ index 1) end
+						    #\-)))
+		     (if (not index*) (lose))
+		     (loop (fix:+ index* 1)
+			   (fix:+ n
+				  (let ((m (fix:- index* index)))
+				    (if (fix:= m 1)
+					1
+					(let ((q (fix:quotient m 4))
+					      (r (fix:remainder m 4)))
+					  (fix:+ (fix:* 3 q)
+						 (case r
+						   ((0) 0)
+						   ((2) 1)
+						   ((3) 2)
+						   (else (lose))))))))))
+		   (fix:+ n (fix:- end start)))))))
+      (let ((s (make-string n)))
+	(let loop ((start start) (j 0))
+	  (let ((index (substring-find-next-char string start end #\&)))
+	    (if index
+		(let ((index*
+		       (substring-find-next-char string (fix:+ index 1) end
+						 #\-)))
+		  (if (not index*) (lose))
+		  (let ((j (substring-move! string start end s j))
+			(m (fix:- index* index)))
+		    (if (fix:= m 1)
+			(begin
+			  (string-set! s j #\&)
+			  (loop (fix:+ index* 1) (fix:+ j 1)))
+			(loop (fix:+ index* 1)
+			      (decode-mailbox-name-1 string
+						     (fix:+ index 1)
+						     index*
+						     s
+						     j
+						     lose))))))))
+	s))))
+
+(define (encode-mailbox-name-1 string start end s j)
+  (let ((write
+	 (lambda (j v)
+	   (string-set! s j
+			(vector-8b-ref base64-digit-table
+				       (fix:and #x3f v))))))
+    (let loop ((start start) (j j))
+      (case (fix:- end start)
+	((0)
+	 j)
+	((1)
+	 (let ((d0 (string-ref string start)))
+	   (write j (fix:lsh d0 -2))
+	   (write (fix:+ j 1) (fix:lsh d0 4)))
+	 (fix:+ j 2))
+	((2)
+	 (let ((d0 (string-ref string start))
+	       (d1 (string-ref string (fix:+ start 1))))
+	   (write j (fix:lsh d0 -2))
+	   (write (fix:+ j 1) (fix:+ (fix:lsh d0 4) (fix:lsh d1 -4)))
+	   (write (fix:+ j 2) (fix:lsh d1 2)))
+	 (fix:+ j 3))
+	(else
+	 (let ((d0 (string-ref string start))
+	       (d1 (string-ref string (fix:+ start 1)))
+	       (d2 (string-ref string (fix:+ start 2))))
+	   (write j (fix:lsh d0 -2))
+	   (write (fix:+ j 1) (fix:+ (fix:lsh d0 4) (fix:lsh d1 -4)))
+	   (write (fix:+ j 2) (fix:+ (fix:lsh d1 2) (fix:lsh d2 -6)))
+	   (write (fix:+ j 3) d2)
+	   (loop (fix:+ start 3) (fix:+ j 4))))))))
+
+(define (decode-mailbox-name-1 string start end s j lose)
+  (let ((read (lambda (i) (decode-base64-char (vector-8b-ref string i))))
+	(write (lambda (j v) (vector-8b-set! s j v))))
+    (let loop ((start start) (j j))
+      (case (fix:- end start)
+	((0)
+	 j)
+	((1)
+	 (lose))
+	((2)
+	 (let ((d0 (read start))
+	       (d1 (read (fix:+ start 1))))
+	   (write j
+		  (fix:+ (fix:lsh d0 2)
+			 (fix:lsh d1 -4))))
+	 (fix:+ j 1))
+	((3)
+	 (let ((d0 (read start))
+	       (d1 (read (fix:+ start 1)))
+	       (d2 (read (fix:+ start 2))))
+	   (write j
+		  (fix:+ (fix:lsh d0 2)
+			 (fix:lsh d1 -4)))
+	   (write (fix:+ j 1)
+		  (fix:+ (fix:lsh (fix:and #x0f d1) 4)
+			 (fix:lsh d2 -2))))
+	 (fix:+ j 2))
+	(else
+	 (let ((d0 (read start))
+	       (d1 (read (fix:+ start 1)))
+	       (d2 (read (fix:+ start 2)))
+	       (d3 (read (fix:+ start 3))))
+	   (write j
+		  (fix:+ (fix:lsh d0 2)
+			 (fix:lsh d1 -4)))
+	   (write (fix:+ j 1)
+		  (fix:+ (fix:lsh (fix:and #x0f d1) 4)
+			 (fix:lsh d2 -2)))
+	   (write (fix:+ j 2)
+		  (fix:+ (fix:lsh (fix:and #x03 d2) 6)
+			 d3)))
+	 (loop (fix:+ start 4) (fix:+ j 3)))))))
+
+(define imap:char-set:mailbox-name-encoded
+  (char-set-union char-set:not-graphic (char-set #\&)))
+
+(define imap:char-set:mailbox-name-unencoded
+  (char-set-invert imap:char-set:mailbox-name-encoded))
+
+(define (decode-base64-char byte)
+  (let ((digit (vector-8b-ref base64-char-table byte)))
+    (if (>= digit #x40)
+	(error "Character not a base64 component:" (integer->char byte)))
+    digit))  
+
+(define base64-char-table)
+(define base64-digit-table)
+(let ((char-table (make-string 256 (integer->char #xff)))
+      (digit-table (make-string 64)))
+  (let ((do-single
+	 (lambda (index value)
+	   (vector-8b-set! char-table index value)
+	   (vector-8b-set! digit-table value index))))
+    (letrec
+	((do-range
+	  (lambda (low high value)
+	    (do-single low value)
+	    (if (fix:< low high)
+		(do-range (fix:+ low 1) high (fix:+ value 1))))))
+      (do-range (char->integer #\A) (char->integer #\Z) 0)
+      (do-range (char->integer #\a) (char->integer #\z) 26)
+      (do-range (char->integer #\0) (char->integer #\9) 52)
+      (do-single (char->integer #\+) 62)
+      (do-single (char->integer #\,) 63)))
+  (set! base64-char-table char-table)
+  (set! base64-digit-table digit-table)
+  unspecific)
\ No newline at end of file