;;; -*-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
;;;
"imail-rmail"
"imail-umail"
"imail-util"
+ "imap-response"
"imap-syntax"
"parser"
"rexp"
;;; -*-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
;;;
("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)
(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)
;;; -*-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
;;;
(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"
--- /dev/null
+;;; -*-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))
+\f
+;;;; 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))))
+\f
+(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))
+\f
+(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))))
+\f
+(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)))
+\f
+(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))))
+\f
+(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
;;; -*-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
;;;
(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 #\+)))
+\f
(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)))
"\"")))
(define imap:match:astring
(alternatives-matcher imap:match:atom
imap:match:string))
-\f
+
(define imap:match:number
(rexp-matcher (rexp+ char-set:numeric)))
(rexp-matcher
(rexp-sequence (char-set-difference char-set:numeric (char-set #\0))
(rexp* char-set:numeric))))
-
+\f
(define imap:match:date
(let ((date-text
(rexp-matcher
(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))))
+\f
+;;;; 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)))
+\f
+(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))))
+\f
+(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)))))))
+\f
+(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
projects / mit-scheme.git / commitdiff