#|-------------------- 3.2 |# "./base64-test.scm" 6645
(use test)
(use base64)

(define lorem-ipsum "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.")
(define lorem-ipsum-base64
  '("TG9yZW0gaXBzdW0gZG9sb3Igc2l0IGFtZXQsIGNvbnNlY3RldHVyIGFkaXBpc2ljaW5nIGVsaXQs"
    "IHNlZCBkbyBlaXVzbW9kIHRlbXBvciBpbmNpZGlkdW50IHV0IGxhYm9yZSBldCBkb2xvcmUgbWFn"
    "bmEgYWxpcXVhLiBVdCBlbmltIGFkIG1pbmltIHZlbmlhbSwgcXVpcyBub3N0cnVkIGV4ZXJjaXRh"
    "dGlvbiB1bGxhbWNvIGxhYm9yaXMgbmlzaSB1dCBhbGlxdWlwIGV4IGVhIGNvbW1vZG8gY29uc2Vx"
    "dWF0LiBEdWlzIGF1dGUgaXJ1cmUgZG9sb3IgaW4gcmVwcmVoZW5kZXJpdCBpbiB2b2x1cHRhdGUg"
    "dmVsaXQgZXNzZSBjaWxsdW0gZG9sb3JlIGV1IGZ1Z2lhdCBudWxsYSBwYXJpYXR1ci4gRXhjZXB0"
    "ZXVyIHNpbnQgb2NjYWVjYXQgY3VwaWRhdGF0IG5vbiBwcm9pZGVudCwgc3VudCBpbiBjdWxwYSBx"
    "dWkgb2ZmaWNpYSBkZXNlcnVudCBtb2xsaXQgYW5pbSBpZCBlc3QgbGFib3J1bS4="
    ""))   ; trailing empty for intersperse

(test-group
 "encoding"
 (test "encode string of length 0"
       ""
       (base64-encode ""))
 (test "encode string of length 1"
       "YQ=="
       (base64-encode "a"))
 (test "encode string of length 2"
       "YWI="
       (base64-encode "ab"))
 (test "encode string of length 3"
       "YWJj"
       (base64-encode "abc"))
 (test "encode string of length 5*3"
       "YWJjZGVmZ2hpamtsbW5v"
       (base64-encode "abcdefghijklmno"))
 (test "encode string of length 5*3+1"
       "YWJjZGVmZ2hpamtsbW5vcA=="
       (base64-encode "abcdefghijklmnop"))
 (test "encode string of length 5*3+2"
       "YWJjZGVmZ2hpamtsbW5vcHE="
       (base64-encode "abcdefghijklmnopq"))
 (test "encode string of length 6*3"
       "YWJjZGVmZ2hpamtsbW5vcHFy"
       (base64-encode "abcdefghijklmnopqr"))
 (test "encode binary string"
       "3q2+78r+sAs="
       (base64-encode "\xde\xad\xbe\xef\xca\xfe\xb0\x0b"))
 (test "lorem ipsum"
       (apply string-append lorem-ipsum-base64)
       (base64-encode lorem-ipsum))
 (let ((s (make-string (+ 10 (* 57 60)) #\Q)))  ; past one input buffer
   (test "port > 1 buffer length -> port"
         (base64-encode s)
         (get-output-string (base64-encode (open-input-string s)
                                           (open-output-string))))
   (test "port > 1 buffer length -> string"
         (base64-encode s)
         (base64-encode (open-input-string s)))))

(test-group
 "encoding linebreaks"
 (parameterize ((base64-line-breaks #t))
   (test "encode empty string"
         ""
         (base64-encode ""))
   (test "encode 9 chars"
         "YWFhYWFhYWFh\r\n"
         (base64-encode (make-string 9 #\a)))
   (test "encode 55 chars"
         "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYQ==\r\n"
         (base64-encode (make-string 55 #\a))) 
   (test "encode 56 chars"
         "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWE=\r\n"
         (base64-encode (make-string 56 #\a)))
   (test "encode 57 chars"
         "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh\r\n"
         (base64-encode (make-string 57 #\a)))
   (test "encode 58 chars"
         "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh\r\nYQ==\r\n"
         (base64-encode (make-string 58 #\a)))
   (test "encode 57*2 chars"
         (string-append "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh"
                        "\r\n"
                        "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh"
                        "\r\n")
         (base64-encode (make-string (* 57 2) #\a)))
   (test "encode 57*2+1 chars"
         (string-append "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh"
                        "\r\n"
                        "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh"
                        "\r\n"
                        "YQ=="
                        "\r\n")
         (base64-encode (make-string (+ 1 (* 57 2)) #\a)))
   (let ((lorem-ipsum-encoded (string-intersperse lorem-ipsum-base64 "\r\n")))
     (test "lorem ipsum"
           lorem-ipsum-encoded
           (base64-encode lorem-ipsum))
     (test "lorem ipsum string -> port"
           lorem-ipsum-encoded
           (get-output-string (base64-encode lorem-ipsum (open-output-string))))
     (test "lorem ipsum port -> string"
           lorem-ipsum-encoded
           (base64-encode (open-input-string lorem-ipsum)))
     (test "lorem ipsum port -> port"
           lorem-ipsum-encoded
           (get-output-string (base64-encode (open-input-string lorem-ipsum)
                                             (open-output-string)))))
   ))

;; to avoid measuring time in test (doesn't really matter)
(define large-string (make-string 10000001 #\a))
(define large-encoded-string (base64-encode large-string))
(define large-invalid-string (make-string 10000001 #\%))

(test-group
 "decoding"
 (test "decode empty string -> empty"
       ""
       (base64-decode ""))
 (test "decode string Y -> empty"
       ""
       (base64-decode "Y"))
 (test "decode string YW -> a"
       "a"
       (base64-decode "YW"))
 (test "decode string YW= -> a"
       "a"
       (base64-decode "YW="))
 (test "decode string YW== -> a"
       "a"
       (base64-decode "YW==")) 
 (test "decode string YWJ => ab"
       "ab"
       (base64-decode "YWJ"))
 (test "decode string YWJ= -> ab"
       "ab"
       (base64-decode "YWJ="))
 (test "decode string YWJj -> abc"
       "abc"
       (base64-decode "YWJj"))
 (test "decode string YW%J^jZ -> abc"
       "abc"
       (base64-decode "YW%J^jZ"))
 (test "decode skips invalid chars"
       "abcdefghijklmnop"
       (base64-decode "YWJjZG(VmZ#2hp@amtsb%&W5v**cA======"))
 (test "decode binary string"
       "\xde\xad\xbe\xef\xca\xfe\xb0\x0b"
       (base64-decode "3q2+78r+sAs="))
 (test "decode large string"
       large-string
       (base64-decode large-encoded-string))
 (test "decode large string of invalid chars"
       ""
       (base64-decode large-invalid-string))
 (test "decode lorem ipsum with linebreaks"
       lorem-ipsum
       (base64-decode (string-intersperse lorem-ipsum-base64 "\r\n"))))

;; Not on a 64-bit machine! :)
;; (test-error "encode string of length 16,000,000 signals an error"
;;             (base64-encode (make-string 16000000)))

#|-------------------- 3.2 |# "./base64.meta" 286
;;; base64.meta -*- Hen -*-
((egg "base64.egg")
 (date "2009-04-14")
 (synopsis "Encoding and decoding of base64 strings")
 (category parsing)
 (license "BSD")
 (doc-from-wiki)
 (files "base64.setup" "base64.scm" "base64-test.scm" "base64.meta")
 (author "James Bailey, Jim Ursetto"))


#|-------------------- 3.2 |# "./base64.scm" 17099
;; Copyright (c) 2004 James Bailey (dgym.REMOVE_THIS.bailey@gmail.com).
;; Copyright (c) 2009 Jim Ursetto.
;;
;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"), to
;; deal in the Software without restriction, including without limitation the
;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
;; sell copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in all
;; copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

;; base64 routines for bigloo, apart from the module info, bit routines, "when"
;; and fixed division "/fx" it should be slightly portable

;; Ported to CHICKEN by felix
;; Rewritten for CHICKEN by Jim Ursetto.  Notes:
;;  Local anonymous functions (bits-at) are not inlined; use define-inline.
;;  Toplevel tables moved to lexical scope.
;;  Encode algorithm moves the test for 1 or 2 remaining bytes out
;;  of the main loop; generates -significantly- better code under Chicken.
;;  Decode algorithm rewritten as state machine; invalid input is
;;  silently skipped.
;;  Compiling with -unsafe is HIGHLY recommended, and gains more benefit
;;  as your inner loop gets tighter.
;;  The optimized variants are almost on par with pure C.
;;  Encoding and decoding can now operate on ports.

(declare
  (fixnum))

(cond-expand ((not compiling)
              (define-syntax define-inline
                (syntax-rules () ((_ e0 ...) (define e0 ...)))))
             (else))

(module base64
  (base64-encode base64-decode base64-line-breaks)

  (import scheme chicken
          (only extras read-string!)
          (only srfi-13 string-concatenate-reverse))
  (require-library srfi-13)

;; If base64-line-breaks is true, a CRLF is inserted every
;; 76 output chars (57 input chars) and at the end of the last
;; line, if it was partial (between 1 and 75 output chars).
(define base64-line-breaks (make-parameter #f))

;; Optimized string->string implementation
(define (base64-encode/string->string str)
  (define-inline (bits-at idx)
    (char->integer (string-ref str idx)))
  (define-inline (b64->char n)
    (define enc-table
      '#(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
         #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z
         #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
         #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
         #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\+ #\/))
    (vector-ref enc-table (bitwise-and n 63)))

  (define (encode-tail out i o r)
    ;; Handle last 1 or 2 bytes
    (case r
      ((0) o)
      ((1)
       (let ((n (arithmetic-shift (bits-at i) 16)))
         (string-set! out o (b64->char (arithmetic-shift n -18)))
         (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
         (+ o 4)))
      ((2)
       (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 16)
                             (arithmetic-shift (bits-at (+ i 1)) 8))))
         (string-set! out o (b64->char (arithmetic-shift n -18)))
         (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
         (string-set! out (+ o 2) (b64->char (arithmetic-shift n -6)))
         (+ o 4)))))

  (##sys#check-string str 'base64-encode)
  (let ((l (string-length str)))
    (let* ((nobreak? (not (base64-line-breaks)))
           (outlen (* 4 (fx/ (+ l 2) 3)))
           (full-lines (fx/ l 57))
           (partial-line (not (= 0 (fxmod l 57))))
           (outlen (if nobreak?
                       outlen
                       (+ outlen (fx* 2 (+ full-lines
                                           (if partial-line 1 0))))))
           (out (make-string outlen #\=)))
      (let ((o
             (let loop ((i 0) (o 0) (r l) (c 1))
               (if (< r 3)
                   (encode-tail out i o r)
                   (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 16)
                                         (arithmetic-shift (bits-at (+ i 1)) 8)
                                         (bits-at (+ i 2)))))
                     (string-set! out o       (b64->char (arithmetic-shift n -18)))
                     (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
                     (string-set! out (+ o 2) (b64->char (arithmetic-shift n -6)))
                     (string-set! out (+ o 3) (b64->char n))
                     (cond (nobreak?
                            (loop (+ i 3) (+ o 4) (- r 3) c))
                           ((< c 19)  ; 57/3 = 76/4 = 19
                            (loop (+ i 3) (+ o 4) (- r 3) (+ c 1)))
                           (else
                            (string-set! out (+ o 4) #\return)
                            (string-set! out (+ o 5) #\newline)
                            (loop (+ i 3) (+ o 6) (- r 3) 1)))
                     )))))
        (when (and (not nobreak?)
                   partial-line)
          (string-set! out o #\return)
          (string-set! out (+ o 1) #\newline))
        out))))

(define (base64-encode in #!optional out)
  (define (port-to-port in out)
    (let* ((buflen (* 57 60))
           (buf (make-string buflen)))
      (let lp ()
        (let ((n (read-string! buflen buf in)))
          (cond ((= n 0) out)
                (else
                 (display (base64-encode/string->string
                           (if (< n buflen) (substring buf 0 n) buf))
                          out)
                 (lp)))))))
  (define (port-to-string in)
    ;; easier on GC than (let ((out (open-output-string)))
    ;;                     (get-output-string (port-to-port in out)))
    (let* ((buflen (* 57 60))
           (buf (make-string buflen)))
      (let lp ((lines '()))
        (let ((n (read-string! buflen buf in)))
          (cond ((= n 0)
                 (string-concatenate-reverse lines))
                (else
                 (lp (cons (base64-encode/string->string
                            (if (< n buflen) (substring buf 0 n) buf))
                           lines))))))))
  (if (port? out)
      (if (string? in)
          (port-to-port (open-input-string in) out)
          (port-to-port in out))      
      (if (string? in)
          (base64-encode/string->string in)
          (port-to-string in))))

;; (define (calc-dec-table)
;;    (let ((res (make-vector 256 -1)))
;;      (do ((i 0 (+ i 1)))
;;          ((>= i 64))
;;        (vector-set! res (char->integer (vector-ref enc-table i)) i))
;;      res))


;; Optimized string->string decoder implementation.  A bit faster than
;; the partial decoder--part of which is less garbage generation due
;; to a better string length guess in the best possible case--but the
;; partial decoder is more general.  So we will probably drop this.
;; It's not currently used.
(define (base64-decode/string->string str)
  (define-inline (bits-at idx)
    (define dec-table
         '#(-1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 62 -1 -1 -1 63
            52 53 54 55 56 57 58 59 60 61 -1 -1 -1 -1 -1 -1
            -1  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14
            15 16 17 18 19 20 21 22 23 24 25 -1 -1 -1 -1 -1
            -1 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
            41 42 43 44 45 46 47 48 49 50 51 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1))
    (vector-ref dec-table (char->integer (string-ref str idx))))
  (define-inline (int->char n)
    (integer->char (bitwise-and n 255)))
  ;; Guess upper bound for string length--assumes no invalid characters
  ;; encountered, and checks the last two chars for validity
  ;; in strings of length 4n.
  (define-inline (guess-out-length l)           ; assumes L > 0
    (let ((floored (fx* 4 (fx/ l 4))))
      (+ (fx* 3 (fx/ l 4))
         (cond ((not (= l floored)) 3)
               (else
                (if (= -1 (bits-at (- l 1)))
                    (if (= -1 (bits-at (- l 2))) -2 -1)
                    0))))))

  (##sys#check-string str 'base64-decode)
  (let ((l (string-length str)))
    (if (= l 0)
        str
        (let* ((outlen (guess-out-length l))  ; avoid substring if possible
               (out (make-string outlen))
               (o 
                (let loop ((i 0) (o 0) (state 0) (n 0))
                  (if (>= i l)
                      o
                      (let ((b (bits-at i)))
                        (if (= -1 b)
                            (loop (+ i 1) o state n)
                            (case state
                              ((0) (loop (+ i 1) o 1 b))
                              ((1) (let ((n (bitwise-ior b (arithmetic-shift n 6))))
                                     (string-set! out o (int->char (arithmetic-shift n -4)))
                                     (loop (+ i 1) (+ o 1) 2 n)))
                              ((2) (let ((n (bitwise-ior b (arithmetic-shift n 6))))
                                     (string-set! out o (int->char (arithmetic-shift n -2)))
                                     (loop (+ i 1) (+ o 1) 3 n)))
                              (else (let ((n (bitwise-ior b (arithmetic-shift n 6))))
                                      (string-set! out o (int->char n))
                                      (loop (+ i 1) (+ o 1) 0 0))))))))))
          ;; Pull this out of the loop; otherwise the code is pessimized.
          (if (= outlen o)
              out
              (substring out 0 o))))))

(define (base64-decode in #!optional out)
  (define (port-to-port in out)
    (let* ((buflen 4096)
           (buf (make-string buflen))
           (st (vector 0 0 0 0)))
      (let lp ()
        (let ((n (read-string! buflen buf in)))
          (cond ((< n buflen)   ; works for ""
                 (display (base64-decode-partial (substring buf 0 n)
                                                 st #f)
                          out)
                 out)
                (else
                 (display (base64-decode-partial buf st #t)
                          out)
                 (lp)))))))
  (define (port-to-string in)
    (let* ((buflen 4096)
           (buf (make-string buflen))
           (st (vector 0 0 0 0)))
      (let lp ((lines '()))
        (let ((n (read-string! buflen buf in)))
          (cond ((< n buflen)
                 (string-concatenate-reverse
                  (cons (base64-decode-partial (substring buf 0 n) st #f)
                        lines)))
                (else
                 (lp (cons (base64-decode-partial buf st #t)
                           lines))))))))
  (if (port? out)
      (if (string? in)
          (port-to-port (open-input-string in) out)
          (port-to-port in out))
      (if (string? in)
;;           (base64-decode/string->string in)
          (let ((st (vector 0 0 0 0)))
            (base64-decode-partial in st #f))
          (port-to-string in))))

;; Incremental base64 decoder
;; Requires initial state vector st: #(state c1 c2 c3)
;; Returns: str; mutates state vector st when more?.
;; If a full 4 encoded characters are not available, AND there is
;; possibly more data, we cannot decode the remaining chars.  We must
;; retain up to 3 input characters along with the current
;; input state, so the decoder may be restarted where it left off.
(define (base64-decode-partial str st more?)
  (define-inline (bits-at idx)
    (define dec-table
      '#(-1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 62 -1 -1 -1 63
            52 53 54 55 56 57 58 59 60 61 -1 -1 -1 -1 -1 -1
            -1  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14
            15 16 17 18 19 20 21 22 23 24 25 -1 -1 -1 -1 -1
            -1 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
            41 42 43 44 45 46 47 48 49 50 51 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1))
    (vector-ref dec-table (char->integer (string-ref str idx))))
  (define-inline (int->char n)
    (integer->char (bitwise-and n 255)))
  ;; Upper bound for string length--nothing fancy for partial reads.
  ;; But add state (# of chars pending) to input length.
  (define-inline (guess-out-length len state)
    (let ((c (+ state len)))
      (if (= 0 (bitwise-and c 3))   ; (fxmod c 4)
          (fx* 3 (fx/ c 4))
          (fx* 3 (+ 1 (fx/ c 4))))))

  ;; When no MORE? data, write out the remaining chars.
  (define (decode-tail out o state c1 c2 c3)
    (case state
      ((0 1) o)
      ((2) (let ((n (bitwise-ior (arithmetic-shift c1 18)
                                 (arithmetic-shift c2 12))))
             (string-set! out o       (int->char (arithmetic-shift n -16)))
             (+ o 1)))
      ((3) (let ((n (bitwise-ior
                     (bitwise-ior (arithmetic-shift c1 18)
                                  (arithmetic-shift c2 12))
                     (arithmetic-shift c3 6))))
             (string-set! out o       (int->char (arithmetic-shift n -16)))
             (string-set! out (+ o 1) (int->char (arithmetic-shift n -8)))
             (+ o 2)))))

  ;; Finish up.  The state vector has already been updated unconditionally;
  ;; write the remaining chars into the buffer if we expect no more data.  Return
  ;; the buffer, truncating if necessary.
  (define-inline (do-tail out o st)
    (let ((o (if more? o
                 (decode-tail out o
                              (vector-ref st 0)
                              (vector-ref st 1)
                              (vector-ref st 2)
                              (vector-ref st 3)))))
      (if (= o (string-length out))
          out
          (substring out 0 o))))
  
  (##sys#check-string str 'base64-decode)
  (let* ((len (string-length str))
         (state (vector-ref st 0))
         (outlen (guess-out-length len state))
         (out (make-string outlen)))
    (let ((o
           (let loop ((i 0) (o 0) (state state)
                      (c1 (vector-ref st 1))
                      (c2 (vector-ref st 2))
                      (c3 (vector-ref st 3)))
             (cond ((>= i len)
                    (vector-set! st 0 state)
                    (vector-set! st 1 c1)
                    (vector-set! st 2 c2)
                    (vector-set! st 3 c3)
                    o)
                   (else
                    (let ((c (bits-at i)))
                      (if (= -1 c)
                          (loop (+ i 1) o state c1 c2 c3)
                          (case state
                            ((0) (loop (+ i 1) o 1 c  c2 c3))
                            ((1) (loop (+ i 1) o 2 c1 c  c3))
                            ((2) (loop (+ i 1) o 3 c1 c2 c ))
                            (else
                             (let ((n (bitwise-ior
                                       (bitwise-ior (arithmetic-shift c1 18)
                                                    (arithmetic-shift c2 12))
                                       (bitwise-ior (arithmetic-shift c3 6)
                                                    c))))
                               (string-set! out o       (int->char (arithmetic-shift n -16)))
                               (string-set! out (+ o 1) (int->char (arithmetic-shift n -8)))
                               (string-set! out (+ o 2) (int->char n))
                               (loop (+ i 1) (+ o 3) 0 c1 c2 c3)))))))))))
      ;; Pull out of loop to avoid stack probe and interrupt check
      ;; causing > 2x slowdown.  decode-tail arguments must then
      ;; be pulled from the state vector.
      (do-tail out o st))))

)

#|-------------------- 3.2 |# "./base64.setup" 201
(compile -s -O2 -d0 -u base64.scm -j base64)
(compile -s -O2 -d0 base64.import.scm)

(install-extension
 'base64 
 '("base64.import.so" "base64.so")
 '((version 3.2)
   (documentation "base64.html")))