(herald bit-field)                                          ; -*- T -*-

;;;;;; Bit field manipulation syntax

;;; Taylor Campbell wrote this code; he places it in the public domain.

;;; Example:
;;;
;;;   (assemble-fixnum (fx 3 foo)
;;;                    (fx 2 #b10)
;;;                    (0 1 0)
;;;                    (fx 5 2 bar)
;;;                    (1 0)
;;;                    (fx 2 baz))
;;;     =>
;;;   (fx-ior (fx-and baz 3)
;;;           (fx-ior (fx-ashl (fx-and (fx-ashr bar 2) 31) 4)
;;;                   (fx-ior (fx-ashl (fx-and foo 7) 12)
;;;                           #b00010010000001000)))

(define-syntax (assemble-fixnum . specs)
  (if (null? specs)                     ; Pathological case, useful for
      0                                 ;   macros expanding to this.
      (receive (literal-mask other-specs)
               (partition-fixnum-assembly specs)
        (if (null? other-specs)
            literal-mask
            (receive (operand more)
                     (if (fx-zero? literal-mask)
                         (return (car other-specs)
                                 (cdr other-specs))
                         (return literal-mask
                                 other-specs))
              (fold (lambda (x y) `(FX-IOR ,x ,y))
                    operand
                    more))))))

(define (partition-fixnum-assembly specs)
  (iterate loop ((specs (reverse specs))
                 (literal-mask 0)
                 (others '())
                 (shift 0))
    (if (null? specs)
        (return literal-mask others)
        (destructure (( ((type . args) . more)
                        specs))
          (case type
            ((fx fixnum)
             (destructure (( (width x . y) args))
               (receive (fx pos)
                        (if (null? y)
                            (return x 0)
                            (return (car y) x))
                 (if (fixnum? fx)
                     (loop more
                           (fx-ior (fx-ashl (fx-and fx (fx-mask width))
                                            shift)
                                   literal-mask)
                           others
                           (fx+ shift width))
                     (loop more
                           literal-mask
                           (let ((part
                                  `(FX-AND ,(if (fx-zero? pos)
                                                fx
                                                `(FX-ASHR ,fx ,pos))
                                           ,(fx-mask width))))
                             `(,(if (fx-zero? shift)
                                    part
                                    `(FX-ASHL ,part ,shift))
                               ,@others))
                           (fx+ shift width))))))

            ((bits 0 1)
             (receive (mask bit-count)
                      (assemble-bits (if (eq? type 'bits)
                                         args
                                         (cons type args)))
               (loop more
                     (fx-ior (fx-ashl mask shift) literal-mask)
                     others
                     (fx+ shift bit-count))))

            ((bool)
             (let ((arg (car args)))
               (if (or (boolean? arg)
                       (and (pair? arg)
                            (eq? (car arg) 'quote)
                            (pair? (cdr arg))
                            (boolean? (cadr arg))))
                   (loop more
                         (if (if (boolean? arg)
                                 arg
                                 (cadr arg))
                             (fx-ior (fx-ashl 1 shift) literal-mask)
                             literal-mask)
                         others
                         (fx+ shift 1))
                   (loop more
                         literal-mask
                         (cons `(IF ,arg
                                    ,(if (fx-zero? shift)
                                         1
                                         `(FX-ASHL 1 ,shift))
                                    0)
                               others)
                         (fx+ shift 1)))))

            (else
             (loop (cons (syntax-error '("illegal ~S specifier~%"
                                         "**    ~S")
                                       'assemble-fixnum
                                       (car specs))
                         more)
                   literal-mask
                   others
                   shift)))))))

(define-integrable (fixnum-mask width)
  (fixnum-lognot (fixnum-ashl -1 width)))

(define-constant fx-mask fixnum-mask)

(define (assemble-bits bits)
  (iterate loop ((bits bits) (mask 0) (count 0))
    (if (null? bits)
        (return mask count)
        (loop (cdr bits)
              (fx-ior (fx-ashl mask 1)
                      ;++ This could be tightened.
                      (fx-and (car bits) 1))
              (fx+ count 1)))))

(define-integrable (fold combiner accum list)
  (iterate loop ((l list) (a accum))
    (if (null? l)
        a
        (loop (cdr l) (combiner (car l) a)))))