New function; buf-ash.

* buf.c (err_oflow): New static function.
(buf_compress): Use err_oflow.
(buf_ash): New function.
(buf_init): Register buf-ash intrinsic.

* buf.h (buf_ash): Declared.

* tests/012/buf.tl: New tests.

* txr.1: Documented.

4 files changed, 296 insertions, 1 deletions

diff --git a/buf.c b/buf.c
index 8a51959a..3c88ea16 100644
--- a/buf.c
+++ b/buf.c
@@ -79,6 +79,11 @@ static cnum buf_check_index(struct buf *b, val index, val self)
   return ix;
 }
 
+static void err_oflow(val self)
+{
+  uw_throwf(error_s, lit("~a: array size overflow"), self, nao);
+}
+
 val make_buf(val len, val init_val, val alloc_size)
 {
   val self = lit("make-buf");
@@ -142,6 +147,15 @@ val make_owned_buf(val len, mem_t *data)
   return buf;
 }
 
+static val make_ubuf(ucnum clen)
+{
+  mem_t *data = chk_malloc(clen);
+  val len = unum(clen);
+  val buf = make_borrowed_buf(len, data);
+  buf->b.size = len;
+  return buf;
+}
+
 static struct buf *buf_handle(val buf, val ctx)
 {
   if (type(buf) == BUF)
@@ -1325,7 +1339,7 @@ static val buf_compress(val buf, val level_opt)
 
   if (convert(uLong, size) != size) {
     free(zdata);
-    uw_throwf(error_s, lit("~a: array size overflow"), self, nao);
+    err_oflow(self);
   }
 
   if (compress2(zdata, &zsize, b->data, size, lev) != Z_OK) {
@@ -1374,6 +1388,85 @@ static val buf_decompress(val buf)
 
 #endif
 
+val buf_ash(val buf, val bits)
+{
+  val self = lit("buf-ash");
+  cnum b = c_num(bits, self);
+  struct buf *bh = buf_handle(buf, self);
+  ucnum len = c_unum(bh->len, self);
+
+  if (b == 0) {
+    return buf;
+  } else if (b > 0) {
+    ucnum r = b % 8;
+    ucnum bytes = b / 8;
+    ucnum nlen = len + bytes;
+
+    if (nlen < len || nlen >= convert(ucnum, -2))
+      err_oflow(self);
+
+    if (r == 0 || nlen == 0) {
+      val nbuf = copy_buf(buf);
+      buf_set_length(nbuf, unum(nlen), 0);
+      return nbuf;
+    } else {
+      unsigned acc = 0, b0 = len ? bh->data[0] : 0;
+      unsigned c = ((b0 << r) & 0xff00) ? 1 : 0;
+      ucnum cnlen = c + nlen;
+      val nbuf = make_ubuf(cnlen);
+      struct buf *nbh = buf_handle(nbuf, self);
+      ucnum i;
+
+      memset(nbh->data + c + len, 0, bytes);
+
+      for (i = len - 1; i != convert(ucnum, -1); --i) {
+        unsigned by = bh->data[i] << r;
+        nbh->data[i + c] = by | acc;
+        acc = by >> 8;
+      }
+
+      if (c)
+        nbh->data[0] = acc;
+
+      return nbuf;
+    }
+  } else {
+    ucnum r = (-b) % 8;
+    ucnum bytes = (-b) / 8;
+    ucnum nlen = len >= bytes ? len - bytes : 0;
+    unsigned b0 = len ? bh->data[0] : 0;
+    unsigned v = b0 && !(b0 >> r);
+
+    if (r == 0 || nlen == 0) {
+      if (v && nlen) {
+        val nbuf = make_ubuf(nlen - 1);
+        struct buf *nbh = buf_handle(nbuf, self);
+        memcpy(nbh->data, bh->data + 1, nlen - 1);
+        return nbuf;
+      } else {
+        val nbuf = make_ubuf(nlen);
+        struct buf *nbh = buf_handle(nbuf, self);
+        memcpy(nbh->data, bh->data, nlen);
+        return nbuf;
+      }
+    } else {
+      unsigned acc = v ? b0 << 8 : 0;
+      ucnum cnlen = nlen - v;
+      val nbuf = make_ubuf(cnlen);
+      struct buf *nbh = buf_handle(nbuf, self);
+      ucnum i;
+
+      for (i = 0; i < len; i++) {
+        unsigned by = bh->data[i + v];
+        nbh->data[i] = (by | acc) >> r;
+        acc = by << 8;
+      }
+
+      return nbuf;
+    }
+  }
+}
+
 void buf_init(void)
 {
   reg_fun(intern(lit("make-buf"), user_package), func_n3o(make_buf, 1));
@@ -1467,5 +1560,7 @@ void buf_init(void)
   reg_fun(intern(lit("buf-decompress"), user_package), func_n1(buf_decompress));
 #endif
 
+  reg_fun(intern(lit("buf-ash"), user_package), func_n2(buf_ash));
+
   fill_stream_ops(&buf_strm_ops);
 }
diff --git a/buf.h b/buf.h
index dce0fac5..ae62d704 100644
--- a/buf.h
+++ b/buf.h
@@ -124,4 +124,6 @@ val get_buf_from_stream(val stream);
 
 void buf_swap32(val buf);
 
+val buf_ash(val buf, val bits);
+
 void buf_init(void);
diff --git a/tests/012/buf.tl b/tests/012/buf.tl
index 03f3ad30..e5a96f13 100644
--- a/tests/012/buf.tl
+++ b/tests/012/buf.tl
@@ -51,3 +51,93 @@
     #b'00000000'
     (prog1 buf (buf-put-buf buf 12 (make-buf 4 #\xcc)))
     #b'000000000000000000000000cccccccc'))
+
+(mtest
+  (buf-ash #b'' 0) #b''
+  (buf-ash #b'ff' 0) #b'ff'
+  (buf-ash #b'00' 0) #b'00'
+  (buf-ash #b'abab' 0) #b'abab'
+  (buf-ash #b'cdcdcd' 0) #b'cdcdcd'
+  (buf-ash #b'000000' 0) #b'000000')
+
+(mtest
+  (buf-ash #b'' 1) #b''
+  (buf-ash #b'' 8) #b'00'
+  (buf-ash #b'' 9) #b'00'
+  (buf-ash #b'' 16) #b'0000'
+  (buf-ash #b'' 17) #b'0000')
+
+(mtest
+  (buf-ash #b'0000' -1) #b'0000'
+  (buf-ash #b'0000' -8) #b'00'
+  (buf-ash #b'0000' -9) #b'00'
+  (buf-ash #b'0000' -16) #b''
+  (buf-ash #b'0000' -17) #b'')
+
+(mtest
+  (buf-ash #b'0100' -1) #b'80'
+  (buf-ash #b'0100' -8) #b'01'
+  (buf-ash #b'0100' -9) #b''
+  (buf-ash #b'0100' -16) #b''
+  (buf-ash #b'0100' -17) #b'')
+
+(defmacro mtest-ash (:form f . pairs) 
+  (unless (evenp (len pairs))
+    (compile-error f "even number of arguments required"))
+  (let ((xpairs (append-matches (((buf-ash @x @bits) @y) (tuples 2 pairs))
+                  ^((buf-ash ,y ,(- bits)) ,x))))
+    ^(mtest ,*pairs ,*xpairs)))
+
+(mtest-ash
+  (buf-ash #b'01' 1) #b'02'
+  (buf-ash #b'01' 2) #b'04'
+  (buf-ash #b'01' 3) #b'08'
+  (buf-ash #b'01' 4) #b'10'
+  (buf-ash #b'01' 5) #b'20'
+  (buf-ash #b'01' 6) #b'40'
+  (buf-ash #b'01' 7) #b'80'
+  (buf-ash #b'01' 8) #b'0100'
+  (buf-ash #b'01' 9) #b'0200'
+  (buf-ash #b'01' 10) #b'0400'
+  (buf-ash #b'01' 11) #b'0800'
+  (buf-ash #b'01' 12) #b'1000'
+  (buf-ash #b'01' 13) #b'2000'
+  (buf-ash #b'01' 14) #b'4000'
+  (buf-ash #b'01' 15) #b'8000'
+  (buf-ash #b'01' 16) #b'010000')
+
+(mtest-ash
+  (buf-ash #b'81' 1) #b'0102'
+  (buf-ash #b'81' 2) #b'0204'
+  (buf-ash #b'81' 3) #b'0408'
+  (buf-ash #b'81' 4) #b'0810'
+  (buf-ash #b'81' 5) #b'1020'
+  (buf-ash #b'81' 6) #b'2040'
+  (buf-ash #b'81' 7) #b'4080'
+  (buf-ash #b'81' 8) #b'8100'
+  (buf-ash #b'81' 9) #b'010200'
+  (buf-ash #b'81' 10) #b'020400'
+  (buf-ash #b'81' 11) #b'040800'
+  (buf-ash #b'81' 12) #b'081000'
+  (buf-ash #b'81' 13) #b'102000'
+  (buf-ash #b'81' 14) #b'204000'
+  (buf-ash #b'81' 15) #b'408000'
+  (buf-ash #b'81' 16) #b'810000')
+
+(mtest-ash
+  (buf-ash #b'8181' 1) #b'010302'
+  (buf-ash #b'8181' 2) #b'020604'
+  (buf-ash #b'8181' 3) #b'040c08'
+  (buf-ash #b'8181' 4) #b'081810'
+  (buf-ash #b'8181' 5) #b'103020'
+  (buf-ash #b'8181' 6) #b'206040'
+  (buf-ash #b'8181' 7) #b'40c080'
+  (buf-ash #b'8181' 8) #b'818100'
+  (buf-ash #b'8181' 9) #b'01030200'
+  (buf-ash #b'8181' 10) #b'02060400'
+  (buf-ash #b'8181' 11) #b'040c0800'
+  (buf-ash #b'8181' 12) #b'08181000'
+  (buf-ash #b'8181' 13) #b'10302000'
+  (buf-ash #b'8181' 14) #b'20604000'
+  (buf-ash #b'8181' 15) #b'40c08000'
+  (buf-ash #b'8181' 16) #b'81810000')
diff --git a/txr.1 b/txr.1
index 8ec0805b..7fb0eaff 100644
--- a/txr.1
+++ b/txr.1
@@ -30099,6 +30099,114 @@ is of integer type and, in the case of
 .codn buf-uint ,
 nonnegative.
 
+.coNP Function @ buf-ash
+.synb
+.mets (buf-ash < buf << bits )
+.syne
+.desc
+The
+.code buf-ash
+performs a bit shifting operation on
+.metn buf ,
+whose result is returned as a buffer object.
+The
+.meta buf
+argument is unaffected. If the return value is
+a buffer identical to
+.metn buf ,
+then
+.meta buf
+itself may be returned.
+
+The
+.code bits
+argument indicates how many bit positions to shift.
+A positive value shifts left, toward the first byte of the buffer; negative
+shifts right, toward the last byte.
+
+A left shift operation of 8 bits or greater adds null bytes on to the right
+side of the buffer value, in addition to shifting the bits. For instance,
+a left shift by 17 bits may be regarded as a left shift by 1 bit, followed
+by appending two null bytes. Even if the
+.meta buf
+argument is an empty buffer, shifts by at 8 bits or more add null bytes.
+
+A left shift operation adds a new byte on the left side if carry occurs into
+that byte position. Carry means that at least one bit whose value is 1 is
+produced. For instance, if the buffer
+.code #b'41'
+is shifted left by 1 bit, there is no carry; the resulting left-shifted
+buffer is
+.codn #b'82' .
+However if
+.code #b'81'
+is shifted left by one bit, there is carry. The result is
+.codn #b'0102' .
+The left operation does not trim null bytes from the left, however.
+When
+.code #b'0000'
+is shifted left between 1 and 7 bits, the result is
+.codn #b'0000' .
+Furthermore, if it is shifted left 8 to 15 bits, the result is
+.codn #b'000000' .
+Since the leftmost byte is zero, there is never carry, but bytes
+are added on the right for shifts wider than a byte.
+
+The right shift operation is the reverse of a left shift.
+A right shift of 8 bits or more deletes one or more rightmost bytes.
+Moreover, a right shift may
+.I vacate
+the leftmost byte, which refers to non-zero leftmost byte in the input
+value turning into a zero byte. If the shift operation vacates the
+leftmost byte, then that byte is deleted.
+Thus a right shift of
+.code #b'0100ffff'
+by 16 bits results in
+.codn #b'0100' :
+two bytes are removed from the right side. A right shift of
+.code #b'0000ffff'
+by 16 bits results in
+.codn #'b'0000' ,
+still a two-byte value because the leftmost byte of the input
+is already zero and therefore isn't vacated.
+A right shift of
+.code #b'11ff'
+by one bit results in
+.codn #b'087f' .
+No bytes are removed from the right, because the shift is
+narrower than one byte, and no byte is vacated on the
+left. A right shift of
+.codn #b'03cc' .
+by two bits results in
+.codn #b'f3' ,
+because the leftmost byte is vacated.
+
+Note: The rules with regard to the vacated leftmost byte or carry byte mean that
+shifting a buffer by one bit
+.I n
+times, in either direction, does not necessarily produce a buffer identical to
+once by
+.I n
+bits in the same direction. For instance, shifting
+.code #b'00'
+left by 1 bit produces
+.codn #b'00' :
+a fixed point is reached. Whereas left-shifting that same buffer by 32 bits
+produces
+.codn #b'0000000000' .
+Moreover, given a buffer
+.meta b
+and nonnegative
+.metn n ,
+the operation
+.mono
+.meti (buf-ash (buf-ash < b << n ) (- << n ))
+.onom
+can only be relied up on to reproduce
+.meta b
+if it has no leading null bytes. In that situation, any carry byte produced
+by the left shift will be vacated and removed by the opposite right shift.
+
 .coNP Functions @ buf-compress and @ buf-decompress
 .synb
 .mets (buf-compress < buf <> [ level ])