Projects : gbw-signer : gbw-signer_static_bit_ops_reindent
| 1 | (lambda () |
| 2 | |
| 3 | (define (repeat obj count) |
| 4 | (if (fx<= count 0) '() |
| 5 | (cons obj (repeat obj (fx-/wrap count 1))))) |
| 6 | |
| 7 | (define (fold f init l) |
| 8 | (do ((l l (cdr l)) |
| 9 | (acc init (f acc (car l)))) |
| 10 | ((null? l) acc))) |
| 11 | |
| 12 | (define (reverse-map1 f l) |
| 13 | (do ((l l (cdr l)) |
| 14 | (acc '() (cons (f (car l)) acc))) |
| 15 | ((null? l) acc))) |
| 16 | |
| 17 | (define (assert err-msg proc . args) |
| 18 | (if (not (apply proc args)) (error err-msg args))) |
| 19 | |
| 20 | ;; A fixed width integer (fz) is represented as a list of fixnum words, least significant first. The width in bits is given by positive fixnum FZ-WIDTH. When it's not a multiple of the system's fixnum width, the high end of the high word is zero-padded. |
| 21 | ;; |
| 22 | ;; This representation is considered an implementation detail. It is an error to pass an object as FZ argument to any of these operators that is not EQUAL? to an FZ object as returned by one of the operators of the same FZ-WIDTH. It is also an error to mutate the contents of any returned FZ object. |
| 23 | (define (fz-ops fz-width) |
| 24 | |
| 25 | ;; Number of fixnum words in an FZ (list length) |
| 26 | (define word-count (quotient (+ fz-width *fixnum-width* -1) |
| 27 | *fixnum-width*)) |
| 28 | |
| 29 | ;; Number of padding bits |
| 30 | (define padding (- *fixnum-width* 1 (modulo (- fz-width 1) |
| 31 | *fixnum-width*))) |
| 32 | ;; Invariants (checked below at end of definitions): |
| 33 | ;; (+ fz-width padding) = (* word-count *fixnum-width*) |
| 34 | ;; 0 <= padding < *fixnum-width* |
| 35 | |
| 36 | ;; Mask covering non-pad bits of a word |
| 37 | (define padding-neg-mask (delay (- (expt 2 (- *fixnum-width* padding)) 1))) |
| 38 | |
| 39 | ;; "Press": construct FZ from reverse-accumulated words, zeroing the pad bits |
| 40 | (define (press-fz rev-words) |
| 41 | (reverse (cons (fxand padding-neg-mask (car rev-words)) |
| 42 | (cdr rev-words)))) |
| 43 | |
| 44 | (define (fz0) |
| 45 | (repeat 0 word-count)) |
| 46 | |
| 47 | (define (word->ufz w) |
| 48 | (cons w (repeat 0 (fx-/wrap word-count 1)))) |
| 49 | |
| 50 | (define (ufz+/pair a b) |
| 51 | (let loop ((a a) (b b) (carry 0) (acc '())) |
| 52 | (if (null? a) (press-fz acc) |
| 53 | (call-with-values |
| 54 | (lambda () (fx+/carry-unsigned (car a) (car b) carry)) |
| 55 | (lambda (sum carry) |
| 56 | (loop (cdr a) (cdr b) carry (cons sum acc))))))) |
| 57 | |
| 58 | ;; !! UNTESTED !! |
| 59 | ;(define (ufz-/pair a b) |
| 60 | ; (let loop ((a a) (b b) (carry 0) (acc '())) |
| 61 | ; (if (null? a) (press-fz acc) |
| 62 | ; (call-with-values |
| 63 | ; (lambda () (fx-/borrow-unsigned (car a) (car b) carry)) |
| 64 | ; (lambda (diff carry) |
| 65 | ; (loop (cdr a) (cdr b) carry (cons diff acc))))))) |
| 66 | |
| 67 | (define (ufz+ a . args) (fold ufz+/pair a args)) |
| 68 | |
| 69 | ;; Positive (left) shift: signedness doesn't matter. |
| 70 | ;; Assumes 0 <= bits < fz-width . |
| 71 | (define (shift-up-by bits) |
| 72 | ;; XXX slow - maybe provide a simultaneous fixnum quotient/remainder , or precompute a lookup table (0 to (- fz-width 1)) ? |
| 73 | (let ((whole-words (quotient bits *fixnum-width*)) |
| 74 | (bits (remainder bits *fixnum-width*))) |
| 75 | ;; 0 <= whole-words < word-count |
| 76 | ;; 0 <= bits < *fixnum-width* |
| 77 | (let ((carry-shift (fx-/wrap bits *fixnum-width*))) |
| 78 | ;; (-)*fixnum-width* <= carry-shift < 0 |
| 79 | (lambda (a) |
| 80 | (do ((words a (cdr words)) |
| 81 | (carry 0 (fxshift/unsigned (car words) carry-shift)) |
| 82 | (acc (repeat 0 whole-words) |
| 83 | (cons (fxior (fxshift (car words) bits) carry) acc)) |
| 84 | (todo (fx-/wrap word-count whole-words) (fx-/wrap todo 1))) |
| 85 | ;; 0 <= todo <= word-count |
| 86 | ((fx= 0 todo) (press-fz acc))))))) |
| 87 | |
| 88 | ;; Negative (right) shift without sign extension. |
| 89 | ;; Assumes 0 <= bits < fz-width . |
| 90 | (define (shift-down-by/unsigned bits) |
| 91 | ; XXX slow - as above |
| 92 | (let ((whole-words (quotient bits *fixnum-width*)) |
| 93 | (bits (fx-/wrap (remainder bits *fixnum-width*)))) |
| 94 | ;; 0 <= whole-words < word-count |
| 95 | ;; (-)*fixnum-width* < bits <= 0 |
| 96 | (let ((carry-shift (fx+/wrap bits *fixnum-width*))) |
| 97 | ;; 0 < carry-shift <= *fixnum-width* |
| 98 | (lambda (a) |
| 99 | (do ((words (reverse (list-tail a whole-words)) (cdr words)) |
| 100 | (carry 0 (fxshift (car words) carry-shift)) |
| 101 | (acc (repeat 0 whole-words) |
| 102 | (cons (fxior (fxshift/unsigned (car words) bits) carry) |
| 103 | acc))) |
| 104 | ((null? words) acc)))))) |
| 105 | |
| 106 | ;; Front-end for unsigned shifts. |
| 107 | ;; Constant time w.r.t. FZ value only (NOT bits). |
| 108 | (define (ufzshift-by bits) |
| 109 | (cond ((zero? bits) (lambda (a) a)) |
| 110 | ((>= (abs bits) fz-width) (lambda (a) (fz0))) |
| 111 | ((fx< 0 bits) (shift-up-by bits)) |
| 112 | (else (shift-down-by/unsigned (fx-/wrap bits))))) |
| 113 | |
| 114 | ;; Bit rotation: signedness doesn't matter. |
| 115 | ;; Rotates to the "left" i.e. more-significant. |
| 116 | ;; Requires 0 <= bits < fz-width . |
| 117 | ;; Constant time w.r.t. FZ value only (NOT bits). |
| 118 | (define (fzrot a bits) |
| 119 | (cond ((fx<=/unsigned fz-width bits) ; also catches negatives |
| 120 | (error "fzrot: bits out of range:" bits)) |
| 121 | ((fx= 0 bits) a) |
| 122 | ;; 0 < bits < fz-width |
| 123 | ;; XXX slow due to separate shifts |
| 124 | (else (fzior ((shift-up-by bits) a) |
| 125 | ((shift-down-by/unsigned (fx-/wrap fz-width bits)) |
| 126 | a))))) |
| 127 | |
| 128 | ;; Curried variant allowing arbitrary integer rotations, pre-reduced. Faster than fzrot if you can reuse the returned procedure for a set shift amount. |
| 129 | (define (fzrot-by bits) |
| 130 | (let ((reduced (modulo bits fz-width))) |
| 131 | (if (fx= 0 reduced) |
| 132 | (lambda (a) a) |
| 133 | ;; 0 < reduced < fz-width |
| 134 | ;; XXX slow due to separate shifts |
| 135 | (let ((shift-up (shift-up-by reduced)) |
| 136 | (shift-down (shift-down-by/unsigned |
| 137 | (fx-/wrap fz-width reduced)))) |
| 138 | (lambda (a) |
| 139 | (fzior (shift-up a) |
| 140 | (shift-down a))))))) |
| 141 | |
| 142 | (define (fznot a) |
| 143 | (press-fz (reverse-map1 fxnot a))) |
| 144 | |
| 145 | ;; Functions that preserve the zero-padding can use 'map' directly. |
| 146 | (define (fzand . args) (apply map fxand args)) |
| 147 | (define (fzior . args) (apply map fxior args)) |
| 148 | (define (fzxor . args) (apply map fxxor args)) |
| 149 | (define (fzif a b c) (map fxif a b c)) |
| 150 | (define (fzmaj a b c) (map fxmaj a b c)) |
| 151 | |
| 152 | ;;; FZ to octet string I/O, big and little endian. |
| 153 | ;;; Complicated due to non-aligned fixnum width, but linear time. |
| 154 | |
| 155 | ;; Construct (* 8 (string-length BUF)) bit wide FZ from the octets in BUF. |
| 156 | (define (bytes->fz buf big-endian) |
| 157 | (define nbytes (string-length buf)) |
| 158 | (define get-char (if big-endian |
| 159 | (lambda (k) (string-ref buf (fx-/wrap nbytes 1 k))) |
| 160 | (lambda (k) (string-ref buf k)))) |
| 161 | (define (loop bit-pos k word acc) |
| 162 | ;; 0 <= bit-pos <= *fixnum-width* |
| 163 | ;; XXX seems sloppy that the upper bound is inclusive, as this allows degenerate shifts |
| 164 | (if (fx= k nbytes) (reverse (cons word acc)) |
| 165 | ;; 0 <= k < nbytes |
| 166 | (let ((byte (char->integer (get-char k)))) |
| 167 | (let ((bit-pos (fx+/wrap bit-pos 8)) |
| 168 | (word (fxior word (fxshift byte bit-pos)))) |
| 169 | ;; 8 <= bit-pos <= (+ *fixnum-width* 8) |
| 170 | (if (fx<=/unsigned bit-pos *fixnum-width*) |
| 171 | ;; whole byte fits in current word |
| 172 | (loop bit-pos (fx+/wrap k 1) word acc) |
| 173 | ;; else spill to next word |
| 174 | ;; bit-pos > *fixnum-width* |
| 175 | (let ((carry-bits (fx-/wrap bit-pos *fixnum-width*))) |
| 176 | ;; 0 < carry-bits <= 8 |
| 177 | (loop carry-bits (fx+/wrap k 1) |
| 178 | (fxshift/unsigned byte (fx-/wrap carry-bits 8)) |
| 179 | (cons word acc)))))))) |
| 180 | (if (not (fx= (fxshift nbytes 3) fz-width)) |
| 181 | (error "bytes->fz: word size doesn't match string bit length:" |
| 182 | (list (fxshift nbytes 3) fz-width))) |
| 183 | (loop 0 0 0 '())) |
| 184 | |
| 185 | ;; Construct octet string from a multiple-of-8 bit wide FZ. |
| 186 | (define (fz->bytes a big-endian) |
| 187 | (define nbytes (fxshift fz-width -3)) |
| 188 | (define buf (delay (make-string nbytes))) |
| 189 | (define set-byte! |
| 190 | (if big-endian |
| 191 | (lambda (k b) |
| 192 | (string-set! buf (fx-/wrap nbytes 1 k) |
| 193 | (integer->char (fxand b 255)))) |
| 194 | (lambda (k b) |
| 195 | (string-set! buf k (integer->char (fxand b 255)))))) |
| 196 | (define (loop bit-pos k word words) |
| 197 | ;; 0 <= bit-pos <= *fixnum-width* |
| 198 | ;; XXX upper bound seems sloppy (as above) |
| 199 | (if (fx= k nbytes) buf |
| 200 | ;; 0 <= k < nbytes |
| 201 | (let ((byte (fxshift/unsigned word (fx-/wrap bit-pos))) |
| 202 | ;; ^ not pre-masked |
| 203 | (bit-pos (fx+/wrap bit-pos 8))) |
| 204 | ;; 8 <= bit-pos <= (+ 8 *fixnum-width*) |
| 205 | (if (fx<=/unsigned bit-pos *fixnum-width*) |
| 206 | ;; whole byte contained in current word |
| 207 | (begin (set-byte! k byte) |
| 208 | (loop bit-pos (fx+/wrap k 1) word words)) |
| 209 | ;; else fill in from next word |
| 210 | ;; bit-pos > *fixnum-width* |
| 211 | (let ((word (car words)) |
| 212 | (peek-bits (fx-/wrap bit-pos *fixnum-width*))) |
| 213 | ;; 0 < peek-bits <= 8 |
| 214 | (set-byte! k (fxior byte |
| 215 | (fxshift word (fx-/wrap 8 peek-bits)))) |
| 216 | (loop peek-bits (fx+/wrap k 1) word (cdr words))))))) |
| 217 | (if (fx</unsigned 0 (fxand fz-width 7)) |
| 218 | (error "fz->bytes: width not divisible by 8:" fz-width)) |
| 219 | (set! buf (force buf)) |
| 220 | (loop 0 0 (car a) (cdr a))) |
| 221 | |
| 222 | ;; Shortcuts, favoring big-endianism as the conventional digit order in writing and in the intrabyte order of hex encoding. |
| 223 | (define (hex->fz a) (bytes->fz (hex->bytes a) #t)) |
| 224 | (define (fz->hex a) (bytes->hex (fz->bytes a #t))) |
| 225 | |
| 226 | (set! padding-neg-mask (force padding-neg-mask)) |
| 227 | (assert "invalid fz-width" |
| 228 | fx< 0 fz-width) |
| 229 | (assert "width + padding != total word bits" |
| 230 | = (+ fz-width padding) (* word-count *fixnum-width*)) |
| 231 | (assert "padding lower bound" |
| 232 | <= 0 padding) |
| 233 | (assert "padding upper bound" |
| 234 | < padding *fixnum-width*) |
| 235 | |
| 236 | (export fz0 word->ufz |
| 237 | ufz+ |
| 238 | ufzshift-by fzrot fzrot-by |
| 239 | fznot fzand fzior fzxor fzif fzmaj |
| 240 | bytes->fz fz->bytes hex->fz fz->hex)) |
| 241 | ;; end of fz-ops |
| 242 | |
| 243 | ;;; Constant time word comparison predicates, returning 0 or 1 |
| 244 | |
| 245 | (define (uword<? a b) |
| 246 | (call-with-values (lambda () (fx-/borrow-unsigned a b)) |
| 247 | (lambda (diff carry) carry))) |
| 248 | |
| 249 | ;; Constant time mux returning: |
| 250 | ;; a | select=0 |
| 251 | ;; b | select=1 |
| 252 | (define (word-mux select a b) |
| 253 | (fxif (fx-/wrap select) b a)) |
| 254 | |
| 255 | ;;; Constant time hex conversion (with respect to valid, fixed size input) |
| 256 | |
| 257 | (define num-lo (- (char->integer #\0) 1)) |
| 258 | (define num-hi (+ (char->integer #\9) 1)) |
| 259 | (define num-0 (char->integer #\0)) |
| 260 | (define uc-lo (- (char->integer #\A) 1)) |
| 261 | (define uc-hi (+ (char->integer #\F) 1)) |
| 262 | (define lc-lo (- (char->integer #\a) 1)) |
| 263 | (define lc-hi (+ (char->integer #\f) 1)) |
| 264 | (define uc-a-10 (- (char->integer #\A) 10)) |
| 265 | (define lc-a-10 (- (char->integer #\a) 10)) |
| 266 | |
| 267 | (define (hexdigit->integer d) |
| 268 | (let ((i (char->integer d))) |
| 269 | (let ((num (fxand (uword<? num-lo i) (uword<? i num-hi))) |
| 270 | (uc (fxand (uword<? uc-lo i) (uword<? i uc-hi))) |
| 271 | (lc (fxand (uword<? lc-lo i) (uword<? i lc-hi)))) |
| 272 | (if (zero? (fxior num uc lc)) (error "bad hex digit:" d)) |
| 273 | (fxior (fxand (fx-/wrap num) (fx-/wrap i num-0)) |
| 274 | (fxand (fx-/wrap uc) (fx-/wrap i uc-a-10)) |
| 275 | (fxand (fx-/wrap lc) (fx-/wrap i lc-a-10)))))) |
| 276 | |
| 277 | ;; Assumes valid input (0-16) |
| 278 | (define (integer->hexdigit i) |
| 279 | (integer->char (fx+/wrap i (word-mux (uword<? i 10) lc-a-10 num-0)))) |
| 280 | |
| 281 | (define (hex->bytes h) |
| 282 | (let* ((len (quotient (+ (string-length h) 1) 2)) |
| 283 | (bytes (make-string len))) |
| 284 | (define (loop i j) |
| 285 | (if (fx= i len) bytes |
| 286 | (let ((hi (string-ref h j)) |
| 287 | (lo (string-ref h (fx+/wrap j 1)))) |
| 288 | (string-set! bytes i |
| 289 | (integer->char |
| 290 | (fxior (fxshift (hexdigit->integer hi) 4) |
| 291 | (hexdigit->integer lo)))) |
| 292 | (loop (fx+/wrap i 1) (fx+/wrap j 2))))) |
| 293 | (if (even? (string-length h)) (loop 0 0) |
| 294 | (begin (string-set! bytes 0 (integer->char (hexdigit->integer |
| 295 | (string-ref h 0)))) |
| 296 | (loop 1 1))))) |
| 297 | |
| 298 | (define (bytes->hex b) |
| 299 | (let* ((len (string-length b)) |
| 300 | (h (make-string (* 2 len)))) |
| 301 | (do ((i 0 (fx+/wrap i 1)) |
| 302 | (j 0 (fx+/wrap j 2))) ((fx= i len) h) |
| 303 | (let ((byte (char->integer (string-ref b i)))) |
| 304 | (string-set! h j (integer->hexdigit (fxshift/unsigned byte -4))) |
| 305 | (string-set! h (fx+/wrap j 1) |
| 306 | (integer->hexdigit (fxand byte 15))))))) |
| 307 | |
| 308 | (export fz-ops hexdigit->integer hex->bytes bytes->hex)) |