(herald (assembler bits t 40)
        (env tsys (assembler as_open) 
                  (assembler fg) 
                  (assembler ib) 
                  (assembler mark)))

;;; ----------------------------------------------------------------
;;; Output bits; also checks to make sure address line up.

;;; Keeping track of the address is vestigial, it should be flushed

(define (bits ibv size machine)
  (let ((ibv-length (vector-length ibv)))
    (let ((bits (cons-bits size machine)))
      (do ((i 0 (fx+ i 1))
           (addr 0 (bits-ib bits addr (vref ibv i))))
          ((fx>= i ibv-length)
           (return bits (bytev-length (bits-bv bits))))))))

(define (bits-ib bits start-addr ib)
  (let ((a (ib-align ib)))
    (if (and a (fx> a 0)) (write-bits bits a 0))
    (iterate loop ((i's (ib-instructions ib)))
      (cond ((null? i's) bits)
            (else
             (bits-fg bits (car i's))
             (write-clumps bits)
             (loop (cdr i's)))))))

;;; First because maybe defined integrable.

(define-integrable (bits-field bits width vop voc1 vars vals)
  (let ((value (get-value vop voc1 vars vals)))
    (write-bits bits width value)))
                                                          
(define (bits-fg bits fg)
  (let* ((fgt (fg-type fg))
         (vars (fg-vars fg))
         (vals (fg-type-vals fgt)))
    (iterate loop ((ops (fg-type-ops fgt)))
      (cond ((null? ops) bits)
            (else
             (xselect (car ops)
               ((wop/fix)
                (destructure (((#f width vop voc1 . ops) ops))
                  (bits-field bits width vop voc1 vars vals)
                  (loop ops)))

               ((wop/@fix)
                (destructure (((#f width-i vop voc1 . ops) ops))
                  (bits-field bits (vref vars width-i) vop voc1 vars vals)
                  (loop ops)))

               ((wop/variable)
                (destructure (((#f sdf-i mark-i fge-i . ops) ops))
                  (let ((fgs ((vref vals fge-i) vars)))
                    (if (list? fgs) 
                        (walk (lambda (fg) (bits-fg bits fg)) fgs)
                        (bits-fg bits fgs))
                    (loop ops))))
               
               ((wop/subfield)
                (destructure (((#f sf-i . ops) ops))
                  (bits-fg bits (vref vars sf-i))
                  (loop ops)))
               
               ((wop/mark)
                (destructure (((#f mark-i . ops) ops))
                  (loop ops)))

               ((wop/group)
                (destructure (((#f start? . ops) ops))
                  (cond ((fxn= (bits-clump-remaining bits)
                               (bits-clump-size bits))
                         (error "group on non-clump boundary ~s" start?)))
                  (cond ((fx= start? 1)
                         (set (bits-grouping? bits) '#t))
                        (else
                         (set (bits-grouping? bits) '#f)
                         (write-clumps bits)))
                  (loop ops)))
               ))))))

;;; ----------------------------------------------------------------
;;;   The real grubby bits stuff

;;; ---------------- BITS structure holds final output

(define-structure-type bits
  clump-size
  clump-writer
  grouping?

  bv            ; the actual bits

  bvpos             ; position of next byte to write in output
  clumps            ; vector of fixnums representing the clumps
  clumps-i          ; index of current clump
  clump-remaining   ; number of bits remaining in current clump
  )

(define (cons-bits bit-size machine)
  (let ((b (make-bits))
        (size (fx/ (fixnum-ceiling bit-size 32) 8)))

    ;; cached from machine guy for convenience
    (set (bits-clump-size b)   (machine-clump-size machine))
    (set (bits-clump-writer b) (machine-clump-writer machine))
    (set (bits-grouping? b)    '#f)

    (set (bits-bv b)           (make-bytev size))

    (set (bits-bvpos b)        0)
    (set (bits-clumps b)       (make-vector (machine-maximum-clumps machine)))
    (set (bits-clumps-i b)     0)
    (set (bits-clump-remaining b) (bits-clump-size b))
    b))

;;; ---------------- Extracting bit fields from integers

;;; "l-" means the start position is the low bit in the field
;;; "h-" means the start position is (1 less than) the high bit in the field

(define-integrable (l-bit-field-fx value start count)
  (cond ((fixnum? value)
         (fixnum-logand (fixnum-lognot (fixnum-ashl -1 count))
                        (fixnum-ashr value start)))
        (else
         (bignum-bit-field-fixnum value start count))))

(define-integrable (h-bit-field-fx value start count)
  (l-bit-field-fx value (fx- start count) count))

(define (bignum-bit-field-fixnum v s c)
  (let ((result (bignum-bit-field v s c)))
    (if (fixnum? result) 
        result
        (error "tas expects a fixnum~%  (bignum-bit-field ~s ~s ~s)" v s c))))

;;; ---------------- Put a field into the output
                                                                       
;;; Fields are collected into clumps in the order that they occur in the spec.
;;; When a field must be broken across clumps, the bits are removed
;;; from high to low, or low to high, depending on the target machine

;;; VALUE is WIDTH bits wide; break VALUE up into clumps

;;; The amount of a clump remaining should never be zero.  The initial
;;; state is clump index = 0, clump remaining = <clump size>.

(define (write-bits bits width value)
  (cond ((and (fx> width 32) (fx= value 0))
         ;; support the "space" pseudo-op; this is completely wrong
         (let ((csize (bits-clump-size bits)))
           (cond ((not (fx= (fixnum-remainder width csize) 0))
                  (error "odd amount of bit space ~S" width))
                 ((fxn= (bits-clump-remaining bits) csize)
                  (error "space not on clump boundary"))
                 ((fxn= (bits-clumps-i bits) 0)
                  (error "space starts after first clump"))
                 (else
                  (modify (bits-bvpos bits)
                          (lambda (p) (fx+ p (fx/ width 8))))))))
        (else
         (write-bits-1 bits width value))))

(define (write-bits-1 bits width value)
  (let ((clumps (bits-clumps bits))
        (clump-size (bits-clump-size bits)))
    (iterate loop ((bit-position width)
                   (bits-remaining width)
                   (clump-remaining (bits-clump-remaining bits))
                   (clump-index (bits-clumps-i bits)))
      (cond ((fx= bits-remaining 0)
             (set (bits-clump-remaining bits) clump-remaining)
             (set (bits-clumps-i bits) clump-index)
             (if (and (fx= clump-remaining clump-size)
                      (not (bits-grouping? bits)))
                 (write-clumps bits)))

            ((fx< bits-remaining clump-remaining)
             (modify (vref clumps clump-index)
                     (lambda (c) (fixnum-logior
                                  (fixnum-ashl c bits-remaining) 
                                  (l-bit-field-fx value 0 bits-remaining))))
             (set (bits-clump-remaining bits)
                  (fx- clump-remaining bits-remaining))
             (set (bits-clumps-i bits) clump-index))

            (else
             (modify (vref clumps clump-index)
                     (lambda (c) (fixnum-logior
                                  (fixnum-ashl c clump-remaining) 
                                  (h-bit-field-fx value
                                                  bit-position
                                                  clump-remaining))))
             (loop (fx- bit-position clump-remaining)
                   (fx- bits-remaining clump-remaining)
                   clump-size
                   (fx+ clump-index 1)))))))

;;; ---------------- Writing clumps

(define-integrable (write-clumps bits)
  (let ((clumps (bits-clumps bits))
        (clumps-i (bits-clumps-i bits))
        (bv (bits-bv bits))
        (bvpos (bits-bvpos bits)))
    (if (fx>= clumps-i (vector-length (bits-clumps bits)))
        (error "(while writing bits) too many buffered clumps: ~s" clumps-i))
    (set (bits-bvpos bits) ((bits-clump-writer bits) clumps clumps-i bv bvpos))
    (set (bits-clumps-i bits) 0)
    (set (bits-clump-remaining bits) (bits-clump-size bits))
    ))

#|
(define (reverse-vector! v hi)
  (iterate loop ((hi hi)
                 (lo 0))
    (cond ((fx< (fx- hi lo) 1) v)
          (else
           (let ((h (vref v hi))
                 (l (vref v lo)))
             (vset v lo h)
             (vset v hi l)
             (loop (fx- hi 1) (fx+ lo 1)))))))
|#

;;; These routines could be made into a single machine independent
;;; one that is parameterized with bits/byte, bytes/clump, clump order,
;;; bit order, and clump size.  This way seems simpler.

;;; Write the bits in the clumps [0..clumps-i] into the byte vector 
;;; BV starting at BVPOS.  CLUMPS is a vector of fixnums, each fixnum 
;;; a clump, the number of bits in the clump depends on the machine.
;;; The choices are which way to look over the clumps (the most
;;; significant clump is index 0), which way to write the bits of
;;; a single clump, and how many bits of each clump to put into a byte 
;;; (this is usually 8), and whether low bits

;;; Return the next unused position in BV which will be
;;; something like (+ BVPOS (* BYTES/CLUMP CLUMPS-I))

;;; 1 byte/clump, 8 bits/byte, low clumps first

(define (vax/write-clumps clumps clumps-i bv bvpos)
  (do ((i (fx- clumps-i 1) (fx- i 1))
       (bvpos bvpos (fx+ bvpos 1)))
      ((fx< i 0) 0)
    (set (bref bv bvpos) (vref clumps i))
    (set (vref clumps i) 0))
  (fx+ bvpos clumps-i))

;;; 2 bytes/clump, 8 bits/byte, low clumps first, high clump bits first

(define (m68/write-clumps clumps clumps-i bv bvpos)
  (do ((i 0 (fx+ i 1))
       (bvpos bvpos (fx+ bvpos 2)))
      ((fx>= i clumps-i) 0)
    (let ((c (vref clumps i)))
       (set (bref bv bvpos) (fixnum-ashr c 8))
       (set (bref bv (fx+ bvpos 1)) c))
    (set (vref clumps i) 0))
  (fx+ bvpos (fixnum-ashl clumps-i 1)))

;;; ---------------- Flonum dismemberment.

;;; Returns sign, and normalized mantissa and exponent  
;;; PRECISION is number of bits desired in the mantissa 
;;; EXCESS is the exponent excess
;;; HIDDEN-BIT-IS-1.? is true if the hidden bit preceeds the
;;;  binary point (it does in Apollo IEEE, does not on the VAX).

(define (normalized-float-parts flonum precision excess hidden-bit-is-1.?)
    (cond ((fl= flonum 0.0)
           (return 0 (%ash 1 (fx+ precision 1)) 0))
          (else
           (integer-decode-float
            (proclaim flonum? flonum)
            (lambda (m e)
              (let* ((have (integer-length m))
                     (need (fx- precision have))
                     (normalized-m (%ash m need))
                     (normalized-e (- (+ e 
                                         precision 
                                         excess
                                         (if hidden-bit-is-1.? -1 0))
                                       need)))
                 (return (if (fl< flonum 0.0) 1 0) normalized-m normalized-e)
                 ))))))