New function: buf-fash.

* buf.c (buf_fash): New function.
(buf_init): buf-fash intrinsic registered.

* buf.h (buf_fash): Declared.

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

* txr.1: Documented.

4 files changed, 193 insertions, 0 deletions

diff --git a/buf.c b/buf.c
index 3c88ea16..7332d5ad 100644
--- a/buf.c
+++ b/buf.c
@@ -1467,6 +1467,68 @@ val buf_ash(val buf, val bits)
   }
 }
 
+val buf_fash(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 || len == 0) {
+    return buf;
+  } else if (b > 0) {
+    ucnum bytes = b / 8;
+
+    if (bytes >= len) {
+      return make_buf(bh->len, zero, bh->len);
+    } else {
+      ucnum r = b % 8;
+      unsigned acc = 0;
+      val nbuf = make_ubuf(len);
+      struct buf *nbh = buf_handle(nbuf, self);
+      ucnum i;
+
+      memset(nbh->data + len - bytes, 0, bytes);
+
+      if (r == 0) {
+        memcpy(nbh->data, bh->data + bytes, len - bytes);
+      } else for (i = len - bytes - 1; i != convert(ucnum, -1); --i) {
+        unsigned by = bh->data[i + bytes] << r;
+        nbh->data[i] = by | acc;
+        acc = by >> 8;
+      }
+
+      return nbuf;
+    }
+  } else {
+    ucnum bytes = (-b) / 8;
+
+    if (bytes >= len) {
+      return make_buf(bh->len, zero, bh->len);
+    } else {
+      ucnum r = (-b) % 8;
+      unsigned acc = 0;
+      val nbuf = make_ubuf(len);
+      struct buf *nbh = buf_handle(nbuf, self);
+      ucnum i;
+
+      memset(nbh->data, 0, bytes);
+
+      if (r == 0) {
+        memcpy(nbh->data + bytes, bh->data, len - bytes);
+      } else for (i = 0; i < len - bytes; i++) {
+        unsigned by = bh->data[i];
+        nbh->data[i + bytes] = (by | acc) >> r;
+        acc = by << 8;
+      }
+
+      return nbuf;
+    }
+  }
+
+  abort();
+}
+
 void buf_init(void)
 {
   reg_fun(intern(lit("make-buf"), user_package), func_n3o(make_buf, 1));
@@ -1561,6 +1623,7 @@ void buf_init(void)
 #endif
 
   reg_fun(intern(lit("buf-ash"), user_package), func_n2(buf_ash));
+  reg_fun(intern(lit("buf-fash"), user_package), func_n2(buf_fash));
 
   fill_stream_ops(&buf_strm_ops);
 }
diff --git a/buf.h b/buf.h
index ae62d704..366706f2 100644
--- a/buf.h
+++ b/buf.h
@@ -125,5 +125,6 @@ val get_buf_from_stream(val stream);
 void buf_swap32(val buf);
 
 val buf_ash(val buf, val bits);
+val buf_fash(val buf, val bits);
 
 void buf_init(void);
diff --git a/tests/012/buf.tl b/tests/012/buf.tl
index e5a96f13..4311e760 100644
--- a/tests/012/buf.tl
+++ b/tests/012/buf.tl
@@ -141,3 +141,66 @@
   (buf-ash #b'8181' 14) #b'20604000'
   (buf-ash #b'8181' 15) #b'40c08000'
   (buf-ash #b'8181' 16) #b'81810000')
+
+(mtest
+  (buf-fash #b'' 0) #b''
+  (buf-fash #b'' 1) #b''
+  (buf-fash #b'' 7) #b''
+  (buf-fash #b'' 8) #b''
+  (buf-fash #b'' 15) #b''
+  (buf-fash #b'' 16) #b'')
+
+(mtest
+  (buf-fash #b'' -1) #b''
+  (buf-fash #b'' -7) #b''
+  (buf-fash #b'' -8) #b''
+  (buf-fash #b'' -15) #b''
+  (buf-fash #b'' -16) #b'')
+
+(mtest
+  (buf-fash #b'81' 0) #b'81'
+  (buf-fash #b'81' 1) #b'02'
+  (buf-fash #b'81' 2) #b'04'
+  (buf-fash #b'81' 3) #b'08'
+  (buf-fash #b'81' 4) #b'10'
+  (buf-fash #b'81' 5) #b'20'
+  (buf-fash #b'81' 6) #b'40'
+  (buf-fash #b'81' 7) #b'80'
+  (buf-fash #b'81' 8) #b'00'
+  (buf-fash #b'81' 9) #b'00'
+  (buf-fash #b'81' 15) #b'00'
+  (buf-fash #b'81' 1000) #b'00')
+
+(mtest
+  (buf-fash #b'81' -1) #b'40'
+  (buf-fash #b'81' -2) #b'20'
+  (buf-fash #b'81' -3) #b'10'
+  (buf-fash #b'81' -4) #b'08'
+  (buf-fash #b'81' -5) #b'04'
+  (buf-fash #b'81' -6) #b'02'
+  (buf-fash #b'81' -7) #b'01'
+  (buf-fash #b'81' -8) #b'00'
+  (buf-fash #b'81' -9) #b'00'
+  (buf-fash #b'81' -15) #b'00'
+  (buf-fash #b'81' -1000) #b'00')
+
+(mtest
+  (buf-fash #b'8811' 0) #b'8811'
+  (buf-fash #b'8811' 4) #b'8110'
+  (buf-fash #b'8811' 8) #b'1100'
+  (buf-fash #b'8811' 12) #b'1000'
+  (buf-fash #b'8811' 15) #b'8000'
+  (buf-fash #b'8811' 16) #b'0000'
+  (buf-fash #b'8811' 1000) #b'0000')
+
+(mtest
+  (buf-fash #b'8811' -4) #b'0881'
+  (buf-fash #b'8811' -8) #b'0088'
+  (buf-fash #b'8811' -12) #b'0008'
+  (buf-fash #b'8811' -15) #b'0001'
+  (buf-fash #b'8811' -16) #b'0000'
+  (buf-fash #b'8811' -1000) #b'0000')
+
+(mtest
+  (buf-fash #b'deadcafef00d' 4) #b'eadcafef00d0'
+  (buf-fash #b'deadcafef00d' -4) #b'0deadcafef00')
diff --git a/txr.1 b/txr.1
index 7fb0eaff..62514296 100644
--- a/txr.1
+++ b/txr.1
@@ -30109,6 +30109,13 @@ The
 performs a bit shifting operation on
 .metn buf ,
 whose result is returned as a buffer object.
+
+Note: the related function
+.code buf-fash
+also provides a bit shift operation for buffers,
+with semantics usefully different from
+.codn buf-ash .
+
 The
 .meta buf
 argument is unaffected. If the return value is
@@ -30207,6 +30214,65 @@ can only be relied up on to reproduce
 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 Function @ buf-fash
+.synb
+.mets (buf-fash < buf << bits )
+.syne
+.desc
+The
+.code buf-fash
+performs a bit shifting operation on
+.metn buf ,
+whose result is returned as a buffer object.
+
+Note: the related function
+.code buf-ash
+also provides a bit shift operation for buffers,
+with semantics usefully different from
+.codn buf-ash .
+
+The
+.meta buf
+argument is unaffected. If the return value is
+a buffer identical to
+.metn buf ,
+then
+.meta buf
+itself may be returned, rather than a new object.
+
+The
+.code buf-fash
+operation returns a buffer of the same length as
+.metn buf ,
+but whose content is possibly bit shifted.
+
+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. Zero indicates the absence of
+a shift operation.
+
+Bits shifted out of
+.meta buf
+are discarded. Bits shifted in are zero. For instance, shifting
+.code #b'cafe'
+left by 4 bits results in
+.codn #b'afe0' ,
+and shifting it right by 4 bits produces
+.codn #b'0caf' .
+
+Shifting
+.meta buf
+by a number of bits greater than or equal
+to the number of bits in the buffer (its length multiplied by 8)
+is permitted and produces a buffer of all zero bytes whose
+length is equal to that of
+.metn buf .
+
+Shifting an empty buffer by any number of bits results in
+an empty buffer.
+
 .coNP Functions @ buf-compress and @ buf-decompress
 .synb
 .mets (buf-compress < buf <> [ level ])