From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 6 Jan 2005 18:10:44 +0000 (+0000)
Subject: Flesh out vector-8b operations a bit.
X-Git-Tag: 20090517-FFI~1402
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2bddf8d7810d33d854c5d66a9f6c36978e7ed31b;p=mit-scheme.git

Flesh out vector-8b operations a bit.
---

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 46cc1f464..3c36de6eb 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,10 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.524 2004/12/23 04:43:38 cph Exp $
+$Id: runtime.pkg,v 14.525 2005/01/06 18:10:17 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
-Copyright 2000,2001,2002,2003,2004 Massachusetts Institute of Technology
+Copyright 2000,2001,2002,2003,2004,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -745,6 +745,10 @@ USA.
   (files "string")
   (parent (runtime))
   (export ()
+	  (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)
 	  allocate-external-string
 	  burst-string
 	  char->string
@@ -758,6 +762,7 @@ USA.
 	  guarantee-substring-start-index
 	  list->string
 	  make-string
+	  make-vector-8b
 	  reverse-string
 	  reverse-string!
 	  reverse-substring
@@ -862,6 +867,7 @@ USA.
 	  substring<?
 	  substring=?
 	  substring?
+	  vector-8b->hexadecimal
 	  vector-8b-fill!
 	  vector-8b-find-next-char
 	  vector-8b-find-next-char-ci
diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm
index f64797768..5e7ca51cd 100644
--- a/v7/src/runtime/string.scm
+++ b/v7/src/runtime/string.scm
@@ -1,10 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: string.scm,v 14.56 2004/02/17 05:35:46 cph Exp $
+$Id: string.scm,v 14.57 2005/01/06 18:10:27 cph Exp $
 
 Copyright 1986,1987,1988,1992,1993,1994 Massachusetts Institute of Technology
 Copyright 1995,1997,1999,2000,2001,2002 Massachusetts Institute of Technology
-Copyright 2003,2004 Massachusetts Institute of Technology
+Copyright 2003,2004,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -74,6 +74,21 @@ 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)
@@ -102,6 +117,9 @@ USA.
 	  (%substring-fill! result 0 length char)
 	  result))))
 
+(define (make-vector-8b length #!optional ascii)
+  (make-string length (if (default-object? ascii) ascii (ascii->char ascii))))
+
 (define (string-fill! string char)
   (guarantee-string string 'STRING-FILL!)
   (guarantee-char char 'STRING-FILL!)
diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm
index dfa2596b1..7c0fab2c2 100644
--- a/v7/src/sf/usiexp.scm
+++ b/v7/src/sf/usiexp.scm
@@ -1,10 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: usiexp.scm,v 4.44 2004/11/18 18:17:59 cph Exp $
+$Id: usiexp.scm,v 4.45 2005/01/06 18:10:44 cph Exp $
 
 Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright 1993,1994,1995,1997,2000,2001 Massachusetts Institute of Technology
-Copyright 2004 Massachusetts Institute of Technology
+Copyright 2004,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -673,6 +673,7 @@ USA.
     intern
     list
     make-string
+    make-vector-8b
     ;; modulo	; Compiler does not currently open-code it.
     negative?
     number?
@@ -755,6 +756,7 @@ USA.
    intern-expansion
    list-expansion
    make-string-expansion
+   make-string-expansion
    ;; modulo-expansion
    negative?-expansion
    complex?-expansion