lloda pushed a commit to branch main
in repository guile.
commit f901a45c31c956a0b61d1e82111f6754442f5a7c
Author: Rob Browning <[email protected]>
AuthorDate: Wed Sep 10 17:28:53 2025 -0500
srfi-207: pregenerate and reuse standard base64 decodings
Pregenerate and re-use decoding tables for the two RFC standard
encodings, and represent the tables as bytevectors since that's more
efficient and all we need. cf.
https://datatracker.ietf.org/doc/html/rfc4648#section-4
https://datatracker.ietf.org/doc/html/rfc4648#section-5
* module/srfi/srfi-207.scm (make-base64-decode-table): Represent table
as bytevector and re-use common decodings.
* module/srfi/srfi-207.scm (get-base64-decode-table): New function.
* module/srfi/srfi-207/upstream/base64.scm (make-base64-decode-table):
Move to srfi-207.scm.
(decode-base64-string): Switch to get-base64-decode-table.
(decode-base64-to-port): Access table as bytevector.
---
module/srfi/srfi-207.scm | 30 ++++++++++++++++++++++++++++++
module/srfi/srfi-207/upstream/base64.scm | 28 +++-------------------------
2 files changed, 33 insertions(+), 25 deletions(-)
diff --git a/module/srfi/srfi-207.scm b/module/srfi/srfi-207.scm
index cd6d1de15..d4fabb097 100644
--- a/module/srfi/srfi-207.scm
+++ b/module/srfi/srfi-207.scm
@@ -28,6 +28,7 @@
#:use-module ((rnrs bytevectors)
#:select (bytevector->u8-list
bytevector-u8-ref
+ bytevector-u8-set!
string->utf8
u8-list->bytevector))
#:use-module ((scheme base)
@@ -120,6 +121,35 @@
(string->bytevector digits "ASCII")
"="))))
+(define outside-char 99) ; luft-balloons
+(define pad-char 101) ; dalmations
+
+(define base64-common-decode-table
+ ;; Everything except the digits
+ (let ((bv (make-bytevector 256 outside-char)))
+ (do ((i 0 (1+ i)))
+ ((= i (string-length common-base64-encoding)))
+ (let ((c (string-ref common-base64-encoding i)))
+ (bytevector-u8-set! bv (char->integer c) i)))
+ (bytevector-u8-set! bv 61 pad-char)
+ bv))
+
+(define (make-base64-decode-table digits)
+ (let ((bv (bytevector-copy base64-common-decode-table)))
+ (bytevector-u8-set! bv (char->integer (string-ref digits 0)) 62)
+ (bytevector-u8-set! bv (char->integer (string-ref digits 1)) 63)
+ bv))
+
+;; RFC 4648 sections 4 and 5
+(define standard-base64-decode-table (make-base64-decode-table "+/"))
+(define url&filename-safe-base64-decode-table (make-base64-decode-table "-_"))
+
+(define (get-base64-decode-table digits)
+ (cond
+ ((string= "+/" digits) standard-base64-decode-table)
+ ((string= "-_" digits) url&filename-safe-base64-decode-table)
+ (else (make-base64-decode-table digits))))
+
(include-from-path "ice-9/read/bytestring.scm")
(include-from-path "srfi/srfi-207/upstream/base64.scm")
(include-from-path "srfi/srfi-207/upstream/bytestrings-impl.scm")
diff --git a/module/srfi/srfi-207/upstream/base64.scm
b/module/srfi/srfi-207/upstream/base64.scm
index cfbd2c9c1..9b8332ae2 100644
--- a/module/srfi/srfi-207/upstream/base64.scm
+++ b/module/srfi/srfi-207/upstream/base64.scm
@@ -25,35 +25,13 @@
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-;;;; Constants and tables
-
-(define outside-char 99) ; luft-balloons
-(define pad-char 101) ; dalmations
+;;;; Decoding
(define (outside-char? x) (eqv? x outside-char))
(define (pad-char? x) (eqv? x pad-char))
-(define (make-base64-decode-table digits)
- (let ((extra-1 (char->integer (string-ref digits 0)))
- (extra-2 (char->integer (string-ref digits 1))))
- (vector-unfold
- (lambda (i)
- (cond ((and (>= i 48) (< i 58)) (+ i 4)) ; numbers
- ((and (>= i 65) (< i 91)) (- i 65)) ; upper case letters
- ((and (>= i 97) (< i 123)) (- i 71)) ; lower case letters
- ((= i extra-1) 62)
- ((= i extra-2) 63)
- ((= i 61) pad-char) ; '='
- (else outside-char)))
- #x100)))
-
-(define (base64-decode-u8 table u8)
- (vector-ref table u8))
-
-;;;; Decoding
-
(define (decode-base64-string src digits)
- (let ((table (make-base64-decode-table digits)))
+ (let ((table (get-base64-decode-table digits)))
(call-with-port
(open-output-bytevector)
(lambda (out)
@@ -68,7 +46,7 @@
(if (= i len)
(decode-base64-trailing port b1 b2 b3)
(let* ((c (string-ref src i))
- (b (base64-decode-u8 table (char->integer c))))
+ (b (bytevector-u8-ref table (char->integer c))))
(cond ((pad-char? b) (decode-base64-trailing port b1 b2 b3))
((char-whitespace? c) (lp (+ i 1) b1 b2 b3))
((outside-char? b)
