From 4684239efa63dc1b2c1cbe37ef7d3062029f5532 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:40 -0800
Subject: Import Upstream version 3b1

---
 byte.scm | 101 +++++++++++++++++++++++++++++++++++++++++----------------------
 1 file changed, 66 insertions(+), 35 deletions(-)

(limited to 'byte.scm')

diff --git a/byte.scm b/byte.scm
index c611cf0..6fdde3d 100644
--- a/byte.scm
+++ b/byte.scm
@@ -1,5 +1,5 @@
 ;;; "byte.scm" small integers, not necessarily chars.
-; Copyright (C) 2001, 2002, 2003, 2006 Aubrey Jaffer
+; Copyright (C) 2001, 2002, 2003, 2006, 2008 Aubrey Jaffer
 ;
 ;Permission to copy this software, to modify it, to redistribute it,
 ;to distribute modified versions, and to use it for any purpose is
@@ -17,7 +17,7 @@
 ;promotional, or sales literature without prior written consent in
 ;each case.
 
-(require 'rev4-optional-procedures)	; string-copy
+(require 'array)
 
 ;;@code{(require 'byte)}
 ;;@ftindex byte
@@ -29,16 +29,17 @@
 ;;character sets.  These functions abstract the notion of a @dfn{byte}.
 ;;@cindex byte
 
-;;@body
+;;@args bytes k
 ;;@2 must be a valid index of @1.  @0 returns byte @2 of @1 using
 ;;zero-origin indexing.
-(define (byte-ref bytes k) (char->integer (string-ref bytes k)))
+(define byte-ref array-ref)
 
 ;;@body
 ;;@2 must be a valid index of @1, and @var{byte} must be a small
 ;;nonnegative integer.  @0 stores @var{byte} in element @2 of @1 and
 ;;returns an unspecified value.  @c <!>
-(define (byte-set! bytes k byte) (string-set! bytes k (integer->char byte)))
+(define (byte-set! bytes k byte)
+  (array-set! bytes byte k))
 
 ;;@args k byte
 ;;@args k
@@ -46,36 +47,65 @@
 ;;given, then all elements of the byte-array are initialized to @2,
 ;;otherwise the contents of the byte-array are unspecified.
 (define (make-bytes len . opt)
-  (if (null? opt) (make-string len)
-      (make-string len (integer->char (car opt)))))
+  (make-array (apply A:fixN8b opt) len))
 
 ;;@args bytes
 ;;@0 returns length of byte-array @1.
-(define bytes-length string-length)
+(define (bytes-length bts)
+  (car (array-dimensions bts)))
 
 ;;@args byte @dots{}
 ;;Returns a newly allocated byte-array composed of the small
 ;;nonnegative arguments.
-(define (bytes . args) (list->bytes args))
-
-;;@args bytes
-;;@0 returns a newly allocated list of the bytes that make up the
-;;given byte-array.
-(define (bytes->list bts) (map char->integer (string->list bts)))
+(define (bytes . args)
+  (list->array 1 (A:fixN8b) args))
 
 ;;@args bytes
 ;;@0 returns a newly allocated byte-array formed from the small
 ;;nonnegative integers in the list @1.
-(define (list->bytes lst) (list->string (map integer->char lst)))
+(define (list->bytes lst)
+  (list->array 1 (A:fixN8b) lst))
+
+;;@args bytes
+;;@0 returns a newly allocated list of the bytes that make up the
+;;given byte-array.
+(define bytes->list array->list)
 
 ;;@noindent
 ;;@code{Bytes->list} and @code{list->bytes} are inverses so far as
 ;;@code{equal?} is concerned.
 ;;@findex equal?
 
+;;@args bytes
+;;Returns a new string formed from applying @code{integer->char} to
+;;each byte in @0.  Note that this may signal an error for bytes
+;;having values between 128 and 255.
+(define (bytes->string bts)
+  (define len (bytes-length bts))
+  (let ((new (make-string len)))
+    (do ((idx (- len 1) (+ -1 idx)))
+	((negative? idx) new)
+      (string-set! new idx (integer->char (byte-ref bts idx))))))
+
+;;@args string
+;;Returns a new byte-array formed from applying @code{char->integer}
+;;to each character in @0.  Note that this may signal an error if an
+;;integer is larger than 255.
+(define (string->bytes str)
+  (define len (string-length str))
+  (let ((new (make-bytes len)))
+    (do ((idx (- len 1) (+ -1 idx)))
+	((negative? idx) new)
+      (byte-set! new idx (char->integer (string-ref str idx))))))
+
 ;;@args bytes
 ;;Returns a newly allocated copy of the given @1.
-(define bytes-copy string-copy)
+(define (bytes-copy bts)
+  (define len (bytes-length bts))
+  (let ((new (make-bytes len)))
+    (do ((idx (- len 1) (+ -1 idx)))
+	((negative? idx) new)
+      (byte-set! new idx (byte-ref bytes idx)))))
 
 ;;@args bytes start end
 ;;@1 must be a bytes, and @2 and @3
@@ -86,7 +116,11 @@
 ;;@0 returns a newly allocated bytes formed from the bytes of
 ;;@1 beginning with index @2 (inclusive) and ending with index
 ;;@3 (exclusive).
-(define subbytes substring)
+(define (subbytes bytes start end)
+  (define new (make-bytes (- end start)))
+  (do ((idx (- end start 1) (+ -1 idx)))
+      ((negative? idx) new)
+    (byte-set! new idx (byte-ref bytes (+ start idx)))))
 
 ;;@body
 ;;Reverses the order of byte-array @1.
@@ -119,7 +153,8 @@
 ;;be omitted, in which case it defaults to the value returned by
 ;;@code{current-output-port}.
 ;;@findex current-output-port
-(define (write-byte byt . opt) (apply write-char (integer->char byt) opt))
+(define (write-byte byt . opt)
+  (apply write-char (integer->char byt) opt))
 
 ;;@args port
 ;;@args
@@ -151,7 +186,7 @@
 ;;@code{(abs @var{n})} bytes read from @2.  If @1 is positive, then
 ;;the first byte read is stored at index 0; otherwise the last byte
 ;;read is stored at index 0.  Note that the length of the returned
-;;string will be less than @code{(abs @var{n})} if @2 reaches
+;;byte-array will be less than @code{(abs @var{n})} if @2 reaches
 ;;end-of-file.
 ;;
 ;;@2 may be omitted, in which case it defaults to the value returned
@@ -165,8 +200,8 @@
     (if (= cnt len)
 	byts
 	(if (positive? n)
-	    (substring byts 0 cnt)
-	    (substring byts (- len cnt) len)))))
+	    (subbytes byts 0 cnt)
+	    (subbytes byts (- len cnt) len)))))
 
 ;;@args bytes n port
 ;;@args bytes n
@@ -188,15 +223,15 @@
 ;;relative size of @var{start} and @var{end} determines the order of
 ;;writing.
 
-;;@args string start end port
-;;@args string start end
+;;@args bts start end port
+;;@args bts start end
 ;;Fills @1 with up to @code{(abs (- @var{start} @var{end}))} bytes
 ;;read from @4.  The first byte read is stored at index @1.
 ;;@0 returns the number of bytes read.
 ;;
 ;;@4 may be omitted, in which case it defaults to the value returned
 ;;by @code{current-input-port}.
-(define (subbytes-read! string start end . port)
+(define (subbytes-read! bts start end . port)
   (if (>= end start)
       (do ((idx start (+ 1 idx)))
 	  ((>= idx end) idx)
@@ -204,7 +239,7 @@
 	  (cond ((eof-object? byt)
 		 (set! idx (+ -1 idx))
 		 (set! end idx))
-		(else (byte-set! string idx byt)))))
+		(else (byte-set! bts idx byt)))))
       (do ((idx (+ -1 start) (+ -1 idx))
 	   (cnt 0 (+ 1 cnt)))
 	  ((< idx end) cnt)
@@ -212,25 +247,21 @@
 	  (cond ((eof-object? byt)
 		 (set! idx start)
 		 (set! cnt (+ -1 cnt)))
-		(else (byte-set! string idx byt)))))))
+		(else (byte-set! bts idx byt)))))))
 
-;;@args string start end port
-;;@args string start end
+;;@args bts start end port
+;;@args bts start end
 ;;@0 writes @code{(abs (- @var{start} @var{end}))} bytes to
 ;;output-port @4.  The first byte written is index @2 of @1.  @0
 ;;returns the number of bytes written.
 ;;
 ;;@4 may be omitted, in which case it defaults to the value returned
 ;;by @code{current-output-port}.
-(define (subbytes-write string start end . port)
+(define (subbytes-write bts start end . port)
   (if (>= end start)
       (do ((idx start (+ 1 idx)))
 	  ((>= idx end) (- end start))
-	(apply write-byte (byte-ref string idx) port))
+	(apply write-byte (byte-ref bts idx) port))
       (do ((idx (+ -1 start) (+ -1 idx)))
 	  ((< idx end) (- start end))
-	(apply write-byte (byte-ref string idx) port))))
-
-;;;; Legacy names.
-(define substring-read! subbytes-read!)
-(define substring-write subbytes-write)
+	(apply write-byte (byte-ref bts idx) port))))
-- 
cgit v1.2.3