diff options
author | Mark H Weaver <mhw@netris.org> | 2017-03-19 18:52:01 -0400 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2017-03-19 18:52:12 -0400 |
commit | f67337e23ec16b1e05fcdcc7953f68f13ed6770a (patch) | |
tree | 766e98a6c4695228f0a066accf91f639791dad68 /guix/base16.scm | |
parent | b99eec83b861f6bee7afb7bd6ffcbdddd8f62b65 (diff) | |
parent | e05fc441cd5528ba6c83b6371c27c1e87dd393e9 (diff) | |
download | guix-patches-f67337e23ec16b1e05fcdcc7953f68f13ed6770a.tar guix-patches-f67337e23ec16b1e05fcdcc7953f68f13ed6770a.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/base16.scm')
-rw-r--r-- | guix/base16.scm | 83 |
1 files changed, 83 insertions, 0 deletions
diff --git a/guix/base16.scm b/guix/base16.scm new file mode 100644 index 0000000000..6c15a9f588 --- /dev/null +++ b/guix/base16.scm @@ -0,0 +1,83 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2014, 2017 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 base16) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-60) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 vlist) + #:use-module (ice-9 format) + #:export (bytevector->base16-string + base16-string->bytevector)) + +;;; +;;; Base 16. +;;; + +(define (bytevector->base16-string bv) + "Return the hexadecimal representation of BV's contents." + (define len + (bytevector-length bv)) + + (let-syntax ((base16-chars (lambda (s) + (syntax-case s () + (_ + (let ((v (list->vector + (unfold (cut > <> 255) + (lambda (n) + (format #f "~2,'0x" n)) + 1+ + 0)))) + v)))))) + (define chars base16-chars) + (let loop ((i len) + (r '())) + (if (zero? i) + (string-concatenate r) + (let ((i (- i 1))) + (loop i + (cons (vector-ref chars (bytevector-u8-ref bv i)) r))))))) + +(define base16-string->bytevector + (let ((chars->value (fold (lambda (i r) + (vhash-consv (string-ref (number->string i 16) + 0) + i r)) + vlist-null + (iota 16)))) + (lambda (s) + "Return the bytevector whose hexadecimal representation is string S." + (define bv + (make-bytevector (quotient (string-length s) 2) 0)) + + (string-fold (lambda (chr i) + (let ((j (quotient i 2)) + (v (and=> (vhash-assv chr chars->value) cdr))) + (if v + (if (zero? (logand i 1)) + (bytevector-u8-set! bv j + (arithmetic-shift v 4)) + (let ((w (bytevector-u8-ref bv j))) + (bytevector-u8-set! bv j (logior v w)))) + (error "invalid hexadecimal character" chr))) + (+ i 1)) + 0 + s) + bv))) + |