[jackhill/guix/guix.git] / guix / base32.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2015, 2017, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix base32)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-60)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 vlist)
  #:export (bytevector-quintet-length
            bytevector->base32-string
            bytevector->nix-base32-string
            base32-string->bytevector
            nix-base32-string->bytevector
            %nix-base32-charset
            %rfc4648-base32-charset
            &invalid-base32-character
            invalid-base32-character?
            invalid-base32-character-value
            invalid-base32-character-string))

;;; Commentary:
;;;
;;; A generic, customizable to convert bytevectors to/from a base32
;;; representation.
;;;
;;; Code:

(define-syntax bit-field
  (lambda (s)
    ;; This inline version of 'bit-field' assumes that START and END are
    ;; literals and pre-computes the mask.  In an ideal world, using 'define'
    ;; or 'define-inlinable' would be enough, but as of 3.0.7, peval doesn't
    ;; expand calls to 'expt' (and 'bit-field' is a subr.)
    (syntax-case s ()
      ((_ n start end)
       (let* ((s    (syntax->datum #'start))
              (e    (syntax->datum #'end))
              (mask (- (expt 2 (- e s)) 1)))
         ;; The baseline compiler in Guile <= 3.0.7 miscompiles (ash x N) as
         ;; (ash x (- N)) when N is a literal: <https://bugs.gnu.org/50696>.
         ;; Here we take advantage of another bug in the baseline compiler,
         ;; fixed in Guile commit 330c6ea83f492672578b62d0683acbb532d1a5d9: we
         ;; introduce 'minus-start' such that it has a different source
         ;; location, which in turn means that the baseline compiler pattern
         ;; for (ash x N) doesn't match, thus avoiding the bug (!).
         (with-syntax ((minus-start (datum->syntax #'start (- s))))
           #`(logand (ash n minus-start) #,mask)))))))

(define bytevector-quintet-ref
  (let* ((ref  bytevector-u8-ref)
         (ref+ (lambda (bv offset)
                 (let ((o (+ 1 offset)))
                   (if (>= o (bytevector-length bv))
                       0
                       (bytevector-u8-ref bv o)))))
         (ref0 (lambda (bv offset)
                 (bit-field (ref bv offset) 3 8)))
         (ref1 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 3) 2)
                         (bit-field (ref+ bv offset) 6 8))))
         (ref2 (lambda (bv offset)
                 (bit-field (ref bv offset) 1 6)))
         (ref3 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 1) 4)
                         (bit-field (ref+ bv offset) 4 8))))
         (ref4 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 4) 1)
                         (bit-field (ref+ bv offset) 7 8))))
         (ref5 (lambda (bv offset)
                 (bit-field (ref bv offset) 2 7)))
         (ref6 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 2) 3)
                         (bit-field (ref+ bv offset) 5 8))))
         (ref7 (lambda (bv offset)
                 (bit-field (ref bv offset) 0 5)))
         (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
    (lambda (bv index)
      "Return the INDEXth quintet of BV."
      (let ((p (vector-ref refs (modulo index 8))))
        (p bv (quotient (* index 5) 8))))))

(define bytevector-quintet-ref-right
  (let* ((ref  bytevector-u8-ref)
         (ref+ (lambda (bv offset)
                 (let ((o (+ 1 offset)))
                   (if (>= o (bytevector-length bv))
                       0
                       (bytevector-u8-ref bv o)))))
         (ref0 (lambda (bv offset)
                 (bit-field (ref bv offset) 0 5)))
         (ref1 (lambda (bv offset)
                 (logior (bit-field (ref bv offset) 5 8)
                         (ash (bit-field (ref+ bv offset) 0 2) 3))))
         (ref2 (lambda (bv offset)
                 (bit-field (ref bv offset) 2 7)))
         (ref3 (lambda (bv offset)
                 (logior (bit-field (ref bv offset) 7 8)
                         (ash (bit-field (ref+ bv offset) 0 4) 1))))
         (ref4 (lambda (bv offset)
                 (logior (bit-field (ref bv offset) 4 8)
                         (ash (bit-field (ref+ bv offset) 0 1) 4))))
         (ref5 (lambda (bv offset)
                 (bit-field (ref bv offset) 1 6)))
         (ref6 (lambda (bv offset)
                 (logior (bit-field (ref bv offset) 6 8)
                         (ash (bit-field (ref+ bv offset) 0 3) 2))))
         (ref7 (lambda (bv offset)
                 (bit-field (ref bv offset) 3 8)))
         (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
    (lambda (bv index)
      "Return the INDEXth quintet of BV, assuming quintets start from the
least-significant bits, contrary to what RFC 4648 describes."
      (let ((p (vector-ref refs (modulo index 8))))
        (p bv (quotient (* index 5) 8))))))

(define (bytevector-quintet-length bv)
  "Return the number of quintets (including truncated ones) available in BV."
  (ceiling (/ (* (bytevector-length bv) 8) 5)))

(define (bytevector-quintet-fold proc init bv)
  "Return the result of applying PROC to each quintet of BV and the result of
the previous application or INIT."
  (define len
    (bytevector-quintet-length bv))

  (let loop ((i 0)
             (r init))
    (if (= i len)
        r
        (loop (1+ i) (proc (bytevector-quintet-ref bv i) r)))))

(define (bytevector-quintet-fold-right proc init bv)
  "Return the result of applying PROC to each quintet of BV and the result of
the previous application or INIT."
  (define len
    (bytevector-quintet-length bv))

  (let loop ((i len)
             (r init))
    (if (zero? i)
        r
        (let ((j (- i 1)))
          (loop j (proc (bytevector-quintet-ref-right bv j) r))))))

(define (make-bytevector->base32-string quintet-fold base32-chars)
  (lambda (bv)
    "Return a base32 encoding of BV using BASE32-CHARS as the alphabet."
    (let ((chars (quintet-fold (lambda (q r)
                                 (cons (vector-ref base32-chars q)
                                       r))
                               '()
                               bv)))
      (list->string (reverse chars)))))

(define %nix-base32-chars
  ;; See `libutil/hash.cc'.
  #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
    #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
    #\p #\q #\r #\s #\v #\w #\x #\y #\z))

(define %nix-base32-charset
  (list->char-set (vector->list %nix-base32-chars)))

(define %rfc4648-base32-chars
  #(#\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
    #\2 #\3 #\4 #\5 #\6 #\7))

(define %rfc4648-base32-charset
  (list->char-set (vector->list %rfc4648-base32-chars)))

(define bytevector->base32-string
  (make-bytevector->base32-string bytevector-quintet-fold
                                  %rfc4648-base32-chars))

(define bytevector->nix-base32-string
  (make-bytevector->base32-string bytevector-quintet-fold-right
                                  %nix-base32-chars))


(define bytevector-quintet-set!
  (let* ((setq! (lambda (bv offset start stop value)
                  (let ((v (bytevector-u8-ref bv offset))
                        (w (arithmetic-shift value start))
                        (m (bitwise-xor (1- (expt 2 stop))
                                        (1- (expt 2 start)))))
                    (bytevector-u8-set! bv offset
                                        (bitwise-merge m w v)))))
         (set0! (lambda (bv offset value)
                  (setq! bv offset 3 8 value)))
         (set1! (lambda (bv offset value)
                  (setq! bv offset 0 3 (bit-field value 2 5))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2)))))
         (set2! (lambda (bv offset value)
                  (setq! bv offset 1 6 value)))
         (set3! (lambda (bv offset value)
                  (setq! bv offset 0 1 (bit-field value 4 5))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4)))))
         (set4! (lambda (bv offset value)
                  (setq! bv offset 0 4 (bit-field value 1 5))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 7 8  (bit-field value 0 1)))))
         (set5! (lambda (bv offset value)
                  (setq! bv offset 2 7 value)))
         (set6! (lambda (bv offset value)
                  (setq! bv offset 0 2 (bit-field value 3 5))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3)))))
         (set7! (lambda (bv offset value)
                  (setq! bv offset 0 5 value)))
         (sets  (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
    (lambda (bv index value)
      "Set the INDEXth quintet of BV to VALUE."
      (let ((p (vector-ref sets (modulo index 8))))
        (p bv (quotient (* index 5) 8) (logand value #x1f))))))

(define bytevector-quintet-set-right!
  (let* ((setq! (lambda (bv offset start stop value)
                  (let ((v (bytevector-u8-ref bv offset))
                        (w (arithmetic-shift value start))
                        (m (bitwise-xor (1- (expt 2 stop))
                                        (1- (expt 2 start)))))
                    (bytevector-u8-set! bv offset
                                        (bitwise-merge m w v)))))
         (set0! (lambda (bv offset value)
                  (setq! bv offset 0 5 value)))
         (set1! (lambda (bv offset value)
                  (setq! bv offset 5 8 (bit-field value 0 3))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5)))))
         (set2! (lambda (bv offset value)
                  (setq! bv offset 2 7 value)))
         (set3! (lambda (bv offset value)
                  (setq! bv offset 7 8 (bit-field value 0 1))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5)))))
         (set4! (lambda (bv offset value)
                  (setq! bv offset 4 8 (bit-field value 0 4))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5)))))
         (set5! (lambda (bv offset value)
                  (setq! bv offset 1 6 value)))
         (set6! (lambda (bv offset value)
                  (setq! bv offset 6 8 (bit-field value 0 2))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5)))))
         (set7! (lambda (bv offset value)
                  (setq! bv offset 3 8 value)))
         (sets  (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
    (lambda (bv index value)
      "Set the INDEXth quintet of BV to VALUE, assuming quintets start from
the least-significant bits."
      (let ((p (vector-ref sets (modulo index 8))))
        (p bv (quotient (* index 5) 8) (logand value #x1f))))))

(define (base32-string-unfold f s)
  "Given procedure F which, when applied to a character, returns the
corresponding quintet, return the bytevector corresponding to string S."
  (define len (string-length s))

  (let ((bv (make-bytevector (quotient (* len 5) 8))))
    (string-fold (lambda (chr index)
                   (bytevector-quintet-set! bv index (f chr))
                   (+ 1 index))
                 0
                 s)
    bv))

(define (base32-string-unfold-right f s)
  "Given procedure F which, when applied to a character, returns the
corresponding quintet, return the bytevector corresponding to string S,
starting from the right of S."
  (define len (string-length s))

  (let ((bv (make-bytevector (quotient (* len 5) 8))))
    (string-fold-right (lambda (chr index)
                         (bytevector-quintet-set-right! bv index (f chr))
                         (+ 1 index))
                       0
                       s)
    bv))

;; Invalid base32 character error condition when decoding base32.
(define-condition-type &invalid-base32-character &error
  invalid-base32-character?
  (character invalid-base32-character-value)
  (string    invalid-base32-character-string))

(define (make-base32-string->bytevector base32-string-unfold base32-chars)
  (let ((char->value (let loop ((i 0)
                                (v vlist-null))
                       (if (= i (vector-length base32-chars))
                           v
                           (loop (+ 1 i)
                                 (vhash-consv (vector-ref base32-chars i)
                                              i v))))))
    (lambda (s)
      "Return the binary representation of base32 string S as a bytevector."
      (base32-string-unfold (lambda (chr)
                              (or (and=> (vhash-assv chr char->value) cdr)
                                  (raise (condition
                                          (&invalid-base32-character
                                           (character chr)
                                           (string s))))))
                            s))))

(define base32-string->bytevector
  (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars))

(define nix-base32-string->bytevector
  (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars))

;;; base32.scm ends here
Commit	Line	Data
233e7676	1	;;; GNU Guix --- Functional package management for GNU
cb06f7c6	2	;;; Copyright © 2012, 2015, 2017, 2021 Ludovic Courtès <ludo@gnu.org>
ddc29a78	3	;;;
233e7676	4	;;; This file is part of GNU Guix.
ddc29a78	5	;;;
233e7676	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
ddc29a78 LC	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
233e7676	11	;;; GNU Guix is distributed in the hope that it will be useful, but
ddc29a78 LC	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
233e7676	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
ddc29a78 LC	18
	19	(define-module (guix base32)
	20	#:use-module (srfi srfi-1)
1a706ff5 LC	21	#:use-module (srfi srfi-34)
1a706ff5 LC	22	#:use-module (srfi srfi-35)
ddc29a78 LC	23	#:use-module (srfi srfi-60)
	24	#:use-module (rnrs bytevectors)
	25	#:use-module (ice-9 vlist)
	26	#:export (bytevector-quintet-length
	27	bytevector->base32-string
	28	bytevector->nix-base32-string
	29	base32-string->bytevector
1a706ff5	30	nix-base32-string->bytevector
0a94dc63 LC	31	%nix-base32-charset
0a94dc63 LC	32	%rfc4648-base32-charset
1a706ff5 LC	33	&invalid-base32-character
	34	invalid-base32-character?
	35	invalid-base32-character-value
	36	invalid-base32-character-string))
ddc29a78 LC	37
	38	;;; Commentary:
	39	;;;
	40	;;; A generic, customizable to convert bytevectors to/from a base32
	41	;;; representation.
	42	;;;
	43	;;; Code:
	44
cb06f7c6 LC	45	(define-syntax bit-field
	46	(lambda (s)
	47	;; This inline version of 'bit-field' assumes that START and END are
	48	;; literals and pre-computes the mask. In an ideal world, using 'define'
	49	;; or 'define-inlinable' would be enough, but as of 3.0.7, peval doesn't
	50	;; expand calls to 'expt' (and 'bit-field' is a subr.)
	51	(syntax-case s ()
	52	((_ n start end)
	53	(let* ((s (syntax->datum #'start))
	54	(e (syntax->datum #'end))
	55	(mask (- (expt 2 (- e s)) 1)))
baa0aa13 LC	56	;; The baseline compiler in Guile <= 3.0.7 miscompiles (ash x N) as
	57	;; (ash x (- N)) when N is a literal: <https://bugs.gnu.org/50696>.
	58	;; Here we take advantage of another bug in the baseline compiler,
	59	;; fixed in Guile commit 330c6ea83f492672578b62d0683acbb532d1a5d9: we
	60	;; introduce 'minus-start' such that it has a different source
	61	;; location, which in turn means that the baseline compiler pattern
	62	;; for (ash x N) doesn't match, thus avoiding the bug (!).
	63	(with-syntax ((minus-start (datum->syntax #'start (- s))))
	64	#`(logand (ash n minus-start) #,mask)))))))
cb06f7c6	65
ddc29a78 LC	66	(define bytevector-quintet-ref
	67	(let* ((ref bytevector-u8-ref)
	68	(ref+ (lambda (bv offset)
	69	(let ((o (+ 1 offset)))
	70	(if (>= o (bytevector-length bv))
	71	0
	72	(bytevector-u8-ref bv o)))))
	73	(ref0 (lambda (bv offset)
	74	(bit-field (ref bv offset) 3 8)))
	75	(ref1 (lambda (bv offset)
	76	(logior (ash (bit-field (ref bv offset) 0 3) 2)
	77	(bit-field (ref+ bv offset) 6 8))))
	78	(ref2 (lambda (bv offset)
	79	(bit-field (ref bv offset) 1 6)))
	80	(ref3 (lambda (bv offset)
	81	(logior (ash (bit-field (ref bv offset) 0 1) 4)
	82	(bit-field (ref+ bv offset) 4 8))))
	83	(ref4 (lambda (bv offset)
	84	(logior (ash (bit-field (ref bv offset) 0 4) 1)
	85	(bit-field (ref+ bv offset) 7 8))))
	86	(ref5 (lambda (bv offset)
	87	(bit-field (ref bv offset) 2 7)))
	88	(ref6 (lambda (bv offset)
	89	(logior (ash (bit-field (ref bv offset) 0 2) 3)
	90	(bit-field (ref+ bv offset) 5 8))))
	91	(ref7 (lambda (bv offset)
	92	(bit-field (ref bv offset) 0 5)))
	93	(refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
	94	(lambda (bv index)
	95	"Return the INDEXth quintet of BV."
	96	(let ((p (vector-ref refs (modulo index 8))))
	97	(p bv (quotient (* index 5) 8))))))
	98
	99	(define bytevector-quintet-ref-right
	100	(let* ((ref bytevector-u8-ref)
	101	(ref+ (lambda (bv offset)
	102	(let ((o (+ 1 offset)))
	103	(if (>= o (bytevector-length bv))
	104	0
	105	(bytevector-u8-ref bv o)))))
	106	(ref0 (lambda (bv offset)
	107	(bit-field (ref bv offset) 0 5)))
	108	(ref1 (lambda (bv offset)
	109	(logior (bit-field (ref bv offset) 5 8)
	110	(ash (bit-field (ref+ bv offset) 0 2) 3))))
	111	(ref2 (lambda (bv offset)
	112	(bit-field (ref bv offset) 2 7)))
	113	(ref3 (lambda (bv offset)
	114	(logior (bit-field (ref bv offset) 7 8)
	115	(ash (bit-field (ref+ bv offset) 0 4) 1))))
	116	(ref4 (lambda (bv offset)
	117	(logior (bit-field (ref bv offset) 4 8)
	118	(ash (bit-field (ref+ bv offset) 0 1) 4))))
	119	(ref5 (lambda (bv offset)
	120	(bit-field (ref bv offset) 1 6)))
	121	(ref6 (lambda (bv offset)
	122	(logior (bit-field (ref bv offset) 6 8)
	123	(ash (bit-field (ref+ bv offset) 0 3) 2))))
	124	(ref7 (lambda (bv offset)
	125	(bit-field (ref bv offset) 3 8)))
	126	(refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
	127	(lambda (bv index)
	128	"Return the INDEXth quintet of BV, assuming quintets start from the
	129	least-significant bits, contrary to what RFC 4648 describes."
130	(let ((p (vector-ref refs (modulo index 8))))
131	(p bv (quotient (* index 5) 8))))))
132
133	(define (bytevector-quintet-length bv)
134	"Return the number of quintets (including truncated ones) available in BV."
135	(ceiling (/ (* (bytevector-length bv) 8) 5)))
136
137	(define (bytevector-quintet-fold proc init bv)
138	"Return the result of applying PROC to each quintet of BV and the result of
139	the previous application or INIT."
140	(define len
141	(bytevector-quintet-length bv))
142
143	(let loop ((i 0)
144	(r init))
145	(if (= i len)
146	r
147	(loop (1+ i) (proc (bytevector-quintet-ref bv i) r)))))
148
149	(define (bytevector-quintet-fold-right proc init bv)
150	"Return the result of applying PROC to each quintet of BV and the result of
151	the previous application or INIT."
152	(define len
153	(bytevector-quintet-length bv))
154
155	(let loop ((i len)
156	(r init))
157	(if (zero? i)
158	r
159	(let ((j (- i 1)))
160	(loop j (proc (bytevector-quintet-ref-right bv j) r))))))
161
162	(define (make-bytevector->base32-string quintet-fold base32-chars)
163	(lambda (bv)
164	"Return a base32 encoding of BV using BASE32-CHARS as the alphabet."
165	(let ((chars (quintet-fold (lambda (q r)
166	(cons (vector-ref base32-chars q)
167	r))
168	'()
169	bv)))
170	(list->string (reverse chars)))))
171
172	(define %nix-base32-chars
173	;; See `libutil/hash.cc'.
174	#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
175	#\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
176	#\p #\q #\r #\s #\v #\w #\x #\y #\z))
177
0a94dc63 LC	178	(define %nix-base32-charset
	179	(list->char-set (vector->list %nix-base32-chars)))
	180
ddc29a78 LC	181	(define %rfc4648-base32-chars
	182	#(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
	183	#\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
	184	#\2 #\3 #\4 #\5 #\6 #\7))
	185
0a94dc63 LC	186	(define %rfc4648-base32-charset
	187	(list->char-set (vector->list %rfc4648-base32-chars)))
	188
ddc29a78 LC	189	(define bytevector->base32-string
	190	(make-bytevector->base32-string bytevector-quintet-fold
	191	%rfc4648-base32-chars))
	192
	193	(define bytevector->nix-base32-string
	194	(make-bytevector->base32-string bytevector-quintet-fold-right
	195	%nix-base32-chars))
	196
	197
	198	(define bytevector-quintet-set!
	199	(let* ((setq! (lambda (bv offset start stop value)
	200	(let ((v (bytevector-u8-ref bv offset))
	201	(w (arithmetic-shift value start))
	202	(m (bitwise-xor (1- (expt 2 stop))
	203	(1- (expt 2 start)))))
	204	(bytevector-u8-set! bv offset
	205	(bitwise-merge m w v)))))
	206	(set0! (lambda (bv offset value)
	207	(setq! bv offset 3 8 value)))
	208	(set1! (lambda (bv offset value)
	209	(setq! bv offset 0 3 (bit-field value 2 5))
	210	(or (= (+ 1 offset) (bytevector-length bv))
	211	(setq! bv (+ 1 offset) 6 8 (bit-field value 0 2)))))
	212	(set2! (lambda (bv offset value)
	213	(setq! bv offset 1 6 value)))
	214	(set3! (lambda (bv offset value)
	215	(setq! bv offset 0 1 (bit-field value 4 5))
	216	(or (= (+ 1 offset) (bytevector-length bv))
	217	(setq! bv (+ 1 offset) 4 8 (bit-field value 0 4)))))
	218	(set4! (lambda (bv offset value)
	219	(setq! bv offset 0 4 (bit-field value 1 5))
	220	(or (= (+ 1 offset) (bytevector-length bv))
	221	(setq! bv (+ 1 offset) 7 8 (bit-field value 0 1)))))
	222	(set5! (lambda (bv offset value)
	223	(setq! bv offset 2 7 value)))
	224	(set6! (lambda (bv offset value)
	225	(setq! bv offset 0 2 (bit-field value 3 5))
	226	(or (= (+ 1 offset) (bytevector-length bv))
	227	(setq! bv (+ 1 offset) 5 8 (bit-field value 0 3)))))
	228	(set7! (lambda (bv offset value)
	229	(setq! bv offset 0 5 value)))
	230	(sets (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
	231	(lambda (bv index value)
	232	"Set the INDEXth quintet of BV to VALUE."
	233	(let ((p (vector-ref sets (modulo index 8))))
	234	(p bv (quotient (* index 5) 8) (logand value #x1f))))))
	235
	236	(define bytevector-quintet-set-right!
	237	(let* ((setq! (lambda (bv offset start stop value)
	238	(let ((v (bytevector-u8-ref bv offset))
	239	(w (arithmetic-shift value start))
	240	(m (bitwise-xor (1- (expt 2 stop))
	241	(1- (expt 2 start)))))
	242	(bytevector-u8-set! bv offset
	243	(bitwise-merge m w v)))))
	244	(set0! (lambda (bv offset value)
	245	(setq! bv offset 0 5 value)))
	246	(set1! (lambda (bv offset value)
	247	(setq! bv offset 5 8 (bit-field value 0 3))
	248	(or (= (+ 1 offset) (bytevector-length bv))
	249	(setq! bv (+ 1 offset) 0 2 (bit-field value 3 5)))))
	250	(set2! (lambda (bv offset value)
	251	(setq! bv offset 2 7 value)))
	252	(set3! (lambda (bv offset value)
253	(setq! bv offset 7 8 (bit-field value 0 1))
254	(or (= (+ 1 offset) (bytevector-length bv))
255	(setq! bv (+ 1 offset) 0 4 (bit-field value 1 5)))))
256	(set4! (lambda (bv offset value)
257	(setq! bv offset 4 8 (bit-field value 0 4))
258	(or (= (+ 1 offset) (bytevector-length bv))
259	(setq! bv (+ 1 offset) 0 1 (bit-field value 4 5)))))
260	(set5! (lambda (bv offset value)
261	(setq! bv offset 1 6 value)))
262	(set6! (lambda (bv offset value)
263	(setq! bv offset 6 8 (bit-field value 0 2))
264	(or (= (+ 1 offset) (bytevector-length bv))
265	(setq! bv (+ 1 offset) 0 3 (bit-field value 2 5)))))
266	(set7! (lambda (bv offset value)
267	(setq! bv offset 3 8 value)))
268	(sets (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
269	(lambda (bv index value)
270	"Set the INDEXth quintet of BV to VALUE, assuming quintets start from
271	the least-significant bits."
272	(let ((p (vector-ref sets (modulo index 8))))
273	(p bv (quotient (* index 5) 8) (logand value #x1f))))))
274
275	(define (base32-string-unfold f s)
276	"Given procedure F which, when applied to a character, returns the
277	corresponding quintet, return the bytevector corresponding to string S."
278	(define len (string-length s))
279
280	(let ((bv (make-bytevector (quotient (* len 5) 8))))
281	(string-fold (lambda (chr index)
282	(bytevector-quintet-set! bv index (f chr))
283	(+ 1 index))
284	0
285	s)
286	bv))
287
288	(define (base32-string-unfold-right f s)
289	"Given procedure F which, when applied to a character, returns the
290	corresponding quintet, return the bytevector corresponding to string S,
291	starting from the right of S."
292	(define len (string-length s))
293
294	(let ((bv (make-bytevector (quotient (* len 5) 8))))
295	(string-fold-right (lambda (chr index)
296	(bytevector-quintet-set-right! bv index (f chr))
297	(+ 1 index))
298	0
299	s)
300	bv))
301
1a706ff5 LC	302	;; Invalid base32 character error condition when decoding base32.
	303	(define-condition-type &invalid-base32-character &error
	304	invalid-base32-character?
	305	(character invalid-base32-character-value)
	306	(string invalid-base32-character-string))
	307
ddc29a78 LC	308	(define (make-base32-string->bytevector base32-string-unfold base32-chars)
	309	(let ((char->value (let loop ((i 0)
	310	(v vlist-null))
	311	(if (= i (vector-length base32-chars))
	312	v
	313	(loop (+ 1 i)
	314	(vhash-consv (vector-ref base32-chars i)
	315	i v))))))
	316	(lambda (s)
	317	"Return the binary representation of base32 string S as a bytevector."
	318	(base32-string-unfold (lambda (chr)
	319	(or (and=> (vhash-assv chr char->value) cdr)
1a706ff5 LC	320	(raise (condition
	321	(&invalid-base32-character
	322	(character chr)
	323	(string s))))))
ddc29a78 LC	324	s))))
	325
	326	(define base32-string->bytevector
	327	(make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars))
	328
	329	(define nix-base32-string->bytevector
	330	(make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars))
	331
	332	;;; base32.scm ends here