;; Utilities for manipulation of binary words and buffers.

(module binary-utils mzscheme
  (require (lib "match.ss")
           "list-utils.ss"
           "tree-utils.ss")
  (provide (all-defined))

  ;; binary

  (define (signed-converter n)
    (lambda (x) (signed-convert x n)))
  
  (define (signed-convert x n)
    (let ((signmask (<<< 1 (- n 1))))
      (- (bxor signmask
               (band x (bitmask n)))
         signmask)))

  (define (bitmask bits)
    (- (<<< 1 bits) 1))

  (define (make-mask bits)
    (let ((bm (bitmask bits)))
      (lambda (x) (bitwise-and bm x))))

  (define <<< arithmetic-shift)
  (define (>>> val shift)
    (<<< val (* -1 shift)))

  (define (<< x) (<<< x 1))
  (define (2/ x) (>>> x 1))  ;; scheme's ints are 2-adic


  (define (bit address n)
    (bitwise-and 1 (>>> address n)))

  ;; convert anything that might be passed to the assembler
  ;; representing a number to integer

  (define (int x)
    (cond
     ((number? x) (inexact->exact (round x)))
     (else (error 'cannot-convert-to-int "~a" x))))

  (define (int8 x)
    (bitwise-and #xFF (int x)))

  (define (band x y) (bitwise-and (int x) (int y)))
  (define (bior x y) (bitwise-ior (int x) (int y)))
  (define (bxor x y) (bitwise-xor (int x) (int y)))

  (define (invert  b)  (bxor b -1)) ;; all bits
  (define (flip    b)  (bxor b 1))  ;; one bit

  (define (negate x) (* -1 x))

  ;; determine next available block from address
  (define (ceiling-block address blocksize)
    (+ 1 (floor (/ (- address 1) blocksize))))
  
  ;; convert a number to a list of chunks.
  (define (number->chunks n l)
    (if (>= n l)
        (cons l (number->chunks (- n l) l))
        (list n)))
              
  ;; symbol generation. not going to make a separate module for this...
  (define (generated-label? x)
    (and (symbol? x)
         (let ((chars
                (string->list
                 (symbol->string x))))
           (if (eq? #\L (car chars))
               (string->number
                (list->string (cdr chars)))
               #f))))
    
  (define make-label
    (let ((n -1))
      (lambda ()
        (set! n (+ n 1))
        (string->symbol
         (format "L~s" n)))))
  

  ;; CHUNKS


  ;; convert a list into a list of list of lists, with a specified
  ;; maximal with.
  ;; (list->table '(1 2 3 4 5) 2)

  (define (list->table lst size)
    (let next ((in  lst)
               (out '())
               (current '(0)))
      (match (cons in current)
             ((() 0)  (reverse out)) ;; done
             ((_  n . l)
              (if (or (null? in)
                      (= n size))
                  ;; row finished
                  (next in
                        (cons (reverse l) out)
                        '(0))
                  ;; accumulate row
                  (next (cdr in)
                        out
                        (cons (+ 1 n)
                              (cons (car in) l))))))))
  
  ;; split a list of words into parts.
  ;; (left right) = (0 n)  little endian
  ;;              = (n 0)  big endian
  ;; (split-nibble-list '(1 2 3 4) 0 3)

  (define (split-nibble-list lst left right)
    (let ((mask (make-mask (max left right))))
      (flatten
       (map
        (lambda (x)
          (list (mask (>>> x left))
                (mask (>>> x right))))
        lst))))

  ;; (post) inverse  of above
  ;; (join-nibble-list '(1 1 2 2) 0 8)
  (define (join-nibble-list lst left right)
    (if (= 1 (bitwise-and 1 (length lst)))
        (error 'odd-list-length "join-nibble-list: odd list length: ~a" lst)
        (let
            ((mask
              (make-mask (max left right)))
             (select
              (lambda (lst which)
                (let rest ((l lst))
                  (if (null? l) l
                      (cons (which l)
                            (rest (cddr l))))))))
          (map
           (lambda (l r)
             (bior (<<< (mask l) left)
                   (<<< (mask r) right)))
           
           (select lst first)
           (select lst second)))))



  ;; (collect-first number? '(1 2 3 a b c))
  (define (collect-first p? lst)
    (let next ((in  lst)
               (out '()))
      (match in
             ((or ()
                  ((= p? #f) . r))
              (cons (reverse! out) in))

             (((and n (= p? #t)) . r)
              (next r (cons n out))))))


  ;; (bin->chunks '((org 123) 1 2 3 (org 456) 4 5 6))
  (define (bin->chunks binary-lst)
    (let next ((lst binary-lst))
      (match lst
             (() ())
             ((('org addr) . bin)
              (match (collect-first number? bin)
                     ((chunk . rest)
                      (cons `(,addr ,chunk)
                            (next rest)))))
             (else
              (error 'asm-error
                     "bin->chunks: cannot chunk input: ~a"
                     lst)))))
  
  (define (bin? lst)
    (match lst
           (() #t)
           ((('org . x) . y) (bin? y))
           ((x . y) (and (number? x)
                         (bin? y)))))
            


  ;; Align a chunk to bit boundary by padding front and back.

  ;; (align-front '(7 ()))
  ;; (align-back  '(0 (1 2 3)))
  ;; (align-chunk '(3 (1 2 3)) 3)
  ;; (define mask (make-mask 3))

  (define (chunk-align-bits lst bits)
    (let ((mask (make-mask bits)))
      (define (align-front lst)
        (let next ((l lst))
          (match l
                 ((addr r)
                  (if (= 0 (mask addr))
                      l
                      (next `(,(- addr 1)
                              (-1 ,@r)))))))) ;; pad
      (define (align-back lst)
        (match lst
               ((addr numbers)
                (let next ((l (reverse numbers)))
                  (if (= 0 (mask (length l)))
                      `(,addr ,(reverse l))
                      (next (cons -1 l)))))))

      ;; perform front first: back only checks the size
      (align-back
       (align-front lst))))

  
  ;; (split-chunk '(0 (1 2 3 4)) 0 8)
  (define (split-chunk  chunk left right) ;;
    (match chunk
           ((addr things)
            `(,(<<< addr 1)
              ,(split-nibble-list things left right)))))
  
  


  

  ;; FORMATTING

  
  ;; (hexdigit 15)
  (define hexdigit
    (let ((table
           (apply vector
                  (string->list "0123456789ABCDEF"))))
      (lambda (x)
        (vector-ref table x))))

  ;; (bytes->hexdigits '(1 2 3 255 240))
  (define (bytes->hexdigits lst)
    (map hexdigit (split-nibble-list lst 4 0)))


  ;; (byte->string 123)
  (define (byte->string x)
    (list->string
     (bytes->hexdigits `(,x))))

  ;; (word->string 1123)
  (define (word->string x)
    (list->string
     (bytes->hexdigits
      (split-nibble-list
       `(,x) 8 0))))


)