From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 7 Jan 2005 15:10:23 +0000 (+0000)
Subject: New procedure HEXADECIMAL->VECTOR-8B.
X-Git-Tag: 20090517-FFI~1398
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=38ca560bb361dce6ce71625e099a16c03e22332e;p=mit-scheme.git

New procedure HEXADECIMAL->VECTOR-8B.
---

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 3c36de6eb..e565d3754 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.525 2005/01/06 18:10:17 cph Exp $
+$Id: runtime.pkg,v 14.526 2005/01/07 15:10:06 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -745,10 +745,12 @@ USA.
   (files "string")
   (parent (runtime))
   (export ()
+	  (guarantee-vector-8b guarantee-string)
 	  (set-vector-8b-length! set-string-length!)
 	  (set-vector-8b-maximum-length! set-string-maximum-length!)
 	  (vector-8b-length string-length)
 	  (vector-8b-maximum-length string-maximum-length)
+	  (vector-8b? string?)
 	  allocate-external-string
 	  burst-string
 	  char->string
@@ -760,6 +762,7 @@ USA.
 	  guarantee-substring
 	  guarantee-substring-end-index
 	  guarantee-substring-start-index
+	  hexadecimal->vector-8b
 	  list->string
 	  make-string
 	  make-vector-8b
diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm
index 5e7ca51cd..0e8415ba5 100644
--- a/v7/src/runtime/string.scm
+++ b/v7/src/runtime/string.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: string.scm,v 14.57 2005/01/06 18:10:27 cph Exp $
+$Id: string.scm,v 14.58 2005/01/07 15:10:23 cph Exp $
 
 Copyright 1986,1987,1988,1992,1993,1994 Massachusetts Institute of Technology
 Copyright 1995,1997,1999,2000,2001,2002 Massachusetts Institute of Technology
@@ -74,21 +74,6 @@ USA.
 (define-integrable (vector-8b-find-previous-char-ci string start end ascii)
   (substring-find-previous-char-ci string start end (ascii->char ascii)))
 
-(define (vector-8b->hexadecimal bytes)
-  (let ((n (vector-8b-length bytes)))
-    (let ((s (make-string (fix:* 2 n))))
-      (do ((i 0 (fix:+ i 1))
-	   (j 0 (fix:+ j 2)))
-	  ((not (fix:< i n)))
-	(string-set! s j (hex-digit (fix:lsh (vector-8b-ref bytes i) -4)))
-	(string-set! s
-		     (fix:+ j 1)
-		     (hex-digit (fix:and (vector-8b-ref bytes i) #x0F))))
-      s)))
-
-(define-integrable (hex-digit k)
-  (string-ref "0123456789abcdef" k))
-
 ;;; Character optimizations
 
 (define-integrable (%%char-downcase char)
@@ -419,6 +404,43 @@ USA.
 	(string-set! string j (string-ref string i))
 	(string-set! string i char)))))
 
+(define (vector-8b->hexadecimal bytes)
+  (define-integrable (hex-char k)
+    (string-ref "0123456789abcdef" (fix:and k #x0F)))
+  (guarantee-string bytes 'VECTOR-8B->HEXADECIMAL)
+  (let ((n (vector-8b-length bytes)))
+    (let ((s (make-string (fix:* 2 n))))
+      (do ((i 0 (fix:+ i 1))
+	   (j 0 (fix:+ j 2)))
+	  ((not (fix:< i n)))
+	(string-set! s j (hex-char (fix:lsh (vector-8b-ref bytes i) -4)))
+	(string-set! s (fix:+ j 1) (hex-char (vector-8b-ref bytes i))))
+      s)))
+
+(define (hexadecimal->vector-8b string)
+  (guarantee-string string 'HEXADECIMAL->VECTOR-8B)
+  (let ((end (string-length string))
+	(lose
+	 (lambda ()
+	   (error:bad-range-argument string 'HEXADECIMAL->VECTOR-8B))))
+    (define-integrable (hex-digit char)
+      (let ((d
+	     (fix:- (char->integer char)
+		    (char->integer #\0))))
+	(if (not (and (fix:<= 0 d) (fix:< d 16)))
+	    (lose))
+	d))
+    (if (not (fix:= (fix:and end 1) 0))
+	(lose))
+    (let ((bytes (make-vector-8b (fix:lsh end -1))))
+      (do ((i 0 (fix:+ i 2))
+	   (j 0 (fix:+ j 1)))
+	  ((not (fix:< i end)))
+	(vector-8b-set! bytes j
+			(fix:+ (fix:lsh (hex-digit (string-ref string i)) 4)
+			       (hex-digit (string-ref string (fix:+ i 1))))))
+      bytes)))
+
 ;;;; Case
 
 (define (string-upper-case? string)