Projects : gbw-signer : gbw-signer_usrbin
| 1 | (lambda () |
| 2 | |
| 3 | (define (repeat obj count) |
| 4 | (if (<= count 0) '() |
| 5 | (cons obj (repeat obj (- 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 (assert err-msg proc . args) |
| 13 | (if (not (apply proc args)) (error err-msg args))) |
| 14 | |
| 15 | (define fxwidth-1 (- *fixnum-width* 1)) |
| 16 | |
| 17 | ;; A fixed width integer (fz) is represented as a list of fixnum words, least significant first, wrapped in an outer list to track the width in bits. As the desired width might not be a multiple of the system's fixnum width, the low end of the low word is zero padded. (This choice allows the carry output from the high word to work naturally.) |
| 18 | ;; |
| 19 | ;; Invariant: |
| 20 | ;; (= (+ bits (padding bits)) (* (word-count bits) *fixnum-width*)) |
| 21 | |
| 22 | (define (word-count bits) |
| 23 | (quotient (+ bits fxwidth-1) *fixnum-width*)) |
| 24 | |
| 25 | (define (padding bits) |
| 26 | (- fxwidth-1 (modulo (- bits 1) *fixnum-width*))) |
| 27 | |
| 28 | ;; Construct a fixed width integer (FZ) |
| 29 | (define (make-fz bit-width words) |
| 30 | (assert "make-fz: bad word count for width" |
| 31 | = (length words) (word-count bit-width)) |
| 32 | (list bit-width words)) |
| 33 | |
| 34 | ;; FZ accessors |
| 35 | (define fz-width car) |
| 36 | (define fz-words cadr) |
| 37 | (define (fz-unpack a consumer) (apply consumer a)) |
| 38 | |
| 39 | ;; "Press": construct FZ from reverse-accumulated words, zeroing the pad bits |
| 40 | (define (press-fz bit-width rev-words) |
| 41 | (let* ((p (padding bit-width)) |
| 42 | (head (fxshift/unsigned (fxshift (car rev-words) p) (- p)))) |
| 43 | (make-fz bit-width (reverse (cons head (cdr rev-words)))))) |
| 44 | |
| 45 | (define (fz0 width) |
| 46 | (make-fz width (repeat 0 (word-count width)))) |
| 47 | |
| 48 | (define (word->ufz width w) |
| 49 | (make-fz width (cons w (repeat 0 (- (word-count width) 1))))) |
| 50 | |
| 51 | (define (ufz+/pair a b) |
| 52 | (let ((width (fz-width a))) |
| 53 | (assert "ufz+: unequal width" = width (fz-width b)) |
| 54 | (let loop ((a (fz-words a)) (b (fz-words b)) (carry 0) (acc '())) |
| 55 | (if (null? a) (press-fz width acc) |
| 56 | (call-with-values |
| 57 | (lambda () (fx+/carry-unsigned (car a) (car b) carry)) |
| 58 | (lambda (sum carry) |
| 59 | (loop (cdr a) (cdr b) carry (cons sum acc)))))))) |
| 60 | |
| 61 | ;; !! UNTESTED !! |
| 62 | ;(define (ufz-/pair a b) |
| 63 | ; (let ((width (fz-width a))) |
| 64 | ; (assert "ufz-: unequal width" = width (fz-width b)) |
| 65 | ; (let loop ((a (fz-words a)) (b (fz-words b)) (carry 0) (acc '())) |
| 66 | ; (if (null? a) (press-fz width acc) |
| 67 | ; (call-with-values |
| 68 | ; (lambda () (fx-/carry-unsigned (car a) (car b) carry)) |
| 69 | ; (lambda (diff carry) |
| 70 | ; (loop (cdr a) (cdr b) carry (cons diff acc)))))))) |
| 71 | |
| 72 | (define (ufz+ a . args) (fold ufz+/pair a args)) |
| 73 | |
| 74 | ;; Positive (left) shift: signedness doesn't matter. |
| 75 | ;; Assumes 0 < bits < width. |
| 76 | ;; Constant time w.r.t. words only (NOT bits). |
| 77 | (define (shift width words bits) |
| 78 | (let ((whole-words (quotient bits *fixnum-width*)) |
| 79 | (bits (remainder bits *fixnum-width*))) |
| 80 | (let ((carry-shift (- bits *fixnum-width*))) |
| 81 | (do ((words words (cdr words)) |
| 82 | (carry 0 (fxshift/unsigned (car words) carry-shift)) |
| 83 | (acc (repeat 0 whole-words) |
| 84 | (cons (fxior (fxshift (car words) bits) carry) acc)) |
| 85 | (todo (- (word-count width) whole-words) (- todo 1))) |
| 86 | ((zero? todo) (press-fz width acc)))))) |
| 87 | |
| 88 | ;; Negative (right) shift without sign extension. |
| 89 | ;; Assumes 0 < bits < width. |
| 90 | ;; Constant time w.r.t. words only (NOT bits). |
| 91 | (define (unshift-unsigned width words bits) |
| 92 | (let ((whole-words (quotient bits *fixnum-width*)) |
| 93 | (bits (- (remainder bits *fixnum-width*)))) |
| 94 | (let ((carry-shift (+ bits *fixnum-width*))) |
| 95 | (do ((words (reverse (list-tail words whole-words)) (cdr words)) |
| 96 | (carry 0 (fxshift (car words) carry-shift)) |
| 97 | (acc (repeat 0 whole-words) |
| 98 | (cons (fxior (fxshift/unsigned (car words) bits) carry) |
| 99 | acc))) |
| 100 | ((null? words) (make-fz width acc)))))) |
| 101 | |
| 102 | ;; Front-end for unsigned shifts. |
| 103 | ;; Constant time w.r.t. FZ value only (NOT bits). |
| 104 | (define (ufzshift a bits) |
| 105 | (fz-unpack |
| 106 | a (lambda (width words) |
| 107 | (cond ((zero? bits) a) |
| 108 | ((>= (abs bits) width) (fz0 width)) |
| 109 | ((positive? bits) (shift width words bits)) |
| 110 | (else (unshift-unsigned width words (- bits))))))) |
| 111 | |
| 112 | ;; Bit rotation: signedness doesn't matter. |
| 113 | ;; Rotates to the "left" i.e. more-significant, but can take negative bits. |
| 114 | ;; Constant time w.r.t. FZ value only (NOT bits). |
| 115 | (define (fzrot a bits) |
| 116 | (fz-unpack |
| 117 | a (lambda (width words) |
| 118 | (let ((bits (modulo bits width))) |
| 119 | (if (zero? bits) a |
| 120 | (fzior (shift width words bits) |
| 121 | (unshift-unsigned width words (- width bits)))))))) |
| 122 | |
| 123 | (define (fznot a) |
| 124 | (fz-unpack a (lambda (width a) (press-fz width (reverse (map fxnot a)))))) |
| 125 | |
| 126 | ;; Build new FZ by mapping func across corresponding words of each input. |
| 127 | ;; Assumes func preserves zero padding. |
| 128 | (define (fzmap func a . tail) |
| 129 | (let ((width (fz-width a))) |
| 130 | (if (not (apply = width (map fz-width tail))) |
| 131 | (error "fzmap: unequal widths")) |
| 132 | (make-fz width (apply map func (fz-words a) (map fz-words tail))))) |
| 133 | |
| 134 | (define (fzand . args) (apply fzmap fxand args)) |
| 135 | (define (fzior . args) (apply fzmap fxior args)) |
| 136 | (define (fzxor . args) (apply fzmap fxxor args)) |
| 137 | (define (fzif a b c) (fzmap fxif a b c)) |
| 138 | (define (fzmaj a b c) (fzmap fxmaj a b c)) |
| 139 | |
| 140 | ;;; FZ to octet string I/O, big and little endian. |
| 141 | ;;; Complicated due to non-aligned fixnum width, but linear time. |
| 142 | |
| 143 | ;; Construct (* 8 (string-length BUF)) bit wide FZ from the octets in BUF. |
| 144 | (define (bytes->fz buf big-endian) |
| 145 | (let* ((nbytes (string-length buf)) |
| 146 | (get-char (if big-endian |
| 147 | (lambda (k) (string-ref buf (- nbytes 1 k))) |
| 148 | (lambda (k) (string-ref buf k))))) |
| 149 | (let loop ((bit-pos 0) (k 0) (word 0) (words '())) |
| 150 | (if (= k nbytes) (make-fz (fxshift nbytes 3) |
| 151 | (reverse (cons word words))) |
| 152 | (let ((byte (char->integer (get-char k)))) |
| 153 | (let ((bit-pos (+ bit-pos 8)) |
| 154 | (k (+ k 1)) |
| 155 | (word (fxior word (fxshift byte bit-pos)))) |
| 156 | (if (<= bit-pos *fixnum-width*) |
| 157 | ;; whole byte fits in current word |
| 158 | (loop bit-pos k word words) |
| 159 | ;; else spill to next word |
| 160 | (let ((carry-bits (- bit-pos *fixnum-width*))) |
| 161 | (loop carry-bits k (fxshift/unsigned byte (- carry-bits 8)) |
| 162 | (cons word words)))))))))) |
| 163 | |
| 164 | (define (lsb->char word) |
| 165 | (integer->char (fxand word 255))) |
| 166 | |
| 167 | ;; Construct octet string from a multiple-of-8 bit wide FZ. |
| 168 | (define (fz->bytes a big-endian) |
| 169 | (fz-unpack |
| 170 | a (lambda (width words) |
| 171 | (if (not (zero? (fxand width 7))) |
| 172 | (error "fz->bytes: width not divisible by 8:" width)) |
| 173 | (let* ((nbytes (fxshift width -3)) |
| 174 | (buf (make-string nbytes)) |
| 175 | (set-byte! |
| 176 | (if big-endian |
| 177 | (lambda (k b) (string-set! buf (- nbytes 1 k) |
| 178 | (lsb->char b))) |
| 179 | (lambda (k b) (string-set! buf k (lsb->char b)))))) |
| 180 | (let loop ((bit-pos 0) (k 0) (word (car words)) |
| 181 | (words (cdr words))) |
| 182 | (if (= k nbytes) buf |
| 183 | (let ((byte (fxshift/unsigned word (- bit-pos))) |
| 184 | (bit-pos (+ bit-pos 8))) |
| 185 | (if (<= bit-pos *fixnum-width*) |
| 186 | ;; whole byte contained in current word |
| 187 | (begin (set-byte! k byte) |
| 188 | (loop bit-pos (+ k 1) word words)) |
| 189 | ;; else fill in from next word |
| 190 | (let ((word (car words)) |
| 191 | (peek (- bit-pos *fixnum-width*))) |
| 192 | (set-byte! k (fxior byte (fxshift word (- 8 peek)))) |
| 193 | (loop peek (+ k 1) word (cdr words))))))))))) |
| 194 | |
| 195 | ;;; Constant time word comparison predicates, returning 0 or 1 |
| 196 | |
| 197 | (define (uword<? a b) |
| 198 | (call-with-values (lambda () (fx-/borrow-unsigned a b)) |
| 199 | (lambda (diff carry) carry))) |
| 200 | |
| 201 | (define (uword<=? a b) |
| 202 | (fxxor 1 (uword<? b a))) |
| 203 | |
| 204 | (define (word=? a b) |
| 205 | (fxand (uword<=? a b) (uword<=? b a))) |
| 206 | |
| 207 | ;; Constant time mux returning: |
| 208 | ;; a | select=0 |
| 209 | ;; b | select=1 |
| 210 | (define (word-mux select a b) |
| 211 | (fxif (fx-/wrap select) b a)) |
| 212 | |
| 213 | ;;; Constant time hex conversion (with respect to valid, fixed size input) |
| 214 | |
| 215 | (define num-lo (- (char->integer #\0) 1)) |
| 216 | (define num-hi (+ (char->integer #\9) 1)) |
| 217 | (define num-0 (char->integer #\0)) |
| 218 | (define uc-lo (- (char->integer #\A) 1)) |
| 219 | (define uc-hi (+ (char->integer #\F) 1)) |
| 220 | (define lc-lo (- (char->integer #\a) 1)) |
| 221 | (define lc-hi (+ (char->integer #\f) 1)) |
| 222 | (define uc-a-10 (- (char->integer #\A) 10)) |
| 223 | (define lc-a-10 (- (char->integer #\a) 10)) |
| 224 | |
| 225 | (define (hexdigit->integer d) |
| 226 | (let ((i (char->integer d))) |
| 227 | (let ((num (fxand (uword<? num-lo i) (uword<? i num-hi))) |
| 228 | (uc (fxand (uword<? uc-lo i) (uword<? i uc-hi))) |
| 229 | (lc (fxand (uword<? lc-lo i) (uword<? i lc-hi)))) |
| 230 | (if (zero? (fxior num uc lc)) (error "bad hex digit:" d)) |
| 231 | (fxior (fxand (fx-/wrap num) (fx-/wrap i num-0)) |
| 232 | (fxand (fx-/wrap uc) (fx-/wrap i uc-a-10)) |
| 233 | (fxand (fx-/wrap lc) (fx-/wrap i lc-a-10)))))) |
| 234 | |
| 235 | ;; Assumes valid input (0-16) |
| 236 | (define (integer->hexdigit i) |
| 237 | (integer->char (fx+/wrap i (word-mux (uword<? i 10) lc-a-10 num-0)))) |
| 238 | |
| 239 | (define (hex->bytes h) |
| 240 | (let* ((len (quotient (+ (string-length h) 1) 2)) |
| 241 | (bytes (make-string len))) |
| 242 | (define (loop i j) |
| 243 | (if (= i len) bytes |
| 244 | (let ((hi (string-ref h j)) (lo (string-ref h (+ j 1)))) |
| 245 | (string-set! bytes i |
| 246 | (integer->char |
| 247 | (fxior (fxshift (hexdigit->integer hi) 4) |
| 248 | (hexdigit->integer lo)))) |
| 249 | (loop (+ i 1) (+ j 2))))) |
| 250 | (if (even? (string-length h)) (loop 0 0) |
| 251 | (begin (string-set! bytes 0 (integer->char (hexdigit->integer |
| 252 | (string-ref h 0)))) |
| 253 | (loop 1 1))))) |
| 254 | |
| 255 | (define (bytes->hex b) |
| 256 | (let* ((len (string-length b)) |
| 257 | (h (make-string (* 2 len)))) |
| 258 | (do ((i 0 (+ i 1)) |
| 259 | (j 0 (+ j 2))) ((= i len) h) |
| 260 | (let ((byte (char->integer (string-ref b i)))) |
| 261 | (string-set! h j (integer->hexdigit (fxshift/unsigned byte -4))) |
| 262 | (string-set! h (+ j 1) (integer->hexdigit (fxand byte 15))))))) |
| 263 | |
| 264 | ;; Shortcuts, favoring big-endianism as the conventional digit order in writing and in the intrabyte order of hex encoding. |
| 265 | (define (fz->hex a) (bytes->hex (fz->bytes a #t))) |
| 266 | (define (hex->fz a) (bytes->fz (hex->bytes a) #t)) |
| 267 | |
| 268 | (export fz0 word->ufz ufz+ ufzshift fzrot fznot fzand fzior fzxor fzif |
| 269 | fzmaj bytes->fz fz->bytes hexdigit->integer hex->bytes bytes->hex |
| 270 | fz->hex hex->fz)) |