From bb82d1aacebeaed6a5f13993390550e739ca96f4 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Tue, 11 Dec 2012 20:35:13 +0000 Subject: [PATCH] Add BIT, BITS, SHIFTIN, and SHIFTOUT, for handily hacking bit fields. --- src/runtime/integer-bits.scm | 33 +++++++++++++++++++++++++++++++++ src/runtime/runtime.pkg | 4 ++++ 2 files changed, 37 insertions(+) diff --git a/src/runtime/integer-bits.scm b/src/runtime/integer-bits.scm index 9596cff64..e2e1ee45b 100644 --- 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))) + +;;; 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 86e925883..edd60d922 100644 --- 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? -- 2.25.1