From d3cf39b5c06f3196db75ae19545c409e90556238 Mon Sep 17 00:00:00 2001
From: Andy Wingo
Date: Thu, 14 Oct 2010 12:03:39 +0200
Subject: base64 efficiency hacks

* tekuti/base64.scm (bytevector-map-n-to-m): Use multiple values.
  (base64-encode): Inline the map-3-to-4 definition, and use multiple
  values.
  (base64-decode): Likewise, with map-4-to-3.
---
 tekuti/base64.scm | 36 +++++++++++++++++++-----------------
 1 file changed, 19 insertions(+), 17 deletions(-)

diff --git a/tekuti/base64.scm b/tekuti/base64.scm
index a971e5e..a7426cb 100644
--- a/tekuti/base64.scm
+++ b/tekuti/base64.scm
@@ -60,28 +60,27 @@
   (lambda (stx)
     (syntax-case stx ()
       ((_ n m)
-       (with-syntax (((byte-arg ...)
+       (with-syntax (((byte-in ...)
                       (map (lambda (x)
                              #`(bytevector-u8-ref s (+ i #,x)))
-                           (iota (syntax->datum #'n)))))
+                           (iota (syntax->datum #'n))))
+                     ((byte-out ...)
+                      (generate-temporaries (iota (syntax->datum #'m))))
+                     ((byte-out-idx ...)
+                      (iota (syntax->datum #'m))))
          #'(lambda (proc s)
              (let* ((len (bytevector-length s))
                     (out (make-bytevector (* len (/ m n)))))
                (let lp ((i 0) (j 0))
                  (cond
                   ((< i len)
-                   (let inner ((k 0) (bytes (proc byte-arg ...)))
-                     (if (not (null? bytes))
-                         (begin (bytevector-u8-set! out (+ j k) (car bytes))
-                                (inner (+ k 1) (cdr bytes)))))
+                   (call-with-values (lambda () (proc byte-in ...))
+                     (lambda (byte-out ...)
+                       (bytevector-u8-set! out (+ j byte-out-idx) byte-out)
+                       ...))
                    (lp (+ i n) (+ j m)))
                   (else out))))))))))
 
-(define bytevector-map-3-to-4
-  (bytevector-map-n-to-m 3 4))
-(define bytevector-map-4-to-3
-  (bytevector-map-n-to-m 4 3))
-
 (define (bytevector-fill-range! bv start end u8)
   (do ((i (- end 1) (- i 1)))
       ((< i start))
@@ -95,11 +94,13 @@
 
 (define (base64-encode bv)
   (let* ((npad (remainder (- 3 (remainder (bytevector-length bv) 3)) 3))
-         (out (bytevector-map-3-to-4
+         (out ((bytevector-map-n-to-m 3 4)
                (lambda (x y z)
                  (let ((n (logior (ash x 16) (ash y 8) z)))
-                   (map int->b64-byte
-                        (list (ash n -18) (ash n -12) (ash n -6) n))))
+                   (values (int->b64-byte (ash n -18))
+                           (int->b64-byte (ash n -12))
+                           (int->b64-byte (ash n -6))
+                           (int->b64-byte n))))
                (bytevector-pad bv (+ (bytevector-length bv) npad) 0))))
     (bytevector-fill-range! out
                             (- (bytevector-length out) npad)
@@ -124,14 +125,15 @@
 (define (base64-decode str)
   (let* ((bv (string->utf8 str))
          (npad (b64-bv-npad bv))
-         (out (bytevector-map-4-to-3
+         (out ((bytevector-map-n-to-m 4 3)
                (lambda (w x y z)
                  (let ((n (logior (ash (b64-byte->int w) 18)
                                   (ash (b64-byte->int x) 12)
                                   (ash (b64-byte->int y) 6)
                                   (b64-byte->int z))))
-                   (list (ash n -16) (logand (ash n -8) 255)
-                         (logand n 255))))
+                   (values (ash n -16)
+                           (logand (ash n -8) 255)
+                           (logand n 255))))
                (bytevector-copy/padding bv npad (char->integer #\A))))
          (result (make-bytevector (- (bytevector-length out) npad))))
     (bytevector-copy! out 0 result 0 (bytevector-length result))
-- 
cgit v1.2.3-54-g00ecf