From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 18 Mar 2017 04:41:18 +0000 (-0700)
Subject: Add u16/u32 equivalents to bytevector.
X-Git-Tag: mit-scheme-pucked-9.2.12~158^2~92
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7820e64492b07fc15e86a6b624b55791c1b747b5;p=mit-scheme.git

Add u16/u32 equivalents to bytevector.
---

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 9abe8c59b..1c35ddc19 100644
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -158,6 +158,22 @@ USA.
 (define-integrable (u16le-byte0 u16) (fix:and u16 #xFF))
 (define-integrable (u16le-byte1 u16) (fix:lsh u16 -8))
 
+(define-integrable (u16-bytevector-maker u16-byte0 u16-byte1)
+  (lambda u16s
+    (let ((bytevector (allocate-bytevector (fix:lsh (length u16s) 1))))
+      (do ((u16s u16s (cdr u16s))
+	   (i 0 (fix:+ i 2)))
+	  ((not (pair? u16s)))
+	(bytevector-u8-set! bytevector i (u16-byte0 (car u16s)))
+	(bytevector-u8-set! bytevector (fix:+ i 1) (u16-byte1 (car u16s))))
+      bytevector)))
+
+(define bytevector-u16be
+  (u16-bytevector-maker u16be-byte0 u16be-byte1))
+
+(define bytevector-u16le
+  (u16-bytevector-maker u16le-byte0 u16le-byte1))
+
 (define (u16? object)
   (and (index-fixnum? object)
        (fix:< object #x10000)))
@@ -246,6 +262,25 @@ USA.
 (define-integrable u32le-byte2 u32be-byte1)
 (define-integrable u32le-byte3 u32be-byte0)
 
+(define-integrable (u32-bytevector-maker u32-byte0 u32-byte1 u32-byte2
+					 u32-byte3)
+  (lambda u32s
+    (let ((bytevector (allocate-bytevector (fix:lsh (length u32s) 2))))
+      (do ((u32s u32s (cdr u32s))
+	   (i 0 (fix:+ i 4)))
+	  ((not (pair? u32s)))
+	(bytevector-u8-set! bytevector i (u32-byte0 (car u32s)))
+	(bytevector-u8-set! bytevector (fix:+ i 1) (u32-byte1 (car u32s)))
+	(bytevector-u8-set! bytevector (fix:+ i 2) (u32-byte2 (car u32s)))
+	(bytevector-u8-set! bytevector (fix:+ i 3) (u32-byte3 (car u32s))))
+      bytevector)))
+
+(define bytevector-u32be
+  (u32-bytevector-maker u32be-byte0 u32be-byte1 u32be-byte2 u32be-byte3))
+
+(define bytevector-u32le
+  (u32-bytevector-maker u32le-byte0 u32le-byte1 u32le-byte2 u32le-byte3))
+
 (define (bytevector-u32be-ref bytevector index)
   (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector)))
       (error:bad-range-argument index 'bytevector-u32be-ref))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e59acbed1..2792eb329 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1071,12 +1071,16 @@ USA.
 	  bytevector-fill!
 	  bytevector-hash
 	  bytevector-length
+	  bytevector-u16be
 	  bytevector-u16be-ref
 	  bytevector-u16be-set!
+	  bytevector-u16le
 	  bytevector-u16le-ref
 	  bytevector-u16le-set!
+	  bytevector-u32be
 	  bytevector-u32be-ref
 	  bytevector-u32be-set!
+	  bytevector-u32le
 	  bytevector-u32le-ref
 	  bytevector-u32le-set!
 	  bytevector-u8-ref