From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 22 Feb 2017 05:31:53 +0000 (-0800)
Subject: Implement bytevector->hexadecimal and hexadecimal->bytevector.
X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~26
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3022b48587742a203d3437e6e32f83074c682dca;p=mit-scheme.git

Implement bytevector->hexadecimal and hexadecimal->bytevector.
---

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 4a984a857..fd0e55ebc 100644
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -374,4 +374,44 @@ USA.
    (set! utf32le->string
 	 (bytes-decoder bytevector-u32le-ref initial-u32->utf32-char-length
 			decode-utf32le-char 1 "UTF-32LE" 'utf32le->string))
-   unspecific))
\ No newline at end of file
+   unspecific))
+
+(define (bytevector->hexadecimal bytes)
+  (define-integrable (hex-char k)
+    (string-ref "0123456789ABCDEF" (fix:and k #x0F)))
+  (guarantee string? bytes 'bytevector->hexadecimal)
+  (let ((n (bytevector-length bytes))
+	(builder (string-builder)))
+    (do ((i 0 (fix:+ i 1)))
+	((not (fix:< i n)))
+      (builder (hex-char (fix:lsh (bytevector-u8-ref bytes i) -4)))
+      (builder (hex-char (bytevector-u8-ref bytes i))))
+    (builder)))
+
+(define (hexadecimal->bytevector string)
+  (guarantee string? string 'hexadecimal->bytevector)
+  (let ((end (string-length string))
+	(lose
+	 (lambda ()
+	   (error:bad-range-argument string 'hexadecimal->bytevector))))
+    (define-integrable (hex-digit char)
+      (let ((i (char->integer char))
+	    (d0 (char->integer #\0))
+	    (d9 (char->integer #\9))
+	    (la (char->integer #\a))
+	    (lf (char->integer #\f))
+	    (UA (char->integer #\A))
+	    (UF (char->integer #\F)))
+	(cond ((and (fix:<= d0 i) (fix:<= i d9)) (fix:- i d0))
+	      ((and (fix:<= la i) (fix:<= i lf)) (fix:+ #xa (fix:- i la)))
+	      ((and (fix:<= UA i) (fix:<= i UF)) (fix:+ #xA (fix:- i UA)))
+	      (else (lose)))))
+    (if (not (fix:= (fix:and end 1) 0))
+	(lose))
+    (let ((builder (bytevector-builder)))
+      (do ((i 0 (fix:+ i 2)))
+	  ((not (fix:< i end)))
+	(builder
+	 (fix:+ (fix:lsh (hex-digit (string-ref string i)) 4)
+		(hex-digit (string-ref string (fix:+ i 1))))))
+      (builder))))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 5fdac0ab2..c4475fd38 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1179,6 +1179,7 @@ USA.
   (export ()
 	  (byte? u8?)
 	  bytevector
+	  bytevector->hexadecimal
 	  bytevector-append
 	  bytevector-builder
 	  bytevector-copy
@@ -1198,6 +1199,7 @@ USA.
 	  bytevector-u8-set!
 	  bytevector=?
 	  bytevector?
+	  hexadecimal->bytevector
 	  make-bytevector
 	  string->utf16be
 	  string->utf16le