;;; SRFI-143 — Fixnums
;;;
;;; Author: John Cowan
;;;
;;; Copyright (c) 2016 John Cowan. All Rights Reserved.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.

(define fxquotient fx/)
(define (fxzero? i) (fx=? i 0))
(define (fxpositive? i) (fx>? i 0))
(define (fxnegative? i) (fx<? i 0))

(define (fxabs i)
  (if (fxnegative? i) (fxneg i) i))

(define (fxsquare i) (fx* i i))

(define (fxarithmetic-shift i count)
  (if (negative? count)
    (fxarithmetic-shift-right i (fxneg count))
    (fxarithmetic-shift-left i count)))

;;; Generic implementation of carry functions from the R6RS standard.
;;;
;;; These implementations of fx+/carry, fx-/carry, and fx*/carry are very
;;; inefficient, and should be replaced by proper assembly language operations
;;; if at all possible. Furthermore, there are no tests for them, because of
;;; their dependency on fx-width.

(define exp-width (expt 2 fx-width))

(define (fx+/carry i j k)
  (let*-values (((s) (+ i j k))
                ((q r) (balanced/ s exp-width)))
    (values r q)))

(define (fx-/carry i j k)
  (let*-values (((d) (- i j k))
                ((q r) (balanced/ d exp-width)))
    (values r q)))

(define (fx*/carry i j k)
  (let*-values (((s) (+ (* i j) k))
                ((q r) (balanced/ s exp-width)))
    (values r q)))

;;; Helper functions from SRFI 151

(define (floor-/+ n d)
  (let ((n (- 0 n)))
    (let ((q (quotient n d)) (r (remainder n d)))
      (if (zero? r)
        (values (- 0 q) r)
        (values (- (- 0 q) 1) (- d r))))))

(define (ceiling-/- n d)
  (let ((n (- 0 n)) (d (- 0 d)))
    (let ((q (quotient n d)) (r (remainder n d)))
      (if (zero? r)
        (values q r)
        (values (+ q 1) (- d r))))))

(define (euclidean/ n d)
  (if (and (exact-integer? n) (exact-integer? d))
    (cond ((and (negative? n) (negative? d)) (ceiling-/- n d))
          ((negative? n) (floor-/+ n d))
          ((negative? d)
           (let ((d (- 0 d)))
             (values (- 0 (quotient n d)) (remainder n d))))
          (else (values (quotient n d) (remainder n d))))
    (let ((q (if (negative? d) (ceiling (/ n d)) (floor (/ n d)))))
      (values q (- n (* d q))))))

(define (balanced/ x y)
  (call-with-values
    (lambda () (euclidean/ x y))
    (lambda (q r)
      (cond ((< r (abs (/ y 2)))
             (values q r))
            ((> y 0)
             (values (+ q 1) (- x (* (+ q 1) y))))
            (else
              (values (- q 1) (- x (* (- q 1) y))))))))

;;; Bitwise functions cloned from SRFI 151, fixnum version
(define fxbit-count
  (letrec ((logcnt (lambda (n tot)
                     (if (fxzero? n)
                       tot
                       (logcnt (fxquotient n 16)
                               (fx+ (vector-ref
                                      '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
                                      (fxremainder n 16))
                                    tot))))))
    (lambda (n)
      (cond ((fxnegative? n) (logcnt (fxnot n) 0))
            ((fxpositive? n) (logcnt n 0))
            (else 0)))))

;; Helper function
(define (mask start end)
  (fxnot (fxarithmetic-shift-left -1 (fx- end start))))

(define (fxif mask n0 n1)
  (fxior (fxand mask n0)
         (fxand (fxnot mask) n1)))

(define (fxbit-set? index n)
  (bit->boolean n index))

(define (fxcopy-bit index to bool)
  (if bool
    (fxior to (fxarithmetic-shift-left 1 index))
    (fxand to (fxnot (fxarithmetic-shift-left 1 index)))))

(define (fxfirst-set-bit i) (fx- (fxbit-count (fxxor i (fx- i 1))) 1))

(define (fxbit-field n start end)
  (fxand (mask start end) (fxarithmetic-shift n (fxneg start))))

(define (fxbit-field-rotate n count start end)
  (define width (fx- end start))
  (set! count (modulo count width))
  (let ((mask (fxnot (fxarithmetic-shift -1 width))))
    (define zn (fxand mask (fxarithmetic-shift n (fxneg start))))
    (fxior (fxarithmetic-shift
             (fxior (fxand mask (fxarithmetic-shift zn count))
                    (fxarithmetic-shift zn (fx- count width)))
             start)
           (fxand (fxnot (fxarithmetic-shift mask start)) n))))

(define (fxreverse k n)
  (do ((m (if (negative? n) (fxnot n) n) (fxarithmetic-shift-right m 1))
       (k (fx+ -1 k) (fx+ -1 k))
       (rvs 0 (fxior (fxarithmetic-shift-left rvs 1) (fxand 1 m))))
      ((fxnegative? k) (if (fxnegative? n) (fxnot rvs) rvs))))

(define (fxbit-field-reverse n start end)
  (define width (fx- end start))
  (let ((mask (fxnot (fxarithmetic-shift-left -1 width))))
    (define zn (fxand mask (fxarithmetic-shift-right n start)))
    (fxior (fxarithmetic-shift-left (fxreverse width zn) start)
           (fxand (fxnot (fxarithmetic-shift-left mask start)) n))))