Add BIT, BITS, SHIFTIN, and SHIFTOUT, for handily hacking bit fields.

diff --git a/src/runtime/integer-bits.scm b/src/runtime/integer-bits.scm
index 9596cff642edddc19253ff64ea9c46c73973d101..e2e1ee45b593e3980e989a0e3b31be341c9f1fbb 100644 (file)
--- a/src/runtime/integer-bits.scm
+++ b/src/runtime/integer-bits.scm
@@ -183,3 +183,36 @@ USA.
   (do ((bits bits (cdr bits))
        (integer 0 (bitwise-ior (shift-left integer 1) (if (car bits) 1 0))))
       ((not (pair? bits)) integer)))
+\f
+;;; NetBSD-style bit field operations.  We desperately need some
+;;; constant folding for these...
+;;;
+;;;   (define frotz-field:fidgets (bits 0 4))
+;;;   (define frotz-field:widgets (bits 5 7))
+;;;
+;;;   (define (frotz-fidgets frotz)
+;;;     (shiftout frotz frotz-field:fidgets))
+;;;
+;;;   (define (frotz-widgets frotz)
+;;;     (shiftout frotz frotz-field:widgets))
+;;;
+;;;   (define (make-frotz fidgets widgets)
+;;;     (bitwise-ior (shiftin fidgets frotz-field:fidgets)
+;;;                  (shiftin widgets frotz-field:widgets)))
+
+(define (bit n)
+  (shift-left 1 n))
+
+(define (bits n m)
+  (define (%bits n m)
+    (bit-mask (+ (- n m) 1) n))
+  (if (<= n m)
+      (%bits n m)
+      (%bits m n)))
+
+(define (shiftout x mask)
+  (shift-right (bitwise-and x mask) (first-set-bit mask)))
+
+(define (shiftin x mask)
+  ;; (bitwise-and ... mask)?
+  (shift-left x (first-set-bit mask)))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 86e9258836938f73efe59e98120841b7dd25ce7f..edd60d92271a487d6b882cee4dffa0b2566d52d6 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -336,11 +336,13 @@ USA.
          all-bits-set?
          any-bits-set?
          arithmetic-shift
+         bit
          bit-antimask
          bit-clear?
          bit-count
          bit-mask
          bit-set?
+         bits
          bitwise-merge
          bitwise-not
          clear-bit
@@ -354,6 +356,8 @@ USA.
          set-bit
          shift-left
          shift-right
+         shiftin
+         shiftout
          splice-bit-field
          test-bit-field
          test-bit-field?