(lambda ()

  (define (repeat obj count)
    (if (<= count 0) '()
      (cons obj (repeat obj (- count 1)))))

  (define (fold f init l)
    (do ((l l (cdr l))
         (acc init (f acc (car l))))
      ((null? l) acc)))

  (define (assert err-msg proc . args)
    (if (not (apply proc args)) (error err-msg args)))

  (define fxwidth-1 (- *fixnum-width* 1))

  ;; 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.)
  ;;
  ;; Invariant:
  ;; (= (+ bits (padding bits)) (* (word-count bits) *fixnum-width*))

  (define (word-count bits)
    (quotient (+ bits fxwidth-1) *fixnum-width*))

  (define (padding bits)
    (- fxwidth-1 (modulo (- bits 1) *fixnum-width*)))

  ;; Construct a fixed width integer (FZ)
  (define (make-fz bit-width words)
    (assert "make-fz: bad word count for width"
            = (length words) (word-count bit-width))
    (list bit-width words))

  ;; FZ accessors
  (define fz-width car)
  (define fz-words cadr)
  (define (fz-unpack a consumer) (apply consumer a))

  ;; "Press": construct FZ from reverse-accumulated words, zeroing the pad bits
  (define (press-fz bit-width rev-words)
    (let* ((p (padding bit-width))
           (head (fxshift-unsigned (fxshift (car rev-words) p) (- p))))
      (make-fz bit-width (reverse (cons head (cdr rev-words))))))

  (define (fz0 width)
    (make-fz width (repeat 0 (word-count width))))

  (define (word->ufz width w)
    (make-fz width (cons w (repeat 0 (- (word-count width) 1)))))

  (define (ufz+/pair a b)
    (let ((width (fz-width a)))
      (assert "ufz+: unequal width" = width (fz-width b))
      (let loop ((a (fz-words a)) (b (fz-words b)) (carry 0) (acc '()))
        (if (null? a) (press-fz width acc)
          (call-with-values
            (lambda () (fx+/carry-unsigned (car a) (car b) carry))
            (lambda (sum carry)
              (loop (cdr a) (cdr b) carry (cons sum acc))))))))

  ;; !! UNTESTED !!
  ;(define (ufz-/pair a b)
  ;  (let ((width (fz-width a)))
  ;    (assert "ufz-: unequal width" = width (fz-width b))
  ;    (let loop ((a (fz-words a)) (b (fz-words b)) (carry 0) (acc '()))
  ;      (if (null? a) (press-fz width acc)
  ;        (call-with-values
  ;          (lambda () (fx-/carry-unsigned (car a) (car b) carry))
  ;          (lambda (diff carry)
  ;            (loop (cdr a) (cdr b) carry (cons diff acc))))))))

  (define (ufz+ a . args) (fold ufz+/pair a args))

  ;; Positive (left) shift: signedness doesn't matter.
  ;; Assumes 0 < bits < width.
  ;; Constant time w.r.t. words only (NOT bits).
  (define (shift width words bits)
    (let ((whole-words (quotient bits *fixnum-width*))
          (bits (remainder bits *fixnum-width*)))
      (let ((carry-shift (- bits *fixnum-width*)))
        (do ((words words (cdr words))
             (carry 0 (fxshift-unsigned (car words) carry-shift))
             (acc (repeat 0 whole-words)
                  (cons (fxior (fxshift (car words) bits) carry) acc))
             (todo (- (word-count width) whole-words) (- todo 1)))
          ((zero? todo) (press-fz width acc))))))

  ;; Negative (right) shift without sign extension.
  ;; Assumes 0 < bits < width.
  ;; Constant time w.r.t. words only (NOT bits).
  (define (unshift-unsigned width words bits)
    (let ((whole-words (quotient bits *fixnum-width*))
          (bits (- (remainder bits *fixnum-width*))))
      (let ((carry-shift (+ bits *fixnum-width*)))
        (do ((words (reverse (list-tail words whole-words)) (cdr words))
             (carry 0 (fxshift (car words) carry-shift))
             (acc (repeat 0 whole-words)
                  (cons (fxior (fxshift-unsigned (car words) bits) carry)
                        acc)))
          ((null? words) (make-fz width acc))))))

  ;; Front-end for unsigned shifts.
  ;; Constant time w.r.t. FZ value only (NOT bits).
  (define (ufzshift a bits)
    (fz-unpack
      a (lambda (width words)
          (cond ((zero? bits) a)
                ((>= (abs bits) width) (fz0 width))
                ((positive? bits) (shift width words bits))
                (else (unshift-unsigned width words (- bits)))))))

  ;; Bit rotation: signedness doesn't matter.
  ;; Rotates to the "left" i.e. more-significant, but can take negative bits.
  ;; Constant time w.r.t. FZ value only (NOT bits).
  (define (fzrot a bits)
    (fz-unpack
      a (lambda (width words)
          (let ((bits (modulo bits width)))
            (if (zero? bits) a
              (fzior (shift width words bits)
                     (unshift-unsigned width words (- width bits))))))))

  (define (fznot a)
    (fz-unpack a (lambda (width a) (press-fz width (reverse (map fxnot a))))))

  ;; Build new FZ by mapping func across corresponding words of each input.
  ;; Assumes func preserves zero padding.
  (define (fzmap func a . tail)
    (let ((width (fz-width a)))
      (if (not (apply = width (map fz-width tail)))
        (error "fzmap: unequal widths"))
      (make-fz width (apply map func (fz-words a) (map fz-words tail)))))

  (define (fzand . args) (apply fzmap fxand args))
  (define (fzior . args) (apply fzmap fxior args))
  (define (fzxor . args) (apply fzmap fxxor args))
  (define (fzif a b c) (fzmap fxif a b c))
  (define (fzmaj a b c) (fzmap fxmaj a b c))

  ;;; FZ to octet string I/O, big and little endian.
  ;;; Complicated due to non-aligned fixnum width, but linear time.

  ;; Construct (* 8 (string-length BUF)) bit wide FZ from the octets in BUF.
  (define (bytes->fz buf big-endian)
    (let* ((nbytes (string-length buf))
           (get-char (if big-endian
                       (lambda (k) (string-ref buf (- nbytes 1 k)))
                       (lambda (k) (string-ref buf k)))))
      (let loop ((bit-pos 0) (k 0) (word 0) (words '()))
        (if (= k nbytes) (make-fz (fxshift nbytes 3)
                                  (reverse (cons word words)))
          (let ((byte (char->integer (get-char k))))
            (let ((bit-pos (+ bit-pos 8))
                  (k (+ k 1))
                  (word (fxior word (fxshift byte bit-pos))))
              (if (<= bit-pos *fixnum-width*)
                ;; whole byte fits in current word
                (loop bit-pos k word words)
                ;; else spill to next word
                (let ((carry-bits (- bit-pos *fixnum-width*)))
                  (loop carry-bits k (fxshift-unsigned byte (- carry-bits 8))
                        (cons word words))))))))))

  (define (lsb->char word)
    (integer->char (fxand word 255)))

  ;; Construct octet string from a multiple-of-8 bit wide FZ.
  (define (fz->bytes a big-endian)
    (fz-unpack
      a (lambda (width words)
          (if (not (zero? (fxand width 7)))
            (error "fz->bytes: width not divisible by 8:" width))
          (let* ((nbytes (fxshift width -3))
                 (buf (make-string nbytes))
                 (set-byte!
                   (if big-endian
                     (lambda (k b) (string-set! buf (- nbytes 1 k)
                                                (lsb->char b)))
                     (lambda (k b) (string-set! buf k (lsb->char b))))))
            (let loop ((bit-pos 0) (k 0) (word (car words))
                                   (words (cdr words)))
              (if (= k nbytes) buf
                (let ((byte (fxshift-unsigned word (- bit-pos)))
                      (bit-pos (+ bit-pos 8)))
                  (if (<= bit-pos *fixnum-width*)
                    ;; whole byte contained in current word
                    (begin (set-byte! k byte)
                           (loop bit-pos (+ k 1) word words))
                    ;; else fill in from next word
                    (let ((word (car words))
                          (peek (- bit-pos *fixnum-width*)))
                      (set-byte! k (fxior byte (fxshift word (- 8 peek))))
                      (loop peek (+ k 1) word (cdr words)))))))))))

  ;;; Constant time word comparison predicates, returning 0 or 1

  (define (uword<? a b)
    (call-with-values (lambda () (fx-/carry-unsigned a b))
                      (lambda (diff carry) carry)))

  (define (uword<=? a b)
    (fxxor 1 (uword<? b a)))

  (define (word=? a b)
    (fxand (uword<=? a b) (uword<=? b a)))

  ;; Constant time mux returning:
  ;;   a | select=0
  ;;   b | select=1
  (define (word-mux select a b)
    (fxif (fx-/wrap select) b a))

  ;;; Constant time hex conversion (with respect to valid, fixed size input)

  (define num-lo (- (char->integer #\0) 1))
  (define num-hi (+ (char->integer #\9) 1))
  (define num-0 (char->integer #\0))
  (define uc-lo (- (char->integer #\A) 1))
  (define uc-hi (+ (char->integer #\F) 1))
  (define lc-lo (- (char->integer #\a) 1))
  (define lc-hi (+ (char->integer #\f) 1))
  (define uc-a-10 (- (char->integer #\A) 10))
  (define lc-a-10 (- (char->integer #\a) 10))

  (define (hexdigit->integer d)
    (let ((i (char->integer d)))
      (let ((num (fxand (uword<? num-lo i) (uword<? i num-hi)))
            (uc (fxand (uword<? uc-lo i) (uword<? i uc-hi)))
            (lc (fxand (uword<? lc-lo i) (uword<? i lc-hi))))
        (if (zero? (fxior num uc lc)) (error "bad hex digit:" d))
        (fxior (fxand (fx-/wrap num) (fx-/wrap i num-0))
               (fxand (fx-/wrap uc) (fx-/wrap i uc-a-10))
               (fxand (fx-/wrap lc) (fx-/wrap i lc-a-10))))))

  ;; Assumes valid input (0-16)
  (define (integer->hexdigit i)
    (integer->char (fx+/wrap i (word-mux (uword<? i 10) lc-a-10 num-0))))

  (define (hex->bytes h)
    (let* ((len (quotient (+ (string-length h) 1) 2))
           (bytes (make-string len)))
      (define (loop i j)
        (if (= i len) bytes
          (let ((hi (string-ref h j)) (lo (string-ref h (+ j 1))))
            (string-set! bytes i
                         (integer->char
                           (fxior (fxshift (hexdigit->integer hi) 4)
                                  (hexdigit->integer lo))))
            (loop (+ i 1) (+ j 2)))))
      (if (even? (string-length h)) (loop 0 0)
        (begin (string-set! bytes 0 (integer->char (hexdigit->integer
                                                     (string-ref h 0))))
               (loop 1 1)))))

  (define (bytes->hex b)
    (let* ((len (string-length b))
           (h (make-string (* 2 len))))
      (do ((i 0 (+ i 1))
           (j 0 (+ j 2))) ((= i len) h)
        (let ((byte (char->integer (string-ref b i))))
          (string-set! h j (integer->hexdigit (fxshift-unsigned byte -4)))
          (string-set! h (+ j 1) (integer->hexdigit (fxand byte 15)))))))

  ;; Shortcuts, favoring big-endianism as the conventional digit order in
  ;; writing and in the intrabyte order of hex encoding.
  (define (fz->hex a) (bytes->hex (fz->bytes a #t)))
  (define (hex->fz a) (bytes->fz (hex->bytes a) #t))

  (export fz0 word->ufz ufz+ ufzshift fzrot fznot fzand fzior fzxor fzif
          fzmaj bytes->fz fz->bytes hexdigit->integer hex->bytes bytes->hex
          fz->hex hex->fz))