From 09372511edffc87ff37c37a2224a3f403f0066e9 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 20 Jul 2019 04:33:47 -0400
Subject: [PATCH] Implement bytevector<?.

---
 src/runtime/bytevector.scm        | 13 ++++++++++++
 src/runtime/runtime.pkg           |  1 +
 tests/runtime/test-bytevector.scm | 33 ++++++++++++++++++++++++++++++-
 3 files changed, 46 insertions(+), 1 deletion(-)

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 094c9e5d2..c77fecfb8 100644
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -106,6 +106,19 @@ USA.
 			   (bytevector-u8-ref b2 index))
 		    (loop (fix:+ index 1))))))))
 
+(define (bytevector<? b1 b2)
+  (let ((l1 (bytevector-length b1))
+	(l2 (bytevector-length b2)))
+    (let ((end (fix:min l1 l2)))
+      (let loop ((index 0))
+	(if (fix:< index end)
+	    (let ((u1 (bytevector-u8-ref b1 index))
+		  (u2 (bytevector-u8-ref b2 index)))
+	      (if (fix:= u1 u2)
+		  (loop (fix:+ index 1))
+		  (fix:< u1 u2)))
+	    (fix:< l1 l2))))))
+
 ;; String hash primitives work on bytevectors too.
 (define (bytevector-hash bytevector #!optional modulus)
   (if (default-object? modulus)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e4915192d..8aee73893 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1213,6 +1213,7 @@ USA.
 	  bytevector-u8-ref
 	  bytevector-u8-set!
 	  bytevector-zero-explicit!
+	  bytevector<?
 	  bytevector=?
 	  bytevector?
 	  exact-nonnegative-integer->bytevector
diff --git a/tests/runtime/test-bytevector.scm b/tests/runtime/test-bytevector.scm
index b26c1bcfe..eca647249 100644
--- a/tests/runtime/test-bytevector.scm
+++ b/tests/runtime/test-bytevector.scm
@@ -462,6 +462,25 @@ USA.
 					 (bytevector-copy bv 11 22)
 					 bv1))))))
 
+(define-test 'bytevector<?
+  (lambda ()
+    (let ((lists (random-byte-lists 16 64)))
+      (for-each (lambda (l1)
+		  (for-each (lambda (l2)
+			      (assert-eqv (bytevector<? (bytes->bv l1)
+							(bytes->bv l2))
+					  (byte-list<? l1 l2)))
+			    lists))
+		lists))))
+
+(define (byte-list<? l1 l2)
+  (if (and (pair? l1) (pair? l2))
+      (if (fix:= (car l1) (car l2))
+	  (byte-list<? (cdr l1) (cdr l2))
+	  (fix:< (car l1) (car l2)))
+      (and (null? l1)
+	   (not (null? l2)))))
+
 (define (build-bytevector objects)
   (let ((builder (bytevector-builder)))
     (for-each builder objects)
@@ -481,4 +500,16 @@ USA.
       (let ((start* (fix:+ start n)))
 	(if (fix:<= start* end)
 	    (loop start* (cons (bytevector-copy bv start start*) bvs))
-	    (reverse! bvs))))))
\ No newline at end of file
+	    (reverse! bvs))))))
+
+(define (random-byte-lists n max-length)
+  (map (lambda (i)
+	 (declare (ignore i))
+	 (random-byte-list max-length))
+       (iota n)))
+
+(define (random-byte-list max-length)
+  (map (lambda (i)
+	 (declare (ignore i))
+	 (random #x100))
+       (iota (random (+ max-length 1)))))
\ No newline at end of file
-- 
2.25.1